Add buffer abstraction

buffer.rkt

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

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
+(define current-fg (make-parameter #f))
-  `#hasheq([normal . ,A:style-normal]
+(define current-bg (make-parameter #f))
-           [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))))
 
 ;; w : exact-nonnegative-integer?
 ;; h : exact-nonnegative-integer?
 ;; ! : (row col char -> void) row col -> bool
 (struct raart (w h !))
 
-(define (draw x
+(define (draw buf x)
-              #:output [op (current-output-port)]
-              #:clear? [clear? #t])
   (match-define (raart w h !) x)
-  (display (A:dec-soft-terminal-reset) op)
+  (define draw-char! (buffer-start! buf h w))
-  (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)
+       (draw-char! (current-style) (current-fg) (current-bg)
-         (when ch (display ch op))
+                   r c ch)
        #t)
-       1 1))
+     0 0)
-  (display (A:show-cursor))
+  (buffer-commit! buf))
-  (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-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)))))
-                     (! d r c))
-                 (set-drawing-parameters!)))))
 
 (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?)
+   (-> buffer? raart?
-        (#:output output-port?
-         #:clear? boolean?)
        void?)]
-  [draw-here
-   (->* (raart?) (#:output output-port?)
-        void?)]
-  [style/c contract?]
   [style (-> style/c raart? raart?)]
-  [color/c contract?]
   [fg (-> color/c raart? raart?)]
   [bg (-> color/c raart? raart?)]
   [with-drawing

lux-chaos.rkt

@@ -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)
+                   o))))
-             #:output (term-out (*term-t c)))))
    (define (chaos-label! c l)
      (display/term (*term-t c) (xterm-set-window-title l)))
    (define (chaos-stop! c)

main.rkt

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

t/draw.rkt

@@ -1,9 +1,13 @@
 #lang racket/base
 (require racket/format
          raart)
+(module+ test
+  (define here (make-output-buffer)))
 
 (module+ test
-  (draw (crop 1 80 1 20
+  (draw
+   here
+   (crop 1 80 1 20
          ;;70 80 10 20
          (matte 80 20
                 #:halign 'right
@@ -17,7 +21,9 @@
   (newline))
 
 (module+ test
-  (draw (translate
+  (draw
+   here
+   (translate
     2 10
     (table
      #:frames? #t
@@ -35,7 +41,8 @@
 
 (module+ test
   (define seen? (list))
-  (draw-here
+  (draw
+   here
    (crop 0 80 70 10
          (vappend*
           #:halign 'left