commander-s/scheme/termbuf.scm

(define-record-type terminal-buffer :terminal-buffer
  (really-make-terminal-buffer width height view-index
			       x y buffer paint-fun
			       esc-code)
  terminal-buffer?
  (width terminal-buffer-width)
  (height terminal-buffer-height)
  (view-index terminal-buffer-view-index
	      set-terminal-buffer-view-index!)
  (x terminal-buffer-x set-terminal-buffer-x!)
  (y terminal-buffer-y set-terminal-buffer-y!)
  (buffer terminal-buffer-buffer set-terminal-buffer-buffer!)
  (paint-fun terminal-buffer-paint-fun set-terminal-buffer-paint-fun!)
  (esc-code terminal-buffer-esc-code set-terminal-buffer-esc-code!))

(define-record-discloser :terminal-buffer
  (lambda (tb)
    `(terminal-buffer 
      (width ,(terminal-buffer-width tb))
      (height ,(terminal-buffer-height tb))
      (x ,(terminal-buffer-x tb))
      (y ,(terminal-buffer-y tb))
      (esc-code ,(map char->ascii (string->list (terminal-buffer-esc-code tb)))))))

(define (make-terminal-buffer width height)
  (let ((buffer (map
		 (lambda (ignore)
		   (make-empty-line width))
		 (iota height))))
    (really-make-terminal-buffer 
     width height buffer 0 0 buffer 
     curses-paint-terminal-buffer/complete
     "")))

(define (line-at-cursor-position termbuf)
  (list-ref (terminal-buffer-view-index termbuf)
	    (terminal-buffer-y termbuf)))

(define (make-empty-line width)
  (make-string width #\space))

(define (cursor-at-end-of-line? termbuf)
  (= (terminal-buffer-x termbuf) 
     (- (terminal-buffer-width termbuf) 1)))

(define (cursor-on-last-line? termbuf)
  (= (terminal-buffer-y termbuf) 
     (- (terminal-buffer-height termbuf) 1)))

(define (append-empty-line termbuf)
  (append! (terminal-buffer-buffer termbuf) 
	   (list (make-empty-line (terminal-buffer-width termbuf)))))

(define (goto-next-line termbuf)
  (set-terminal-buffer-y!
   termbuf (+ (terminal-buffer-y termbuf) 1))
  (maybe-scroll-terminal-buffer termbuf))

(define (move-cursor termbuf x-offset y-offset)
  (let ((new-x (+ (terminal-buffer-x termbuf) x-offset))
	(new-y (+ (terminal-buffer-y termbuf) y-offset)))
    
    (cond
     ((< new-x 0)
      (set-terminal-buffer-x! termbuf 0))
     ((>= new-x (terminal-buffer-width termbuf))
      (set-terminal-buffer-x! 
       termbuf (- (terminal-buffer-width termbuf) 1)))
     (else
      (set-terminal-buffer-x! termbuf new-x)))

    (cond
     ((< new-y 0)
      (set-terminal-buffer-y! termbuf 0))
     ((>= new-y (terminal-buffer-width termbuf))
      (set-terminal-buffer-y!
       (termbuf (- (terminal-buffer-width termbuf) 1))))
     (else 
      (set-terminal-buffer-y! termbuf new-y)))))

(define (scroll-view-index-down termbuf)
  (set-terminal-buffer-view-index!
   termbuf (cdr (terminal-buffer-view-index termbuf)))
  (set-terminal-buffer-paint-fun!
   termbuf paint-complete-buffer))

(define (maybe-scroll-terminal-buffer termbuf)
  (and (>= (terminal-buffer-y termbuf)
	   (terminal-buffer-height termbuf))
       (begin
	 (scroll-view-index-down termbuf)
	 (set-terminal-buffer-y!
	  termbuf
	  (- (terminal-buffer-y termbuf) 1)))))

(define (goto-beginning-of-line termbuf)
  (set-terminal-buffer-x! termbuf 0))

(define (terminal-buffer-add-char termbuf char)
  (cond
   ((not (string=? "" (terminal-buffer-esc-code termbuf)))
    (read-escape-code termbuf char))
   ((char=? char (ascii->char 27))
    (set-terminal-buffer-esc-code! termbuf (string char)))
   ((char=? char (ascii->char 13))
    (goto-beginning-of-line termbuf)
    (set-terminal-buffer-paint-fun! termbuf position-cursor))
   ((char=? char #\newline)
    (if (cursor-on-last-line? termbuf)
	(append-empty-line termbuf))
    (goto-next-line termbuf)
    (set-terminal-buffer-paint-fun! termbuf position-cursor))
   ((char-set-contains? char-set:printing char)
    (add-normal-char termbuf char))))

(define (add-normal-char termbuf char)
  (cond
   ((cursor-at-end-of-line? termbuf)
    (append-empty-line termbuf)
    (goto-next-line termbuf)
    (goto-beginning-of-line termbuf)
    (insert-char termbuf char)
    (set-terminal-buffer-paint-fun!
     termbuf paint-complete-buffer))
   (else
    (insert-char termbuf char)
    (goto-next-char termbuf)
    (set-terminal-buffer-paint-fun!
     termbuf paint-single-char))))

(define (paint-complete-buffer termbuf win)
  (wclear win)
  (let lp ((i (terminal-buffer-height termbuf))
	   (lines (terminal-buffer-view-index termbuf))
	   (y 0))
    (if (zero? i)
	'blorf
	(begin
	  (mvwaddstr win y 0 (car lines))
	  (lp (- i 1) (cdr lines) (+ y 1)))))
  (position-cursor termbuf win))

(define (paint-single-line termbuf win)
  (wmove win (terminal-buffer-y termbuf) 0)
  (wclrtoeol win)
  (waddstr win (line-at-cursor-position termbuf))
  (position-cursor termbuf win))

(define (paint-single-char termbuf win)
  (let ((x (if (zero? (terminal-buffer-x termbuf))
	       (terminal-buffer-x termbuf)
	       (- (terminal-buffer-x termbuf) 1))))
    (waddch win 
;	      (terminal-buffer-y termbuf)
;	      x
	      (string-ref (line-at-cursor-position termbuf) x))))

(define (curses-paint-terminal-buffer termbuf win)
  ((terminal-buffer-paint-fun termbuf) termbuf win))

(define curses-paint-terminal-buffer/complete 
  paint-complete-buffer)

(define (position-cursor termbuf win)
  (wmove win 
	 (terminal-buffer-y termbuf)
	 (terminal-buffer-x termbuf)))

(define (insert-char termbuf char)
  (string-set! (line-at-cursor-position termbuf)
	       (terminal-buffer-x termbuf)
	       char))

(define (goto-next-char termbuf)
  (set-terminal-buffer-x! 
   termbuf (+ 1 (terminal-buffer-x termbuf))))

(define (read-escape-code termbuf char)
  (let ((code (string-append
	       (terminal-buffer-esc-code termbuf)
	       (string char))))
    (cond
     ;; very ugly hack
     ((> (string-length code) 5)
      (set-terminal-buffer-esc-code! termbuf ""))
     ((recognize-simple-cursor-movement code)
      => (lambda (lst)
	   (apply move-cursor (cons termbuf lst))
	   (set-terminal-buffer-esc-code! termbuf "")))
     ((recognize-cursor-movement code)
       => (lambda (lst)
	    (apply move-cursor (cons termbuf lst))
	    (set-terminal-buffer-esc-code! termbuf "")))
     (else 
      (set-terminal-buffer-esc-code! termbuf code)))))

(define (recognize-cursor-movement partial-code)
  (if-match
   (regexp-search (rx (: ,(ascii->char 27) 
			 #\[ (submatch digit) (submatch ("ABCD"))
			 eos))
		  partial-code)
   (whole-code count direction)
   (cond
     ((string=? direction "A")
      (list 0 (- (string->number count))))
     ((string=? direction "B")
      (list 0 (string->number count)))
     ((string=? direction "C")
      (list (string->number count) 0))
     ((string=? direction "D")
      (list (- (string->number count)) 0))
     (else (error 'gnarf direction)))
   #f))

(define (recognize-simple-cursor-movement partial-code)
  (if-match
   (regexp-search (rx (: ,(ascii->char 27) (? #\[) (? #\O) (submatch ("ABCD")) eos))
		  partial-code)
   (whole-code direction)
   (cond
     ((string=? direction "A") '( 0 -1))
     ((string=? direction "B") '( 0  1))
     ((string=? direction "C") '( 1  0))
     ((string=? direction "D") '(-1  0))
     (else (error 'gnarf2 (string? direction) (char? direction) )))
   (begin (debug-message "does not match ") #f)))