432 lines
14 KiB
Racket
432 lines
14 KiB
Racket
#lang racket/base
|
|
(require racket/match
|
|
racket/list
|
|
racket/contract/base
|
|
(for-syntax racket/base
|
|
syntax/parse)
|
|
"buffer.rkt"
|
|
(submod "buffer.rkt" internal))
|
|
|
|
;; XXX ensure that argument order is ALWAYS w h r c
|
|
|
|
(define (strict-or a b) (or a b))
|
|
|
|
(define current-style (make-parameter 'normal))
|
|
(define current-fg (make-parameter #f))
|
|
(define current-bg (make-parameter #f))
|
|
(define-syntax (with-maybe-parameterize stx)
|
|
(syntax-parse stx
|
|
[(_ () . body) #'(let () . body)]
|
|
[(_ ([p:id v:id] . m) . body)
|
|
#'(let ([t (λ () (with-maybe-parameterize m . body))])
|
|
(if v (parameterize ([p v]) (t)) (t)))]))
|
|
|
|
(define (rectangle-intersect a-x1 a-y1
|
|
a-x2 a-y2
|
|
b-x1 b-y1
|
|
b-x2 b-y2)
|
|
(and (< a-x1 b-x2)
|
|
(> a-x2 b-x1)
|
|
(< a-y1 b-y2)
|
|
(> a-y2 b-y1)))
|
|
|
|
;; w : exact-nonnegative-integer?
|
|
;; h : exact-nonnegative-integer?
|
|
;; ! : okay? (row col char -> void) row col -> bool
|
|
(struct raart (w h !))
|
|
|
|
(struct meta-raart raart (m))
|
|
(define (without-cursor x)
|
|
(match-define (raart w h !) x)
|
|
(meta-raart w h ! '(without-cursor)))
|
|
|
|
(define (draw buf x)
|
|
(match-define (raart w h !) x)
|
|
(define-values
|
|
(max-rows max-cols draw-char!)
|
|
(buffer-start! buf h w))
|
|
(define (draw-with-params r c ch)
|
|
(unless (or (negative? r) (negative? c))
|
|
(draw-char! (current-style) (current-fg) (current-bg)
|
|
r c ch)))
|
|
(define (on-screen? w h r c)
|
|
(rectangle-intersect 0 0
|
|
max-cols max-rows
|
|
c r
|
|
(+ c w) (+ r h)))
|
|
(! on-screen? draw-with-params 0 0)
|
|
(define without-cursor?
|
|
(memq 'without-cursor (if (meta-raart? x) (meta-raart-m x) '())))
|
|
(buffer-commit! #:cursor? (not without-cursor) buf))
|
|
|
|
(define (raart* w h !)
|
|
(raart w h
|
|
(λ (okay? d r c)
|
|
(and (okay? w h r c)
|
|
(! okay? d r c)))))
|
|
|
|
;; Core forms
|
|
(define (with-drawing s f b x)
|
|
(match-define (raart w h !) x)
|
|
(raart* w h (λ (okay? d r c)
|
|
(with-maybe-parameterize ([current-style s]
|
|
[current-fg f]
|
|
[current-bg b])
|
|
(! okay? d r c)))))
|
|
|
|
(define (blank [w 0] [h 1])
|
|
(raart* w h (λ (okay? d r c) #f)))
|
|
|
|
(define (char ch)
|
|
(when (char-iso-control? ch)
|
|
(error 'char "Illegal character: ~v" ch))
|
|
(raart* 1 1 (λ (okay? d r c) (d r c ch))))
|
|
|
|
(define (text s)
|
|
(for ([ch (in-string s)]
|
|
#:when (char-iso-control? ch))
|
|
(error 'text "Illegal character in string: ~v" ch))
|
|
(raart* (string-length s) 1
|
|
(λ (okay? d r c)
|
|
(for ([ch (in-string s)]
|
|
[dc (in-naturals)])
|
|
(d r (+ c dc) ch)))))
|
|
|
|
(define (place-at back dr dc front)
|
|
(match-define (raart bw bh b!) back)
|
|
(match-define (raart fw fh f!) front)
|
|
(unless (and (<= fw bw) (<= fh bh))
|
|
(error 'place-at "Foreground must fit inside background"))
|
|
(raart* bw bh
|
|
(λ (okay? d r c)
|
|
(strict-or
|
|
(b! okay? d r c)
|
|
(f! okay? d (+ r dr) (+ c dc))))))
|
|
|
|
(define (mask mc mw mr mh x)
|
|
(match-define (raart xw xh x!) x)
|
|
(raart* xw xh
|
|
(λ (okay? d r c)
|
|
(x!
|
|
(λ (w h r c)
|
|
(and (okay? w h r c)
|
|
(rectangle-intersect mc mr
|
|
(+ mc mw) (+ mr mh)
|
|
c r
|
|
(+ c w) (+ r h))))
|
|
d r c))))
|
|
|
|
(define (crop cc cw cr ch x)
|
|
(define mx (mask cc cw cr ch x))
|
|
(match-define (raart mw mh m!) mx)
|
|
(raart* cw ch
|
|
(λ (okay? d r c)
|
|
(m! (λ (w h r c)
|
|
(okay? w h (- r cr) (- c cc)))
|
|
(λ (r c ch)
|
|
(d (- r cr) (- c cc) ch))
|
|
r c))))
|
|
|
|
(define (if-drawn f x)
|
|
(match-define (raart w h !) x)
|
|
(raart* w h (λ (okay? d r c)
|
|
(define ? (! okay? d r c))
|
|
(when ? (f r c w h))
|
|
?)))
|
|
|
|
(define (place-cursor-after x cr cc)
|
|
(match-define (raart w h !) x)
|
|
(raart* w h (λ (okay? d r c)
|
|
(strict-or (! okay? d r c)
|
|
(d cr cc #f)))))
|
|
|
|
(define (*vappend2 #:reverse? [reverse? #f] y x)
|
|
(match-define (raart xw xh x!) x)
|
|
(match-define (raart yw yh y!) y)
|
|
(unless (= xw yw)
|
|
(error '*vappend2 "Widths must be equal: ~e vs ~e" xw yw))
|
|
(raart* xw (+ xh yh)
|
|
(λ (okay? d r c)
|
|
(define (dx) (x! okay? d (+ r 0) c))
|
|
(define (dy) (y! okay? d (+ r xh) c))
|
|
(if reverse?
|
|
(strict-or (dy) (dx))
|
|
(strict-or (dx) (dy))))))
|
|
|
|
(define (*happend2 #:reverse? [reverse? #f] y x)
|
|
(match-define (raart xw xh x!) x)
|
|
(match-define (raart yw yh y!) y)
|
|
(unless (= xh yh)
|
|
(error '*happend2 "Heights must be equal: ~e vs ~e" xh yh))
|
|
(raart* (+ xw yw) xh
|
|
(λ (okay? d r c)
|
|
(define (dx) (x! okay? d r (+ c 0)))
|
|
(define (dy) (y! okay? d r (+ c xw)))
|
|
(if reverse?
|
|
(strict-or (dy) (dx))
|
|
(strict-or (dx) (dy))))))
|
|
|
|
;; Library
|
|
(define (style s x) (with-drawing s #f #f x))
|
|
(define (fg f x) (with-drawing #f f #f x))
|
|
(define (bg b x) (with-drawing #f #f b x))
|
|
|
|
(define-syntax (place-at* stx)
|
|
(syntax-parse stx
|
|
[(_ b:expr) #'b]
|
|
[(_ b:expr [dr:expr dc:expr f:expr] . more:expr)
|
|
#'(place-at* (place-at b dr dc f) . more)]))
|
|
|
|
(define (matte-at mw mh @c @r x)
|
|
(match-define (raart xw xh x!) x)
|
|
(unless (and (<= (+ xw @c) mw)
|
|
(<= (+ xh @r) mh))
|
|
(error 'matte-at "Original (~ax~a@~a,~a) must fit inside matte (~ax~a)"
|
|
xw xh @c @r mw mh))
|
|
(place-at (blank mw mh) @r @c x))
|
|
|
|
(define (translate dr dc x)
|
|
(match-define (raart xw xh x!) x)
|
|
(matte-at (+ xw dc) (+ xh dr) dc dr x))
|
|
|
|
(define (matte aw ah
|
|
#:halign [ws 'center]
|
|
#:valign [hs 'center]
|
|
x)
|
|
(define w (or aw (raart-w x)))
|
|
(define h (or ah (raart-h x)))
|
|
(match-define (raart xw xh x!) x)
|
|
(unless (and (<= xw w) (<= xh h))
|
|
(error 'matte "Original (~ax~a) must fit inside matte (~ax~a)"
|
|
xw xh w h))
|
|
(matte-at w h
|
|
(match ws
|
|
['left 0]
|
|
['center (floor (/ (- w xw) 2))]
|
|
['right (- w xw)])
|
|
(match hs
|
|
['top 0]
|
|
['center (floor (/ (- h xh) 2))]
|
|
['bottom (- h xh)])
|
|
x))
|
|
|
|
(define (inset dw dh x)
|
|
(match-define (raart w h !) x)
|
|
(matte (+ dw w dw) (+ dh h dh)
|
|
#:halign 'center #:valign 'center
|
|
x))
|
|
|
|
(define (vappend2 y x #:halign [halign #f] #:reverse? [reverse? #f])
|
|
(cond
|
|
[(not halign) (*vappend2 #:reverse? reverse? y x)]
|
|
[else
|
|
(match-define (raart xw xh x!) x)
|
|
(match-define (raart yw yh y!) y)
|
|
(define nw (max xw yw))
|
|
(define xp (matte nw xh #:halign halign x))
|
|
(define yp (matte nw yh #:halign halign y))
|
|
(*vappend2 #:reverse? reverse? yp xp)]))
|
|
(define (vappend #:halign [halign #f] #:reverse? [reverse? #f] r1 . rs)
|
|
(foldl (λ (a d) (vappend2 #:halign halign #:reverse? reverse? a d)) r1 rs))
|
|
(define (vappend* #:halign [halign #f] #:reverse? [reverse? #f] rs)
|
|
(apply vappend rs #:halign halign #:reverse? reverse?))
|
|
|
|
(define (happend2 y x #:valign [valign #f] #:reverse? [reverse? #f])
|
|
(cond
|
|
[(not valign) (*happend2 #:reverse? reverse? y x)]
|
|
[else
|
|
(match-define (raart xw xh x!) x)
|
|
(match-define (raart yw yh y!) y)
|
|
(define nh (max xh yh))
|
|
(define xp (matte xw nh #:valign valign x))
|
|
(define yp (matte yw nh #:valign valign y))
|
|
(*happend2 #:reverse? reverse? yp xp)]))
|
|
(define (happend #:valign [valign #f] #:reverse? [reverse? #f] r1 . rs)
|
|
(foldl (λ (a d) (happend2 #:valign valign #:reverse? reverse? a d)) r1 rs))
|
|
(define (happend* #:valign [valign #f] #:reverse? [reverse? #f] rs)
|
|
(apply happend rs #:valign valign #:reverse? reverse?))
|
|
|
|
(define (hline w)
|
|
(text (make-string w #\─)))
|
|
(define (vline h)
|
|
(vappend* (make-list h (char #\│))))
|
|
|
|
(define (frame #:style [s #f] #:fg [f #f] #:bg [b #f] x)
|
|
(match-define (raart w h _) x)
|
|
(place-at
|
|
(with-drawing s f b
|
|
(vappend
|
|
(happend (char #\┌) (hline w ) (char #\┐))
|
|
(happend (vline h) (blank w h) (vline h))
|
|
(happend (char #\└) (hline w ) (char #\┘))))
|
|
1 1 x))
|
|
|
|
(define (table rows
|
|
;; XXX add more options to frames
|
|
#:frames? [frames? #t]
|
|
#:style [s #f] #:fg [f #f] #:bg [b #f]
|
|
#:inset-dw [dw 0]
|
|
#:inset-dh [dh 0]
|
|
#:valign [row-valign 'top]
|
|
#:halign [halign 'left])
|
|
(define (list-ref* i l)
|
|
(list-ref l (min i (sub1 (length l)))))
|
|
(define (col-halign-sel i halign)
|
|
(match halign
|
|
[(? symbol?) halign]
|
|
[(? list?) (list-ref* i halign)]))
|
|
(define (col-halign col-i)
|
|
(col-halign-sel col-i halign))
|
|
(define col-ws
|
|
(for/list ([i (in-range (length (first rows)))])
|
|
(define col (map (λ (r) (list-ref r i)) rows))
|
|
(apply max (map raart-w col))))
|
|
(define last-col (sub1 (length col-ws)))
|
|
|
|
(define (make-bar left middle right)
|
|
(happend*
|
|
(cons
|
|
(char left)
|
|
(for/list ([col-w (in-list col-ws)]
|
|
[col-i (in-naturals)])
|
|
(happend (hline (+ dw col-w dw))
|
|
(if (= last-col col-i)
|
|
(char right)
|
|
(char middle)))))))
|
|
|
|
(define header (make-bar #\┌ #\┬ #\┐))
|
|
(define inbetween (make-bar #\├ #\┼ #\┤))
|
|
(define footer (make-bar #\└ #\┴ #\┘))
|
|
(define last-row (sub1 (length rows)))
|
|
(vappend*
|
|
(for/list ([row (in-list rows)]
|
|
[row-i (in-naturals)])
|
|
(define row-h (apply max (map raart-h row)))
|
|
(define cell-h (+ dh row-h dh))
|
|
(define cell-wall (vline cell-h))
|
|
(define the-row
|
|
(happend*
|
|
(for/list ([col (in-list row)]
|
|
[col-w (in-list col-ws)]
|
|
[col-i (in-naturals)])
|
|
(define cell-w (+ dw col-w dw))
|
|
(define the-cell
|
|
(matte cell-w #:halign (col-halign col-i)
|
|
cell-h #:valign row-valign
|
|
(inset dw dh col)))
|
|
(define cell+left
|
|
(happend cell-wall the-cell))
|
|
(if (= col-i last-col)
|
|
(happend cell+left cell-wall)
|
|
cell+left))))
|
|
(define include-header? (zero? row-i))
|
|
(define row-and-above
|
|
(if include-header? (vappend header the-row) the-row))
|
|
(define include-footer? (= row-i last-row))
|
|
(define row-and-below
|
|
(vappend row-and-above
|
|
(if include-footer?
|
|
footer
|
|
inbetween)))
|
|
row-and-below)))
|
|
(define (text-rows rows)
|
|
(local-require racket/format)
|
|
(for/list ([row (in-list rows)])
|
|
(for/list ([col (in-list row)])
|
|
(if (raart? col) col (text (~a col))))))
|
|
|
|
(define (draw-here r)
|
|
(draw (make-output-buffer) r))
|
|
|
|
(define valign/c (or/c 'top 'center 'bottom))
|
|
(define halign/c (or/c 'left 'center 'right))
|
|
(provide
|
|
(contract-out
|
|
[raart? (-> any/c boolean?)]
|
|
[raart-w (-> raart? integer?)]
|
|
[raart-h (-> raart? integer?)]
|
|
[draw
|
|
(-> buffer? raart?
|
|
void?)]
|
|
[draw-here (-> raart? void?)]
|
|
[style (-> style/c raart? raart?)]
|
|
[fg (-> color/c raart? raart?)]
|
|
[bg (-> color/c raart? raart?)]
|
|
[with-drawing
|
|
(-> (or/c style/c #f)
|
|
(or/c color/c #f)
|
|
(or/c color/c #f)
|
|
raart? raart?)]
|
|
[blank (->* () (exact-nonnegative-integer? exact-nonnegative-integer?) raart?)]
|
|
[char (-> (and/c char? (not/c char-iso-control?)) raart?)]
|
|
[text (-> string? raart?)]
|
|
[hline (-> exact-nonnegative-integer? raart?)]
|
|
[vline (-> exact-nonnegative-integer? raart?)]
|
|
[vappend2 (->* (raart? raart?)
|
|
(#:halign (or/c halign/c #f) #:reverse? boolean?)
|
|
raart?)]
|
|
[vappend (->* (raart?)
|
|
(#:halign (or/c halign/c #f) #:reverse? boolean?)
|
|
#:rest (listof raart?)
|
|
raart?)]
|
|
[vappend* (->* ((non-empty-listof raart?))
|
|
(#:halign (or/c halign/c #f) #:reverse? boolean?)
|
|
raart?)]
|
|
[happend2 (->* (raart? raart?)
|
|
(#:valign (or/c valign/c #f) #:reverse? boolean?)
|
|
raart?)]
|
|
[happend (->* (raart?)
|
|
(#:valign (or/c valign/c #f) #:reverse? boolean?)
|
|
#:rest (listof raart?)
|
|
raart?)]
|
|
[happend* (->* ((non-empty-listof raart?))
|
|
(#:valign (or/c valign/c #f) #:reverse? boolean?)
|
|
raart?)]
|
|
[place-at (-> raart? exact-nonnegative-integer? exact-nonnegative-integer? raart?
|
|
raart?)]
|
|
[frame (->* (raart?)
|
|
(#:style (or/c style/c #f) #:fg (or/c color/c #f) #:bg (or/c color/c #f))
|
|
raart?)]
|
|
[matte-at (-> exact-nonnegative-integer? exact-nonnegative-integer?
|
|
exact-nonnegative-integer? exact-nonnegative-integer?
|
|
raart?
|
|
raart?)]
|
|
[translate (-> exact-nonnegative-integer? exact-nonnegative-integer?
|
|
raart? raart?)]
|
|
[halign/c contract?]
|
|
[valign/c contract?]
|
|
[matte (->* ((or/c exact-nonnegative-integer? false/c)
|
|
(or/c exact-nonnegative-integer? false/c)
|
|
raart?)
|
|
(#:halign halign/c #:valign valign/c)
|
|
raart?)]
|
|
[inset (-> exact-nonnegative-integer? exact-nonnegative-integer? raart? raart?)]
|
|
[mask (-> exact-nonnegative-integer? exact-nonnegative-integer?
|
|
exact-nonnegative-integer? exact-nonnegative-integer?
|
|
raart? raart?)]
|
|
[crop (-> exact-nonnegative-integer? exact-nonnegative-integer?
|
|
exact-nonnegative-integer? exact-nonnegative-integer?
|
|
raart? raart?)]
|
|
[table (->* ((listof (listof raart?)))
|
|
(#:frames? boolean?
|
|
#:style (or/c style/c #f)
|
|
#:fg (or/c color/c #f)
|
|
#:bg (or/c color/c #f)
|
|
#:inset-dw exact-nonnegative-integer?
|
|
#:inset-dh exact-nonnegative-integer?
|
|
#:valign valign/c
|
|
#:halign (or/c halign/c (list*of halign/c (or/c halign/c '()))))
|
|
raart?)]
|
|
[text-rows (-> (listof (listof any/c))
|
|
(listof (listof raart?)))]
|
|
[if-drawn (-> (-> exact-nonnegative-integer? exact-nonnegative-integer?
|
|
exact-nonnegative-integer? exact-nonnegative-integer?
|
|
any)
|
|
raart? raart?)]
|
|
[place-cursor-after
|
|
(-> raart? exact-nonnegative-integer? exact-nonnegative-integer?
|
|
raart?)]
|
|
[without-cursor
|
|
(-> raart? raart?)])
|
|
place-at*)
|