scsh-conservatory
/
commander-s
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

performace improvements for the terminal emulator. Now feels like a 

4800 bps modem connection (before: 1200-2400 bps).
This commit is contained in:
eknauel 2005-06-07 20:52:49 +00:00
parent 60ad7d02c4
commit 4c903444f2
2 changed files with 36 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/console.scm
View File

@ -60,9 +60,11 @@
(lp paint?))))))))))
(define (pause-console-output console)
(debug-message "pause-console-output")
(send (console-pause-channel console) 'ignore))
(define (resume-console-output console)
(debug-message "resume-console-output")
(send (console-resume-channel console) 'ignore))
(define (view-console console)

73
scheme/termbuf.scm
View File

@ -1,10 +1,6 @@
;; turn off debugging for the moment
(define debug-message
(lambda args #f))
(define-record-type terminal-buffer :terminal-buffer
(really-make-terminal-buffer width height view-index
x y buffer repaint?
x y buffer paint-fun
esc-code)
terminal-buffer?
(width terminal-buffer-width)
@ -14,7 +10,7 @@
(x terminal-buffer-x set-terminal-buffer-x!)
(y terminal-buffer-y set-terminal-buffer-y!)
(buffer terminal-buffer-buffer set-terminal-buffer-buffer!)
(repaint? terminal-buffer-repaint? set-terminal-buffer-repaint?!)
(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
@ -24,7 +20,6 @@
(height ,(terminal-buffer-height tb))
(x ,(terminal-buffer-x tb))
(y ,(terminal-buffer-y tb))
(repaint? ,(terminal-buffer-repaint? tb))
(esc-code ,(map char->ascii (string->list (terminal-buffer-esc-code tb)))))))
(define (make-terminal-buffer width height)
@ -32,8 +27,10 @@
(lambda (ignore)
(make-empty-line width))
(iota height))))
(really-make-terminal-buffer width height buffer
0 0 buffer #f "")))
(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)
@ -51,18 +48,15 @@
(- (terminal-buffer-height termbuf) 1)))
(define (append-empty-line termbuf)
(debug-message "append-empty-line")
(append! (terminal-buffer-buffer termbuf)
(list (make-empty-line (terminal-buffer-width termbuf)))))
(define (goto-next-line termbuf)
(debug-message "goto-next-line")
(set-terminal-buffer-y!
termbuf (+ (terminal-buffer-y termbuf) 1))
(maybe-scroll-terminal-buffer termbuf))
(define (move-cursor termbuf x-offset y-offset)
(debug-message "move-cursor " termbuf " " x-offset " " y-offset)
(let ((new-x (+ (terminal-buffer-x termbuf) x-offset))
(new-y (+ (terminal-buffer-y termbuf) y-offset)))
@ -87,10 +81,10 @@
(define (scroll-view-index-down termbuf)
(set-terminal-buffer-view-index!
termbuf (cdr (terminal-buffer-view-index termbuf)))
(set-terminal-buffer-repaint?! termbuf #t))
(set-terminal-buffer-paint-fun!
termbuf paint-complete-buffer))
(define (maybe-scroll-terminal-buffer termbuf)
(debug-message "maybe-scroll-terminal-buffer")
(and (>= (terminal-buffer-y termbuf)
(terminal-buffer-height termbuf))
(begin
@ -100,23 +94,22 @@
(- (terminal-buffer-y termbuf) 1)))))
(define (goto-beginning-of-line termbuf)
(debug-message "goto-beginning-of-line")
(set-terminal-buffer-x! termbuf 0))
(define (terminal-buffer-add-char termbuf char)
(debug-message "add-char " termbuf " '" char "' "
(char->ascii 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))
(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))
(goto-next-line termbuf)
(set-terminal-buffer-paint-fun! termbuf position-cursor))
((char-set-contains? char-set:printing char)
(add-normal-char termbuf char))))
@ -126,21 +119,16 @@
(append-empty-line termbuf)
(goto-next-line termbuf)
(goto-beginning-of-line termbuf)
(insert-char termbuf char))
(insert-char termbuf char)
(set-terminal-buffer-paint-fun!
termbuf paint-complete-buffer))
(else
(insert-char termbuf char)
(goto-next-char termbuf)))
(debug-message "add-normal-char "
(string-length (line-at-cursor-position termbuf))
"'" (line-at-cursor-position termbuf) "'"))
(goto-next-char termbuf)
(set-terminal-buffer-paint-fun!
termbuf paint-single-char))))
(define (curses-paint-terminal-buffer termbuf win)
(if (terminal-buffer-repaint? termbuf)
(clear/repaint-buffer termbuf win)
(paint-single-line termbuf win)))
(define (clear/repaint-buffer termbuf win)
(debug-message "clear/repaint-buffer")
(define (paint-complete-buffer termbuf win)
(wclear win)
(let lp ((i (terminal-buffer-height termbuf))
(lines (terminal-buffer-view-index termbuf))
@ -148,21 +136,31 @@
(if (zero? i)
'blorf
(begin
(debug-message y ": '" (car lines) "'")
(mvwaddstr win y 0 (car lines))
(lp (- i 1) (cdr lines) (+ y 1)))))
(position-cursor termbuf win))
(define curses-paint-terminal-buffer/complete
clear/repaint-buffer)
(define (paint-single-line termbuf win)
(debug-message "paint-single-line " termbuf)
(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)
@ -178,7 +176,6 @@
termbuf (+ 1 (terminal-buffer-x termbuf))))
(define (read-escape-code termbuf char)
(debug-message "read-escape-code " (char->ascii char) " " termbuf)
(let ((code (string-append
(terminal-buffer-esc-code termbuf)
(string char))))
@ -198,7 +195,6 @@
(set-terminal-buffer-esc-code! termbuf code)))))
(define (recognize-cursor-movement partial-code)
(debug-message "recognize-cursor-movement " partial-code)
(if-match
(regexp-search (rx (: ,(ascii->char 27)
#\[ (submatch digit) (submatch ("ABCD"))
@ -218,7 +214,6 @@
#f))
(define (recognize-simple-cursor-movement partial-code)
(debug-message "recognize-simple-cursor-movement ")
(if-match
(regexp-search (rx (: ,(ascii->char 27) (? #\[) (? #\O) (submatch ("ABCD")) eos))
partial-code)