Add buffer abstraction
This commit is contained in:
Jay McCarthy
parent
37341a0c9c
commit
59a3ec62ed
|
|
@ -0,0 +1,157 @@
|
|||
#lang racket/base
|
||||
(require racket/generic
|
||||
racket/match
|
||||
racket/contract/base
|
||||
(prefix-in A: ansi))
|
||||
|
||||
(define-generics buffer
|
||||
(buffer-resize! buffer rows cols)
|
||||
(buffer-start! buffer rows cols)
|
||||
(buffer-commit! buffer))
|
||||
|
||||
(define symbol->style
|
||||
`#hasheq([normal . ,A:style-normal]
|
||||
[bold . ,A:style-bold]
|
||||
[inverse . ,A:style-inverse]
|
||||
[underline . ,A:style-underline]))
|
||||
(define style/c (apply or/c (hash-keys symbol->style)))
|
||||
|
||||
(define symbol->color
|
||||
`#hasheq(
|
||||
[black . 0] [red . 1] [green . 2] [yellow . 3]
|
||||
[blue . 4] [magenta . 5] [cyan . 6] [white . 7]
|
||||
[brblack . 8] [brred . 9] [brgreen . 10] [bryellow . 11]
|
||||
[brblue . 12] [brmagenta . 13] [brcyan . 14] [brwhite . 15]))
|
||||
(define color/c (apply or/c #f (hash-keys symbol->color)))
|
||||
|
||||
(define (select-style* s)
|
||||
(A:select-graphic-rendition (hash-ref symbol->style s)))
|
||||
(define (select-text-color* c)
|
||||
(if c
|
||||
(A:select-xterm-256-text-color (hash-ref symbol->color c))
|
||||
(A:select-graphic-rendition A:style-default-text-color)))
|
||||
(define (select-background-color* c)
|
||||
(if c
|
||||
(A:select-xterm-256-background-color (hash-ref symbol->color c))
|
||||
(A:select-graphic-rendition A:style-default-background-color)))
|
||||
|
||||
(define (make-terminal-buffer term-rows term-cols
|
||||
#:clear? [clear? #t]
|
||||
#:output [op (current-output-port)])
|
||||
(terminal-buffer clear? op term-rows term-cols))
|
||||
(struct terminal-buffer (clear? op term-rows term-cols)
|
||||
#:mutable
|
||||
#:methods gen:buffer
|
||||
[(define (buffer-resize! buf new-rows new-cols)
|
||||
(set-terminal-buffer-term-rows! buf new-rows)
|
||||
(set-terminal-buffer-term-cols! buf new-cols))
|
||||
(define (buffer-start! buf draw-rows draw-cols)
|
||||
(define op (terminal-buffer-op buf))
|
||||
(display (A:dec-soft-terminal-reset) op)
|
||||
(when (terminal-buffer-clear? buf)
|
||||
(display (A:clear-screen/home) op))
|
||||
(display (A:hide-cursor) op)
|
||||
(λ (s f b r c ch)
|
||||
(display (select-style* s) op)
|
||||
(display (select-text-color* f) op)
|
||||
(display (select-background-color* b) op)
|
||||
;; XXX maybe add1 to r & c
|
||||
(display (A:goto (add1 r) (add1 c)) op)
|
||||
(when ch (display ch op))))
|
||||
(define (buffer-commit! buf)
|
||||
(define op (terminal-buffer-op buf))
|
||||
(display (A:show-cursor) op)
|
||||
(flush-output op))])
|
||||
|
||||
(struct output-cell (s f b ch) #:mutable)
|
||||
(define (clear-cell! c)
|
||||
(set-output-cell-s! c 'normal)
|
||||
(set-output-cell-f! c #f)
|
||||
(set-output-cell-b! c #f)
|
||||
(set-output-cell-ch! c #f))
|
||||
(define (default-cell) (output-cell 'normal #f #f #f))
|
||||
(define (make-cells rows cols)
|
||||
(build-vector
|
||||
rows
|
||||
(λ (r)
|
||||
(build-vector cols (λ (c) (default-cell))))))
|
||||
|
||||
(define (make-output-buffer #:output [op (current-output-port)])
|
||||
(output-buffer op 0 0 (make-cells 0 0)))
|
||||
(struct output-buffer (op rows cols cells)
|
||||
#:mutable
|
||||
#:methods gen:buffer
|
||||
[(define (buffer-resize! buf new-rows new-cols)
|
||||
(match-define (output-buffer _ old-rows old-cols _) buf)
|
||||
(when (or (not (<= new-rows old-rows))
|
||||
(not (<= new-cols old-cols)))
|
||||
(set-output-buffer-rows! buf new-rows)
|
||||
(set-output-buffer-cols! buf new-cols)
|
||||
(set-output-buffer-cells! buf (make-cells new-rows new-cols))))
|
||||
(define (buffer-start! buf draw-rows draw-cols)
|
||||
(buffer-resize! buf draw-rows draw-cols)
|
||||
(define cells (output-buffer-cells buf))
|
||||
(for* ([row (in-vector cells)]
|
||||
[cell (in-vector row)])
|
||||
(clear-cell! cell))
|
||||
(λ (s f b r c ch)
|
||||
(define cell (vector-ref (vector-ref cells r) c))
|
||||
(set-output-cell-s! cell s)
|
||||
(set-output-cell-f! cell f)
|
||||
(set-output-cell-b! cell b)
|
||||
(set-output-cell-ch! cell ch)))
|
||||
(define (buffer-commit! buf)
|
||||
(define op (output-buffer-op buf))
|
||||
(define cells (output-buffer-cells buf))
|
||||
(for/fold ([last-s 'normal] [last-f #f] [last-b #f])
|
||||
([row (in-vector cells)])
|
||||
(begin0
|
||||
(for/fold ([last-s last-s] [last-f last-f] [last-b last-b])
|
||||
([oc (in-vector row)])
|
||||
(match-define (output-cell s f b ch) oc)
|
||||
(unless (eq? last-s s)
|
||||
(display (select-style* s) op))
|
||||
(unless (eq? last-f f)
|
||||
(display (select-text-color* f) op))
|
||||
(unless (eq? last-b b)
|
||||
(display (select-background-color* b) op))
|
||||
(display (or ch #\space) op)
|
||||
(values s f b))
|
||||
(newline op)))
|
||||
(flush-output op)
|
||||
(void))])
|
||||
|
||||
(define (make-buffered-terminal-buffer term-rows term-cols
|
||||
#:output [op (current-output-port)])
|
||||
;; XXX
|
||||
(make-terminal-buffer term-rows term-cols
|
||||
#:clear? #t
|
||||
#:output op))
|
||||
|
||||
(provide
|
||||
(contract-out
|
||||
[color/c contract?]
|
||||
[style/c contract?]
|
||||
[buffer? (-> any/c boolean?)]
|
||||
[buffer-resize!
|
||||
(-> buffer?
|
||||
exact-nonnegative-integer? exact-nonnegative-integer?
|
||||
void?)]
|
||||
[buffer-start!
|
||||
(-> buffer?
|
||||
exact-nonnegative-integer? exact-nonnegative-integer?
|
||||
(-> style/c color/c color/c
|
||||
exact-nonnegative-integer? exact-nonnegative-integer? (or/c char? #f)
|
||||
void?))]
|
||||
[buffer-commit!
|
||||
(-> buffer? void?)]
|
||||
[make-terminal-buffer
|
||||
(->* (exact-nonnegative-integer? exact-nonnegative-integer?)
|
||||
(#:clear? boolean? #:output output-port?)
|
||||
buffer?)]
|
||||
[make-output-buffer
|
||||
(->* () (#:output output-port?) buffer?)]
|
||||
[make-buffered-terminal-buffer
|
||||
(->* (exact-nonnegative-integer? exact-nonnegative-integer?)
|
||||
(#:output output-port?)
|
||||
buffer?)]))
|
||||
107
draw.rkt
107
draw.rkt
|
|
@ -4,89 +4,28 @@
|
|||
racket/contract/base
|
||||
(for-syntax racket/base
|
||||
syntax/parse)
|
||||
(prefix-in A: ansi))
|
||||
"buffer.rkt")
|
||||
|
||||
(define (strict-or a b) (or a b))
|
||||
|
||||
(define current-style (make-parameter 'normal))
|
||||
(define symbol->style
|
||||
`#hasheq([normal . ,A:style-normal]
|
||||
[bold . ,A:style-bold]
|
||||
[inverse . ,A:style-inverse]
|
||||
[underline . ,A:style-underline]))
|
||||
(define current-fg (make-parameter 'default))
|
||||
(define current-bg (make-parameter 'default))
|
||||
(define current-display-drawing-parameters?
|
||||
(make-parameter (current-output-port)))
|
||||
(define symbol->color
|
||||
`#hasheq(
|
||||
[black . 0] [red . 1] [green . 2] [yellow . 3]
|
||||
[blue . 4] [magenta . 5] [cyan . 6] [white . 7]
|
||||
[brblack . 8] [brred . 9] [brgreen . 10] [bryellow . 11]
|
||||
[brblue . 12] [brmagenta . 13] [brcyan . 14] [brwhite . 15]))
|
||||
(define (select-text-color* c)
|
||||
(if (eq? c 'default)
|
||||
(A:select-graphic-rendition A:style-default-text-color)
|
||||
(A:select-xterm-256-text-color (hash-ref symbol->color c))))
|
||||
(define (select-background-color* c)
|
||||
(if (eq? c 'default)
|
||||
(A:select-graphic-rendition A:style-default-background-color)
|
||||
(A:select-xterm-256-background-color (hash-ref symbol->color c))))
|
||||
(define (set-drawing-parameters!)
|
||||
(cond
|
||||
[(current-display-drawing-parameters?)
|
||||
=> (λ (op) (display (get-drawing-parameters) op))]))
|
||||
(define (get-drawing-parameters)
|
||||
(string-append
|
||||
(A:select-graphic-rendition (hash-ref symbol->style (current-style)))
|
||||
(select-text-color* (current-fg))
|
||||
(select-background-color* (current-bg))))
|
||||
(define current-fg (make-parameter #f))
|
||||
(define current-bg (make-parameter #f))
|
||||
|
||||
;; w : exact-nonnegative-integer?
|
||||
;; h : exact-nonnegative-integer?
|
||||
;; ! : (row col char -> void) row col -> bool
|
||||
(struct raart (w h !))
|
||||
|
||||
(define (draw x
|
||||
#:output [op (current-output-port)]
|
||||
#:clear? [clear? #t])
|
||||
(define (draw buf x)
|
||||
(match-define (raart w h !) x)
|
||||
(display (A:dec-soft-terminal-reset) op)
|
||||
(when clear?
|
||||
(display (A:clear-screen/home) op))
|
||||
(display (A:hide-cursor))
|
||||
(parameterize ([current-display-drawing-parameters? op])
|
||||
(set-drawing-parameters!)
|
||||
(! (λ (r c ch)
|
||||
(display (A:goto r c) op)
|
||||
(when ch (display ch op))
|
||||
#t)
|
||||
1 1))
|
||||
(display (A:show-cursor))
|
||||
(flush-output op))
|
||||
|
||||
(define (draw-here x #:output [op (current-output-port)])
|
||||
(match-define (raart w h !) x)
|
||||
(define init-dp (get-drawing-parameters))
|
||||
(define def (cons init-dp #\space))
|
||||
(define rows (build-vector h (λ (i) (make-vector w def))))
|
||||
(parameterize ([current-display-drawing-parameters? #f])
|
||||
(! (λ (r c ch)
|
||||
(vector-set! (vector-ref rows r) c
|
||||
(cons (get-drawing-parameters) ch))
|
||||
#t)
|
||||
0 0))
|
||||
(for/fold ([last-dp init-dp]) ([r (in-vector rows)])
|
||||
(begin0
|
||||
(for/fold ([last-dp last-dp]) ([dp*ch (in-vector r)])
|
||||
(match-define (cons this-dp ch) dp*ch)
|
||||
(unless (string=? this-dp last-dp)
|
||||
(display this-dp op))
|
||||
(display ch op)
|
||||
this-dp)
|
||||
(newline op)))
|
||||
(flush-output op)
|
||||
(void))
|
||||
(define draw-char! (buffer-start! buf h w))
|
||||
(! (λ (r c ch)
|
||||
(draw-char! (current-style) (current-fg) (current-bg)
|
||||
r c ch)
|
||||
#t)
|
||||
0 0)
|
||||
(buffer-commit! buf))
|
||||
|
||||
(define-syntax (with-maybe-parameterize stx)
|
||||
(syntax-parse stx
|
||||
|
|
@ -101,13 +40,10 @@
|
|||
(define (with-drawing s f b x)
|
||||
(match-define (raart w h !) x)
|
||||
(raart w h (λ (d r c)
|
||||
(begin0
|
||||
(with-maybe-parameterize ([current-style s]
|
||||
[current-fg f]
|
||||
[current-bg b])
|
||||
(set-drawing-parameters!)
|
||||
(! d r c))
|
||||
(set-drawing-parameters!)))))
|
||||
(with-maybe-parameterize ([current-style s]
|
||||
[current-fg f]
|
||||
[current-bg b])
|
||||
(! d r c)))))
|
||||
|
||||
(define (blank [w 0] [h 1])
|
||||
(raart w h void))
|
||||
|
|
@ -348,24 +284,15 @@
|
|||
(strict-or (! d r c)
|
||||
(d cr cc #f)))))
|
||||
|
||||
(define style/c (apply or/c (hash-keys symbol->style)))
|
||||
(define color/c (apply or/c (hash-keys symbol->color)))
|
||||
(define valign/c (or/c 'top 'center 'bottom))
|
||||
(define halign/c (or/c 'left 'center 'right))
|
||||
(provide
|
||||
(contract-out
|
||||
[raart? (-> any/c boolean?)]
|
||||
[draw
|
||||
(->* (raart?)
|
||||
(#:output output-port?
|
||||
#:clear? boolean?)
|
||||
void?)]
|
||||
[draw-here
|
||||
(->* (raart?) (#:output output-port?)
|
||||
void?)]
|
||||
[style/c contract?]
|
||||
(-> buffer? raart?
|
||||
void?)]
|
||||
[style (-> style/c raart? raart?)]
|
||||
[color/c contract?]
|
||||
[fg (-> color/c raart? raart?)]
|
||||
[bg (-> color/c raart? raart?)]
|
||||
[with-drawing
|
||||
|
|
|
|||
|
|
@ -9,7 +9,8 @@
|
|||
ansi/private/tty-raw-extension
|
||||
unix-signals
|
||||
lux/chaos
|
||||
raart/draw)
|
||||
raart/draw
|
||||
raart/buffer)
|
||||
(provide (all-from-out (submod ansi/lcd-terminal event-structs)))
|
||||
|
||||
(struct term (f in out))
|
||||
|
|
@ -76,6 +77,11 @@
|
|||
(define alternate? #t)
|
||||
|
||||
(define t (open-term))
|
||||
(define init-rows 24)
|
||||
(define init-cols 80)
|
||||
(define buf
|
||||
(make-buffered-terminal-buffer init-rows init-cols
|
||||
#:output (term-out t)))
|
||||
(define ch (make-async-channel))
|
||||
;; Initialize term
|
||||
(when alternate?
|
||||
|
|
@ -107,25 +113,27 @@
|
|||
(async-channel-put ch v)
|
||||
(loop))))))
|
||||
;; Return
|
||||
(*term alternate? mouse? t ch sig-th input-th 24 80))
|
||||
(*term alternate? mouse? t buf ch sig-th input-th init-rows init-cols))
|
||||
|
||||
(struct *term
|
||||
(alternate? mouse? t ch sig-th input-th [rows #:mutable] [cols #:mutable])
|
||||
(alternate? mouse? t buf ch sig-th input-th [rows #:mutable] [cols #:mutable])
|
||||
#:methods gen:chaos
|
||||
[(define (chaos-event c)
|
||||
(handle-evt (*term-ch c)
|
||||
(match-lambda
|
||||
[(and e (screen-size-report rows cols))
|
||||
(buffer-resize! (*term-buf c) rows cols)
|
||||
(set-*term-rows! c rows)
|
||||
(set-*term-cols! c cols)
|
||||
e]
|
||||
[e e])))
|
||||
(define (chaos-output! c o)
|
||||
(when o
|
||||
(draw (crop 0 (add1 (*term-cols c))
|
||||
(draw (*term-buf c)
|
||||
;; XXX put this crop inside buffer?
|
||||
(crop 0 (add1 (*term-cols c))
|
||||
0 (add1 (*term-rows c))
|
||||
o)
|
||||
#:output (term-out (*term-t c)))))
|
||||
o))))
|
||||
(define (chaos-label! c l)
|
||||
(display/term (*term-t c) (xterm-set-window-title l)))
|
||||
(define (chaos-stop! c)
|
||||
|
|
|
|||
59
t/draw.rkt
59
t/draw.rkt
|
|
@ -1,41 +1,48 @@
|
|||
#lang racket/base
|
||||
(require racket/format
|
||||
raart)
|
||||
(module+ test
|
||||
(define here (make-output-buffer)))
|
||||
|
||||
(module+ test
|
||||
(draw (crop 1 80 1 20
|
||||
;;70 80 10 20
|
||||
(matte 80 20
|
||||
#:halign 'right
|
||||
(fg 'blue
|
||||
(frame #:fg 'red
|
||||
(inset
|
||||
4 5
|
||||
(happend (style 'underline (text "Left"))
|
||||
(blank 4)
|
||||
(style 'bold (text "Right")))))))))
|
||||
(draw
|
||||
here
|
||||
(crop 1 80 1 20
|
||||
;;70 80 10 20
|
||||
(matte 80 20
|
||||
#:halign 'right
|
||||
(fg 'blue
|
||||
(frame #:fg 'red
|
||||
(inset
|
||||
4 5
|
||||
(happend (style 'underline (text "Left"))
|
||||
(blank 4)
|
||||
(style 'bold (text "Right")))))))))
|
||||
(newline))
|
||||
|
||||
(module+ test
|
||||
(draw (translate
|
||||
2 10
|
||||
(table
|
||||
#:frames? #t
|
||||
#:inset-dw 2
|
||||
#:valign 'center
|
||||
#:halign '(right left left left)
|
||||
(text-rows
|
||||
`([ "ID" "First Name" "Last Name" "Grade"]
|
||||
[70022 "John" "Smith" "A+"]
|
||||
[ 22 "Macumber" "Stark" "B"]
|
||||
[ 1223 "Sarah" ,(vappend (text "Top")
|
||||
(text "Mid")
|
||||
(text "Bot")) "C"])))))
|
||||
(draw
|
||||
here
|
||||
(translate
|
||||
2 10
|
||||
(table
|
||||
#:frames? #t
|
||||
#:inset-dw 2
|
||||
#:valign 'center
|
||||
#:halign '(right left left left)
|
||||
(text-rows
|
||||
`([ "ID" "First Name" "Last Name" "Grade"]
|
||||
[70022 "John" "Smith" "A+"]
|
||||
[ 22 "Macumber" "Stark" "B"]
|
||||
[ 1223 "Sarah" ,(vappend (text "Top")
|
||||
(text "Mid")
|
||||
(text "Bot")) "C"])))))
|
||||
(newline))
|
||||
|
||||
(module+ test
|
||||
(define seen? (list))
|
||||
(draw-here
|
||||
(draw
|
||||
here
|
||||
(crop 0 80 70 10
|
||||
(vappend*
|
||||
#:halign 'left
|
||||
|
|
|
|||
Loading…
Reference in New Issue