275 lines
9.2 KiB
Scheme
275 lines
9.2 KiB
Scheme
(define-module (guart)
|
|
#:use-module (srfi srfi-9 gnu)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 streams)
|
|
#:use-module (uniseg)
|
|
#:use-module (uniseg graphemes)
|
|
#:use-module (uniseg graphemes stream)
|
|
#:use-module (uniseg graphemes iterator)
|
|
#:export (<guart>
|
|
guart?
|
|
guart-w
|
|
guart-h
|
|
guart-draw
|
|
blank
|
|
char
|
|
text
|
|
place-at
|
|
mask
|
|
crop
|
|
if-drawn
|
|
place-cursor-after
|
|
matte-at
|
|
matte
|
|
inset
|
|
vap
|
|
end2
|
|
vappend
|
|
vappend*
|
|
happend2
|
|
happend
|
|
happend*
|
|
hline
|
|
vline
|
|
frame))
|
|
|
|
(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)))
|
|
|
|
(define-immutable-record-type <guart>
|
|
(guart w h draw)
|
|
guart?
|
|
(w guart-w)
|
|
(h guart-h)
|
|
(draw guart-draw))
|
|
|
|
|
|
(define* (blank #:optional (w 0) (h 1))
|
|
(guart w h (λ (okay? blit! rpos cpos) #f)))
|
|
|
|
(define (char ch)
|
|
(define grapheme (char->grapheme ch))
|
|
(unless grapheme
|
|
(scm-error 'convert-failure "char" "Unable to convert ~s to a valid unicode grapheme" (list ch) (list ch)))
|
|
|
|
(guart
|
|
1 1
|
|
(λ (okay? blit! rpos cpos)
|
|
(blit! rpos cpos grapheme)
|
|
#f)))
|
|
|
|
;; TODO: detect non-printable characters other than newline
|
|
;; We need to discard them and also handle escape codes/printing those, etc.
|
|
(define* (text str #:key (halign #f))
|
|
(define contains-newline? (string-index str #\newline))
|
|
(if contains-newline?
|
|
(if halign
|
|
(vappend* (map text (string-split str #\newline)) #:halign halign)
|
|
(scm-error 'keyword-argument-error "text" "String contained newlines but no halign argument was set" '() (list halign)))
|
|
(guart
|
|
(string-width str) 1
|
|
(λ (okay? blit! rpos cpos)
|
|
;; Go through each grapheme, print it and advance the position
|
|
;; depending on the width
|
|
(fold
|
|
(λ (gr c)
|
|
(blit! rpos c gr)
|
|
(+ c (grapheme-width gr)))
|
|
cpos
|
|
(string->grapheme-list str))
|
|
#f))))
|
|
|
|
(define (place-at back row-offset col-offset front)
|
|
(match-let ((($ <guart> bw bh draw-b) back)
|
|
(($ <guart> fw fh draw-f) front))
|
|
(guart bw bh
|
|
(λ (okay? blit! rpos cpos)
|
|
(or (draw-b okay? blit! rpos cpos)
|
|
(draw-f okay? blit! (+ rpos row-offset) (+ cpos col-offset)))))))
|
|
|
|
(define (matte-at matte-width matte-height cpos rpos x)
|
|
(match-let ((($ <guart> xw xh _) x))
|
|
(unless (and (<= (+ xw cpos) matte-width)
|
|
(<= (+ xh rpos) matte-height))
|
|
(scm-error 'matte-error "matte-at" "Original (~ax~a@~a,~a) must fit inside matte (~ax~a)" (list xw xh cpos rpos matte-width matte-height) (list x)))
|
|
(place-at (blank matte-width matte-height) rpos cpos x)))
|
|
|
|
(define* (matte matte-width matte-height x #:key (halign 'center) (valign 'center))
|
|
(define width (or matte-width (guart-w x)))
|
|
(define height (or matte-height (guart-h x)))
|
|
(match-let ((($ <guart> xw xh draw-x) x))
|
|
(unless (and (<= xw width)
|
|
(<= xh height))
|
|
(scm-error 'matte-error "matte" "Original (~ax~a) must fit inside matte (~ax~a)" (list xw xh width height) (list x)))
|
|
|
|
(matte-at width height
|
|
(match halign
|
|
('left 0)
|
|
('center (floor (/ (- width xw) 2)))
|
|
('right (- width xw)))
|
|
(match valign
|
|
('top 0)
|
|
('center (floor (/ (- height xh) 2)))
|
|
('bottom (- height xh)))
|
|
x)))
|
|
|
|
(define (inset width-offset height-offset x)
|
|
(match-let ((($ <guart> xw xh _) x))
|
|
(matte (+ width-offset xw width-offset)
|
|
(+ height-offset xh height-offset)
|
|
x
|
|
#:halign 'center #:valign 'center)))
|
|
|
|
(define (translate row-offset col-offset x)
|
|
(match-let ((($ <guart> xw xh _) x))
|
|
(matte-at (+ xw col-offset) (+ xh row-offset) col-offset row-offset x)))
|
|
|
|
|
|
(define (mask mask-cpos mask-width mask-rpos mask-height x)
|
|
(match-let ((($ <guart> xw xh draw-x) x))
|
|
(guart xw xh
|
|
(λ (okay? blit! rpos cpos)
|
|
(draw-x
|
|
;; okay? function definition for this art
|
|
(λ (width height rpos cpos)
|
|
(and (okay? width height rpos cpos)
|
|
(rectangle-intersect mask-cpos mask-rpos
|
|
(+ mask-cpos mask-width) (+ mask-rpos mask-height)
|
|
cpos rpos
|
|
(+ cpos width) (+ rpos height))))
|
|
blit! rpos cpos))
|
|
)))
|
|
|
|
|
|
(define (crop crop-cpos crop-width crop-rpos crop-height x)
|
|
(define mask-x (mask crop-cpos crop-width crop-rpos crop-height x))
|
|
(match-let ((($ <guart> _ _ draw-m) mask-x))
|
|
(guart
|
|
crop-width
|
|
crop-height
|
|
(λ (okay? blit! rpos cpos)
|
|
(draw-m
|
|
;; okay? function definition for this art
|
|
(λ (width height rpos cpos)
|
|
(okay? width height (- rpos crop-rpos) (- cpos crop-cpos)))
|
|
;; blit! function definition for this art
|
|
(λ (rpos cpos ch)
|
|
(blit! (- rpos crop-rpos) (- cpos crop-cpos) ch))
|
|
rpos cpos)))))
|
|
|
|
(define (if-drawn func x)
|
|
(match-let ((($ <guart> xw xh draw-x) x))
|
|
(guart xw xh
|
|
(λ (okay? blit! rpos cpos)
|
|
(define ? (draw-x okay? blit! rpos cpos))
|
|
(when ? (func rpos cpos ))
|
|
?))))
|
|
|
|
(define (place-cursor-after x cursor-rpos cursor-cpos)
|
|
(match-let ((($ <guart> xw xh draw-x) x))
|
|
(guart xw xh
|
|
(λ (okay? blit! rpos cpos)
|
|
(or (draw-x okay? blit! rpos cpos)
|
|
(blit! cursor-rpos cursor-cpos #f))))))
|
|
|
|
(define (strip-keywords lst)
|
|
(match lst
|
|
(((? keyword? kw) arg . remainder) (strip-keywords remainder))
|
|
((item . remainder) (cons item (strip-keywords remainder)))
|
|
(item item)))
|
|
|
|
(define* (*vappend2 y x #:key (reverse? #f))
|
|
(match-let ((($ <guart> xw xh draw-x) x)
|
|
(($ <guart> yw yh draw-y) y))
|
|
(unless (= xw yw)
|
|
(scm-error 'append-error "vappend2" "Widths must be equal: ~a vs ~a" (list xw yw) (list xw yw)))
|
|
(guart
|
|
xw (+ xh yh)
|
|
(λ (okay? blit! rpos cpos)
|
|
(define (dx) (draw-x okay? blit! rpos cpos))
|
|
(define (dy) (draw-y okay? blit! (+ rpos xh) cpos))
|
|
(if reverse?
|
|
(or (dy) (dx))
|
|
(or (dx) (dy)))))))
|
|
|
|
(define* (vappend2 y x #:key (halign #f) (reverse? #f))
|
|
(cond
|
|
((not halign) (*vappend2 y x #:reverse? reverse?))
|
|
(else
|
|
(match-let ((($ <guart> xw xh draw-x) x)
|
|
(($ <guart> yw yh draw-y) y))
|
|
(define new-width (max xw yw))
|
|
(define x-paint (matte new-width xh x #:halign halign))
|
|
(define y-paint (matte new-width yh y #:halign halign))
|
|
(*vappend2 y-paint x-paint #:reverse? reverse?)))))
|
|
|
|
(define* (vappend r1 #:key (halign #f) (reverse? #f) #:rest rs)
|
|
(fold (λ (a d) (vappend2 a d #:halign halign #:reverse? reverse?)) r1 (strip-keywords rs)))
|
|
|
|
(define* (vappend* rs #:key (halign #f) (reverse? #f))
|
|
(apply vappend (car rs) #:halign halign #:reverse? reverse? (cdr rs)))
|
|
|
|
(define* (*happend2 y x #:key (reverse? #f))
|
|
(match-let ((($ <guart> xw xh draw-x) x)
|
|
(($ <guart> yw yh draw-y) y))
|
|
(unless (= xh yh)
|
|
(scm-error 'append-error "happend2" "Heights must be equal: ~a vs ~a" (list xh yh) (list xh yh)))
|
|
(guart
|
|
(+ xw yw) xh
|
|
(λ (okay? blit! rpos cpos)
|
|
(define (dx) (draw-x okay? blit! rpos cpos))
|
|
(define (dy) (draw-y okay? blit! rpos (+ cpos xw)))
|
|
(if reverse?
|
|
(or (dy) (dx))
|
|
(or (dx) (dy)))))))
|
|
|
|
;; TODO: for both v and h: need to better detect and error if the alignments are not set and are needed.
|
|
(define* (happend2 y x #:key (valign #f) (reverse? #f))
|
|
(cond
|
|
((not valign) (*happend2 y x #:reverse? reverse?))
|
|
(else
|
|
(match-let ((($ <guart> xw xh draw-x) x)
|
|
(($ <guart> yw yh draw-y) y))
|
|
(define new-height (max xh yh))
|
|
(define x-paint (matte xw new-height x #:valign valign))
|
|
(define y-paint (matte yw new-height y #:valign valign))
|
|
(*happend2 y-paint x-paint #:reverse? reverse?)))))
|
|
|
|
(define* (happend r1 #:key (valign #f) (reverse? #f) #:rest rs)
|
|
(fold (λ (a d) (happend2 a d #:valign valign #:reverse? reverse?)) r1 (strip-keywords rs)))
|
|
|
|
(define* (happend* rs #:key (valign #f) (reverse? #f))
|
|
(apply happend (car rs) #:valign valign #:reverse? reverse? (cdr rs)))
|
|
|
|
(define* (hline w #:key (ch #\─))
|
|
(text (make-string w ch)))
|
|
|
|
(define* (vline h #:key (ch #\│))
|
|
(vappend* (make-list h (char ch))))
|
|
|
|
(define* (frame x
|
|
#:key
|
|
(top-left #\┌)
|
|
(top-right #\┐)
|
|
(bottom-left #\└)
|
|
(bottom-right #\┘)
|
|
(horiz-line #\─)
|
|
(vert-line #\│))
|
|
(match-let* ((($ <guart> width height _) x)
|
|
(hl (hline width #:ch horiz-line))
|
|
(vl (vline height #:ch vert-line))
|
|
(bl (blank width height)))
|
|
(place-at
|
|
(vappend
|
|
(happend (char top-left) hl (char top-right))
|
|
(happend vl bl vl)
|
|
(happend (char bottom-left) hl (char bottom-right)))
|
|
1 1 x)))
|