238 lines
7.4 KiB
Scheme
238 lines
7.4 KiB
Scheme
(define-module (gaart)
|
|
#:use-module (srfi srfi-9 gnu)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 streams)
|
|
#:use-module (uniseg)
|
|
#:use-module (uniseg graphemes)
|
|
#:use-module (uniseg graphemes stream)
|
|
#:export (gaart?
|
|
gaart-w
|
|
gaart-h
|
|
draw
|
|
blank
|
|
text
|
|
place-at
|
|
mask
|
|
crop
|
|
if-drawn
|
|
place-cursor-after
|
|
matte-at
|
|
matte
|
|
inset
|
|
vappend2
|
|
vappend
|
|
vappend*
|
|
happend2
|
|
happend
|
|
happend*))
|
|
|
|
(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 <gaart>
|
|
(gaart w h draw)
|
|
gaart?
|
|
(w gaart-w)
|
|
(h gaart-h)
|
|
(draw gaart-draw))
|
|
|
|
(define (draw buffer g)
|
|
"Draw a gaart to the provided buffer"
|
|
)
|
|
|
|
(define* (blank #:key (w 0) (h 1))
|
|
(gaart w h (λ (okay? blit! rpos cpos) #f)))
|
|
|
|
(define (char ch)
|
|
(gaart
|
|
1 1
|
|
(λ (okay? blit! rpos cpos)
|
|
(blit! rpos cpos ch)
|
|
#f)))
|
|
|
|
(define (text str)
|
|
(gaart
|
|
(string-width str) 1
|
|
(λ (okay? blit! rpos cpos)
|
|
;; Go through each grapheme, print it and advance the position
|
|
;; depending on the width
|
|
(stream-fold
|
|
(λ (gr c)
|
|
(blit! rpos c (grapheme-string gr))
|
|
(+ c (grapheme-width gr)))
|
|
cpos
|
|
(string->grapheme-stream str))
|
|
#f)))
|
|
|
|
(define (place-at back row-offset col-offset front)
|
|
(match-let ((($ <gaart> bw bh draw-b) back)
|
|
(($ <gaart> fw fh draw-f) front))
|
|
(gaart 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 ((($ <gaart> xw xh _) x))
|
|
(unless (and (<= (+ xw cpos) matte-width)
|
|
(<= (+ xh rpos) matte-height))
|
|
(error (format #f "matte-at: Original (~ax~a@~a,~a) must fit inside matte (~ax~a)" xw xh cpos rpos matte-width matte-height)))
|
|
(place-at (blank mw mh) rpos cpos x)))
|
|
|
|
(define (matte matte-width matte-height x #:key (halign 'center) (valign 'center))
|
|
(define width (or matte-width (gaart-w x)))
|
|
(define height (or matte-height (gaart-h x)))
|
|
(match-let ((($ <gaart> xw xh draw-x) x))
|
|
(unless (and (<= xw width)
|
|
(<= xh height))
|
|
(error (format #f "matte: Original (~ax~a) must fit inside matte (~ax~a)" xw xh width height)))
|
|
|
|
(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 ((($ <gaart> xw xh _) x))
|
|
(matte (+ width-offset xw width-offset)
|
|
(+ height-offset xh height-offset)
|
|
#:halign 'center #:valign 'center
|
|
x)))
|
|
|
|
(define (translate row-offset col-offset x)
|
|
(match-let ((($ <gaart> xw xh _)))
|
|
(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 ((($ <gaart> xw xh draw-x) x))
|
|
(gaart 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 ((($ <gaart> _ _ draw-m) mask-x))
|
|
(gaart
|
|
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 ((($ <gaart> xw xh draw-x) x))
|
|
(gaart 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 ((($ <gaart> xw xh draw-x) x))
|
|
(gaart xw xh
|
|
(λ (okay? blit! rpos cpos)
|
|
(or (draw-x okay? blit! rpos cpos)
|
|
(blit! cursor-rpos cursor-cpos #f))))))
|
|
|
|
(define* (*vappend2 y x #:key (reverse? #f))
|
|
(match-let ((($ <gaart> xw xh draw-x) x)
|
|
(($ <gaart> yw yh draw-y) y))
|
|
(unless (= xw yw)
|
|
;; TODO: proper error messages with irritants
|
|
(error (format #f "vappend2: Widths must be equal: ~d vs ~d" xw yw)))
|
|
(gaart
|
|
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 #:reverse? reverse? y x))
|
|
(else
|
|
(match-let ((($ <gaart> xw xh draw-x) x)
|
|
(($ <gaart> yw yh draw-y) y))
|
|
(define new-width (max xw yw))
|
|
(define x-paint (matte new-width xh #:halign halign x))
|
|
(define y-paint (matte new-width yh #:halign halign y))
|
|
(*vappend2 #:reverse? reverse? y-paint x-paint)))))
|
|
|
|
(define* (vappend r1 . rs #:key (halign #f) (reverse? #f))
|
|
(foldl (λ (a d) (vappend2 #:halign halign #:reverse? reverse? a d)) r1 rs))
|
|
|
|
(define* (vappend* rs #:key (halign #f) (reverse? #f))
|
|
(apply vappend rs #:halign halign #:reverse? reverse?))
|
|
|
|
(define* (*happend2 y x #:key (reverse? #f))
|
|
(match-let ((($ <gaart> xw xh draw-x) x)
|
|
(($ <gaart> yw yh draw-y) y))
|
|
(unless (= xh yh)
|
|
(error "happend2: Heights must be equal: ~d vs ~d" xh yh))
|
|
(gaart
|
|
(+ 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)))))))
|
|
|
|
|
|
(define* (happend2 y x #:key (valign #f) (reverse? #f))
|
|
(cond
|
|
((not valign) (*happend2 #:reverse? reverse? y x))
|
|
(else
|
|
(match-let ((($ <gaart> xw xh draw-x) x)
|
|
(($ <gaart> yw yh draw-y) y))
|
|
(define new-height (max xh yh))
|
|
(define x-paint (matte hw new-height #:halign halign x))
|
|
(define y-paint (matte yw new-height #:halign halign y))
|
|
(*happend2 #:reverse? reverse? y-paint x-paint)))))
|
|
|
|
|
|
(define* (happend r1 . rs #:key (valign #f) (reverse? #f))
|
|
(foldl (λ (a d) (happend2 #:halign valign #:reverse? reverse? a d)) r1 rs))
|
|
|
|
(define* (happend* rs #:key (valign #f) (reverse? #f))
|
|
(apply happend rs #:valign valign #:reverse? reverse?))
|
|
|
|
|
|
(define (hline w)
|
|
(text (make-string w #\─)))
|
|
|
|
(define (vline h)
|
|
(vappend* (make-list h (char #\│))))
|