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

It's pretty well working, unicode breaks it still 

Missing:
 - paragraph wrapping functionality (i probably will change this around)
 - style support of any kind (also will be different from raart)
 - tables
This commit is contained in:
Vivianne 2024-03-10 23:28:32 -04:00
parent f1c2d204cd
commit 7c4d86d1a7
Signed by: vv
GPG Key ID: F3E249EDFAC7BE26
4 changed files with 165 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile.am
View File

@ -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 =

89
gaart.scm
View File

@ -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
@ -49,11 +54,19 @@
(define* (blank #:optional (w 0) (h 1))
(gaart w h (λ (okay? blit! rpos cpos) #f)))
;; TODO: use stock char->grapheme
(define (char->grapheme char)
((make-grapheme-iterator) char))
(define (char ch)
(define grapheme (char->grapheme ch))
(unless grapheme
(error (format #f "Unable to convert ~s to a valid unicode grapheme" ch)))
(gaart
1 1
(λ (okay? blit! rpos cpos)
(blit! rpos cpos ch)
(blit! rpos cpos grapheme)
#f)))
(define (text str)
@ -64,7 +77,7 @@
;; depending on the width
(stream-fold
(λ (gr c)
(blit! rpos c (grapheme-string gr))
(blit! rpos c gr)
(+ c (grapheme-width gr)))
cpos
(string->grapheme-stream str))
@ -108,8 +121,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,7 +176,12 @@
(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))
@ -179,29 +197,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 y-paint (matte new-width yh #:halign halign y))
(define x-paint (matte new-width xh x #:halign halign))
(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)
(fold (λ (a d) (vappend2 a d #:halign halign #:reverse? reverse?)) r1 rs))
(define* (vappend r1 #:key (halign #f) (reverse? #f) #:rest 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))
(error (format #f "happend2: Heights must be equal: ~a vs ~a" xh yh)))
(gaart
(+ xw yw) xh
(λ (okay? blit! rpos cpos)
@ -211,28 +228,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 y-paint (matte yw new-height #:valign valign y))
(define x-paint (matte xw new-height x #:valign valign))
(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) . rs)
(fold (λ (a d) (happend2 a d #:valign valign #:reverse? reverse?)) r1 rs))
(define* (happend r1 #:key (valign #f) (reverse? #f) #:rest rs)
(fold (λ (a d) (happend2 a d #:valign valign #:reverse? reverse?)) r1 (strip-keywords 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)
(text (make-string w #\─)))
(define* (vline h #:key (ch #\│))
(vappend* (make-list h (char ch))))
(define (vline h)
(vappend* (make-list h (char #\│))))
(define* (frame x
#: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)))

89
gaart/buffer.scm Normal file
View File

@ -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))

22
gaart/draw.scm
View File

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