solarpunk-guile
/
guile-guart
3
0
Fork 0
Code Issues Pull Requests Releases Activity

Many of the primitives and helpers!

This commit is contained in:
Vivianne 2024-03-08 19:11:15 -05:00
parent d55cea5be4
commit bc3fcc35fa
Signed by: vv
GPG Key ID: F3E249EDFAC7BE26
1 changed files with 236 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

237
gaart.scm
View File

@ -1,2 +1,237 @@
(define-module (gaart)
#:export ())
#: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 #\│))))