From bc3fcc35faa33f054cc7f8d6831f5f84689ae0c5 Mon Sep 17 00:00:00 2001 From: Vivianne Langdon Date: Fri, 8 Mar 2024 19:11:15 -0500 Subject: [PATCH] Many of the primitives and helpers! --- gaart.scm | 237 +++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 236 insertions(+), 1 deletion(-) diff --git a/gaart.scm b/gaart.scm index 95082d1..93c4198 100644 --- a/gaart.scm +++ b/gaart.scm @@ -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 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 ((($ bw bh draw-b) back) + (($ 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 ((($ 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 ((($ 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 ((($ 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 ((($ 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 ((($ 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 ((($ _ _ 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 ((($ 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 ((($ 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 ((($ xw xh draw-x) x) + (($ 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 ((($ xw xh draw-x) x) + (($ 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 ((($ xw xh draw-x) x) + (($ 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 ((($ xw xh draw-x) x) + (($ 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 #\│))))