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

up

This commit is contained in:
Jay McCarthy 2018-01-01 18:33:27 -05:00
parent 17a0290016
commit f84fd13c34
2 changed files with 248 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

256
main.rkt
View File

@ -35,14 +35,17 @@
;; w : exact-nonnegative-integer? ;; w : exact-nonnegative-integer?
;; h : exact-nonnegative-integer? ;; h : exact-nonnegative-integer?
;; ! : row col -> void ;; ! : (row col char -> void) row col -> void
(struct rart (w h !)) (struct rart (w h !))
(define (draw row col r) (define (draw row col x)
(match-define (rart w h !) r) (match-define (rart w h !) x)
(display (A:dec-soft-terminal-reset)) (display (A:dec-soft-terminal-reset))
(display (A:clear-screen/home)) (display (A:clear-screen/home))
(set-drawing-parameters!) (set-drawing-parameters!)
(! row col) (! (λ (r c ch)
(display (A:goto r c))
(display ch))
row col)
(display (A:goto (+ row h) (+ col w)))) (display (A:goto (+ row h) (+ col w))))
(define-syntax (with-maybe-parameterize stx) (define-syntax (with-maybe-parameterize stx)
@ -52,27 +55,26 @@
#'(let ([t (λ () (with-maybe-parameterize m . body))]) #'(let ([t (λ () (with-maybe-parameterize m . body))])
(if v (parameterize ([p v]) (t)) (t)))])) (if v (parameterize ([p v]) (t)) (t)))]))
(define (style s r) (with-drawing s #f #f r)) (define (style s x) (with-drawing s #f #f x))
(define (fg f r) (with-drawing #f f #f r)) (define (fg f x) (with-drawing #f f #f x))
(define (bg b r) (with-drawing #f #f b r)) (define (bg b x) (with-drawing #f #f b x))
(define (with-drawing s f b r) (define (with-drawing s f b x)
(match-define (rart w h !) r) (match-define (rart w h !) x)
(rart w h (λ (r c) (rart w h (λ (d r c)
(with-maybe-parameterize ([current-style s] (with-maybe-parameterize ([current-style s]
[current-fg f] [current-fg f]
[current-bg b]) [current-bg b])
(set-drawing-parameters!) (set-drawing-parameters!)
(! r c)) (! d r c))
(set-drawing-parameters!)))) (set-drawing-parameters!))))
(define (blank [w 0] [h 1]) (define (blank [w 0] [h 1])
(rart w h void)) (rart w h void))
;; XXX What if ch is a newline?
(define (char ch) (define (char ch)
(when (char-iso-control? ch) (when (char-iso-control? ch)
(error 'char "Illegal character: ~v" ch)) (error 'char "Illegal character: ~v" ch))
(rart 1 1 (λ (r c) (display (A:goto r c)) (display ch)))) (rart 1 1 (λ (d r c) (d r c ch))))
(define (text s) (define (text s)
(happend* (map char (string->list s)))) (happend* (map char (string->list s))))
@ -81,30 +83,30 @@
(define (vline h) (define (vline h)
(vappend* (make-list h (char #\│)))) (vappend* (make-list h (char #\│))))
(define (vappend1 y x) (define (vappend2 y x)
(match-define (rart xw xh x!) x) (match-define (rart xw xh x!) x)
(match-define (rart yw yh y!) y) (match-define (rart yw yh y!) y)
(unless (= xw yw) (unless (= xw yw)
(error 'vappend1 "Widths must be equal: ~e vs ~e" xw yw)) (error 'vappend2 "Widths must be equal: ~e vs ~e" xw yw))
(rart xw (+ xh yh) (rart xw (+ xh yh)
(λ (r c) (λ (d r c)
(x! (+ r 0) c) (x! d (+ r 0) c)
(y! (+ r xh) c)))) (y! d (+ r xh) c))))
(define (vappend r1 . rs) (define (vappend r1 . rs)
(foldl vappend1 r1 rs)) (foldl vappend2 r1 rs))
(define (vappend* rs) (apply vappend rs)) (define (vappend* rs) (apply vappend rs))
(define (happend1 y x) (define (happend2 y x)
(match-define (rart xw xh x!) x) (match-define (rart xw xh x!) x)
(match-define (rart yw yh y!) y) (match-define (rart yw yh y!) y)
(unless (= xh yh) (unless (= xh yh)
(error 'vappend1 "Heights must be equal: ~e vs ~e" xh yh)) (error 'happend2 "Heights must be equal: ~e vs ~e" xh yh))
(rart (+ xw yw) xh (rart (+ xw yw) xh
(λ (r c) (λ (d r c)
(x! r (+ c 0)) (x! d r (+ c 0))
(y! r (+ c xw))))) (y! d r (+ c xw)))))
(define (happend r1 . rs) (define (happend r1 . rs)
(foldl happend1 r1 rs)) (foldl happend2 r1 rs))
(define (happend* rs) (apply happend rs)) (define (happend* rs) (apply happend rs))
(define (place-at back dr dc front) (define (place-at back dr dc front)
@ -113,67 +115,191 @@
(unless (and (<= fw bw) (<= fh bh)) (unless (and (<= fw bw) (<= fh bh))
(error 'place-at "Foreground must fit inside background")) (error 'place-at "Foreground must fit inside background"))
(rart bw bh (rart bw bh
(λ (r c) (λ (d r c)
(b! r c) (b! d r c)
(f! (+ r dr) (+ c dc))))) (f! d (+ r dr) (+ c dc)))))
(define-syntax (place-at* stx) (define-syntax (place-at* stx)
(syntax-parse stx (syntax-parse stx
[(_ b:expr) #'b] [(_ b:expr) #'b]
[(_ b:expr [dr:expr dc:expr f:expr] . more:expr) [(_ b:expr [dr:expr dc:expr f:expr] . more:expr)
#'(place-at* (place-at b dr dc f) . more)])) #'(place-at* (place-at b dr dc f) . more)]))
(define (frame #:style [s #f] #:fg [f #f] #:bg [b #f] r) (define (frame #:style [s #f] #:fg [f #f] #:bg [b #f] x)
(match-define (rart w h _) r) (match-define (rart w h _) x)
(place-at (place-at
(with-drawing s f b (with-drawing s f b
(vappend (vappend
(happend (char #\┌) (hline w ) (char #\┐)) (happend (char #\┌) (hline w ) (char #\┐))
(happend (vline h) (blank w h) (vline h)) (happend (vline h) (blank w h) (vline h))
(happend (char #\└) (hline w ) (char #\┘)))) (happend (char #\└) (hline w ) (char #\┘))))
1 1 r)) 1 1 x))
(define (inset dw dh r) (define (matte-at mw mh @c @r x)
(match-define (rart w h !) r) (match-define (rart xw xh x!) x)
(rart (+ dw w dw) (+ dh h dh) (unless (and (<= (+ xw @c) mw)
(λ (r c) (<= (+ xh @r) mh))
(! (+ r dh) (+ c dw))))) (error 'matte-at "Original (~ax~a) must fit inside matte (~ax~a)"
xw xh mw mh))
(place-at (blank mw mh) @r @c x))
(define (scale w h (define (translate dr dc x)
#:ws [ws 'center] (match-define (rart xw xh x!) x)
#:hs [hs 'middle] (matte-at (+ xw dc) (+ xh dr) dc dr x))
r)
(match-define (rart rw rh r!) r) (define (matte w h
(unless (and (<= rw w) (<= rh h)) #:halign [ws 'center]
(error 'scale "Original (~ax~a) must fit inside scaled (~ax~a)" #:valign [hs 'center]
rw rh w h)) x)
(rart w h (match-define (rart xw xh x!) x)
(λ (r c) (unless (and (<= xw w) (<= xh h))
(r! (match hs (error 'matte "Original (~ax~a) must fit inside matte (~ax~a)"
['top r] xw xh w h))
['middle (+ r (floor (/ (- h rh) 2)))] (matte-at w h
['bottom (+ r (- h rh))])
(match ws (match ws
['left c] ['left 0]
['center (+ c (floor (/ (- w rw) 2)))] ['center (floor (/ (- w xw) 2))]
['right (+ c (- w rw))]))))) ['right (- w xw)])
(match hs
['top 0]
['center (floor (/ (- h xh) 2))]
['bottom (- h xh)])
x))
;; xxx table (with optional framing) (define (inset dw dh x)
;; xxx mask (select a piece of a largest image) (match-define (rart w h !) x)
;; xxx render xexpr-like thing (matte (+ dw w dw) (+ dh h dh)
;; xxx text... (fit text inside a width) #:halign 'center #:valign 'center
;; xxx paragraph (fit text inside a box) x))
(define (mask mc mw mr mh x)
(match-define (rart xw xh x!) x)
(rart xw xh
(λ (d r c)
(x!
(λ (r c ch)
(when (and (<= mr r (+ mr mh))
(<= mc c (+ mc mw)))
(d r c ch)))
r c))))
(define (crop cc cw cr ch x)
(match-define (rart mw mh m!) (mask cc cw cr ch x))
(rart cw ch
(λ (d r c)
(m! (λ (r c ch)
(d (- r cr) (- c cc) ch))
r c))))
(module+ test (module+ test
(draw 1 1 (draw 1 1
(scale 80 20 (crop 70 80 10 20
#:ws 'right (matte 80 20
#:halign 'right
(fg 'blue (fg 'blue
(frame #:fg 'red (frame #:fg 'red
(inset (inset
4 5 4 5
(happend (style 'underline (text "Left")) (happend (style 'underline (text "Left"))
(blank 4) (blank 4)
(style 'bold (text "Right")))))))) (style 'bold (text "Right")))))))))
(newline))
(define (table rows
#: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)
(cond
[(not (pair? l)) l]
[(zero? i) (first l)]
[else (list-ref* (sub1 i) (rest 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 rart-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 footer (make-bar #\└ #\┴ #\┘))
(define inbetween (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 rart-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 (rart? col) col (text (~a col))))))
;; xxx render xexpr-like thing
;; xxx text... (fit text inside a width)
;; xxx paragraph (fit text inside a box)
(module+ test
(draw 1 1
(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)) (newline))
(provide rart? (provide rart?
@ -181,9 +307,9 @@
style fg bg with-drawing style fg bg with-drawing
blank char text blank char text
hline vline hline vline
vappend1 vappend vappend2 vappend
happend1 happend happend2 happend
place-at place-at* place-at place-at*
frame frame
inset inset matte-at matte translate
scale) table text-rows)

53
size.rkt Normal file
View File

@ -0,0 +1,53 @@
#lang racket/base
(require racket/match
racket/list
racket/system
ansi)
(define stty-minus-f-arg-string
(case (system-type 'os)
((macosx) "-f")
(else "-F")))
(define (read-until ip char)
(define byte (char->integer char))
(apply bytes
(let loop ()
(match (read-byte ip)
[(== byte) empty]
[next (cons next (loop))]))))
(define (screen-size)
(define tty-str "/dev/tty")
(system* "/bin/stty"
stty-minus-f-arg-string
tty-str
"raw"
"-echo")
(define-values (in out)
(open-input-output-file tty-str #:exists 'update))
(write-bytes #"\e[18t" out) (flush-output out)
(dynamic-wind
void
(λ ()
(match (read-until in #\;)
[#"\e[8"
(define row-s (read-until in #\;))
(define col-s (read-until in #\t))
(values (bytes->number row-s)
(bytes->number col-s))]
[_ (values #f #f)]))
(λ ()
(close-input-port in)
(close-output-port out)
(system* "/bin/stty"
stty-minus-f-arg-string
tty-str
"cooked"
"echo"))))
(define (bytes->number bs)
(string->number (bytes->string/utf-8 bs)))
(module+ main
(screen-size))