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

struct-define

This commit is contained in:
Jay McCarthy 2018-01-03 18:18:40 -05:00
parent 07e8f3382f
commit f5bdaed63f
2 changed files with 48 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
buffer.rkt
View File

@ -40,15 +40,15 @@
#:clear? [clear? #t] #:clear? [clear? #t]
#:output [op (current-output-port)]) #:output [op (current-output-port)])
(terminal-buffer clear? op term-rows term-cols)) (terminal-buffer clear? op term-rows term-cols))
(define-struct-define terminal-buffer terminal-buffer-define)
(struct terminal-buffer (clear? op [term-rows #:mutable] [term-cols #:mutable]) (struct terminal-buffer (clear? op [term-rows #:mutable] [term-cols #:mutable])
#:methods gen:buffer #:methods gen:buffer
[(define (buffer-resize! buf new-rows new-cols) [(define (buffer-resize! buf new-rows new-cols)
(set-terminal-buffer-term-rows! buf new-rows) (terminal-buffer-define buf)
(set-terminal-buffer-term-cols! buf new-cols)) (set! term-rows new-rows)
(set! term-cols new-cols))
(define (buffer-start! buf draw-rows draw-cols) (define (buffer-start! buf draw-rows draw-cols)
(define op (terminal-buffer-op buf)) (terminal-buffer-define buf)
(define ok-rows (terminal-buffer-term-rows buf))
(define ok-cols (terminal-buffer-term-cols buf))
(define-syntax-rule (define-syntax-rule
(maybe-update last-X X select-X) (maybe-update last-X X select-X)
(unless (eq? last-X X) (unless (eq? last-X X)
@ -65,13 +65,13 @@
(define cur-r 1) (define cur-r 1)
(define cur-c 1) (define cur-c 1)
(values (values
ok-rows ok-cols term-rows term-cols
(λ (s f b r c ch) (λ (s f b r c ch)
(cond (cond
[(or (< r 0) [(or (< r 0)
(<= ok-rows r) (<= term-rows r)
(< c 0) (< c 0)
(<= ok-cols c)) (<= term-cols c))
#f] #f]
[else [else
(maybe-update last-s s select-style*) (maybe-update last-s s select-style*)
@ -92,7 +92,7 @@
#t])))) #t]))))
(define (buffer-commit! buf) (define (buffer-commit! buf)
(define op (terminal-buffer-op buf)) (terminal-buffer-define buf)
(display (A:show-cursor) op) (display (A:show-cursor) op)
(flush-output op))]) (flush-output op))])
@ -143,18 +143,19 @@
(define (make-output-buffer #:output [op (current-output-port)]) (define (make-output-buffer #:output [op (current-output-port)])
(output-buffer op (make-cells 0 0))) (output-buffer op (make-cells 0 0)))
(define-struct-define output-buffer output-buffer-define)
(struct output-buffer (op [cells #:mutable]) (struct output-buffer (op [cells #:mutable])
#:methods gen:buffer #:methods gen:buffer
[(define (buffer-resize! buf new-rows new-cols) [(define (buffer-resize! buf new-rows new-cols)
(struct-define output-buffer buf) (output-buffer-define buf)
(set! cells (maybe-make-cells cells new-rows new-cols))) (set! cells (maybe-make-cells cells new-rows new-cols)))
(define (buffer-start! buf draw-rows draw-cols) (define (buffer-start! buf draw-rows draw-cols)
(struct-define output-buffer buf) (output-buffer-define buf)
(buffer-resize! buf draw-rows draw-cols) (buffer-resize! buf draw-rows draw-cols)
(clear-cells! cells) (clear-cells! cells)
(values draw-rows draw-cols (draw-cell! cells))) (values draw-rows draw-cols (draw-cell! cells)))
(define (buffer-commit! buf) (define (buffer-commit! buf)
(struct-define output-buffer buf) (output-buffer-define buf)
(for/fold ([last-s 'normal] [last-f #f] [last-b #f]) (for/fold ([last-s 'normal] [last-f #f] [last-b #f])
([row (in-vector (cells-vec cells))]) ([row (in-vector (cells-vec cells))])
(begin0 (begin0
@ -186,6 +187,7 @@
(make-cells term-rows term-cols) (make-cells term-rows term-cols)
(make-cells term-rows term-cols) (make-cells term-rows term-cols)
0 0)) 0 0))
(define-struct-define cached-buffer cached-buffer-define)
(struct cached-buffer (struct cached-buffer
([clear-next? #:mutable] ([clear-next? #:mutable]
term-nclear term-yclear term-nclear term-yclear
@ -198,39 +200,30 @@
(define/generic super-buffer-commit! buffer-commit!) (define/generic super-buffer-commit! buffer-commit!)
(define (buffer-resize! buf new-rows new-cols) (define (buffer-resize! buf new-rows new-cols)
(set-cached-buffer-clear-next?! buf #t) (cached-buffer-define buf)
(super-buffer-resize! (cached-buffer-term-nclear buf) new-rows new-cols) (set! clear-next? #t)
(super-buffer-resize! (cached-buffer-term-yclear buf) new-rows new-cols) (super-buffer-resize! term-nclear new-rows new-cols)
(set-cached-buffer-term-rows! buf new-rows) (super-buffer-resize! term-yclear new-rows new-cols)
(set-cached-buffer-term-cols! buf new-cols) (set! term-rows new-rows)
(clear-cells! (cached-buffer-cur-cells buf))) (set! term-cols new-cols)
(clear-cells! cur-cells))
(define (buffer-start! buf draw-rows draw-cols) (define (buffer-start! buf draw-rows draw-cols)
(define ok-rows (cached-buffer-term-rows buf)) (cached-buffer-define buf)
(define ok-cols (cached-buffer-term-cols buf)) (clear-cells! new-cells)
(define cs (cached-buffer-new-cells buf)) (define dc (draw-cell! new-cells))
(clear-cells! cs) (values term-rows term-cols
(define dc (draw-cell! cs))
(values ok-rows ok-cols
(λ (s f b r c ch) (λ (s f b r c ch)
(set-cached-buffer-last-row! buf r) (set! last-row r)
(set-cached-buffer-last-col! buf c) (set! last-col c)
(dc s f b r c ch)))) (dc s f b r c ch))))
(define (buffer-commit! buf) (define (buffer-commit! buf)
(define ok-rows (cached-buffer-term-rows buf)) (cached-buffer-define buf)
(define ok-cols (cached-buffer-term-cols buf)) (define inner-buf (if clear-next? term-yclear term-nclear))
(define cur-cs (cached-buffer-cur-cells buf)) (set! clear-next? #f)
(define new-cs (cached-buffer-new-cells buf)) (define-values (ok-rows ok-cols draw!)
(define inner-buf (super-buffer-start! inner-buf term-rows term-cols))
(cond (for ([cur-row (in-vector (cells-vec cur-cells))]
[(cached-buffer-clear-next? buf) [new-row (in-vector (cells-vec new-cells))]
(set-cached-buffer-clear-next?! buf #f)
(cached-buffer-term-yclear buf)]
[else
(cached-buffer-term-nclear buf)]))
(define-values (_ok-rows _ok-cols draw!)
(super-buffer-start! inner-buf ok-rows ok-cols))
(for ([cur-row (in-vector (cells-vec cur-cs))]
[new-row (in-vector (cells-vec new-cs))]
[r (in-naturals)]) [r (in-naturals)])
(for ([cur-cell (in-vector cur-row)] (for ([cur-cell (in-vector cur-row)]
[new-cell (in-vector new-row)] [new-cell (in-vector new-row)]
@ -239,13 +232,14 @@
(match-define (output-cell _ _ _ cur-ch) cur-cell) (match-define (output-cell _ _ _ cur-ch) cur-cell)
(match-define (output-cell s f b new-ch) new-cell) (match-define (output-cell s f b new-ch) new-cell)
(draw! s f b r c (or new-ch #\space))))) (draw! s f b r c (or new-ch #\space)))))
(draw! 'normal #f #f (draw! 'normal #f #f last-row last-col #f)
(cached-buffer-last-row buf)
(cached-buffer-last-col buf)
#f)
(super-buffer-commit! inner-buf) (super-buffer-commit! inner-buf)
(set-cached-buffer-cur-cells! buf new-cs) (swap! new-cells cur-cells))])
(set-cached-buffer-new-cells! buf cur-cs))])
(define-syntax-rule (swap! x y)
(let ([tmp x])
(set! x y)
(set! y tmp)))
(provide (provide
(contract-out (contract-out

9
struct-define.rkt
View File

@ -19,7 +19,7 @@
(define field-name-s (define field-name-s
(substring field-ref-s struct+-len)) (substring field-ref-s struct+-len))
(define field-name (define field-name
(datum->syntax stx (string->symbol field-name-s))) (datum->syntax #'the-instance (string->symbol field-name-s)))
(list field-name field-ref field-set)) (list field-name field-ref field-set))
#:with (field-val-id ...) #:with (field-val-id ...)
(generate-temporaries #'(field-name ...)) (generate-temporaries #'(field-name ...))
@ -40,4 +40,9 @@
(field-ref the-instance-id))])))) (field-ref the-instance-id))]))))
...))])) ...))]))
(provide struct-define) (define-syntax-rule (define-struct-define the-struct the-struct-define)
(define-syntax-rule (the-struct-define instance-id)
(struct-define the-struct instance-id)))
(provide struct-define
define-struct-define)