misc-deps
/
racket-ansi
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Intraline diffs for more efficient display on slow terminals. Fixes cut/paste, too.

This commit is contained in:
Tony Garnock-Jones 2014-12-26 18:56:49 -05:00
parent f91e66e623
commit 7fcd3587b5
2 changed files with 103 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
rmacs/TODO
View File

@ -17,7 +17,3 @@ behaviour near the end of the demo file.
Catch and handle SIGWINCH. Catch and handle SIGWINCH.
See http://man7.org/tlpi/code/online/dist/tty/demo_SIGWINCH.c.html See http://man7.org/tlpi/code/online/dist/tty/demo_SIGWINCH.c.html
Cut-and-paste via X doesn't work too well. The trailing spaces on each
line are part of the selection. Worth trying to elide them? Or fill
unprinted slots with #f or #\nul?

176
rmacs/display.rkt
View File

@ -60,7 +60,7 @@
) #:prefab) ) #:prefab)
(define (make-screen rows columns pen) (define (make-screen rows columns pen)
(define contents (for/vector ((row rows)) (make-vector columns (cons pen #\space)))) (define contents (for/vector ((row rows)) (make-vector columns (cons pen 'empty))))
(screen rows columns 0 0 pen contents)) (screen rows columns 0 0 pen contents))
(define (copy-screen s) (define (copy-screen s)
@ -137,33 +137,51 @@
(set-screen-cursor-column! (tty-displayed-screen tty) 0) (set-screen-cursor-column! (tty-displayed-screen tty) 0)
tty) tty)
(define (color-near-cursor s row-delta column-delta)
(define r (max 0 (min (- (screen-rows s) 1) (+ (screen-cursor-row s) row-delta))))
(define c (max 0 (min (- (screen-columns s) 1) (+ (screen-cursor-column s) column-delta))))
(car (vector-ref (vector-ref (screen-contents s) r) c)))
(define (vector-delete! v base count fill)
(vector-copy! v base v (+ base count) (vector-length v))
(for ((i (in-range (- (vector-length v) count) (vector-length v)))) (vector-set! v i fill)))
(define (vector-insert! v base count fill)
(vector-copy! v (+ base count) v base (- (vector-length v) count))
(for ((i (in-range base (+ base count)))) (vector-set! v i fill)))
(define (delete-lines tty n) (define (delete-lines tty n)
(define s (tty-displayed-screen tty)) (define s (tty-displayed-screen tty))
(set-pen tty *pen-white-on-black*)
(output tty (ansi:delete-lines n)) (output tty (ansi:delete-lines n))
(define blank-line (make-vector (screen-columns s) (cons 'unknown #\space))) (define blank-line (make-vector (screen-columns s) (cons (screen-pen s) 'empty)))
(vector-copy! (screen-contents s) (vector-delete! (screen-contents s) (screen-cursor-row s) n blank-line)
(screen-cursor-row s)
(screen-contents s)
(+ (screen-cursor-row s) n)
(screen-rows s))
(for ((i (in-range (- (screen-rows s) n) (screen-rows s))))
(vector-set! (screen-contents s) i blank-line))
tty) tty)
(define (insert-lines tty n) (define (insert-lines tty n)
(define s (tty-displayed-screen tty)) (define s (tty-displayed-screen tty))
(set-pen tty (car (vector-ref (vector-ref (screen-contents s) (set-pen tty *pen-white-on-black*)
(max 0 (- (screen-cursor-row s) 1)))
(screen-cursor-column s))))
(output tty (ansi:insert-lines n)) (output tty (ansi:insert-lines n))
(define blank-line (make-vector (screen-columns s) (cons (screen-pen s) #\space))) (define blank-line (make-vector (screen-columns s) (cons (screen-pen s) 'empty)))
(vector-copy! (screen-contents s) (vector-insert! (screen-contents s) (screen-cursor-row s) n blank-line)
(+ (screen-cursor-row s) n) tty)
(screen-contents s)
(screen-cursor-row s) (define (delete-columns tty n)
(- (screen-rows s) n)) (define s (tty-displayed-screen tty))
(for ((i (in-range (screen-cursor-row s) (+ (screen-cursor-row s) n)))) (set-pen tty *pen-white-on-black*)
(vector-set! (screen-contents s) i blank-line)) (output tty (ansi:delete-characters n))
(define blank-cell (cons (screen-pen s) 'empty))
(define line (vector-ref (screen-contents s) (screen-cursor-row s)))
(vector-delete! line (screen-cursor-column s) n blank-cell)
tty)
(define (insert-columns tty n)
(define s (tty-displayed-screen tty))
(set-pen tty (color-near-cursor s 0 -1))
(output tty (ansi:insert-characters n))
(define blank-cell (cons (screen-pen s) 'empty))
(define line (vector-ref (screen-contents s) (screen-cursor-row s)))
(vector-insert! line (screen-cursor-column s) n blank-cell)
tty) tty)
(define (output tty . items) (define (output tty . items)
@ -184,6 +202,8 @@
(define (tty-cursor-row t) (screen-cursor-row (tty-pending-screen t))) (define (tty-cursor-row t) (screen-cursor-row (tty-pending-screen t)))
(define (tty-cursor-column t) (screen-cursor-column (tty-pending-screen t))) (define (tty-cursor-column t) (screen-cursor-column (tty-pending-screen t)))
(define (non-empty? ch) (not (equal? ch 'empty)))
(define (putc tty ch) (define (putc tty ch)
(define s (tty-pending-screen tty)) (define s (tty-pending-screen tty))
(match ch (match ch
@ -193,7 +213,7 @@
(tty-goto tty (+ (screen-cursor-row s) 1) (screen-cursor-column s))] (tty-goto tty (+ (screen-cursor-row s) 1) (screen-cursor-column s))]
[#\tab [#\tab
(for ((i (- 8 (modulo (screen-cursor-column s) 8)))) (putc tty #\space))] (for ((i (- 8 (modulo (screen-cursor-column s) 8)))) (putc tty #\space))]
[(? char-iso-control?) [(and (? non-empty?) (? char-iso-control?))
(puts tty (format "[~x]" (char->integer ch)))] (puts tty (format "[~x]" (char->integer ch)))]
[_ [_
(when (< (screen-cursor-column s) (screen-columns s)) (when (< (screen-cursor-column s) (screen-columns s))
@ -219,7 +239,10 @@
(define (tty-clear-to-eol tty) (define (tty-clear-to-eol tty)
(define start-column (tty-cursor-column tty)) (define start-column (tty-cursor-column tty))
(for ((i (- (tty-columns tty) (tty-cursor-column tty)))) (putc tty #\space)) (define pen (screen-pen (tty-pending-screen tty)))
(tty-set-pen! tty *pen-white-on-black*)
(for ((i (- (tty-columns tty) (tty-cursor-column tty)))) (putc tty 'empty))
(tty-set-pen! tty pen)
(tty-goto tty (tty-cursor-row tty) start-column) (tty-goto tty (tty-cursor-row tty) start-column)
tty) tty)
@ -250,71 +273,78 @@
;; (list->string ;; (list->string
;; (for*/list ((line (screen-contents s)) ;; (for*/list ((line (screen-contents s))
;; (cell line) ;; (cell line)
;; #:when (not (equal? (cdr cell) #\space))) ;; #:when (non-empty? (cdr cell)))
;; (cdr cell))))) ;; (cdr cell)))))
(define (goto-if-needed s row column) (define (goto-if-needed s row column)
(if (and (= (screen-cursor-row s) row) (cond
(= (screen-cursor-column s) column)) [(and (= (screen-cursor-row s) row) (= (screen-cursor-column s) column))
"" ""]
(begin0 (ansi:goto (+ row 1) (+ column 1)) [(= (screen-cursor-row s) row)
(set-screen-cursor-row! s row) (begin0 (ansi:goto-column (+ column 1))
(set-screen-cursor-column! s column)))) (set-screen-cursor-column! s column))]
[else
(begin0 (ansi:goto (+ row 1) (+ column 1))
(set-screen-cursor-row! s row)
(set-screen-cursor-column! s column))]))
(define (advance-cursor! s) (define (advance-cursor! tty s)
(set-screen-cursor-column! s (+ (screen-cursor-column s) 1)) (set-screen-cursor-column! s (+ (screen-cursor-column s) 1))
(when (= (screen-cursor-column s) (screen-columns s)) (when (= (screen-cursor-column s) (screen-columns s))
(when (< (screen-cursor-row s) (- (screen-rows s) 1))
(output tty (ansi:clear-to-eol) "\r\n"))
(set-screen-cursor-column! s 0) (set-screen-cursor-column! s 0)
(set-screen-cursor-row! s (+ (screen-cursor-row s) 1)))) (set-screen-cursor-row! s (+ (screen-cursor-row s) 1))))
;; Answers #t when an edit to a line would produce a visible effect.
(define (interesting-change? old-line new-line column right-margin)
(for/or [(i (in-range column right-margin))]
(not (equal? (vector-ref old-line i) (vector-ref new-line i)))))
(define (tty-flush tty) (define (tty-flush tty)
;; (set-pen tty *pen-white-on-black* #:force #t)
;; (clear tty)
(define old (tty-displayed-screen tty)) (define old (tty-displayed-screen tty))
(define new (tty-pending-screen tty)) (define new (tty-pending-screen tty))
(define patches (diff-indices (screen-contents old) (screen-contents new))) (apply-patch! (diff-indices (screen-contents old) (screen-contents new))
(lambda (first-row lines-to-remove)
;; Proceed in two stages: (output tty (goto-if-needed old first-row (screen-cursor-column old)))
;; - delete unwanted lines (delete-lines tty lines-to-remove))
;; - insert and blank lines (lambda (first-row lines-to-insert line-count)
(when (positive? lines-to-insert)
(for/fold [(skew 0)] (output tty (goto-if-needed old first-row (screen-cursor-column old)))
[(patch patches)] (insert-lines tty lines-to-insert))
(match-define (list patch-old-line patch-old-count patch-new-line patch-new-count) patch) (for ((row (in-range first-row (+ first-row line-count))))
(define delta-lines (- patch-new-count patch-old-count)) (define old-line (vector-ref (screen-contents old) row))
(define first-row (+ patch-old-line skew)) (define new-line (vector-ref (screen-contents new) row))
(if (negative? delta-lines) (apply-patch! (diff-indices old-line new-line)
(begin (output tty (goto-if-needed old first-row (screen-cursor-column old))) (lambda (first-col cols-to-remove)
(delete-lines tty (- delta-lines)) (when (interesting-change? old-line
(+ skew delta-lines)) new-line
skew)) first-col
(screen-columns new))
(for/fold [(skew 0)] (output tty (goto-if-needed old row first-col))
[(patch patches)] (delete-columns tty cols-to-remove)))
(match-define (list patch-old-line patch-old-count patch-new-line patch-new-count) patch) (lambda (first-col cols-to-insert cell-count)
(define delta-lines (- patch-new-count patch-old-count)) (when (interesting-change? old-line
(define first-row (+ patch-old-line skew)) new-line
(when (positive? delta-lines) first-col
(output tty (goto-if-needed old first-row (screen-cursor-column old))) (screen-columns new))
(insert-lines tty delta-lines)) (output tty (goto-if-needed old row first-col))
(for ((row (in-range first-row (+ patch-old-line skew patch-new-count)))) (when (and (positive? cols-to-insert)
(define old-line (vector-ref (screen-contents old) row)) (interesting-change? old-line
(define new-line (vector-ref (screen-contents new) row)) new-line
;; TODO: consider diffing old-line and new-line and applying (+ first-col cols-to-insert)
;; patches rather than just blitting out the whole line (screen-columns new)))
;; whereever it is different. (insert-columns tty cols-to-insert))
(for ((column (screen-columns new))) (for ((column (in-range first-col (+ first-col cell-count))))
(match-define (cons old-pen old-ch) (vector-ref old-line column)) (match-define (cons new-pen new-ch)
(match-define (cons new-pen new-ch) (vector-ref new-line column)) (vector-ref new-line column))
(when (not (and (equal? old-pen new-pen) (equal? old-ch new-ch))) (when (non-empty? new-ch)
(set-pen tty new-pen) (set-pen tty new-pen)
(output tty (goto-if-needed old row column) new-ch) (output tty (goto-if-needed old row column) new-ch)
(advance-cursor! old)))) (advance-cursor! tty old)))))))))
(+ skew delta-lines))
(output tty (goto-if-needed old (screen-cursor-row new) (screen-cursor-column new))) (output tty (goto-if-needed old (screen-cursor-row new) (screen-cursor-column new)))
(flush tty) (flush tty)
(set-tty-displayed-screen! tty new) (set-tty-displayed-screen! tty (struct-copy screen new [pen (screen-pen old)]))
(set-tty-pending-screen! tty (copy-screen new)) (set-tty-pending-screen! tty (copy-screen new))
tty) tty)