ncursesライブラリバインディングのcl-charmsを使って less コマンドのようなものを作ってみる

less.ros

#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#
(ql:quickload :cl-charms :silent t)

(defun read-file (fname)
  "return lines in fname"
  (with-open-file (s fname)
    (loop for l = (read-line s nil nil)
       while l collect l)))

(defun char-width (c w)
  (cond ((char-equal c #\tab)
	 (* (ceiling (1+ w) charms/ll:*tabsize*) charms/ll:*tabsize*))
	(t (+ w
	      (cffi:foreign-funcall "wcwidth" :int (char-code c) :int)))))

(defun string-width (str)
  (loop for c across str
     with width = 0
     do (setf width (char-width c width))
     finally (return width)))

(defun main (&rest argv)
  (declare (ignorable argv))
  (let*
      ((fname (car argv))
       (lines (read-file fname))
       (minrow 0)
       (mincol 0)
       scr
       pad
       pad-width
       pad-height)

    ;; initialize screen and pad
    (setf scr (charms/ll:initscr)
	  pad-height (length lines)
	  pad-width (loop for l in lines
		       maximize (string-width l))
	  pad (charms/ll:newpad pad-height pad-width))

    (charms/ll:cbreak)			; get key input immediately,
					; but 
    (charms/ll:noecho)			; don't display key inputted from user
    (charms/ll:keypad pad 1)		; accept special keys like arrow keys
    (charms/ll:curs-set 0)		; don't show cursor

    ;; initialize pad contents
    (loop for l in lines
       for y from 0
       do (charms::check-status (charms/ll:mvwaddstr pad y 0 l)))

    ;; draw pad
    (charms/ll:wclear scr)
    (charms::check-status
     (charms/ll:prefresh pad minrow mincol
			 0 0
			 (1- charms/ll:*LINES*) (1- charms/ll:*COLS*)))

    ;; main loop
    (loop named loop for k = (charms/ll:wgetch pad)
       do (cond ((= k (char-code #\q))
		 (return-from loop))
		((= k (char-code #\j))
		 (incf minrow))
		((= k (char-code #\k))
		 (decf minrow))
		((= k (char-code #\h))
		 (decf mincol))
		((= k (char-code #\l))
		 (incf mincol))
		((= k charms/ll:key_down)
		 (incf minrow))
		((= k charms/ll:key_up)
		 (decf minrow))
		((= k charms/ll:key_left)
		 (decf mincol))
		((= k charms/ll:key_right)
		 (incf mincol))
		(t
		 ;; (format t "[~A ~C ~:C]~%" k (code-char k) (code-char k))
		 ;; (finish-output)
		 ))
       do (charms/ll:wclear scr)
       do (charms/ll:wrefresh scr)
       do (charms/ll:prefresh pad minrow mincol
			      0 0
			      (1- charms/ll:*LINES*) (1- charms/ll:*COLS*)))
    (charms/ll:endwin)))