raart/draw.rkt

#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*)