229 lines
7.1 KiB
Scheme
229 lines
7.1 KiB
Scheme
(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))
|
|
(set-terminal-buffer-paint-fun! termbuf position-cursor)
|
|
(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))
|
|
((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)
|
|
(goto-next-char termbuf)
|
|
(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)))
|