Add buffer abstraction

This commit is contained in:
Jay McCarthy 2018-01-02 22:05:06 -05:00
parent 37341a0c9c
commit 59a3ec62ed
5 changed files with 223 additions and 123 deletions

157
buffer.rkt Normal file
View File

@ -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
View File

@ -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

View File

@ -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)

View File

@ -1,3 +1,4 @@
#lang reprovide
"buffer.rkt"
"draw.rkt"
"lux-chaos.rkt"

View File

@ -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