TUI experiment WIP
This commit is contained in:
parent
7633174562
commit
5d7557df55
|
@ -0,0 +1,129 @@
|
|||
#lang racket/base
|
||||
;; Text diff algorithm after Myers 1986 and Ukkonen 1985, following
|
||||
;; Levente Uzonyi's Squeak Smalltalk implementation at
|
||||
;; http://squeaksource.com/DiffMerge.html
|
||||
;;
|
||||
;; E. W. Myers, “An O(ND) difference algorithm and its variations,”
|
||||
;; Algorithmica, vol. 1, no. 1–4, pp. 251–266, Nov. 1986.
|
||||
;;
|
||||
;; E. Ukkonen, “Algorithms for approximate string matching,” Inf.
|
||||
;; Control, vol. 64, no. 1–3, pp. 100–118, Jan. 1985.
|
||||
|
||||
(provide diff-indices
|
||||
apply-patch!)
|
||||
|
||||
(require racket/match)
|
||||
|
||||
(define (longest-common-subsequence* xs ys)
|
||||
(define xs-length (vector-length xs))
|
||||
(define ys-length (vector-length ys))
|
||||
(define total-length (+ xs-length ys-length))
|
||||
(define storage-length (+ 1 (* 2 total-length)))
|
||||
(define frontier (make-vector storage-length 0))
|
||||
(define candidates (make-vector storage-length '()))
|
||||
(let/ec return
|
||||
(for ((d (in-range 0 (+ total-length 1))))
|
||||
(for ((k (in-range (- d) (+ d 1) 2)))
|
||||
(define-values (index x)
|
||||
(if (or (= k (- d))
|
||||
(and (not (= k d))
|
||||
(< (vector-ref frontier (+ total-length k -1))
|
||||
(vector-ref frontier (+ total-length k 1)))))
|
||||
(values (+ total-length k 1) (vector-ref frontier (+ total-length k 1)))
|
||||
(values (+ total-length k -1) (+ (vector-ref frontier (+ total-length k -1)) 1))))
|
||||
(let loop ((x x) (y (- x k)) (chain (vector-ref candidates index)))
|
||||
(cond
|
||||
[(and (< x xs-length) (< y ys-length) (equal? (vector-ref xs x) (vector-ref ys y)))
|
||||
(loop (+ x 1) (+ y 1) (cons (cons x y) chain))]
|
||||
[(and (>= x xs-length) (>= y ys-length))
|
||||
(return (reverse chain))]
|
||||
[else
|
||||
(vector-set! frontier (+ total-length k) x)
|
||||
(vector-set! candidates (+ total-length k) chain)]))))))
|
||||
|
||||
(define (sequence->vector xs) (for/vector ((x xs)) x))
|
||||
|
||||
(define (longest-common-subsequence xs ys)
|
||||
(longest-common-subsequence* (sequence->vector xs) (sequence->vector ys)))
|
||||
|
||||
(define (diff-indices xs0 ys0)
|
||||
(define xs (sequence->vector xs0))
|
||||
(define ys (sequence->vector ys0))
|
||||
(let loop ((i -1)
|
||||
(j -1)
|
||||
(matches (append (longest-common-subsequence* xs ys)
|
||||
(list (cons (vector-length xs) (vector-length ys))))))
|
||||
(match matches
|
||||
['() '()]
|
||||
[(cons (cons mi mj) rest)
|
||||
(define li (- mi i 1))
|
||||
(define lj (- mj j 1))
|
||||
(if (or (positive? li) (positive? lj))
|
||||
(cons (list (+ i 1) li (+ j 1) lj) (loop mi mj rest))
|
||||
(loop mi mj rest))])))
|
||||
|
||||
;; patch-indices is a result from a call to diff-indices
|
||||
(define (apply-patch! patch-indices ;; DiffIndices
|
||||
remove-elements! ;; Nat Nat -> Void
|
||||
insert-elements! ;; Nat Nat Nat -> Void
|
||||
)
|
||||
(for/fold [(skew 0)] [(patch patch-indices)]
|
||||
(match-define (list old-i old-n new-i new-n) patch)
|
||||
(define delta (- new-n old-n))
|
||||
(if (negative? delta)
|
||||
(begin (remove-elements! (+ old-i skew) (- delta))
|
||||
(+ skew delta))
|
||||
skew))
|
||||
(for/fold [(skew 0)] [(patch patch-indices)]
|
||||
(match-define (list old-i old-n new-i new-n) patch)
|
||||
(define delta (- new-n old-n))
|
||||
(insert-elements! (+ old-i skew) (max 0 delta) new-n)
|
||||
(+ skew delta))
|
||||
(void))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
;; (define (test-example xs ys)
|
||||
;; (printf "~v\n" (longest-common-subsequence xs ys))
|
||||
;; (printf "~v\n" (diff-indices xs ys)))
|
||||
;; (test-example "The red brown fox jumped over the rolling log"
|
||||
;; "The brown spotted fox leaped over the rolling log")
|
||||
|
||||
(check-equal? (diff-indices "The red brown fox jumped over the rolling log"
|
||||
"The brown spotted fox leaped over the rolling log")
|
||||
'((4 4 4 0) (14 0 10 8) (18 3 22 3)))
|
||||
|
||||
(check-equal? (longest-common-subsequence "acbcaca" "bcbcacb")
|
||||
'((1 . 1) (2 . 2) (3 . 3) (4 . 4) (5 . 5)))
|
||||
(check-equal? (longest-common-subsequence "bcbcacb" "acbcaca")
|
||||
'((1 . 1) (2 . 2) (3 . 3) (4 . 4) (5 . 5)))
|
||||
(check-equal? (longest-common-subsequence "acba" "bcbb")
|
||||
'((1 . 1) (2 . 2)))
|
||||
(check-equal? (longest-common-subsequence "abcabba" "cbabac")
|
||||
'((2 . 0) (3 . 2) (4 . 3) (6 . 4)))
|
||||
(check-equal? (longest-common-subsequence "cbabac" "abcabba")
|
||||
'((1 . 1) (2 . 3) (3 . 4) (4 . 6)))
|
||||
|
||||
(check-equal? (longest-common-subsequence
|
||||
(vector (vector 1 1 1) (vector 1 1 1) (vector 1 1 1) (vector 1 1 1))
|
||||
(vector (vector 1 1 1) (vector 2 2 2) (vector 1 1 1) (vector 4 4 4)))
|
||||
'((0 . 0) (1 . 2)))
|
||||
(check-equal? (diff-indices
|
||||
(vector (vector 1 1 1) (vector 1 1 1) (vector 1 1 1) (vector 1 1 1))
|
||||
(vector (vector 1 1 1) (vector 2 2 2) (vector 1 1 1) (vector 4 4 4)))
|
||||
'((1 0 1 1) (2 2 3 1)))
|
||||
|
||||
(check-equal? (longest-common-subsequence '(a b c) '(d e f)) '())
|
||||
(check-equal? (diff-indices '(a b c) '(d e f)) '((0 3 0 3)))
|
||||
|
||||
(let ((size 400))
|
||||
(local-require profile)
|
||||
(profile-thunk
|
||||
(lambda ()
|
||||
(diff-indices (make-vector size 'x)
|
||||
(let ((v (make-vector size 'x)))
|
||||
(vector-set! v 0 'a)
|
||||
(vector-set! v 1 'b)
|
||||
(vector-set! v 2 'c)
|
||||
v))))))
|
|
@ -0,0 +1,269 @@
|
|||
#lang racket/base
|
||||
;; Implicitly provides a factory via display.rkt's `register-tty-backend!`.
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require (only-in racket/vector vector-copy))
|
||||
(require (prefix-in ansi: ansi))
|
||||
(require "display.rkt")
|
||||
(require "diff.rkt")
|
||||
|
||||
(struct terminal (input ;; InputPort
|
||||
output ;; OutputPort
|
||||
[displayed-screen #:mutable] ;; Screen
|
||||
[pending-screen #:mutable] ;; Screen
|
||||
[utf-8-input? #:mutable] ;; Boolean
|
||||
[displayed-title #:mutable] ;; (Option String)
|
||||
[pending-title #:mutable] ;; (Option String)
|
||||
)
|
||||
#:methods gen:tty
|
||||
[(define (tty-pending-screen t) (terminal-pending-screen t))
|
||||
(define (set-tty-pending-screen! t s) (set-terminal-pending-screen! t s))
|
||||
(define (tty-reset t) (reset t))
|
||||
(define (tty-flush t) (terminal-flush t))
|
||||
(define (tty-set-title! t title) (set-terminal-pending-title! t title))
|
||||
(define (tty-next-key t) (terminal-next-key t))
|
||||
(define (tty-next-key-evt t) (terminal-next-key-evt t))
|
||||
(define (tty-input-available-evt t) (terminal-input t))])
|
||||
|
||||
(define *stdin-tty* #f)
|
||||
(define (stdin-tty)
|
||||
(when (not *stdin-tty*)
|
||||
(ansi:tty-raw!)
|
||||
(set! *stdin-tty*
|
||||
(terminal
|
||||
(current-input-port)
|
||||
(current-output-port)
|
||||
(make-screen 24 80 tty-default-pen)
|
||||
(make-screen 24 80 tty-default-pen)
|
||||
(match (getenv "RMACS_UTF8_INPUT")
|
||||
[(or #f "yes" "true" "1") #t]
|
||||
[(or "no" "false" "0") #f]
|
||||
[v (error 'RMACS_UTF8_INPUT
|
||||
"Environment variable RMACS_UTF8_INPUT value ~v invalid: must be in ~v"
|
||||
v
|
||||
(list "yes" "true" "1" "no" "false" "0"))])
|
||||
#f
|
||||
#f))
|
||||
(reset *stdin-tty*)
|
||||
(plumber-add-flush! (current-plumber)
|
||||
(lambda (h)
|
||||
(output *stdin-tty*
|
||||
(ansi:select-graphic-rendition ansi:style-normal)
|
||||
(ansi:goto (tty-rows *stdin-tty*) 1))
|
||||
(flush *stdin-tty*))))
|
||||
*stdin-tty*)
|
||||
|
||||
(define (collect-position-report tty)
|
||||
(let loop ()
|
||||
(sync/timeout 0.5
|
||||
(handle-evt (terminal-input tty)
|
||||
(lambda (p)
|
||||
(match (ansi:lex-lcd-input p)
|
||||
[(? ansi:position-report? r) r]
|
||||
[_ (loop)]))))))
|
||||
|
||||
(define (reset tty)
|
||||
(output tty
|
||||
(ansi:clear-screen)
|
||||
(ansi:goto 999 999)
|
||||
(ansi:position-report-request))
|
||||
(flush tty)
|
||||
(define report (or (collect-position-report tty)
|
||||
(ansi:position-report 24 80))) ;; TODO: have a more flexible fallback
|
||||
(define rows (ansi:position-report-row report))
|
||||
(define columns (ansi:position-report-column report))
|
||||
(set-pen tty tty-default-pen #:force #t)
|
||||
(clear tty)
|
||||
(flush tty)
|
||||
(set-terminal-displayed-screen! tty (make-screen rows columns tty-default-pen))
|
||||
(set-terminal-pending-screen! tty (make-screen rows columns tty-default-pen))
|
||||
tty)
|
||||
|
||||
(define (set-pen tty p #:force [force #f])
|
||||
(when (or force (not (equal? p (screen-pen (terminal-displayed-screen tty)))))
|
||||
(match p
|
||||
[(pen fgcolor bgcolor bold? italic?)
|
||||
(output tty
|
||||
(apply ansi:select-graphic-rendition
|
||||
`(,@(if bold? (list ansi:style-bold) (list))
|
||||
,@(if italic? (list ansi:style-italic/inverse) (list))
|
||||
,(ansi:style-text-color fgcolor)
|
||||
,(ansi:style-background-color bgcolor))))]
|
||||
['default
|
||||
(output tty (ansi:select-graphic-rendition ansi:style-normal))])
|
||||
(set-screen-pen! (terminal-displayed-screen tty) p))
|
||||
tty)
|
||||
|
||||
(define (clear tty)
|
||||
(output tty (ansi:clear-screen/home))
|
||||
(set-screen-cursor-row! (terminal-displayed-screen tty) 0)
|
||||
(set-screen-cursor-column! (terminal-displayed-screen tty) 0)
|
||||
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 s (terminal-displayed-screen tty))
|
||||
(set-pen tty tty-default-pen)
|
||||
(output tty (ansi:delete-lines n))
|
||||
(define blank-line (make-vector (screen-columns s) (cons (screen-pen s) 'empty)))
|
||||
(vector-delete! (screen-contents s) (screen-cursor-row s) n blank-line)
|
||||
tty)
|
||||
|
||||
(define (insert-lines tty n)
|
||||
(define s (terminal-displayed-screen tty))
|
||||
(set-pen tty tty-default-pen)
|
||||
(output tty (ansi:insert-lines n))
|
||||
(define blank-line (make-vector (screen-columns s) (cons (screen-pen s) 'empty)))
|
||||
(vector-insert! (screen-contents s) (screen-cursor-row s) n blank-line)
|
||||
tty)
|
||||
|
||||
(define (delete-columns tty n)
|
||||
(define s (terminal-displayed-screen tty))
|
||||
(set-pen tty tty-default-pen)
|
||||
(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 (terminal-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)
|
||||
|
||||
(define (output tty . items)
|
||||
(for ((i items)) (display i (terminal-output tty))))
|
||||
|
||||
(define (flush tty)
|
||||
(flush-output (terminal-output tty)))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Display to buffered screen
|
||||
|
||||
(define (goto-if-needed s row column)
|
||||
(cond
|
||||
[(and (= (screen-cursor-row s) row) (= (screen-cursor-column s) column))
|
||||
""]
|
||||
[(= (screen-cursor-row s) row)
|
||||
(begin0 (ansi:goto-column (+ column 1))
|
||||
(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! tty s)
|
||||
(set-screen-cursor-column! s (+ (screen-cursor-column s) 1))
|
||||
(when (= (screen-cursor-column s) (screen-columns s))
|
||||
(when (< (screen-cursor-row s) (- (screen-rows s) 1))
|
||||
(output tty "\r\n"))
|
||||
(set-screen-cursor-column! s 0)
|
||||
(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 (non-empty? ch) (not (equal? ch 'empty)))
|
||||
|
||||
(define (repair-span! tty old new-line row first-col cell-count)
|
||||
(define trailing-empty-count
|
||||
(for/fold [(empty-count 0)] [(column (in-range first-col (+ first-col cell-count)))]
|
||||
(match-define (cons new-pen new-ch) (vector-ref new-line column))
|
||||
(if (non-empty? new-ch)
|
||||
(begin (set-pen tty new-pen)
|
||||
(output tty (goto-if-needed old row column) new-ch)
|
||||
(advance-cursor! tty old)
|
||||
0)
|
||||
(+ empty-count 1))))
|
||||
(when (and (positive? trailing-empty-count) (= (+ first-col cell-count) (tty-columns tty)))
|
||||
(output tty (ansi:clear-to-eol))))
|
||||
|
||||
(define (repair-line! tty old new row)
|
||||
(define columns (screen-columns new))
|
||||
(define old-line (vector-ref (screen-contents old) row))
|
||||
(define new-line (vector-ref (screen-contents new) row))
|
||||
(define patches (diff-indices old-line new-line))
|
||||
(if (<= (length patches) 3)
|
||||
(apply-patch! patches
|
||||
(lambda (first-col cols-to-remove)
|
||||
(when (interesting-change? old-line new-line first-col columns)
|
||||
(output tty (goto-if-needed old row first-col))
|
||||
(delete-columns tty cols-to-remove)))
|
||||
(lambda (first-col cols-to-insert cell-count)
|
||||
(when (interesting-change? old-line new-line first-col columns)
|
||||
(output tty (goto-if-needed old row first-col))
|
||||
(when (and (positive? cols-to-insert)
|
||||
(interesting-change? old-line
|
||||
new-line
|
||||
(+ first-col cols-to-insert)
|
||||
columns))
|
||||
(insert-columns tty cols-to-insert))
|
||||
(repair-span! tty old new-line row first-col cell-count))))
|
||||
(repair-span! tty old new-line row 0 columns)))
|
||||
|
||||
(define (terminal-flush t)
|
||||
(define old (terminal-displayed-screen t))
|
||||
(define new (terminal-pending-screen t))
|
||||
(apply-patch! (diff-indices (screen-contents old) (screen-contents new))
|
||||
(lambda (first-row lines-to-remove)
|
||||
(output t (goto-if-needed old first-row (screen-cursor-column old)))
|
||||
(delete-lines t lines-to-remove))
|
||||
(lambda (first-row lines-to-insert line-count)
|
||||
(when (positive? lines-to-insert)
|
||||
(output t (goto-if-needed old first-row (screen-cursor-column old)))
|
||||
(insert-lines t lines-to-insert))
|
||||
(for ((row (in-range first-row (+ first-row line-count))))
|
||||
(repair-line! t old new row))))
|
||||
(output t (goto-if-needed old (screen-cursor-row new) (screen-cursor-column new)))
|
||||
(let ((new-title (terminal-pending-title t)))
|
||||
(when (not (equal? new-title (terminal-displayed-title t)))
|
||||
(when new-title (output t (ansi:xterm-set-window-title new-title)))
|
||||
(set-terminal-displayed-title! t new-title)))
|
||||
(flush t)
|
||||
(set-terminal-displayed-screen! t (struct-copy screen new [pen (screen-pen old)]))
|
||||
(set-terminal-pending-screen! t (copy-screen new))
|
||||
t)
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Input
|
||||
|
||||
(define (has-control-modifier? modifiers)
|
||||
(set-member? modifiers 'control))
|
||||
|
||||
(define (terminal-next-key tty)
|
||||
(define k (ansi:lex-lcd-input (terminal-input tty) #:utf-8? (terminal-utf-8-input? tty)))
|
||||
(match k
|
||||
[(ansi:key #\tab modifiers) (ansi:key 'tab modifiers)]
|
||||
[(ansi:key #\I (? has-control-modifier? ms)) (ansi:key 'tab (set-remove ms 'control))]
|
||||
[(ansi:key #\M (? has-control-modifier? ms)) (ansi:key 'return (set-remove ms 'control))]
|
||||
[(ansi:key #\[ (? has-control-modifier? ms)) ;; ESC
|
||||
(or (sync/timeout 0.5
|
||||
(handle-evt (terminal-next-key-evt tty)
|
||||
(lambda (k) (ansi:add-modifier 'meta k))))
|
||||
(ansi:key 'escape (set-remove ms 'control)))]
|
||||
[_ k]))
|
||||
|
||||
(define (terminal-next-key-evt tty)
|
||||
(handle-evt (terminal-input tty)
|
||||
(lambda (_) (terminal-next-key tty))))
|
||||
|
||||
(register-tty-backend! 'terminal stdin-tty)
|
|
@ -0,0 +1,208 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide gen:tty
|
||||
tty?
|
||||
tty-pending-screen
|
||||
set-tty-pending-screen!
|
||||
tty-rows
|
||||
tty-columns
|
||||
tty-last-row
|
||||
tty-last-column
|
||||
tty-cursor-row
|
||||
tty-cursor-column
|
||||
tty-display
|
||||
tty-newline
|
||||
tty-clear
|
||||
tty-clear-to-eol
|
||||
tty-reset
|
||||
tty-goto
|
||||
tty-set-pen!
|
||||
tty-default-pen
|
||||
tty-pen
|
||||
tty-flush
|
||||
tty-set-title!
|
||||
tty-next-key
|
||||
tty-next-key-evt
|
||||
tty-input-available-evt
|
||||
|
||||
(struct-out pen)
|
||||
|
||||
register-tty-backend!
|
||||
default-tty
|
||||
|
||||
(struct-out screen)
|
||||
make-screen
|
||||
copy-screen
|
||||
screen-last-row
|
||||
screen-last-column
|
||||
screen-goto
|
||||
screen-putc
|
||||
screen-puts
|
||||
screen-clear-to-eol
|
||||
|
||||
;; From ansi. TODO: better color & keyboard abstractions
|
||||
(struct-out key)
|
||||
(rename-out [ansi:color-black color-black]
|
||||
[ansi:color-red color-red]
|
||||
[ansi:color-green color-green]
|
||||
[ansi:color-yellow color-yellow]
|
||||
[ansi:color-blue color-blue]
|
||||
[ansi:color-magenta color-magenta]
|
||||
[ansi:color-cyan color-cyan]
|
||||
[ansi:color-white color-white]))
|
||||
|
||||
(require racket/match)
|
||||
(require racket/generic)
|
||||
(require (only-in racket/vector vector-copy))
|
||||
(require (prefix-in ansi: (only-in ansi
|
||||
color-black
|
||||
color-red
|
||||
color-green
|
||||
color-yellow
|
||||
color-blue
|
||||
color-magenta
|
||||
color-cyan
|
||||
color-white)))
|
||||
(require (only-in ansi struct:key key key? key-value key-modifiers))
|
||||
|
||||
;; A Color is a Nat. TODO: better color abstraction.
|
||||
|
||||
(define-generics tty
|
||||
(tty-pending-screen tty)
|
||||
(set-tty-pending-screen! tty s)
|
||||
(tty-reset tty)
|
||||
(tty-flush tty)
|
||||
(tty-set-title! tty title)
|
||||
(tty-next-key tty)
|
||||
|
||||
;; Do not retain the events returned by these functions across
|
||||
;; actual input from the tty! See comment in editor-sit-for, and
|
||||
;; implementations of these functions in display-gui.rkt. (The
|
||||
;; fragility of the pushback in display-gui.rkt is the cause of this
|
||||
;; restriction.)
|
||||
(tty-next-key-evt tty)
|
||||
(tty-input-available-evt tty)
|
||||
)
|
||||
|
||||
(define (tty-rows t) (screen-rows (tty-pending-screen t)))
|
||||
(define (tty-columns t) (screen-columns (tty-pending-screen t)))
|
||||
|
||||
(define (tty-last-row t) (- (tty-rows t) 1))
|
||||
(define (tty-last-column t) (- (tty-columns t) 1))
|
||||
|
||||
(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-display t . strings)
|
||||
(for [(str strings)]
|
||||
(screen-puts (tty-pending-screen t) str)))
|
||||
|
||||
(define (tty-newline t)
|
||||
(define s (tty-pending-screen t))
|
||||
(screen-clear-to-eol s)
|
||||
(screen-putc s #\return)
|
||||
(screen-putc s #\newline))
|
||||
|
||||
(define (tty-clear t)
|
||||
(define s (tty-pending-screen t))
|
||||
(set-tty-pending-screen! t (make-screen (screen-rows s) (screen-columns s) (screen-pen s)))
|
||||
t)
|
||||
|
||||
(define (tty-clear-to-eol t) (screen-clear-to-eol (tty-pending-screen t)))
|
||||
(define (tty-goto t row col) (screen-goto (tty-pending-screen t) row col))
|
||||
(define (tty-set-pen! t p) (set-screen-pen! (tty-pending-screen t) p))
|
||||
(define (tty-pen t) (screen-pen (tty-pending-screen t)))
|
||||
|
||||
(define tty-default-pen 'default)
|
||||
|
||||
(struct pen (foreground-color ;; Color
|
||||
background-color ;; Color
|
||||
bold? ;; Boolean
|
||||
italic? ;; Boolean
|
||||
) #:prefab)
|
||||
|
||||
(struct backend (name ;; Symbol
|
||||
priority ;; Integer
|
||||
factory ;; (-> TTY)
|
||||
)
|
||||
#:prefab)
|
||||
|
||||
(struct screen (rows ;; Nat
|
||||
columns ;; Nat
|
||||
[cursor-row #:mutable] ;; Nat
|
||||
[cursor-column #:mutable] ;; Nat
|
||||
[pen #:mutable] ;; Pen
|
||||
contents ;; (Vector[rows] (Vector[columns] (Cons Pen Character)))
|
||||
) #:prefab)
|
||||
|
||||
(define (screen-last-row s) (- (screen-rows s) 1))
|
||||
(define (screen-last-column s) (- (screen-columns s) 1))
|
||||
|
||||
(define (make-screen rows columns pen)
|
||||
(define contents (for/vector ((row rows)) (make-vector columns (cons pen 'empty))))
|
||||
(screen rows columns 0 0 pen contents))
|
||||
|
||||
(define (copy-screen s)
|
||||
(match-define (screen rows columns cursor-row cursor-column pen contents) s)
|
||||
(define new-contents (for/vector ((row rows)) (vector-copy (vector-ref contents row))))
|
||||
(screen rows columns cursor-row cursor-column pen new-contents))
|
||||
|
||||
(define (screen-goto s row0 column0)
|
||||
(define row (max 0 (min (screen-last-row s) row0)))
|
||||
(define column (max 0 (min (screen-last-column s) column0)))
|
||||
(set-screen-cursor-row! s row)
|
||||
(set-screen-cursor-column! s column)
|
||||
s)
|
||||
|
||||
(define (non-empty? ch) (not (equal? ch 'empty)))
|
||||
|
||||
(define (screen-putc s ch)
|
||||
(match ch
|
||||
[#\return
|
||||
(screen-goto s (screen-cursor-row s) 0)]
|
||||
[#\newline
|
||||
(screen-goto s (+ (screen-cursor-row s) 1) (screen-cursor-column s))]
|
||||
[#\tab
|
||||
(for ((i (- 8 (modulo (screen-cursor-column s) 8)))) (screen-putc s #\space))]
|
||||
[(and (? non-empty?) (? char-iso-control?))
|
||||
(screen-puts s (format "[~x]" (char->integer ch)))]
|
||||
[_
|
||||
(when (< (screen-cursor-column s) (screen-columns s))
|
||||
(vector-set! (vector-ref (screen-contents s) (screen-cursor-row s))
|
||||
(screen-cursor-column s)
|
||||
(cons (screen-pen s) ch)))
|
||||
(set-screen-cursor-column! s (+ (screen-cursor-column s) 1))]))
|
||||
|
||||
(define (screen-puts s str)
|
||||
(for ((ch str)) (screen-putc s ch)))
|
||||
|
||||
(define (screen-clear-to-eol s)
|
||||
(define start-column (screen-cursor-column s))
|
||||
(define pen (screen-pen s))
|
||||
(set-screen-pen! s tty-default-pen)
|
||||
(for ((i (max 0 (- (screen-columns s) (screen-cursor-column s)))))
|
||||
(screen-putc s 'empty))
|
||||
(set-screen-pen! s pen)
|
||||
(screen-goto s (screen-cursor-row s) start-column)
|
||||
s)
|
||||
|
||||
(define *tty-backends* '())
|
||||
|
||||
(define (register-tty-backend! name factory #:priority [priority 0])
|
||||
(set! *tty-backends* (cons (backend name priority factory)
|
||||
(filter (lambda (b) (not (eq? (backend-name b) name)))
|
||||
*tty-backends*)))
|
||||
(set! *tty-backends* (sort *tty-backends* > #:key backend-priority)))
|
||||
|
||||
(define *default-tty* #f)
|
||||
(define (default-tty)
|
||||
(when (not *default-tty*)
|
||||
(let loop ((backends *tty-backends*))
|
||||
(match backends
|
||||
['() (error 'default-tty "No available tty backends")]
|
||||
[(cons (backend name _priority factory) rest)
|
||||
(define t (factory))
|
||||
(if t
|
||||
(set! *default-tty* t)
|
||||
(loop rest))])))
|
||||
*default-tty*)
|
|
@ -0,0 +1,63 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide tui-dataspace
|
||||
install-tui-dataspace!)
|
||||
|
||||
(require racket/async-channel)
|
||||
(require racket/match)
|
||||
(require racket/set)
|
||||
(require (only-in racket/string string-replace))
|
||||
|
||||
(require (only-in syndicate seal process-name process-behavior process))
|
||||
(require (only-in syndicate/dataspace dataspace?))
|
||||
(require (only-in syndicate/relay relay))
|
||||
(require (only-in syndicate/lang current-ground-dataspace))
|
||||
(require syndicate/patch)
|
||||
(require syndicate/ground)
|
||||
(require syndicate/trace)
|
||||
(require syndicate/store)
|
||||
|
||||
(require "display.rkt")
|
||||
(require "display-terminal.rkt")
|
||||
|
||||
(define (process-is-dataspace? p)
|
||||
(match p
|
||||
[(process _name _beh (? dataspace? _)) #t]
|
||||
[(process _name _beh (relay _ _ _ _ _ (process _inner-name _inner-beh (? dataspace? _)))) #t]
|
||||
[_ #f]))
|
||||
|
||||
(define ((tui-dataspace) . boot-actions)
|
||||
(define from-user-thread-ch (make-async-channel))
|
||||
|
||||
(define user-thread
|
||||
(thread (lambda ()
|
||||
(with-store ((current-trace-procedures
|
||||
(cons (lambda (n) (async-channel-put from-user-thread-ch n))
|
||||
(current-trace-procedures))))
|
||||
(run-ground boot-actions)))))
|
||||
|
||||
(signal-background-activity! #t)
|
||||
(define tty (default-tty))
|
||||
|
||||
(define (dump x)
|
||||
(tty-display tty (string-replace (format "~v\n" x) "\n" "\r\n")))
|
||||
|
||||
(let loop ()
|
||||
(tty-flush tty)
|
||||
(sync (handle-evt from-user-thread-ch
|
||||
(lambda (n)
|
||||
(dump n)
|
||||
(loop)))
|
||||
(handle-evt (tty-next-key-evt tty)
|
||||
(lambda (k)
|
||||
(match k
|
||||
[(key #\q (== (set))) (void)]
|
||||
[_
|
||||
(dump k)
|
||||
(loop)]))))))
|
||||
|
||||
(define install-tui-dataspace!
|
||||
(make-keyword-procedure
|
||||
(lambda (ks vs . positionals)
|
||||
(define installed-dataspace (current-ground-dataspace))
|
||||
(current-ground-dataspace (keyword-apply tui-dataspace ks vs positionals)))))
|
|
@ -0,0 +1,158 @@
|
|||
#lang racket/base
|
||||
;; TUI Window Manager
|
||||
|
||||
;; A TBox is a thing that can be laid out, displayed, and interacted
|
||||
;; with.
|
||||
|
||||
;; TBoxes can be placed in relationship to other boxes:
|
||||
;; - h{t,c,b}-append
|
||||
;; - v{l,c,r}-append
|
||||
;; - {l,c,r}{t,c,b}-superimpose
|
||||
;; - wrap
|
||||
|
||||
;; Sources of inspiration:
|
||||
;; http://icie.cs.byu.edu/cs456/UIBook/05-Layout.pdf
|
||||
;; http://doc.qt.io/qt-5/qtwidgets-tutorials-widgets-nestedlayouts-example.html
|
||||
;; http://www.math.utah.edu/~beebe/reports/2009/boxes.pdf
|
||||
|
||||
;; EXAMPLES for developing intuition:
|
||||
;; 1. a button
|
||||
;; 2. a scrollbar
|
||||
;; 3. a list of items with a panel to its right having a
|
||||
;; variable-width pretty-printing of the selected item
|
||||
;;
|
||||
;; Button: Minimum size reflects minimal chrome; simply the smallest
|
||||
;; possible workable size. Desired and maximum size are the same,
|
||||
;; large enough to contain the usual chrome.
|
||||
;;
|
||||
;; Scrollbar: wolog, horizontal. Height is fixed. Minimum width
|
||||
;; reflects thumbless condition. Desired width might reflect some
|
||||
;; arbitrary size where the thumb could be moved around. Max width
|
||||
;; would usually involve a horizontal fill of some weight and rank.
|
||||
;; Hmm, but then why not have the desired width just be the max width?
|
||||
;; Perhaps desired and max are the same?
|
||||
;;
|
||||
;; Items and pretty-printing: Something like this:
|
||||
;;
|
||||
;; +----------+------------+
|
||||
;; |*(foo ...*| (foo (bar |
|
||||
;; | (b () .. | zot) |
|
||||
;; | 123 | () |
|
||||
;; | | quux |
|
||||
;; | | baz) |
|
||||
;; +----------+------------+
|
||||
;;
|
||||
;; We want the item list to get some reasonable minimal amount of
|
||||
;; space, and otherwise to take up space not used by the
|
||||
;; pretty-printing. The pretty-printing should try to use vertical
|
||||
;; space within reason and otherwise should try to be as compact as
|
||||
;; possible.
|
||||
;;
|
||||
;; ---
|
||||
;;
|
||||
;; This min/desired/max split is a bit clunky. Could we have a list of
|
||||
;; preferred TeX-style sizings, ordered most-preferred first? They
|
||||
;; could include information to send back to the box at render time.
|
||||
;; For example, the button might offer horizontal sizings
|
||||
;;
|
||||
;; (list (sizing 'normal-chrome 10 (fill 1 1) 2)
|
||||
;; (sizing 'no-chrome 6 0 0))
|
||||
;;
|
||||
;; ---
|
||||
;;
|
||||
;; How does arithmetic on sizings work?
|
||||
;;
|
||||
;; Ideals are never fills, they're simply naturals. They can be
|
||||
;; added/min'd/max'd as usual.
|
||||
;;
|
||||
;; Stretch is sometimes a natural, and sometimes a fill.
|
||||
;;
|
||||
;; n + fill w r = fill w r
|
||||
;; fill w1 r + fill w2 r = fill (w1 + w2) r
|
||||
;; fill _ s + fill w r = fill w r when r > s
|
||||
;;
|
||||
;; The definitions of `max` is similar, with `max` for `+`. A fill
|
||||
;; behaves as a zero for the purposes of `min`.
|
||||
|
||||
(require racket/generic)
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
;; A Fill is one of
|
||||
;; - a Nat, a fixed amount of space
|
||||
;; - a (fill Nat Nat), a potentially infinite amount of space
|
||||
(struct fill (weight rank) #:transparent)
|
||||
|
||||
;; A Sizing is a (sizing Nat Fill Fill)
|
||||
(struct sizing (ideal stretch shrink) #:transparent)
|
||||
|
||||
;; (Nat Nat -> Nat) -> (Fill Fill -> Fill)
|
||||
(define ((fill-binop op) a b)
|
||||
(match* (a b)
|
||||
[((? number?) (? number?)) (op a b)]
|
||||
[((? number?) (? fill?)) b]
|
||||
[((? fill?) (? number?)) a]
|
||||
[((fill w1 r1) (fill w2 r2))
|
||||
(cond [(= r1 r2) (fill (op w1 w2) r1)]
|
||||
[(> r1 r2) (fill w1 r1)]
|
||||
[(< r1 r2) (fill w2 r2)])]))
|
||||
|
||||
;; Fill Fill -> Fill
|
||||
(define fill+ (fill-binop +))
|
||||
(define fill-max (fill-binop max))
|
||||
(define (fill-min a b)
|
||||
(if (and (number? a) (number? b))
|
||||
(min a b)
|
||||
0))
|
||||
|
||||
;; (Nat Nat -> Nat) (Fill Fill -> Fill) -> (Sizing Sizing -> Sizing)
|
||||
;;
|
||||
;; TODO: for max and min, do we really want fop to be used for both
|
||||
;; stretch and shrink?
|
||||
;;
|
||||
(define ((sizing-binop iop fop) a b)
|
||||
(match-define (sizing ia ta ha) a)
|
||||
(match-define (sizing ib tb hb) b)
|
||||
(sizing (iop ia ib) (fop ta tb) (fop ha hb)))
|
||||
|
||||
;; Sizing Sizing -> Sizing
|
||||
(define sizing+ (sizing-binop + fill+))
|
||||
(define sizing-max (sizing-binop max fill-max))
|
||||
(define sizing-min (sizing-binop min fill-min))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define-generics tbox
|
||||
;; TBox (Option Nat) (Option Nat) -> (Listof (List Sizing Sizing))
|
||||
(tbox-sizings tbox maybe-speculative-width maybe-speculative-height)
|
||||
;; TBox TTY Nat Nat Nat Nat -> Void
|
||||
(tbox-render! tbox tty top left width height))
|
||||
|
||||
(struct glue-tbox (horizontal vertical string pen) #:transparent
|
||||
#:methods gen:tbox
|
||||
[(define (tbox-sizings t w h)
|
||||
(list (list (glue-tbox-horizontal t) (glue-tbox-vertical t))))
|
||||
(define (tbox-render! t tty top left width height)
|
||||
(define str (fill-tbox-string t))
|
||||
(define whole-repeats (quotient width (string-length str)))
|
||||
(define fragment (substring str 0 (remainder width (string-length str))))
|
||||
(tty-set-pen! tty (fill-tbox-pen t))
|
||||
(for [(y (in-range height))]
|
||||
(tty-goto tty (+ top y) left)
|
||||
(for [(i (in-range whole-repeats))] (tty-display tty str))
|
||||
(tty-display tty fragment)))])
|
||||
|
||||
;; Nat -> (Cons X (Listof X)) -> X
|
||||
(define ((nth-or-last n) xs)
|
||||
(cond [(zero? n) (car xs)]
|
||||
[(null? (cdr xs)) (car xs)]
|
||||
[else (drop-n-or-last (- n 1) (cdr xs))]))
|
||||
|
||||
(define (layout-horizontal items width height)
|
||||
(define item-count (length items))
|
||||
(define size-preferences (map (lambda (i) (tbox-sizings i #f #f)) items))
|
||||
(let try-nth-choices ((nth-choice 0))
|
||||
(define candidates (map (nth-or-last nth-choice) size-preferences))
|
||||
(define aggregate-h (apply sizing+ (map car candidates)))
|
||||
...
|
||||
|
Loading…
Reference in New Issue