Fixed compile

gaart.scm

@@ -1,2 +1,238 @@
 (define-module (gaart)
-   #:export ())
+  #: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)
+  #: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 #:optional (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 matte-width matte-height) 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 _) 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 ((($ <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: ~a vs ~a" 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 #:key (halign #f) (reverse? #f) . rs)
+  (fold (λ (a d) (vappend2 a d #:halign halign #:reverse? reverse?)) 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: ~a vs ~a" 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 xw new-height #:valign valign x))
+      (define y-paint (matte yw new-height #:valign valign y))
+      (*happend2 #:reverse? reverse? y-paint x-paint)))))
+
+
+(define* (happend r1 #:key (valign #f) (reverse? #f) . rs)
+  (fold (λ (a d) (happend2 a d #:valign valign #:reverse? reverse?)) 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 #\│))))