Remove testing

Missing:
 - paragraph wrapping functionality (i probably will change this around)
 - style support of any kind (also will be different from raart)
 - tables

Makefile.am

@@ -24,7 +24,8 @@ SUFFIXES = .scm .go
 	$(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILE_TOOLS) compile $(GUILE_TARGET) $(GUILE_WARNINGS) -o "$@" "$<"
 
 SOURCES = gaart.scm \
-					gaart/draw.scm
+					gaart/draw.scm \
+					gaart/buffer.scm
 
 TESTS =
 

gaart.scm

@@ -6,11 +6,14 @@
   #:use-module (uniseg)
   #:use-module (uniseg graphemes)
   #:use-module (uniseg graphemes stream)
-  #:export (gaart?
+  #:use-module (uniseg graphemes iterator)
+  #:export (<gaart>
+            gaart?
             gaart-w
             gaart-h
             gaart-draw
             blank
+            char
             text
             place-at
             mask
@@ -20,14 +23,16 @@
             matte-at
             matte
             inset
-            vappend2
+            vap
+            end2
             vappend
             vappend*
             happend2
             happend
             happend*
             hline
-            vline))
+            vline
+            frame))
 
 (define (rectangle-intersect a-x1 a-y1
                              a-x2 a-y2
@@ -50,10 +55,14 @@
   (gaart w h (λ (okay? blit! rpos cpos) #f)))
 
 (define (char ch)
+  (define grapheme (char->grapheme ch))
+  (unless grapheme
+    (scm-error #f "char" "Unable to convert ~s to a valid unicode grapheme" (list ch) (list ch)))
+
   (gaart
    1 1
    (λ (okay? blit! rpos cpos)
-     (blit! rpos cpos ch)
+     (blit! rpos cpos grapheme)
      #f)))
 
 (define (text str)
@@ -62,12 +71,12 @@
    (λ (okay? blit! rpos cpos)
      ;; Go through each grapheme, print it and advance the position
      ;; depending on the width
-     (stream-fold
+     (fold
       (λ (gr c)
-        (blit! rpos c (grapheme-string gr))
+        (blit! rpos c gr)
         (+ c (grapheme-width gr)))
       cpos
-      (string->grapheme-stream str))
+      (string->grapheme-list str))
      #f)))
 
 (define (place-at back row-offset col-offset front)
@@ -82,7 +91,7 @@
   (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)))
+      (scm-error #f "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))
@@ -91,7 +100,7 @@
   (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)))
+      (scm-error #f "matte" "Original (~ax~a) must fit inside matte (~ax~a)" (list xw xh width height) (list x)))
 
     (matte-at width height
               (match halign
@@ -108,8 +117,8 @@
   (match-let ((($ <gaart> xw xh _) x))
     (matte (+ width-offset xw width-offset)
            (+ height-offset xh height-offset)
-           #:halign 'center #:valign 'center
+           x
-           x)))
+           #:halign 'center #:valign 'center)))
 
 (define (translate row-offset col-offset x)
   (match-let ((($ <gaart> xw xh _) x))
@@ -163,13 +172,17 @@
              (or (draw-x okay? blit! rpos cpos)
                  (blit! cursor-rpos cursor-cpos #f))))))
 
-;; figure out "invalid keyword" error
+(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 ((($ <gaart> xw xh draw-x) x)
               (($ <gaart> yw yh draw-y) y))
     (unless (= xw yw)
-      ;; TODO: proper error messages with irritants
+      (scm-error #f "vappend2" "Widths must be equal: ~a vs ~a" (list xw yw) (list xw yw)))
-      (error (format #f "vappend2: Widths must be equal: ~a vs ~a" xw yw)))
     (gaart
      xw (+ xh yh)
      (λ (okay? blit! rpos cpos)
@@ -179,29 +192,28 @@
            (or (dy) (dx))
            (or (dx) (dy)))))))
 
-
 (define* (vappend2 y x #:key (halign #f) (reverse? #f))
   (cond
-   ((not halign) (*vappend2 #:reverse? reverse? y x))
+   ((not halign) (*vappend2 y x #:reverse? reverse?))
    (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 x-paint (matte new-width xh x #:halign halign))
-      (define y-paint (matte new-width yh #:halign halign y))
+      (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) . rs)
+(define* (vappend r1 #:key (halign #f) (reverse? #f) #:rest rs)
-  (fold (λ (a d) (vappend2 a d #:halign halign #:reverse? reverse?)) r1 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 rs #:halign halign #:reverse? reverse?))
+  (apply vappend (car rs) #:halign halign #:reverse? reverse? (cdr rs)))
 
 (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))
+      (scm-error #f "happend2" "Heights must be equal: ~a vs ~a" (list xh yh) (list xh yh)))
     (gaart
      (+ xw yw) xh
      (λ (okay? blit! rpos cpos)
@@ -211,28 +223,44 @@
            (or (dy) (dx))
            (or (dx) (dy)))))))
 
-
 (define* (happend2 y x #:key (valign #f) (reverse? #f))
   (cond
-   ((not valign) (*happend2 #:reverse? reverse? y x))
+   ((not valign) (*happend2 y x #:reverse? reverse?))
    (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 x-paint (matte xw new-height x #:valign valign))
-      (define y-paint (matte yw new-height #:valign valign y))
+      (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)
-(define* (happend r1 #:key (valign #f) (reverse? #f) . rs)
+  (fold (λ (a d) (happend2 a d #:valign valign #:reverse? reverse?)) r1 (strip-keywords 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?))
+  (apply happend (car rs) #:valign valign #:reverse? reverse? (cdr rs)))
 
+(define* (hline w #:key (ch #\─))
+  (text (make-string w ch)))
 
-(define (hline w)
+(define* (vline h #:key (ch #\│))
-  (text (make-string w #\─)))
+  (vappend* (make-list h (char ch))))
 
-(define (vline h)
+(define* (frame x
-  (vappend* (make-list h (char #\│))))
+         #:key
+         (top-left #\┌)
+         (top-right #\┐)
+         (bottom-left #\└)
+         (bottom-right #\┘)
+         (horiz-line #\─)
+         (vert-line #\│))
+  (match-let* ((($ <gaart> 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)))

gaart/buffer.scm

@@ -0,0 +1,89 @@
+(define-module (gaart buffer)
+  #:use-module (uniseg graphemes)
+  #:use-module (srfi srfi-43)
+  #:export (make-buffer
+            write-buffer
+            buffer-set!
+            buffer-ref))
+
+(define %empty-entry '(#\space))
+
+;; Buffer is a 2d vector, containing lists as the innermost data type.
+;; We use lists so that we can support multi-character graphemes at a single position.
+;; Additionally, the vector's content is set to #f if a double- or triple-width character is to the left.
+;; So, upon encountering a #f, we need to move to the left and reset all the cols set to #f or the multi-width glyph.
+(define (make-buffer width height)
+  (define outer-vec (make-vector height #f))
+  (for-each
+   (λ (i) (vector-set! outer-vec i (make-vector width %empty-entry)))
+   (iota height))
+  outer-vec)
+
+;; Naiively set without checking for multi-width neighbors or setting multi-width neighbors!
+(define (_buffer-set! buf rpos cpos glyphs)
+  (vector-set! (vector-ref buf rpos) cpos glyphs))
+
+(define (buffer-set! buf rpos cpos grapheme)
+  (define-values (entry col-vec) (_buffer-ref buf rpos cpos))
+  (unless entry
+    ;; We found a #f entry. So to the left is a grapheme.
+    ;; Iterate backwards from current pos - 1 until we find the grapheme or the first entry in the row.
+    ;; Clear all entries including the grapheme.
+    (unless (= cpos 0)
+      (let loop ((c (- cpos 1))
+                 (e (_buffer-ref buf rpos (- cpos 1))))
+        (_buffer-set! buf rpos c %empty-entry)
+        (unless (or e (= c 0))
+          (loop (- c 1) (_buffer-ref buf rpos (- c 1)))))))
+
+  ;; Actually set the value now
+  (_buffer-set! buf rpos cpos (grapheme-glyphs grapheme))
+
+  ;; Clear out `width-1' entries right from the new entry
+  (let ((width (grapheme-width grapheme))
+        (max-col (vector-length col-vec)))
+    (do ((c (1+ cpos) (1+ c)))
+        ((or (>= c max-col)
+             (>= c (+ cpos width))))
+      (_buffer-set! buf rpos c #f))
+    ;; We also have to make sure that if any of the right neighbors are #f
+    ;; due to former now cleared multi-width graphemes, that they are all cleared as well!
+    (do ((c (+ cpos width) (1+ c)))
+        ;; ensure in bounds and all values are false
+        ((or (>= c max-col)
+             (_buffer-ref buf rpos c)))
+      (_buffer-set! buf rpos c %empty-entry))))
+
+;; Internal direct buffer access, and also gives out the column vector for convenience
+(define (_buffer-ref buf rpos cpos)
+  (let ((col-vec (vector-ref buf rpos)))
+    (values
+     (vector-ref col-vec cpos)
+     col-vec)))
+
+;; Buffer ref that finds the actual grapheme and returns the actual column pos as a second value
+(define (buffer-ref buf rpos cpos)
+  (let ((entry (_buffer-ref buf rpos cpos)))
+    (cond
+     (entry (values entry cpos))
+     ((<= cpos 0) #f)
+     (else (buffer-ref buf rpos (- cpos 1))))))
+
+
+(define* (write-buffer buf #:optional (port #f))
+  "Output the buffer to an output port. If `port' is not specified, uses current output port"
+  (unless port (set! port (current-output-port)))
+  (vector-for-each
+   (λ (rpos row)
+     (define row-str
+       (list->string
+        (vector-fold-right
+         (λ (cpos lst entry)
+           (if entry
+               (append entry lst)
+               lst))
+         '()
+         row)))
+     (display row-str port)
+     (display "\n" port))
+   buf))

gaart/draw.scm

@@ -1,13 +1,17 @@
 (define-module (gaart draw)
   #:use-module (gaart)
-  #:use-module (termenv screen)
+  #:use-module (gaart buffer)
-  #:export (draw))
+  #:use-module (ice-9 match)
+  #:export (draw-here))
 
-(define (draw buffer ga)
+(define* (draw-here ga #:optional (port #f))
-  "Draw a gaart to the provided buffer"
+  (unless port
-  ;; TODO: better okay and use buffer
+    (set! port (current-output-port)))
-  ((gaart-draw ga) (λ (width height rpos cpos) #t) blit! 0 0))
 
-(define (blit! rpos cpos ch)
+  (match-let* ((($ <gaart> w h draw) ga)
-  (move-cursor rpos cpos)
+               (buf (make-buffer w h))
-  (display ch))
+               (okay? (λ (width height rpos cpos) #t))
+               (blit! (λ (rpos cpos grapheme)
+                        (buffer-set! buf rpos cpos grapheme))))
+    (draw okay? blit! 0 0)
+    (write-buffer buf port)))