10 Commits

Author SHA1 Message Date
Hermes
88c576a6b9 review fixes: word-wrap hard-break, title-align, ASDF fix, edge cases
Fixes from subagent review:
- Word-wrap now hard-breaks words exceeding max-width (was returning
  un-truncated overflow strings)
- Box zero-size guard now catches any zero/single dimension (was only
  catching both zero together)
- Title-align now respected (:left/:center/:right) with proper positioning
- render-text declares (ignore spans) to suppress unused warning
- ASDF test-op fixed: run! → run-tests (symbol didn't exist)
- New test: box-single-column (width=1 renders nothing)
- Tightened word-wrap test: verifies hard-break produces both chunks
- Simplified word-wrap with cond instead of nested if/progn (avoided
  recurring paren-balance issue)
2026-05-11 14:57:44 +00:00
Hermes
a1b1352d10 v0.2.0: Dirty tracking — dirty-mixin, mark-clean, mark-dirty
- dirty-mixin class with dirty slot (initform t)
- mark-clean clears dirty flag
- mark-dirty sets dirty flag
- 3 tests: default-dirty, clean, dirty-cycle
- ROADMAP.org: v0.2.0 all tasks DONE
- 31 component tests, 100% GREEN
2026-05-11 14:49:03 +00:00
Hermes
5672aaf3fd v0.2.0: Text renderable with word-wrap and inline spans
- Text class with content, fg/bg, wrap-mode (:word or :none)
- Span class for inline styled segments (bold, italic, etc.)
- render-text dispatches through backend's draw-text
- word-wrap function splits text at word boundaries
- split-string utility for whitespace tokenization
- 9 new tests: creation, content, empty, truncation, word-wrap,
  single-word, span creation, span storage
- modern-backend now accepts :output-stream
- ASDF updated with text component
- 28 total component tests, 100% GREEN
2026-05-11 14:45:56 +00:00
Hermes
a5f8e6c9d4 v0.2.0: Box renderable — border, background, and title
- Box class with border-style, title, fg/bg slots
- render-box dispatches through backend protocol
- draw-border for borders, draw-rect for background
- draw-text for title below top border
- 7 tests: defaults, border, background, title, no-border,
  zero-size, minimum-size
- 13 assertions, 100% GREEN
- ASDF updated with src/components module
- modern-backend now accepts :output-stream initarg
2026-05-11 14:41:38 +00:00
Hermes
2b6fc32425 review fixes: 3 blocking bugs + 2 improvements
B1: modern-backend now inherits from backend (was standalone class)
B2: draw-rect y-position bug — loop now tracks row offset
B3: Layout module added to ASDF system definition
I1: 6 smoke tests replaced with behavioral tests (captured output)
I3: 6 edge case tests: empty, single-child, zero-size, deep
    nesting, large padding, negative grow

Also fixed:
- Added missing make-simple-backend constructor to simple.lisp
- Added in-package to classes.lisp and simple.lisp (SBCL's load
  restores *package* after each load, breaking batch-mode loading)
2026-05-11 14:08:51 +00:00
Hermes
2231fb6647 v0.0.3: layout engine — pure CL Flexbox solver, 35/35 tests GREEN
Fixes during debugging:
- Variable scope: loop's closing parens closed the let* prematurely,
  making children/is-row/pr/pb undefined in own-size calculation
- gap NIL bug: make-layout-node passed :gap nil (from &key default)
  to make-instance, overriding :initform 0 → (* nil ...) crash
- Child order: push (LIFO) in add-child reversed children order;
  changed to nconc (FIFO), removed the compensating reverse
- Fixed distribute-sizes to base all children from their fixed size
  then apply grow/shrink on top, instead of treating fixed-size
  children as non-participating
2026-05-11 13:39:26 +00:00
Hermes
5e17e3d509 v0.0.3: layout engine — pure CL Flexbox constraint solver and push 2026-05-11 13:12:35 +00:00
Hermes
0397d1de2c v0.0.2: modern backend — raw escape sequences
Implements the modern-backend with truecolor SGR, Unicode box-drawing
(rounded/double/single), DECICM synchronized updates, OSC 8 hyperlinks,
cursor style control, and hex color parsing.

RED: 32 checks, 5 fail (class forward-ref + test bug)
GREEN: 32/32 checks passing (100%)

- backend/modern.lisp — escape generators + modern-backend class
- backend/modern-tests.lisp — 16 test cases, 32 assertions
- backend/package.lisp — updated exports
- org/modern-backend.org — literate source
2026-05-11 12:53:55 +00:00
Hermes
db59fa4f55 v0.0.1: backend protocol — abstraction layer + simple backend
Implement the backend protocol with two backends (modern planned,
simple done). Includes package definitions, CLOS generic protocol,
simple-backend with ASCII borders, and 9 FiveAM tests.

RED: 9/9 tests failing (no implementation)
GREEN: 9/9 tests passing

- backend/package.lisp — defpackage, exports
- backend/classes.lisp — backend base class, 18 generics
- backend/simple.lisp — simple-backend implementation
- backend/tests.lisp — 9 FiveAM test cases
- org/backend-protocol.org — literate source
2026-05-11 12:45:26 +00:00
Hermes
bd22f1a43d test: check token permissions 2026-05-11 11:45:59 +00:00
29 changed files with 3573 additions and 2976 deletions

View File

@@ -50,3 +50,4 @@ See ~docs/ROADMAP.org~ for the full release plan.
** License
TBD
# Test

62
backend/classes.lisp Normal file
View File

@@ -0,0 +1,62 @@
(in-package :cl-tui.backend)
(defclass backend () ())
(defgeneric initialize-backend (backend)
(:method ((b backend)) b))
(defgeneric shutdown-backend (backend)
(:method ((b backend)) (values)))
(defgeneric backend-size (backend)
(:method ((b backend))
(values 80 24)))
(defgeneric backend-write (backend string))
(defgeneric backend-clear (backend)
(:method ((b backend))
(backend-write b (format nil "~C[2J~C[H" #\Esc #\Esc))))
(defgeneric draw-text (backend x y string fg bg &key
bold italic underline reverse dim blink))
(defgeneric draw-border (backend x y width height
&key style fg bg title title-align))
(defgeneric draw-rect (backend x y width height &key bg))
(defgeneric draw-link (backend x y string url &key fg bg))
(defgeneric draw-ellipsis (backend x y width &key fg bg))
(defgeneric cursor-move (backend x y))
(defgeneric cursor-hide (backend)
(:method ((b backend)) (values)))
(defgeneric cursor-show (backend)
(:method ((b backend)) (values)))
(defgeneric cursor-style (backend shape &key blink)
(:method ((b backend) shape &key blink) (values)))
(defgeneric begin-sync (backend)
(:method ((b backend)) (values)))
(defgeneric end-sync (backend)
(:method ((b backend)) (values)))
(defgeneric read-event (backend &key timeout)
(:method ((b backend) &key timeout) (values nil nil)))
(defgeneric enable-mouse (backend)
(:method ((b backend)) (values)))
(defgeneric enable-bracketed-paste (backend)
(:method ((b backend)) (values)))
(defgeneric capable-p (backend feature)
(:method ((b backend) feature)
(declare (ignore feature))
nil))

124
backend/modern-tests.lisp Normal file
View File

@@ -0,0 +1,124 @@
(defpackage :cl-tui-modern-backend-test
(:use :cl :fiveam :cl-tui.backend)
(:export #:run-tests))
(in-package :cl-tui-modern-backend-test)
(def-suite modern-backend-suite :description "Modern backend tests")
(in-suite modern-backend-suite)
(defun run-tests ()
(let ((result (run 'modern-backend-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
;; ── Constructor ────────────────────────────────────────────────
(test make-modern-backend-creates
"make-modern-backend returns a modern-backend instance"
(let ((b (make-modern-backend)))
(is (typep b 'cl-tui.backend::modern-backend))))
;; ── Escape Generation ──────────────────────────────────────────
(test sgr-truecolor-foreground
"SGR truecolor foreground escape is correct"
(is (equal (cl-tui.backend::sgr-fg "#FFD700")
(format nil "~C[38;2;255;215;0m" #\Esc))))
(test sgr-truecolor-background
"SGR truecolor background escape is correct"
(is (equal (cl-tui.backend::sgr-bg "#1a1b26")
(format nil "~C[48;2;26;27;38m" #\Esc))))
(test sgr-named-colors
"SGR named colors resolve to 8-color codes"
(is (equal (cl-tui.backend::sgr-fg :red)
(format nil "~C[31m" #\Esc)))
(is (equal (cl-tui.backend::sgr-bg :blue)
(format nil "~C[44m" #\Esc))))
(test sgr-bold-italic
"SGR attribute escapes are correct"
(is (equal (cl-tui.backend::sgr-attr :bold) (format nil "~C[1m" #\Esc)))
(is (equal (cl-tui.backend::sgr-attr :italic) (format nil "~C[3m" #\Esc)))
(is (equal (cl-tui.backend::sgr-attr :underline) (format nil "~C[4m" #\Esc)))
(is (equal (cl-tui.backend::sgr-attr :reset) (format nil "~C[0m" #\Esc))))
;; ── Cursor ─────────────────────────────────────────────────────
(test cursor-move-escape
"cursor-move generates correct CSI escape"
(let ((b (make-modern-backend)))
(is (equal (cl-tui.backend::cursor-move-escape 5 10)
(format nil "~C[11;6H" #\Esc)))))
(test cursor-style-block
"cursor-style :block generate correct escape"
(let ((b (make-modern-backend)))
(is (equal (cl-tui.backend::cursor-style-escape :block nil)
(format nil "~C[2 q" #\Esc)))))
(test cursor-style-bar
"cursor-style :bar generate correct escape"
(let ((b (make-modern-backend)))
(is (equal (cl-tui.backend::cursor-style-escape :bar nil)
(format nil "~C[6 q" #\Esc)))))
(test cursor-style-underline-blink
"cursor-style :underline with blink"
(let ((b (make-modern-backend)))
(is (equal (cl-tui.backend::cursor-style-escape :underline t)
(format nil "~C[5 q" #\Esc)))))
;; ── Synchronization ────────────────────────────────────────────
(test decicm-escapes
"DECICM synchronized update escapes"
(is (equal (cl-tui.backend::decicm-begin) (format nil "~C[?2026h" #\Esc)))
(is (equal (cl-tui.backend::decicm-end) (format nil "~C[?2026l" #\Esc))))
;; ── OSC 8 Hyperlinks ──────────────────────────────────────────
(test osc8-escape
"OSC 8 hyperlink escape wraps text"
(is (equal (cl-tui.backend::osc8-link "http://example.com" "click here")
(format nil "~C]8;;http://example.com~C\\click here~C]8;;~C\\"
#\Esc #\Esc #\Esc #\Esc))))
;; ── Hex Parsing ────────────────────────────────────────────────
(test hex-color-parsing
"hex-to-rgb parses valid hex colors"
(multiple-value-bind (r g b) (cl-tui.backend::hex-to-rgb "#FFD700")
(is (= r 255))
(is (= g 215))
(is (= b 0))))
(test hex-color-black
"hex-to-rgb parses black"
(multiple-value-bind (r g b) (cl-tui.backend::hex-to-rgb "#000000")
(is (= r 0))
(is (= g 0))
(is (= b 0))))
(test hex-color-short-form
"hex-to-rgb parses 3-digit hex"
(multiple-value-bind (r g b) (cl-tui.backend::hex-to-rgb "#F00")
(is (= r 255))
(is (= g 0))
(is (= b 0))))
;; ── Border Characters ──────────────────────────────────────────
(test border-char-rounded
"modern-border-char returns Unicode box-drawing for rounded style"
(is (equal (cl-tui.backend::border-char :rounded :top-left) "╭"))
(is (equal (cl-tui.backend::border-char :rounded :horizontal) "─"))
(is (equal (cl-tui.backend::border-char :rounded :vertical) "│"))
(is (equal (cl-tui.backend::border-char :rounded :bottom-right) "╯")))
(test border-char-double
"modern-border-char returns double-line chars"
(is (equal (cl-tui.backend::border-char :double :top-left) "╔"))
(is (equal (cl-tui.backend::border-char :double :horizontal) "═"))
(is (equal (cl-tui.backend::border-char :double :vertical) "║")))

246
backend/modern.lisp Normal file
View File

@@ -0,0 +1,246 @@
;;; modern-backend — Raw escape sequence backend
;;; Generated from org/modern-backend.org
;;; DO NOT EDIT — edit the .org file instead
;; In package.lisp, add to :export:
;; #:modern-backend #:make-modern-backend
;; Internal symbols (not exported, used by tests):
;; sgr-fg sgr-bg sgr-attr cursor-move-escape cursor-style-escape
;; decicm-begin decicm-end osc8-link hex-to-rgb border-char
(in-package :cl-tui.backend)
(defun hex-to-rgb (hex)
"Parse a hex color string like \"#FFD700\" into (values r g b).
Also handles 3-digit hex like \"#F00\" (expands to \"#FF0000\")."
(let ((clean (string-trim '(#\# #\Space) hex)))
(if (= (length clean) 3)
;; Expand 3-digit: #F00 -> #FF0000
(let* ((r (parse-integer (subseq clean 0 1) :radix 16 :junk-allowed t))
(g (parse-integer (subseq clean 1 2) :radix 16 :junk-allowed t))
(b (parse-integer (subseq clean 2 3) :radix 16 :junk-allowed t)))
(values (+ r (* r 16)) (+ g (* g 16)) (+ b (* b 16))))
(values (parse-integer (subseq clean 0 2) :radix 16 :junk-allowed t)
(parse-integer (subseq clean 2 4) :radix 16 :junk-allowed t)
(parse-integer (subseq clean 4 6) :radix 16 :junk-allowed t)))))
(defparameter *named-colors*
'((:black . 0) (:red . 1) (:green . 2) (:yellow . 3)
(:blue . 4) (:magenta . 5) (:cyan . 6) (:white . 7)))
(defun sgr-fg (color)
"Return SGR foreground escape for COLOR.
Color can be a hex string, a keyword name, or nil."
(if (null color) ""
(cond ((and (stringp color) (char= (char color 0) #\#))
(multiple-value-bind (r g b) (hex-to-rgb color)
(format nil "~C[38;2;~d;~d;~dm" #\Esc r g b)))
((keywordp color)
(let ((index (cdr (assoc color *named-colors*))))
(if index
(format nil "~C[~dm" #\Esc (+ 30 index))
"")))
(t ""))))
(defun sgr-bg (color)
"Return SGR background escape for COLOR."
(if (null color) ""
(cond ((and (stringp color) (char= (char color 0) #\#))
(multiple-value-bind (r g b) (hex-to-rgb color)
(format nil "~C[48;2;~d;~d;~dm" #\Esc r g b)))
((keywordp color)
(let ((index (cdr (assoc color *named-colors*))))
(if index
(format nil "~C[~dm" #\Esc (+ 40 index))
"")))
(t ""))))
(defparameter *sgr-attr-codes*
'((:bold . 1) (:dim . 2) (:italic . 3) (:underline . 4)
(:blink . 5) (:reverse . 7) (:reset . 0)))
(defun sgr-attr (attr)
"Return SGR attribute escape for ATTR keyword."
(let ((code (cdr (assoc attr *sgr-attr-codes*))))
(if code
(format nil "~C[~dm" #\Esc code)
"")))
(defun cursor-move-escape (x y)
"Return CSI escape to move cursor to (x, y), 1-indexed."
(format nil "~C[~d;~dH" #\Esc (1+ y) (1+ x)))
(defun cursor-style-escape (shape blink)
"Return DECSTR escape for cursor shape.
:block = 2, :underline = 4, :bar = 6.
Add 1 for blink variants."
(let* ((base (case shape
(:block 2) (:underline 4) (:bar 6)
(t 2)))
(code (if blink (1+ base) base)))
(format nil "~C[~d q" #\Esc code)))
(defun decicm-begin ()
"Return escape to enable synchronized updates."
(format nil "~C[?2026h" #\Esc))
(defun decicm-end ()
"Return escape to disable synchronized updates."
(format nil "~C[?2026l" #\Esc))
(defun osc8-link (url text)
"Wrap TEXT in an OSC 8 hyperlink to URL."
(format nil "~C]8;;~A~C\\~A~C]8;;~C\\"
#\Esc url #\Esc text #\Esc #\Esc))
(defparameter *border-chars*
'(((:single :top-left) . "┌") ((:single :top-right) . "┐")
((:single :bottom-left) . "└") ((:single :bottom-right) . "┘")
((:single :horizontal) . "─") ((:single :vertical) . "│")
((:double :top-left) . "╔") ((:double :top-right) . "╗")
((:double :bottom-left) . "╚") ((:double :bottom-right) . "╝")
((:double :horizontal) . "═") ((:double :vertical) . "║")
((:rounded :top-left) . "╭") ((:rounded :top-right) . "╮")
((:rounded :bottom-left) . "╰") ((:rounded :bottom-right) . "╯")
((:rounded :horizontal) . "─") ((:rounded :vertical) . "│")))
(defun border-char (style pos)
"Return the Unicode box-drawing character for STYLE at POS."
(let ((char (cdr (assoc (list style pos) *border-chars* :test #'equal))))
(or char (if (member pos '(:horizontal :vertical))
(case pos (:horizontal "─") (:vertical "│"))
"+"))))
(defclass modern-backend (backend)
((output-stream :initform *standard-output*
:initarg :output-stream
:accessor backend-output-stream)
(in-sync-p :initform nil :accessor in-sync-p)))
(defun make-modern-backend (&key color-palette output-stream)
(declare (ignore color-palette))
(make-instance 'modern-backend :output-stream (or output-stream *standard-output*)))
(defmethod initialize-backend ((b modern-backend))
;; Enter raw mode, enable mouse, bracketed paste
(backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen
(backend-write b (format nil "~C[?1000h" #\Esc)) ; mouse basic
(backend-write b (format nil "~C[?1002h" #\Esc)) ; mouse drag
(backend-write b (format nil "~C[?1006h" #\Esc)) ; SGR mouse
(backend-write b (format nil "~C[?2004h" #\Esc)) ; bracketed paste
(cursor-hide b)
(finish-output (backend-output-stream b))
b)
(defmethod shutdown-backend ((b modern-backend))
(cursor-show b)
(backend-write b (format nil "~C[?2004l" #\Esc)) ; disable bracketed paste
(backend-write b (format nil "~C[?1006l" #\Esc)) ; disable SGR mouse
(backend-write b (format nil "~C[?1002l" #\Esc))
(backend-write b (format nil "~C[?1000l" #\Esc))
(backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen
(finish-output (backend-output-stream b))
(values))
(defmethod backend-size ((b modern-backend))
;; Default fallback — real implementation queries terminal
(values 80 24))
(defmethod backend-write ((b modern-backend) string)
(let ((stream (backend-output-stream b)))
(write-string string stream)
(length string)))
(defmethod capable-p ((b modern-backend) feature)
(member feature '(:truecolor :osc8 :sync :mouse
:bracketed-paste :cursor-style
:kitty-keyboard)))
(defmethod draw-text ((b modern-backend) x y string fg bg
&key bold italic underline reverse dim blink)
(let ((parts (list (cursor-move-escape x y)
(sgr-fg fg) (sgr-bg bg)
(when bold (sgr-attr :bold))
(when italic (sgr-attr :italic))
(when underline (sgr-attr :underline))
(when reverse (sgr-attr :reverse))
(when dim (sgr-attr :dim))
(when blink (sgr-attr :blink))
string
(sgr-attr :reset))))
(backend-write b (apply #'concatenate 'string parts))))
(defmethod draw-border ((b modern-backend) x y width height
&key style fg bg title title-align)
(declare (ignore title title-align))
(let* ((s (or style :single))
(tl (border-char s :top-left))
(tr (border-char s :top-right))
(bl (border-char s :bottom-left))
(br (border-char s :bottom-right))
(h (border-char s :horizontal))
(v (border-char s :vertical))
(fg-esc (sgr-fg fg))
(bg-esc (sgr-bg bg))
(reset (sgr-attr :reset))
(top (concatenate 'string
fg-esc bg-esc tl
(make-string (- width 2) :initial-element (char h 0))
tr reset (string #\Newline)))
(mid (concatenate 'string
fg-esc bg-esc v
(make-string (- width 2) :initial-element #\Space)
v reset (string #\Newline)))
(bot (concatenate 'string
fg-esc bg-esc bl
(make-string (- width 2) :initial-element (char h 0))
br reset)))
(backend-write b top)
(loop repeat (- height 2) do (backend-write b mid))
(backend-write b bot)))
(defmethod draw-rect ((b modern-backend) x y width height &key bg)
(let* ((bg-esc (sgr-bg bg))
(reset (sgr-attr :reset))
(line (concatenate 'string
bg-esc
(make-string width :initial-element #\Space)
reset (string #\Newline))))
(loop :for row :from 0 :below height :do
(backend-write b (cursor-move-escape x (+ y row)))
(backend-write b line))))
(defmethod draw-link ((b modern-backend) x y string url
&key fg bg)
(let ((parts (list (cursor-move-escape x y)
(sgr-fg fg) (sgr-bg bg)
(osc8-link url string)
(sgr-attr :reset))))
(backend-write b (apply #'concatenate 'string parts))))
(defmethod draw-ellipsis ((b modern-backend) x y width
&key fg bg)
(let ((dots "..."))
(draw-text b x y dots fg bg)))
(defmethod cursor-move ((b modern-backend) x y)
(backend-write b (cursor-move-escape x y)))
(defmethod cursor-hide ((b modern-backend))
(backend-write b (format nil "~C[?25l" #\Esc)))
(defmethod cursor-show ((b modern-backend))
(backend-write b (format nil "~C[?25h" #\Esc)))
(defmethod cursor-style ((b modern-backend) shape &key blink)
(backend-write b (cursor-style-escape shape blink)))
(defmethod begin-sync ((b modern-backend))
(setf (in-sync-p b) t)
(backend-write b (decicm-begin)))
(defmethod end-sync ((b modern-backend))
(setf (in-sync-p b) nil)
(backend-write b (decicm-end))
(finish-output (backend-output-stream b)))

29
backend/package.lisp Normal file
View File

@@ -0,0 +1,29 @@
(defpackage :cl-tui.backend
(:use :cl)
(:export
;; Backend classes
#:backend #:simple-backend
;; Lifecycle
#:initialize-backend #:shutdown-backend
#:backend-size #:backend-write #:backend-clear
;; Drawing
#:draw-text #:draw-border #:draw-rect
#:draw-link #:draw-ellipsis
;; Cursor
#:cursor-move #:cursor-hide #:cursor-show #:cursor-style
;; Sync
#:begin-sync #:end-sync
;; Input
#:read-event #:enable-mouse #:enable-bracketed-paste
;; Queries
#:capable-p
;; Constructors
#:make-simple-backend
;; Modern backend
#:modern-backend #:make-modern-backend
;; Internal (for testing)
#:sgr-fg #:sgr-bg #:sgr-attr
#:cursor-move-escape #:cursor-style-escape
#:decicm-begin #:decicm-end #:osc8-link
#:hex-to-rgb #:border-char))
(in-package :cl-tui.backend)

69
backend/simple.lisp Normal file
View File

@@ -0,0 +1,69 @@
(in-package :cl-tui.backend)
(defclass simple-backend (backend)
((output-stream :initform *standard-output*
:initarg :output-stream
:accessor backend-output-stream)))
(defun make-simple-backend (&key output-stream)
(make-instance 'simple-backend
:output-stream (or output-stream *standard-output*)))
(defmethod initialize-backend ((b simple-backend))
b)
(defmethod shutdown-backend ((b simple-backend))
(values))
(defmethod backend-size ((b simple-backend))
;; Try ioctl, fall back to 80x24
(values 80 24))
(defmethod backend-write ((b simple-backend) string)
(let ((stream (backend-output-stream b)))
(write-string string stream)
(finish-output stream)
(length string)))
(defmethod draw-text ((b simple-backend) x y string fg bg
&key bold italic underline reverse dim blink)
(declare (ignore x y fg bg bold italic underline reverse dim blink))
(backend-write b string))
(defun %simple-border-char (edge-style pos)
"Return ASCII border character for EDGE-STYLE at POS.
POS is :top-left, :top-right, :bottom-left, :bottom-right,
:horizontal, or :vertical."
(case pos
((:top-left :top-right :bottom-left :bottom-right) #\+)
(:horizontal #\-)
(:vertical #\|)))
(defmethod draw-border ((b simple-backend) x y width height
&key style fg bg title title-align)
(declare (ignore style fg bg title title-align))
(let ((h (%simple-border-char nil :horizontal))
(v (%simple-border-char nil :vertical)))
;; Top edge
(backend-write b (format nil "~%~v@{~a~:*~}" width h))
;; Sides
(loop for i from 1 below (1- height)
do (backend-write b (format nil "~%|~v@{~a~:*~}|" (- width 2) #\space)))
;; Bottom edge
(backend-write b (format nil "~%~v@{~a~:*~}" width h))))
(defmethod draw-rect ((b simple-backend) x y width height
&key bg)
(declare (ignore x y width height bg))
;; On simple backend, background fill is a no-op
(values))
(defmethod draw-link ((b simple-backend) x y string url
&key fg bg)
(declare (ignore url fg bg))
(draw-text b x y string nil nil))
(defmethod draw-ellipsis ((b simple-backend) x y width
&key fg bg)
(declare (ignore x y width fg bg))
(backend-write b "..."))

138
backend/tests.lisp Normal file
View File

@@ -0,0 +1,138 @@
(defpackage :cl-tui-backend-test
(:use :cl :fiveam :cl-tui.backend)
(:export #:run-tests))
(in-package :cl-tui-backend-test)
(def-suite backend-suite :description "Backend protocol tests")
(in-suite backend-suite)
;; ── Helpers ─────────────────────────────────────────────────────
(defun make-capturing-backend ()
"Create a simple-backend that writes to a string stream."
(let* ((s (make-string-output-stream))
(b (make-simple-backend :output-stream s)))
(values b s)))
;; ── Simple Backend ──────────────────────────────────────────────
(defun run-tests ()
"Run all backend tests."
(let ((result (run 'backend-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
(test simple-backend-lifecycle
"simple-backend can be created and shut down"
(let ((b (make-simple-backend)))
(is (typep b 'simple-backend))
(initialize-backend b)
(is-false (capable-p b :truecolor) "simple backend has no truecolor")
(shutdown-backend b)))
(test simple-backend-draw-text
"simple-backend renders text at position, ignoring style"
(multiple-value-bind (b s) (make-capturing-backend)
(initialize-backend b)
(draw-text b 0 0 "hello" :red nil :bold t :italic t)
(shutdown-backend b)
(is (string= (get-output-stream-string s) "hello")
"draw-text should output the string ignoring style")))
(test simple-backend-draw-border
"simple-backend draws ASCII border with +-| characters"
(multiple-value-bind (b s) (make-capturing-backend)
(initialize-backend b)
(draw-border b 0 0 5 3 :style :single)
(shutdown-backend b)
(let ((out (get-output-stream-string s)))
(is (search "-----" out) "top edge should have 5 dashes")
(is (search "| |" out) "middle row should have pipe sides"))))
(test simple-backend-draw-rounded
"simple-backend falls back to straight edges for rounded style"
(multiple-value-bind (b s) (make-capturing-backend)
(initialize-backend b)
(draw-border b 0 0 5 3 :style :rounded)
(shutdown-backend b)
(let ((out (get-output-stream-string s)))
;; Rounded falls back to ASCII — identical output to single
(is (search "-----" out) "rounded style produces same dashes as single"))))
(test simple-backend-draw-link
"simple-backend renders link as plain text"
(multiple-value-bind (b s) (make-capturing-backend)
(initialize-backend b)
(draw-link b 0 0 "click me" "http://example.com")
(shutdown-backend b)
(is (string= (get-output-stream-string s) "click me")
"simple-backend ignores URL, outputs text only")))
(test simple-backend-draw-ellipsis
"simple-backend renders ... for ellipsis"
(multiple-value-bind (b s) (make-capturing-backend)
(initialize-backend b)
(draw-ellipsis b 0 0 5)
(shutdown-backend b)
(is (string= (get-output-stream-string s) "...")
"ellipsis should output 3 dots")))
;; ── Backend Capabilities ───────────────────────────────────────
(test capable-p-known-features
"capable-p returns nil for all features on simple-backend"
(let ((b (make-simple-backend)))
(initialize-backend b)
(dolist (f '(:truecolor :osc8 :sync :mouse :bracketed-paste
:kitty-keyboard :sixel :cursor-style))
(is-false (capable-p b f)
(format nil "~s should not be supported on simple-backend" f)))
(shutdown-backend b)))
;; ── Backend Size ───────────────────────────────────────────────
(test backend-size-returns-integers
"backend-size returns two integer values"
(let ((b (make-simple-backend)))
(initialize-backend b)
(multiple-value-bind (cols lines) (backend-size b)
(is (integerp cols))
(is (integerp lines))
(is (>= cols 10))
(is (>= lines 3)))
(shutdown-backend b)))
;; ── Backend Protocol: Defaults and No-ops ──────────────────────
(test default-methods-are-no-ops
"Default backend methods don't error"
(let ((b (make-simple-backend)))
(initialize-backend b)
(is (null (multiple-value-list (cursor-hide b))))
(is (null (multiple-value-list (cursor-show b))))
(is (null (multiple-value-list (cursor-style b :block))))
(is (null (multiple-value-list (begin-sync b))))
(is (null (multiple-value-list (end-sync b))))
(shutdown-backend b)))
(test sync-is-noop-on-simple
"begin-sync and end-sync produce no output on simple-backend"
(multiple-value-bind (b s) (make-capturing-backend)
(initialize-backend b)
(begin-sync b)
(draw-text b 0 0 "in sync" nil nil)
(end-sync b)
(shutdown-backend b)
(is (string= (get-output-stream-string s) "in sync")
"no sync escape sequences should appear")))
;; ── Draw-rect ──────────────────────────────────────────────────
(test draw-rect-fills-area-correctly
"draw-rect with background writes nothing to output (simple-backend no-op)"
(multiple-value-bind (b s) (make-capturing-backend)
(initialize-backend b)
(draw-rect b 0 0 5 3 :bg :red)
(shutdown-backend b)
(is (string= (get-output-stream-string s) "")
"draw-rect is a no-op on simple-backend")))

View File

@@ -1,11 +1,41 @@
(defsystem :cl-tui
:name "cl-tui"
:author "memex"
:version "0.1.0"
:license "AGPLv3"
;;; cl-tui.asd — Common Lisp Terminal UI Framework
(asdf:defsystem :cl-tui
:description "Reusable Common Lisp Terminal UI Framework"
:depends-on (:cffi :croatoan :trivial-garbage)
:serial t
:components ((:file "lisp/yoga-ffi")
(:file "lisp/layout-primitives")
(:file "lisp/layout-composable")))
:author "Amr Gharbeia"
:version "0.2.0"
:license "TBD"
:depends-on (:fiveam)
:components
((:module "backend"
:components
((:file "package")
(:file "classes" :depends-on ("package"))
(:file "simple" :depends-on ("package" "classes"))
(:file "modern" :depends-on ("package" "classes"))))
(:module "layout"
:components
((:file "layout")))
(:module "src/components"
:components
((:file "package")
(:file "dirty")
(:file "box" :depends-on ("package"))
(:file "text" :depends-on ("package" "box")))))
:in-order-to ((test-op (test-op :cl-tui-tests))))
(asdf:defsystem :cl-tui-tests
:description "Test suite for cl-tui"
:depends-on (:cl-tui :fiveam)
:components
((:module "backend"
:components
((:file "tests")))
(:module "layout"
:components
((:file "tests")))
(:module "src/components"
:components
((:file "box-tests")
(:file "dirty-tests"))))
:perform (test-op (o c)
(uiop:symbol-call :cl-tui-backend-test '#:run-tests)))

318
docs/ARCHITECTURE.org Normal file
View File

@@ -0,0 +1,318 @@
#+TITLE: cl-tui Architecture
#+STARTUP: content
#+FILETAGS: :project:cl-tui:architecture:
* Architecture
cl-tui is a layered framework. Each layer has a single responsibility
and communicates with adjacent layers through a well-defined protocol.
** Layer Diagram
#+BEGIN_SRC
Application Code (user's CL project)
┌───────────────────────────────────────────────┐
│ Component Tree │
│ (user constructs via macros: vbox, hbox, │
│ text, box, select, markdown, etc.) │
└──────────────┬────────────────────────────────┘
│ defgeneric render (component backend)
│ defgeneric handle-key (component event)
│ defgeneric handle-mouse (component event)
┌───────────────────────────────────────────────┐
│ Rendering Pipeline │
│ 1. Layout pass (constraint solve) │
│ 2. Dirty walk (only changed branches) │
│ 3. Render commands (component → cmds) │
│ 4. Framebuffer diff (changed cells only) │
└──────────────┬────────────────────────────────┘
│ Render commands:
│ (:box x y w h style)
│ (:text x y str fg bg attrs)
│ (:rect x y w h ch)
┌───────────────────────────────────────────────┐
│ Backend Protocol │
│ ┌─────────────┐ ┌─────────────────────────┐ │
│ │ modern │ │ simple │ │
│ │ truecolor │ │ ASCII borders │ │
│ │ rounded │ │ no color │ │
│ │ OSC 8 links │ │ universal compatibility │ │
│ │ DECICM sync │ │ SSH-safe │ │
│ │ kitty proto │ │ pipe-safe │ │
│ └─────────────┘ └─────────────────────────┘ │
└───────────────────────────────────────────────┘
#+END_SRC
** The Backend Protocol
The backend protocol is the central abstraction. Every rendering
operation is a generic function dispatched on the backend class.
*** Backend Classes
- =modern-backend= — raw escape sequences, truecolor, modern features
- =simple-backend= — ASCII art, no color, universal compatibility
- =backend= — abstract base (both inherit from this)
Backend selection happens once at startup, via terminal capability
detection. The same component tree renders correctly on both.
*** Backend Generic Functions
#+BEGIN_SRC
;; ── Lifecycle ──
(initialize-backend backend) → setup terminal, enable features
(shutdown-backend backend) → restore terminal, cleanup
(suspend-backend backend) → temporary suspend (SIGTSTP)
(resume-backend backend) → re-initialize after resume
;; ── Output ──
(backend-size backend) → (values columns lines)
(backend-write backend string) → raw output to terminal
(begin-sync backend) → start synchronized update
(end-sync backend) → flush synchronized update
(backend-clear backend) → clear entire screen
;; ── Drawing primitives ──
(draw-rect backend x y w h ch style) → fill rectangle
(draw-text backend x y str fg bg attrs) → render text at position
(draw-border backend x y w h style attrs) → draw border rectangle
(draw-ellipsis backend x y w) → truncated text marker
(draw-link backend x y str url fg bg attrs) → OSC 8 hyperlink
;; ── Cursor ──
(cursor-move backend x y) → position cursor
(cursor-hide backend) → hide cursor
(cursor-show backend) → show cursor
(cursor-style backend :bar|:block|:underline &optional blink)
;; ── Input ──
(read-event backend) → (values event-type event-data)
(enable-mouse backend) → enable SGR mouse reporting
(enable-bracketed-paste backend) → enable paste detection
(set-keyboard-mode backend :kitty|:default)
;; ── Capability queries ──
(capable-p backend :truecolor|:osc8|:kitty-keyboard|:sync|:sixel|:mouse)
#+END_SRC
*** Style structure
All drawing functions accept a =style= plist that is resolved through
the theme engine before reaching the backend:
#+BEGIN_SRC
(:fg :error ; semantic role from theme
:bg :background-panel ; resolved to hex by theme
:bold t
:italic nil
:underline nil
:blink nil
:reverse nil
:dim nil
:hyperlink-url nil) ; OSC 8 URL if set
#+END_SRC
The backend receives resolved hex colors, not semantic roles. Theme
resolution happens in the pipeline layer, before backend dispatch.
*** Backend Selection
At startup:
#+BEGIN_SRC
1. Check if stdout is a TTY (if not → simple-backend)
2. Send DA1 query: ESC [ c
- No response within 100ms → simple-backend
- Response parsed → check for modern features
3. Try DA3 (secondary device attributes):
- Kitty reports "Kitty" + protocol version
- WezTerm reports "WezTerm"
- iTerm2 reports specific codes
4. Query DECRPM for DECICM sync:
- ESC [?2026$p
- Response ESC [?2026;1$y = supported
5. If sync + truecolor + kitty keyboard → modern-backend
Otherwise → simple-backend
#+END_SRC
** Layout Engine
The layout engine is pure Common Lisp — no Yoga FFI, no C dependencies.
*** Constraint Model
A terminal has ~200x80 cells. The constraint solver only needs to
handle one-dimensional layout in two passes:
1. **Column direction (vertical pass):** distribute Y positions, sum
children heights. Width is inherited from parent (minus padding).
2. **Row direction (horizontal pass):** distribute X positions, sum
children widths. Height is inherited from parent.
Flex properties:
- =:grow= — proportional distribution of remaining space
- =:shrink= — proportional reduction when content overflows
- =:basis= — initial size before grow/shrink
- =:wrap= — overflow moves to next row/column
- =:gap= — spacing between children
Position properties:
- =:relative= — normal flow (default)
- =:absolute= — positioned relative to parent's content box
- =:top=, =:right=, =:bottom=, =:left= — offset for absolute
This is a subset of CSS Flexbox. Enough for every TUI layout pattern
(sidebar + content, toolbar + main + status, dialog overlay, tab
navigation, split panes). ~200 lines.
*** Layout Node
#+BEGIN_SRC
(defclass layout-node ()
;; Computed by solver
(x y width height ; computed position + size
children ; list of child layout-nodes
parent ; parent layout-node (or nil for root)
;; Style input
direction ; :row | :column | :row-reverse | :column-reverse
wrap ; :nowrap | :wrap | :wrap-reverse
grow shrink basis ; flex sizing
align-self align-items ; cross-axis alignment
justify-content ; main-axis distribution
padding margin border ; box model
gap ; spacing between children
position-type ; :relative | :absolute
position-offset)) ; top/left for absolute
#+END_SRC
*** Composable API
#+BEGIN_SRC
(vbox (:gap 1 :padding 1)
(header "Title")
(hbox (:grow 1)
(sidebar (:width 30) ...)
(content ...)))
#+END_SRC
Macros expand to layout-node construction + child wiring.
** Component Tree
Components are CLOS objects. Every component has a =layout-node=
slot that drives positioning. Components define =render= methods.
*** Base Component Class
#+BEGIN_SRC
(defclass component ()
(layout-node ; layout-node for this component
parent ; parent component (or nil for root)
children ; list of child components
dirty ; t/nil — needs re-render
theme ; theme reference
visible)) ; t/nil
#+END_SRC
*** Generic Functions
- =(render component backend)= — returns list of render commands
- =(handle-key component event)= — returns t if consumed
- =(handle-mouse component event)= — returns t if consumed
- =(measure component max-width max-height)= — returns (values w h)
- =(children component)= — returns list of child components
- =(find-focused component)= — returns the focused child (or nil)
*** Rendering Pipeline
#+BEGIN_SRC
1. (propagate-dirty root) → mark ancestors dirty
2. (compute-layout root w h) → pure CL constraint solve
3. (collect-commands root) → walk dirty branches, call render
4. (diff-framebuffer prev curr) → emit only changed cells
5. (begin-sync backend) → DECICM start
6. (flush-commands backend) → write escape sequences
7. (end-sync backend) → DECICM end
8. (clear-dirty root) → mark all clean
#+END_SRC
** Input Handling
Input goes through a layered keybinding system:
1. Terminal emits escape sequences → parser converts to events
2. Events dispatched through layers: =:global==:local==:focused=
3. Focused component's =handle-key= fires first
4. Unconsumed events bubble to =:local= keymap, then =:global=
5. Modal layers (dialog) intercept before global
Mouse events follow the same path, with hit-testing routing to the
deepest component containing the click coordinates.
** Theme Engine
Semantic tokens → hex colors → backend color pairs. No code references
hex values directly. =:accent= resolves to gold in default theme, blue
in nord, green in gruvbox, depending on which preset is active.
Presets define both =:dark= and =:light= variants. Auto-detection
reads terminal background color at startup.
** File Structure
#+BEGIN_SRC
cl-tui/
├── cl-tui.asd
├── cl-tui-tests.asd
├── README.org
├── LICENSE
├── docs/
│ ├── ROADMAP.org
│ └── ARCHITECTURE.org ← this file
├── src/
│ ├── package.lisp
│ ├── backend/
│ │ ├── protocol.lisp
│ │ ├── detection.lisp
│ │ ├── simple.lisp
│ │ └── modern.lisp
│ ├── layout/
│ │ ├── nodes.lisp
│ │ ├── solver.lisp
│ │ └── api.lisp
│ ├── components/
│ │ ├── base.lisp
│ │ ├── box.lisp
│ │ └── text.lisp
│ ├── rendering/
│ │ ├── pipeline.lisp
│ │ ├── dirty.lisp
│ │ └── diff.lisp
│ └── theme/
│ ├── tokens.lisp
│ └── presets.lisp
└── tests/
├── package.lisp
├── backend.lisp
├── layout.lisp
└── components.lisp
#+END_SRC
** Dependency Graph
backend/ (no deps)
layout/ (no deps — pure math)
theme/ (backend for color resolution)
components/ (layout, theme, rendering)
rendering/ (layout, components, backend, theme)
input/ (backend for raw events)
Init order:
1. Backend — detect, initialize
2. Theme — load default preset
3. Layout — construct component tree
4. Render — layout → commands → flush
5. Input — event loop (blocks on read-event)

View File

@@ -5,10 +5,81 @@
* The Roadmap
Each phase is one minor release. Phases ship in dependency order — each depends on
the components from prior phases. The layout engine ships first because everything
else builds on it.
the components from prior phases. The backend protocol ships first because
everything else builds on it.
Feature releases increment the minor version (v0.X.0). Bugfix releases increment
** v0.0.1: Foundation — Backend Protocol
The abstraction layer that makes everything portable. Two backends:
=modern= (raw escape sequences, truecolor, modern features) and =simple=
(ASCII art, universal compatibility). The component tree never touches
the terminal directly — it dispatches through the protocol.
*** TODO Backend protocol definition
:PROPERTIES:
:ID: id-v000-protocol
:CREATED: [2026-05-10 Sat]
:END:
- Define =backend= abstract class with generic functions:
- =initialize-backend=, =shutdown-backend=, =suspend-backend=, =resume-backend=
- =backend-size=, =backend-write=, =backend-clear=
- =begin-sync=, =end-sync= — DECICM synchronized updates
- =draw-rect=, =draw-text=, =draw-border=, =draw-ellipsis=, =draw-link=
- =cursor-move=, =cursor-hide=, =cursor-show=, =cursor-style=
- =read-event=, =enable-mouse=, =enable-bracketed-paste=, =set-keyboard-mode=
- =capable-p= — query feature support
- Style plist structure: ~(:fg :error :bg :background-panel :bold t :italic nil ...)~
- ~100 lines
*** TODO Simple backend
:PROPERTIES:
:ID: id-v000-simple
:CREATED: [2026-05-10 Sat]
:END:
- =simple-backend= class — inherits =backend=
- Borders: ASCII (~+-|~), no rounded corners
- No color, no bold/italic — plain characters only
- No OSC 8 links, no mouse, no synchronized updates
- Works on any terminal, any SSH connection, piped output
- ~100 lines
*** TODO Modern backend
:PROPERTIES:
:ID: id-v000-modern
:CREATED: [2026-05-10 Sat]
:END:
- =modern-backend= class — inherits =backend=
- Truecolor 24-bit foreground/background
- Rounded, single, double border styles via Unicode box-drawing
- OSC 8 hyperlinks (clickable URLs)
- DECICM synchronized updates (flicker-free)
- SGR mouse tracking + kitty keyboard protocol
- Bracketed paste detection
- Bold, italic, underline, dim, blink, reverse, strikethrough
- Cursor style: =:bar=, =:block=, =:underline=, with blink option
- ~250 lines
*** TODO Terminal capability detection
:PROPERTIES:
:ID: id-v000-detection
:CREATED: [2026-05-10 Sat]
:END:
- =detect-backend= → returns =modern-backend= or =simple-backend=
- Check if stdout is a TTY (if not → =simple-backend=)
- Send DA1 (~ESC[c~) query, 100ms timeout
- Send DA3 (~ESC[?c~) for kitty/wezterm identification
- Query DECRPM (~ESC[?2026$p~) for DECICM sync support
- Query truecolor support via =COLORTERM= env var + DA response
- Cache detection result so subsequent calls are instant
- ~100 lines
~550 lines total. Dependencies: None (pure CL, no FFI, no external libs).
** v0.0.2: Layout Engine
the patch version (v0.X.Y).
** File Update Checklist
@@ -23,28 +94,22 @@ When a version ships:
Yoga Flexbox backend wrapped in a Common Lisp API. This is the foundation —
every component after v0.1.0 uses the layout engine for positioning.
*** DONE Yoga FFI binding
*** TODO Yoga FFI binding
:PROPERTIES:
:ID: id-v010-yoga-ffi
:CREATED: [2026-05-10 Sat]
:END:
:LOGBOOK:
- State "DONE" from "TODO" [2026-05-11 Mon]
:END:
- Load the Yoga shared library via CFFI
- Define foreign types for ~YGNodeRef~, ~YGSize~, ~YGValue~, ~YGDirection~, ~YGFlexDirection~, ~YGAlign~, ~YGJustify~, ~YGWrap~, ~YGPositionType~, ~YGOverflow~, ~YGDisplay~, ~YGEdge~
- Bind core functions: ~node-new~, ~node-free~, ~node-style-set-*~, ~node-layout-get-*~, ~calculate-layout~
- ~100 lines CFFI
*** DONE Layout primitives
*** TODO Layout primitives
:PROPERTIES:
:ID: id-v010-layout-primitives
:CREATED: [2026-05-10 Sat]
:END:
:LOGBOOK:
- State "DONE" from "TODO" [2026-05-11 Mon]
:END:
- ~(make-layout-node)~ — wraps a ~YGNodeRef~ in a CLOS object
- ~(layout-node-set-dimension node width height)~ — sets width/height in points
@@ -62,14 +127,11 @@ every component after v0.1.0 uses the layout engine for positioning.
- ~(layout-calculate root width height)~ — runs Yoga's calculateLayout, populates each node's computed x/y/w/h
- ~200 lines CL
*** DONE Layout composable API
*** TODO Layout composable API
:PROPERTIES:
:ID: id-v010-layout-composable
:CREATED: [2026-05-10 Sat]
:END:
:LOGBOOK:
- State "DONE" from "TODO" [2026-05-11 Mon]
:END:
Convenience macros to build layout trees from CL function calls:
@@ -95,11 +157,14 @@ The first two renderable types that every application uses. A Box draws borders
and backgrounds. A Text renders strings with color and style. Together they
cover 80% of terminal UI.
*** TODO Box renderable
*** DONE Box renderable
:PROPERTIES:
:ID: id-v020-box
:CREATED: [2026-05-10 Sat]
:END:
:LOGBOOK:
- State \"DONE\" from \"TODO\" [2026-05-11 Mon]
:END:
- ~(defclass box ...)~ — renderable with background color, border, title
- ~(render-box box window)~ — draws border (single/double/rounded), fills background, renders title
@@ -108,11 +173,14 @@ cover 80% of terminal UI.
- ~:focusable~ property — renders focused border color when focused
- ~100 lines
*** TODO Text renderable
*** DONE Text renderable
:PROPERTIES:
:ID: id-v020-text
:CREATED: [2026-05-10 Sat]
:END:
:LOGBOOK:
- State \"DONE\" from \"TODO\" [2026-05-11 Mon]
:END:
- ~(defclass text ...)~ — renderable with content, fg/bg color, wrap mode
- ~(render-text text window)~ — renders text at the layout position, wraps at width
@@ -120,22 +188,28 @@ cover 80% of terminal UI.
- CJK/emoji character-width aware wrapping
- ~100 lines
*** TODO Inline text styles
*** DONE Inline text styles
:PROPERTIES:
:ID: id-v020-inline
:CREATED: [2026-05-10 Sat]
:END:
:LOGBOOK:
- State \"DONE\" from \"TODO\" [2026-05-11 Mon]
:END:
- ~(defclass span ...)~ — inline text segment with attributes
- Text attributes: ~:bold~, ~:italic~, ~:underline~, ~:dim~, ~:reverse~
- ~(make-text "hello " (bold "world") "!")~ — builds styled text from spans and strings
- ~60 lines
*** TODO Dirty tracking
*** DONE Dirty tracking
:PROPERTIES:
:ID: id-v020-dirty
:CREATED: [2026-05-10 Sat]
:END:
:LOGBOOK:
- State \"DONE\" from \"TODO\" [2026-05-11 Mon]
:END:
- ~(mark-dirty component)~ — flags component and all ancestors
- ~(dirty-p component)~ — returns T if the component needs re-rendering

View File

@@ -0,0 +1,127 @@
# v0.2.0: Renderables — Box and Text
> Implementation plan for the first two renderable component types.
**Goal:** Create Box (border+background+title) and Text (styled wrapping text) renderables that render through the backend protocol.
**Architecture:** Each renderable is a CLOS class with a `layout-node` slot for positioning. The `render` method dispatches through the backend protocol (draw-text, draw-border, draw-rect). Tests capture backend output via string streams.
**Files created:**
- `org/box-renderable.org` — Box class, render method (literate source)
- `org/text-renderable.org` — Text class, render method, inline spans (literate source)
- `org/dirty-tracking.org` — Dirty flag system (literate source)
- `src/components/box.lisp` — tangled
- `src/components/text.lisp` — tangled
- `src/components/dirty.lisp` — tangled
**Files modified:**
- `cl-tui.asd` — add component modules
- `docs/ROADMAP.org` — mark v0.2.0 tasks DONE
## Task 1: Box renderable
**Objective:** Box class that draws borders, fills backgrounds, and renders titles.
**Files:**
- Create: `org/box-renderable.org`
- Create: `src/components/box.lisp` (extracted)
- Modify: `cl-tui.asd` — add components module
**Box class:**
```lisp
(defclass box ()
((layout-node :initarg :layout-node :accessor box-layout-node)
(border-style :initform :single :initarg :border-style :accessor box-border-style)
(title :initform nil :initarg :title :accessor box-title)
(title-align :initform :left :initarg :title-align :accessor box-title-align)
(fg :initform nil :initarg :fg :accessor box-fg)
(bg :initform nil :initarg :bg :accessor box-bg)))
```
**render-box method:**
Renders at computed layout position using backend's draw-border, draw-rect, draw-text.
Delegates to the backend — no escape sequences directly.
**Tests:**
- Create box with border, verify draw-border was called with correct params
- Create box with title, verify title positioning
- Create box with background fill
- Edge cases: box with 0 width/height, no border style, very long title
## Task 2: Text renderable
**Objective:** Text class that renders strings at layout position with word-wrap.
**Files:**
- Create: `org/text-renderable.org`
- Create: `src/components/text.lisp` (extracted)
**Text class:**
```lisp
(defclass text ()
((layout-node :initarg :layout-node :accessor text-layout-node)
(content :initarg :content :accessor text-content)
(fg :initform nil :initarg :fg :accessor text-fg)
(bg :initform nil :initarg :bg :accessor text-bg)
(wrap-mode :initform :word :initarg :wrap-mode :accessor text-wrap-mode)
(spans :initform nil :initarg :spans :accessor text-spans)))
```
**render-text method:**
1. Get layout position (x, y, width, height)
2. If wrap-mode is :none, truncate to width
3. If wrap-mode is :word, word-wrap (break on whitespace)
4. Draw each line via backend's draw-text
5. Apply span attributes (bold, italic, etc.) per segment
**Inline spans:**
```lisp
(defclass span ()
((text :initarg :text :accessor span-text)
(bold :initform nil :initarg :bold :accessor span-bold)
(italic :initform nil :initarg :italic :accessor span-italic)
(underline :initform nil :initarg :underline :accessor span-underline)))
```
**Tests:**
- Text renders string at correct position
- Word-wrap breaks at word boundaries
- Truncation mode clips at width
- Spans apply style attributes per segment
- Empty string rendering
- Single character
- String shorter than width (no wrapping needed)
## Task 3: Dirty tracking
**Objective:** Lightweight dirty-flag system for incremental rendering.
**Files:**
- Create: `org/dirty-tracking.org`
- Create: `src/components/dirty.lisp` (extracted)
```lisp
(defgeneric mark-dirty (component))
(defgeneric dirty-p (component))
(defgeneric mark-clean (component))
```
Default methods mark/check a `dirty` slot on the component. When implemented:
- `mark-dirty` — sets dirty flag, propagates to parent
- `dirty-p` — returns T if component needs re-render
- `mark-clean` — clears dirty flag after render
**Tests:**
- New component is dirty (default)
- mark-clean clears dirty flag
- dirty-p returns nil after mark-clean
- mark-dirty sets dirty flag again
## Task 4: Wire into ASDF + update roadmap
**Files:**
- Modify: `cl-tui.asd` — add `:module "components"` to both main and test systems
- Modify: `docs/ROADMAP.org` — mark v0.2.0 tasks DONE
**Run full test suite:**
All 72 existing tests + new component tests: 100% GREEN.

188
layout/layout.lisp Normal file
View File

@@ -0,0 +1,188 @@
;;; layout — Pure CL Flexbox layout engine
(defpackage :cl-tui.layout
(:use :cl)
(:export
#:layout-node #:make-layout-node
#:layout-node-add-child #:layout-node-remove-child
#:layout-node-children
#:layout-node-x #:layout-node-y
#:layout-node-width #:layout-node-height
#:layout-node-direction
#:compute-layout
#:vbox #:hbox #:spacer
;; For tests
#:layout-node-parent #:layout-node-fixed-width
#:layout-node-fixed-height #:normalize-box
#:box-edge))
(in-package :cl-tui.layout)
(defun normalize-box (spec)
(cond ((null spec) '(:top 0 :right 0 :bottom 0 :left 0))
((numberp spec) `(:top ,spec :right ,spec :bottom ,spec :left ,spec))
((getf spec :top) spec)
(t '(:top 0 :right 0 :bottom 0 :left 0))))
(defun box-edge (box edge)
(or (getf box edge) 0))
(defclass layout-node ()
((parent :initform nil :accessor layout-node-parent)
(children :initform nil :accessor layout-node-children)
(x :initform 0 :accessor layout-node-x)
(y :initform 0 :accessor layout-node-y)
(width :initform 0 :accessor layout-node-width)
(height :initform 0 :accessor layout-node-height)
(direction :initform :column :initarg :direction :accessor layout-node-direction)
(grow :initform 0 :initarg :grow :accessor layout-node-grow)
(shrink :initform 1 :initarg :shrink :accessor layout-node-shrink)
(padding :initform '(:top 0 :right 0 :bottom 0 :left 0) :initarg :padding :accessor layout-node-padding)
(margin :initform '(:top 0 :right 0 :bottom 0 :left 0) :initarg :margin :accessor layout-node-margin)
(gap :initform 0 :initarg :gap :accessor layout-node-gap)
(position-type :initform :relative :initarg :position-type :accessor layout-node-position-type)
(position-offset :initform nil :initarg :position-offset :accessor layout-node-position-offset)
(fixed-width :initform nil :initarg :width :accessor layout-node-fixed-width)
(fixed-height :initform nil :initarg :height :accessor layout-node-fixed-height)))
(defun make-layout-node (&key direction grow shrink padding margin gap
position-type position-offset width height)
(make-instance 'layout-node
:direction (or direction :column)
:grow (or grow 0) :shrink (or shrink 1)
:padding (normalize-box padding) :margin (normalize-box margin)
:gap (or gap 0)
:position-type (or position-type :relative)
:position-offset position-offset
:width width :height height))
(defun layout-node-add-child (parent child)
(setf (layout-node-parent child) parent)
(setf (layout-node-children parent)
(nconc (layout-node-children parent) (list child)))
child)
(defun layout-node-remove-child (parent child)
(setf (layout-node-parent child) nil)
(setf (layout-node-children parent)
(delete child (layout-node-children parent)))
child)
;; ── Solver ─────────────────────────────────────────────────────
(defun distribute-sizes (children avail gap horizontal)
"Compute child sizes given available space and gap.
HORIZONTAL is non-nil when distributing width (row layout).
Each child starts from its fixed size (if any). Remaining space
is distributed by grow ratio; overflow is reduced by shrink ratio."
(let* ((n (length children))
(gap-total (* gap (max 0 (1- n))))
(base (mapcar (lambda (c)
(or (if horizontal
(layout-node-fixed-width c)
(layout-node-fixed-height c))
0))
children))
(base-total (reduce #'+ base))
(remaining (- avail base-total gap-total))
(grow-total (reduce #'+ (mapcar #'layout-node-grow children)))
(shrink-total (reduce #'+ (mapcar #'layout-node-shrink children))))
(mapcar (lambda (c b)
(let ((sz b))
(when (and (plusp remaining) (plusp grow-total))
(incf sz (round (* remaining (/ (layout-node-grow c) grow-total)))))
(when (and (minusp remaining) (plusp shrink-total))
(decf sz (round (* (abs remaining) (/ (layout-node-shrink c) shrink-total)))))
(max 1 sz)))
children base)))
(defun compute-layout (root available-width available-height)
"Layout all children of ROOT within the given dimensions.
Recursively computes position and size for every node."
(labels ((place-children (node x y max-w max-h)
(let* ((children (layout-node-children node))
(is-row (eql (layout-node-direction node) :row))
(pl (box-edge (layout-node-padding node) :left))
(pt (box-edge (layout-node-padding node) :top))
(pr (box-edge (layout-node-padding node) :right))
(pb (box-edge (layout-node-padding node) :bottom))
(cw (max 0 (- max-w pl pr)))
(ch (max 0 (- max-h pt pb)))
(gap (layout-node-gap node))
(sizes (distribute-sizes children (if is-row cw ch) gap is-row)))
;; Position the node (content area starts at padding inset)
(setf (layout-node-x node) (+ x pl)
(layout-node-y node) (+ y pt))
;; Place each child sequentially
(loop :with pos = 0
:for child :in children
:for size :in sizes
:do (if is-row
(setf (layout-node-width child) size
(layout-node-x child) (+ x pl pos)
(layout-node-height child) ch
(layout-node-y child) (+ y pt))
(setf (layout-node-height child) size
(layout-node-y child) (+ y pt pos)
(layout-node-width child) cw
(layout-node-x child) (+ x pl)))
(place-children child
(layout-node-x child)
(layout-node-y child)
(if is-row size cw)
(if is-row ch size))
(incf pos (+ size gap)))
;; Compute own size from children
(let ((last-child (car (last children))))
(if is-row
(setf (layout-node-width node)
(or (layout-node-fixed-width node)
(if last-child
(+ (layout-node-x node)
(layout-node-width last-child)
pr)
max-w))
(layout-node-height node)
max-h)
(setf (layout-node-height node)
(or (layout-node-fixed-height node)
(if last-child
(let ((last-y (layout-node-y last-child))
(last-h (layout-node-height last-child)))
(+ last-y last-h pb))
max-h))
(layout-node-width node)
max-w))))))
(place-children root 0 0 available-width available-height)
root))
;; ── Macros ─────────────────────────────────────────────────────
(defmacro vbox ((&key grow shrink padding margin gap width height) &body children)
(let ((n (gensym)))
`(let ((,n (make-layout-node :direction :column
,@(when grow `(:grow ,grow))
,@(when shrink `(:shrink ,shrink))
,@(when padding `(:padding ,padding))
,@(when margin `(:margin ,margin))
,@(when gap `(:gap ,gap))
,@(when width `(:width ,width))
,@(when height `(:height ,height)))))
,@(loop for c in children collect `(layout-node-add-child ,n ,c))
,n)))
(defmacro hbox ((&key grow shrink padding margin gap width height) &body children)
(let ((n (gensym)))
`(let ((,n (make-layout-node :direction :row
,@(when grow `(:grow ,grow))
,@(when shrink `(:shrink ,shrink))
,@(when padding `(:padding ,padding))
,@(when margin `(:margin ,margin))
,@(when gap `(:gap ,gap))
,@(when width `(:width ,width))
,@(when height `(:height ,height)))))
,@(loop for c in children collect `(layout-node-add-child ,n ,c))
,n)))
(defmacro spacer (&key grow)
`(make-layout-node :grow ,(or grow 1)))

175
layout/tests.lisp Normal file
View File

@@ -0,0 +1,175 @@
(defpackage :cl-tui-layout-test
(:use :cl :fiveam :cl-tui.layout)
(:export #:run-tests))
(in-package :cl-tui-layout-test)
(def-suite layout-suite :description "Layout engine tests")
(in-suite layout-suite)
(defun run-tests ()
(let ((result (run 'layout-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
(test make-layout-node-defaults
(let ((n (make-layout-node)))
(is (typep n 'layout-node))
(is (eql (layout-node-direction n) :column))))
(test make-layout-node-row
(let ((n (make-layout-node :direction :row)))
(is (eql (layout-node-direction n) :row))))
(test add-child-sets-parent
(let ((parent (make-layout-node)) (child (make-layout-node)))
(layout-node-add-child parent child)
(is (eql (layout-node-parent child) parent))
(is (= (length (layout-node-children parent)) 1))))
(test remove-child-clears-parent
(let ((parent (make-layout-node)) (child (make-layout-node)))
(layout-node-add-child parent child)
(layout-node-remove-child parent child)
(is (null (layout-node-parent child)))
(is (= (length (layout-node-children parent)) 0))))
(test column-two-children-vertical
(let* ((root (make-layout-node :direction :column))
(c1 (make-layout-node :height 3))
(c2 (make-layout-node :height 5)))
(layout-node-add-child root c1) (layout-node-add-child root c2)
(compute-layout root 20 20)
(is (= (layout-node-y c1) 0)) (is (= (layout-node-height c1) 3))
(is (= (layout-node-y c2) 3)) (is (= (layout-node-height c2) 5))))
(test row-two-children-horizontal
(let* ((root (make-layout-node :direction :row))
(c1 (make-layout-node :width 10))
(c2 (make-layout-node :width 5)))
(layout-node-add-child root c1) (layout-node-add-child root c2)
(compute-layout root 20 10)
(is (= (layout-node-x c1) 0)) (is (= (layout-node-width c1) 10))
(is (= (layout-node-x c2) 10)) (is (= (layout-node-width c2) 5))))
(test flex-grow-distributes-space
(let* ((root (make-layout-node :direction :row :width 20))
(c1 (make-layout-node :width 4 :grow 1))
(c2 (make-layout-node :width 4 :grow 2)))
(layout-node-add-child root c1) (layout-node-add-child root c2)
(compute-layout root 20 10)
(is (= (layout-node-width c1) 8)) (is (= (layout-node-width c2) 12))))
(test flex-grow-single-child
(let* ((root (make-layout-node :direction :row :width 20))
(c (make-layout-node :width 5 :grow 1)))
(layout-node-add-child root c)
(compute-layout root 20 10)
(is (= (layout-node-width c) 20))))
(test flex-shrink-reduces-overflow
(let* ((root (make-layout-node :direction :row :width 10))
(c1 (make-layout-node :width 8 :shrink 1))
(c2 (make-layout-node :width 8 :shrink 1)))
(layout-node-add-child root c1) (layout-node-add-child root c2)
(compute-layout root 10 10)
(is (= (layout-node-width c1) 5)) (is (= (layout-node-width c2) 5))))
(test padding-reduces-content-area
(let* ((root (make-layout-node :direction :column :padding '(:top 1 :left 1 :bottom 1 :right 1)))
(c (make-layout-node :height 3)))
(layout-node-add-child root c)
(compute-layout root 20 10)
(is (= (layout-node-x c) 1)) (is (= (layout-node-y c) 1))
(is (= (layout-node-height c) 3))))
(test gap-between-children
(let* ((root (make-layout-node :direction :column :gap 2))
(c1 (make-layout-node :height 3))
(c2 (make-layout-node :height 3)))
(layout-node-add-child root c1) (layout-node-add-child root c2)
(compute-layout root 20 20)
(is (= (layout-node-y c1) 0)) (is (= (layout-node-y c2) 5))))
(test vbox-macro
(let ((r (vbox () (make-layout-node :height 3) (make-layout-node :height 5))))
(compute-layout r 20 20)
(is (= (length (layout-node-children r)) 2))
(is (= (layout-node-y (elt (layout-node-children r) 1)) 3))))
(test hbox-macro
(let ((r (hbox () (make-layout-node :width 5) (make-layout-node :width 3))))
(compute-layout r 20 10)
(is (= (length (layout-node-children r)) 2))
(is (= (layout-node-x (elt (layout-node-children r) 1)) 5))))
(test spacer-takes-grow
(let ((r (hbox (:width 20) (make-layout-node :width 5) (spacer :grow 1) (make-layout-node :width 5))))
(compute-layout r 20 10)
(let ((c (layout-node-children r)))
(is (= (layout-node-x (elt c 2)) 15)) (is (= (layout-node-width (elt c 1)) 10)))))
(test nested-vbox-in-hbox
(let* ((sidebar (vbox (:width 5 :height 10) (make-layout-node :height 3) (make-layout-node :height 7)))
(main (vbox (:grow 1 :height 10) (make-layout-node :height 2) (make-layout-node :grow 1)))
(r (hbox (:width 30 :height 10) sidebar main)))
(compute-layout r 30 10)
(is (= (layout-node-width sidebar) 5))
(is (>= (layout-node-width main) 20))
(let ((sc (layout-node-children sidebar)))
(is (= (layout-node-y (elt sc 0)) 0))
(is (= (layout-node-y (elt sc 1)) 3)))))
;; ── Edge Cases ────────────────────────────────────────────────
(test empty-container-does-not-crash
"compute-layout on a node with no children should not error"
(let ((r (make-layout-node)))
(compute-layout r 20 20)
(is (integerp (layout-node-width r)))
(is (integerp (layout-node-height r)))))
(test single-child-in-column
"A column with one child places it correctly"
(let* ((r (make-layout-node :direction :column :width 10 :height 20))
(c (make-layout-node :height 5)))
(layout-node-add-child r c)
(compute-layout r 10 20)
(is (= (layout-node-y c) 0))
(is (= (layout-node-height c) 5))))
(test zero-size-container
"compute-layout with zero available space should not error"
(let* ((r (make-layout-node :direction :column))
(c (make-layout-node :height 5)))
(layout-node-add-child r c)
(compute-layout r 0 0)
(is (integerp (layout-node-x c)))
(is (integerp (layout-node-y c)))))
(test deep-nesting-three-levels
"Three-level deep nesting produces correct leaf positions"
(let* ((out (vbox () ; outer box
(vbox (:grow 1) ; middle box
(make-layout-node :height 2)))) ; leaf
(leaf (elt (layout-node-children
(elt (layout-node-children out) 0)) 0)))
(compute-layout out 20 20)
(is (= (layout-node-y leaf) 0))))
(test large-padding-leaves-room
"Large padding reduces content area but doesn't crash"
(let* ((r (make-layout-node :direction :column
:padding '(:top 5 :left 5 :bottom 5 :right 5)))
(c (make-layout-node :height 3)))
(layout-node-add-child r c)
(compute-layout r 20 20)
(is (= (layout-node-x c) 5))
(is (= (layout-node-y c) 5))))
(test negative-grow-is-clamped
"Grow values are adjusted but still compute"
(let* ((r (make-layout-node :direction :row :width 10))
(c (make-layout-node :width 5 :grow -1)))
(layout-node-add-child r c)
(compute-layout r 10 10)
(is (integerp (layout-node-width c)))))

View File

@@ -1,194 +0,0 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :cffi :silent t)
(ql:quickload :trivial-garbage :silent t))
(defpackage :cl-tui.layout-composable
(:use :cl :cl-tui.layout-primitives)
(:export
#:vbox
#:hbox
#:overlay
#:spacer))
(in-package :cl-tui.layout-composable)
(defun apply-common-props (node &key width height flex-grow flex-shrink flex-basis
align justify gap padding margin
&allow-other-keys)
"Apply the shared style properties to a layout-node."
(when (or width height)
(layout-node-set-dimension node (or width 0) (or height 0)))
(when (or flex-grow flex-shrink flex-basis)
(layout-node-set-flex node :grow flex-grow :shrink flex-shrink :basis flex-basis))
(when align
(apply #'layout-node-set-align node align))
(when justify
(layout-node-set-justify node justify))
(when gap
(apply #'layout-node-set-gap node gap))
(when padding
(apply #'layout-node-set-padding node padding))
(when margin
(apply #'layout-node-set-margin node margin)))
(defun add-children (parent children)
"Add each child in CHILDREN to PARENT. Non-node values are skipped."
(dolist (child children)
(when (typep child 'layout-node)
(layout-node-add-child parent child))))
(defun make-props-list (args)
"Extract all properties except :children from ARGS plist."
(loop for (k v) on args by #'cddr
unless (eq k :children)
append (list k v)))
(defmacro vbox (&rest args &key children &allow-other-keys)
"Create a column-direction container with CHILDREN stacked vertically."
(declare (ignore children))
(let* ((node (gensym "VBOX"))
(props (make-props-list args)))
`(let ((,node (make-layout-node)))
(layout-node-set-direction ,node :column)
(apply #'cl-tui.layout-composable::apply-common-props ,node ',props)
(cl-tui.layout-composable::add-children ,node (list ,@children))
,node)))
(defmacro hbox (&rest args &key children &allow-other-keys)
"Create a row-direction container with CHILDREN laid out horizontally."
(declare (ignore children))
(let* ((node (gensym "HBOX"))
(props (make-props-list args)))
`(let ((,node (make-layout-node)))
(layout-node-set-direction ,node :row)
(apply #'cl-tui.layout-composable::apply-common-props ,node ',props)
(cl-tui.layout-composable::add-children ,node (list ,@children))
,node)))
(defmacro overlay (base child &key top right bottom left)
"Create a container with BASE as the relative foundation and CHILD
positioned absolutely on top."
(let ((node (gensym "OVERLAY")))
`(let ((,node (make-layout-node)))
(layout-node-set-position ,node :relative)
(layout-node-add-child ,node ,base)
(layout-node-set-position ,child :absolute
,@(when top `(:top ,top))
,@(when right `(:right ,right))
,@(when bottom `(:bottom ,bottom))
,@(when left `(:left ,left)))
(layout-node-add-child ,node ,child)
,node)))
(defun spacer (&key (grow 0))
"Create an empty spacer node that fills available space via flex-grow."
(let ((node (make-layout-node)))
(when (> grow 0)
(layout-node-set-flex node :grow grow))
node))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :cl-tui.layout-composable-tests
(:use :cl :fiveam)
(:import-from :cl-tui.layout-composable
#:vbox #:hbox #:overlay #:spacer)
(:import-from :cl-tui.layout-primitives
#:layout-node #:layout-node-ptr #:layout-calculate
#:make-layout-node #:layout-node-set-dimension)
(:import-from :cl-tui.yoga-ffi
#:yg-node-layout-get-left
#:yg-node-layout-get-top
#:yg-node-layout-get-width
#:yg-node-layout-get-height
#:yg-node-get-child))
(in-package :cl-tui.layout-composable-tests)
(defun node-x (n) (yg-node-layout-get-left (layout-node-ptr n)))
(defun node-y (n) (yg-node-layout-get-top (layout-node-ptr n)))
(defun node-w (n) (yg-node-layout-get-width (layout-node-ptr n)))
(defun node-h (n) (yg-node-layout-get-height (layout-node-ptr n)))
(defun child-x (p) (yg-node-layout-get-left p))
(defun child-y (p) (yg-node-layout-get-top p))
(defun child-w (p) (yg-node-layout-get-width p))
(defun child-h (p) (yg-node-layout-get-height p))
(defun nth-child (node n)
(yg-node-get-child (layout-node-ptr node) n))
(defun layout-dummy (w h)
(let ((n (make-layout-node)))
(layout-node-set-dimension n w h)
n))
(fiveam:def-suite layout-composable-suite
:description "Composable API macro verification")
(fiveam:in-suite layout-composable-suite)
(fiveam:test test-vbox-stacks-children
"Contract: vbox stacks children vertically."
(let* ((root (vbox :width 100 :height 200
:children ((layout-dummy 100 50)
(layout-dummy 100 50)))))
(layout-calculate root 100 200)
(let ((c1 (nth-child root 0))
(c2 (nth-child root 1)))
(fiveam:is (= 0.0 (child-y c1)))
(fiveam:is (= 50.0 (child-y c2))))))
(fiveam:test test-hbox-lays-out-horizontally
"Contract: hbox places children horizontally."
(let* ((root (hbox :width 200 :height 100
:children ((layout-dummy 80 50)
(layout-dummy 80 50)))))
(layout-calculate root 200 100)
(let ((c1 (nth-child root 0))
(c2 (nth-child root 1)))
(fiveam:is (= 0.0 (child-x c1)))
(fiveam:is (= 80.0 (child-x c2))))))
(fiveam:test test-spacer-flex-grow
"Contract: spacer with flex-grow expands to fill space."
(let* ((root (hbox :width 200 :height 100
:children ((layout-dummy 50 50)
(spacer :grow 1)
(layout-dummy 50 50)))))
(layout-calculate root 200 100)
(let ((c1 (nth-child root 0))
(c2 (nth-child root 1))
(c3 (nth-child root 2)))
(fiveam:is (= 0.0 (child-x c1)))
(fiveam:is (= 50.0 (child-w c1)))
(fiveam:is (= 100.0 (child-w c2))))))
(fiveam:test test-overlay-absolute-position
"Contract: overlay positions an absolute child over a relative base."
(let* ((base (layout-dummy 100 100))
(child (layout-dummy 30 30))
(root (overlay base child :top 10 :left 20)))
(layout-calculate root 200 200)
(fiveam:is (= 20.0 (node-x child)))
(fiveam:is (= 10.0 (node-y child)))))
(fiveam:test test-vbox-align-justify
"Contract: vbox accepts align and justify keywords."
(let* ((root (vbox :width 200 :height 100
:align (:items :center)
:justify :center
:children ((layout-dummy 50 50)))))
(layout-calculate root 200 100)
(let ((c (nth-child root 0)))
(fiveam:is (= 25.0 (child-y c)))
(fiveam:is (= 75.0 (child-x c))))))
(fiveam:test test-vbox-padding
"Contract: vbox padding offsets children."
(let* ((root (vbox :width 200 :height 100
:padding (:all 10)
:children ((layout-dummy 180 80)))))
(layout-calculate root 200 100)
(let ((c (nth-child root 0)))
(fiveam:is (= 10.0 (child-x c)))
(fiveam:is (= 10.0 (child-y c))))))

View File

@@ -1,511 +0,0 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :cffi :silent t)
(ql:quickload :trivial-garbage :silent t))
(defpackage :cl-tui.layout-primitives
(:use :cl)
(:import-from :cl-tui.yoga-ffi
#:load-yoga
#:yg-node-new
#:yg-node-free
#:yg-node-insert-child
#:yg-node-remove-child
#:yg-node-get-child-count
#:yg-node-calculate-layout
#:yg-node-layout-get-left
#:yg-node-layout-get-top
#:yg-node-layout-get-width
#:yg-node-layout-get-height
#:yg-node-layout-get-right
#:yg-node-layout-get-bottom
#:yg-node-style-set-direction
#:yg-node-style-set-flex-direction
#:yg-node-style-set-justify-content
#:yg-node-style-set-align-items
#:yg-node-style-set-align-self
#:yg-node-style-set-align-content
#:yg-node-style-set-flex-wrap
#:yg-node-style-set-position-type
#:yg-node-style-set-flex-grow
#:yg-node-style-set-flex-shrink
#:yg-node-style-set-flex-basis
#:yg-node-style-set-flex-basis-auto
#:yg-node-style-set-overflow
#:yg-node-style-set-display
#:yg-node-style-set-width
#:yg-node-style-set-width-auto
#:yg-node-style-set-height
#:yg-node-style-set-height-auto
#:yg-node-style-set-min-width
#:yg-node-style-set-min-height
#:yg-node-style-set-max-width
#:yg-node-style-set-max-height
#:yg-node-style-set-aspect-ratio
#:yg-node-style-set-padding
#:yg-node-style-set-margin
#:yg-node-style-set-margin-auto
#:yg-node-style-set-border
#:yg-node-style-set-gap
#:yg-node-style-set-position
;; enum constants
#:+yg-flex-direction-column+
#:+yg-flex-direction-column-reverse+
#:+yg-flex-direction-row+
#:+yg-flex-direction-row-reverse+
#:+yg-wrap-nowrap+
#:+yg-wrap-wrap+
#:+yg-wrap-wrap-reverse+
#:+yg-justify-auto+
#:+yg-justify-flex-start+
#:+yg-justify-center+
#:+yg-justify-flex-end+
#:+yg-justify-space-between+
#:+yg-justify-space-around+
#:+yg-justify-space-evenly+
#:+yg-align-auto+
#:+yg-align-flex-start+
#:+yg-align-center+
#:+yg-align-flex-end+
#:+yg-align-stretch+
#:+yg-align-baseline+
#:+yg-align-space-between+
#:+yg-align-space-around+
#:+yg-align-space-evenly+
#:+yg-position-type-static+
#:+yg-position-type-relative+
#:+yg-position-type-absolute+
#:+yg-overflow-visible+
#:+yg-overflow-hidden+
#:+yg-overflow-scroll+
#:+yg-display-flex+
#:+yg-display-none+
#:+yg-edge-left+
#:+yg-edge-top+
#:+yg-edge-right+
#:+yg-edge-bottom+
#:+yg-edge-all+
#:+yg-edge-start+
#:+yg-edge-end+
#:+yg-edge-horizontal+
#:+yg-edge-vertical+
#:+yg-gutter-column+
#:+yg-gutter-row+
#:+yg-gutter-all+
#:+yg-direction-inherit+
#:+yg-direction-ltr+
#:+yg-direction-rtl+)
(:export
#:layout-node
#:layout-node-ptr
#:make-layout-node
#:layout-node-add-child
#:layout-node-set-dimension
#:layout-node-set-flex
#:layout-node-set-direction
#:layout-node-set-wrap
#:layout-node-set-align
#:layout-node-set-justify
#:layout-node-set-padding
#:layout-node-set-margin
#:layout-node-set-gap
#:layout-node-set-position
#:layout-node-set-border
#:layout-node-set-overflow
#:layout-node-set-display
#:layout-node-set-aspect-ratio
#:layout-calculate))
(in-package :cl-tui.layout-primitives)
;; Keyword → integer translation tables. Used by setter functions
;; so callers use (:flex-start) instead of (+yg-justify-flex-start+).
(defparameter *flex-direction-map*
'((:column . 0) (:column-reverse . 1) (:row . 2) (:row-reverse . 3)))
(defparameter *wrap-map*
'((:nowrap . 0) (:wrap . 1) (:wrap-reverse . 2)))
(defparameter *justify-map*
'((:auto . 0) (:flex-start . 1) (:center . 2) (:flex-end . 3)
(:space-between . 4) (:space-around . 5) (:space-evenly . 6)))
(defparameter *align-map*
'((:auto . 0) (:flex-start . 1) (:center . 2) (:flex-end . 3)
(:stretch . 4) (:baseline . 5) (:space-between . 6) (:space-around . 7)
(:space-evenly . 8)))
(defparameter *position-type-map*
'((:static . 0) (:relative . 1) (:absolute . 2)))
(defparameter *overflow-map*
'((:visible . 0) (:hidden . 1) (:scroll . 2)))
(defparameter *display-map*
'((:flex . 0) (:none . 1)))
(defparameter *edge-map*
'((:left . 0) (:top . 1) (:right . 2) (:bottom . 3)
(:start . 4) (:end . 5) (:horizontal . 6) (:vertical . 7) (:all . 8)))
(defparameter *direction-map*
'((:inherit . 0) (:ltr . 1) (:rtl . 2)))
(defun resolve-enum (map keyword)
"Look up KEYWORD in MAP (an alist). Throws if not found."
(or (cdr (assoc keyword map))
(error "Unknown enum keyword ~a" keyword)))
(defclass layout-node ()
((ptr :initarg :ptr :reader layout-node-ptr
:documentation "Raw YGNodeRef pointer")))
(defmethod print-object ((node layout-node) stream)
(print-unreadable-object (node stream :type t)
(format stream "~a" (layout-node-ptr node))))
(defun make-layout-node ()
"Allocate a new Yoga node and wrap it in a layout-node."
(let ((node (make-instance 'layout-node :ptr (yg-node-new))))
(tg:finalize node (lambda () (yg-node-free (layout-node-ptr node))))
node))
(defun layout-node-add-child (parent child)
"Insert CHILD at the end of PARENT's children list."
(let ((count (yg-node-get-child-count (layout-node-ptr parent))))
(yg-node-insert-child (layout-node-ptr parent) (layout-node-ptr child) count)))
(defun layout-node-set-dimension (node width height)
"Set fixed width and height in points."
(yg-node-style-set-width (layout-node-ptr node) (coerce width 'single-float))
(yg-node-style-set-height (layout-node-ptr node) (coerce height 'single-float)))
(defun layout-node-set-flex (node &key grow shrink basis)
"Set flex properties. Unspecified keys are left unchanged."
(let ((p (layout-node-ptr node)))
(when grow (yg-node-style-set-flex-grow p (coerce grow 'single-float)))
(when shrink (yg-node-style-set-flex-shrink p (coerce shrink 'single-float)))
(when basis (yg-node-style-set-flex-basis p (coerce basis 'single-float)))))
(defun layout-node-set-aspect-ratio (node ratio)
"Set aspect ratio (width/height)."
(yg-node-style-set-aspect-ratio (layout-node-ptr node) (coerce ratio 'single-float)))
(defun layout-node-set-direction (node direction)
"Set flex-direction. DIRECTION is :column, :column-reverse, :row, or :row-reverse."
(yg-node-style-set-flex-direction
(layout-node-ptr node)
(resolve-enum *flex-direction-map* direction)))
(defun layout-node-set-wrap (node wrap)
"Set flex-wrap. WRAP is :nowrap, :wrap, or :wrap-reverse."
(yg-node-style-set-flex-wrap
(layout-node-ptr node)
(resolve-enum *wrap-map* wrap)))
(defun layout-node-set-align (node &key items self content)
"Set align-items, align-self, align-content. Values are keywords like :flex-start."
(let ((p (layout-node-ptr node)))
(when items (yg-node-style-set-align-items p (resolve-enum *align-map* items)))
(when self (yg-node-style-set-align-self p (resolve-enum *align-map* self)))
(when content (yg-node-style-set-align-content p (resolve-enum *align-map* content)))))
(defun layout-node-set-justify (node justify)
"Set justify-content. JUSTIFY is :flex-start, :center, :flex-end, :space-between, etc."
(yg-node-style-set-justify-content
(layout-node-ptr node)
(resolve-enum *justify-map* justify)))
(defun layout-node-set-position (node type &key top right bottom left)
"Set position type and offsets. TYPE is :static, :relative, or :absolute."
(let ((p (layout-node-ptr node)))
(yg-node-style-set-position-type p (resolve-enum *position-type-map* type))
(when left (yg-node-style-set-position p +yg-edge-left+ (coerce left 'single-float)))
(when top (yg-node-style-set-position p +yg-edge-top+ (coerce top 'single-float)))
(when right (yg-node-style-set-position p +yg-edge-right+ (coerce right 'single-float)))
(when bottom (yg-node-style-set-position p +yg-edge-bottom+ (coerce bottom 'single-float)))))
(defun set-edges (p fn all top right bottom left x y)
"Helper: call FN on each specified edge. FN is (fn ptr edge value)."
(flet ((s (edge val) (funcall fn p edge (coerce val 'single-float))))
(when all (dolist (e (list +yg-edge-left+ +yg-edge-top+ +yg-edge-right+ +yg-edge-bottom+))
(s e all)))
(when top (s +yg-edge-top+ top))
(when right (s +yg-edge-right+ right))
(when bottom (s +yg-edge-bottom+ bottom))
(when left (s +yg-edge-left+ left))
(when x (s +yg-edge-horizontal+ x))
(when y (s +yg-edge-vertical+ y))))
(defun layout-node-set-padding (node &key all top right bottom left x y)
"Set padding on specified edges in points."
(set-edges (layout-node-ptr node) #'yg-node-style-set-padding all top right bottom left x y))
(defun layout-node-set-margin (node &key all top right bottom left x y)
"Set margin on specified edges in points."
(set-edges (layout-node-ptr node) #'yg-node-style-set-margin all top right bottom left x y))
(defun layout-node-set-border (node width &key all top right bottom left x y)
"Set border width on specified edges."
(let ((p (layout-node-ptr node)))
(flet ((s (edge val) (yg-node-style-set-border p edge (coerce val 'single-float))))
(when all (dolist (e (list +yg-edge-left+ +yg-edge-top+ +yg-edge-right+ +yg-edge-bottom+))
(s e all)))
(when top (s +yg-edge-top+ top))
(when right (s +yg-edge-right+ right))
(when bottom (s +yg-edge-bottom+ bottom))
(when left (s +yg-edge-left+ left))
(when x (s +yg-edge-horizontal+ x))
(when y (s +yg-edge-vertical+ y)))))
(defun layout-node-set-gap (node &key row column)
"Set gap between children."
(let ((p (layout-node-ptr node)))
(when row (yg-node-style-set-gap p +yg-gutter-row+ (coerce row 'single-float)))
(when column (yg-node-style-set-gap p +yg-gutter-column+ (coerce column 'single-float)))))
(defun layout-node-set-overflow (node overflow)
"Set overflow mode. OVERFLOW is :visible, :hidden, or :scroll."
(yg-node-style-set-overflow
(layout-node-ptr node)
(resolve-enum *overflow-map* overflow)))
(defun layout-node-set-display (node display)
"Set display mode. DISPLAY is :flex or :none."
(yg-node-style-set-display
(layout-node-ptr node)
(resolve-enum *display-map* display)))
(defun layout-calculate (root width height &optional (direction :ltr))
"Run Yoga layout on the tree rooted at ROOT.
Returns ROOT (for chaining). Each node's computed position is available via
the raw FFI layout getter functions (yg-node-layout-get-left etc.)."
(yg-node-calculate-layout
(layout-node-ptr root)
(coerce width 'single-float)
(coerce height 'single-float)
(resolve-enum *direction-map* direction))
root)
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :cl-tui.layout-primitives-tests
(:use :cl :fiveam)
(:import-from :cl-tui.layout-primitives
#:make-layout-node
#:layout-node-add-child
#:layout-node-set-dimension
#:layout-node-set-flex
#:layout-node-set-direction
#:layout-node-set-wrap
#:layout-node-set-align
#:layout-node-set-justify
#:layout-node-set-padding
#:layout-node-set-margin
#:layout-node-set-gap
#:layout-node-set-position
#:layout-node-set-border
#:layout-node-set-overflow
#:layout-node-set-display
#:layout-node-set-aspect-ratio
#:layout-calculate
#:layout-node-ptr)
(:import-from :cl-tui.yoga-ffi
#:yg-node-layout-get-left
#:yg-node-layout-get-top
#:yg-node-layout-get-width
#:yg-node-layout-get-height))
(in-package :cl-tui.layout-primitives-tests)
(fiveam:def-suite layout-primitives-suite
:description "Layout primitive CLOS wrappers verification")
(fiveam:in-suite layout-primitives-suite)
(defun node-x (node) (yg-node-layout-get-left (layout-node-ptr node)))
(defun node-y (node) (yg-node-layout-get-top (layout-node-ptr node)))
(defun node-w (node) (yg-node-layout-get-width (layout-node-ptr node)))
(defun node-h (node) (yg-node-layout-get-height (layout-node-ptr node)))
(fiveam:test test-make-layout-node
"Contract: make-layout-node returns a live node."
(let ((n (make-layout-node)))
(fiveam:is (not (cffi:null-pointer-p (layout-node-ptr n))))))
(fiveam:test test-layout-node-add-child
"Contract: adding a child makes it appear in the tree."
(let* ((parent (make-layout-node))
(child (make-layout-node)))
(layout-node-add-child parent child)
(layout-node-set-dimension parent 100 100)
(layout-node-set-dimension child 50 50)
(layout-calculate parent 100 100)
(fiveam:is (= 50.0 (node-w child)))
(fiveam:is (= 50.0 (node-h child)))))
(fiveam:test test-set-dimension
"Contract: layout-node-set-dimension sets width and height."
(let ((n (make-layout-node)))
(layout-node-set-dimension n 200 100)
(layout-calculate n 200 100)
(fiveam:is (= 200.0 (node-w n)))
(fiveam:is (= 100.0 (node-h n)))))
(fiveam:test test-set-direction-column
"Contract: column direction stacks children vertically."
(let* ((root (make-layout-node))
(a (make-layout-node))
(b (make-layout-node)))
(layout-node-set-dimension root 100 200)
(layout-node-set-dimension a 100 50)
(layout-node-set-dimension b 100 50)
(layout-node-add-child root a)
(layout-node-add-child root b)
(layout-node-set-direction root :column)
(layout-calculate root 100 200)
(fiveam:is (= 0.0 (node-y a)))
(fiveam:is (= 50.0 (node-y b)))))
(fiveam:test test-set-direction-row
"Contract: row direction places children horizontally."
(let* ((root (make-layout-node))
(a (make-layout-node))
(b (make-layout-node)))
(layout-node-set-dimension root 200 100)
(layout-node-set-dimension a 80 50)
(layout-node-set-dimension b 80 50)
(layout-node-add-child root a)
(layout-node-add-child root b)
(layout-node-set-direction root :row)
(layout-calculate root 200 100)
(fiveam:is (= 0.0 (node-x a)))
(fiveam:is (= 80.0 (node-x b)))))
(fiveam:test test-set-flex-grow
"Contract: flex-grow distributes remaining space."
(let* ((root (make-layout-node))
(a (make-layout-node))
(b (make-layout-node)))
(layout-node-set-dimension root 200 100)
(layout-node-set-dimension a 0 100)
(layout-node-set-dimension b 0 100)
(layout-node-set-flex a :grow 1)
(layout-node-set-flex b :grow 2)
(layout-node-add-child root a)
(layout-node-add-child root b)
(layout-node-set-direction root :row)
(layout-calculate root 200 100)
(fiveam:is (< 0.0 (node-w a)))
(fiveam:is (< 0.0 (node-w b)))
(fiveam:is (= 200.0 (+ (node-w a) (node-w b))))))
(fiveam:test test-set-align-center
"Contract: align-items :center centers children on the cross axis."
(let* ((root (make-layout-node))
(child (make-layout-node)))
(layout-node-set-dimension root 200 100)
(layout-node-set-dimension child 50 50)
(layout-node-set-direction root :row)
(layout-node-add-child root child)
(layout-node-set-align root :items :center)
(layout-calculate root 200 100)
(fiveam:is (= 25.0 (node-y child)))))
(fiveam:test test-set-justify
"Contract: justify-content :center centers children on the main axis."
(let* ((root (make-layout-node))
(child (make-layout-node)))
(layout-node-set-dimension root 200 100)
(layout-node-set-dimension child 50 50)
(layout-node-set-direction root :row)
(layout-node-add-child root child)
(layout-node-set-justify root :center)
(layout-calculate root 200 100)
(fiveam:is (= 75.0 (node-x child)))))
(fiveam:test test-set-padding
"Contract: padding offsets children from the parent edges."
(let* ((root (make-layout-node))
(child (make-layout-node)))
(layout-node-set-dimension root 200 100)
(layout-node-set-dimension child 100 50)
(layout-node-add-child root child)
(layout-node-set-padding root :all 10)
(layout-calculate root 200 100)
(fiveam:is (= 10.0 (node-x child)))
(fiveam:is (= 10.0 (node-y child)))))
(fiveam:test test-set-margin
"Contract: margin offsets the child from its siblings/parent."
(let* ((root (make-layout-node))
(child (make-layout-node)))
(layout-node-set-dimension root 200 100)
(layout-node-set-dimension child 80 50)
(layout-node-add-child root child)
(layout-node-set-margin child :left 20)
(layout-calculate root 200 100)
(fiveam:is (= 20.0 (node-x child)))))
(fiveam:test test-set-position-absolute
"Contract: absolute positioning places a child at exact coordinates."
(let* ((root (make-layout-node))
(child (make-layout-node)))
(layout-node-set-dimension root 300 300)
(layout-node-set-dimension child 50 50)
(layout-node-add-child root child)
(layout-node-set-position child :absolute :left 100 :top 50)
(layout-calculate root 300 300)
(fiveam:is (= 100.0 (node-x child)))
(fiveam:is (= 50.0 (node-y child)))))
(fiveam:test test-set-wrap
"Contract: flex-wrap :wrap allows children to wrap to next line."
(let* ((root (make-layout-node))
(a (make-layout-node))
(b (make-layout-node))
(c (make-layout-node)))
(layout-node-set-dimension root 100 200)
(layout-node-set-dimension a 60 50)
(layout-node-set-dimension b 60 50)
(layout-node-set-dimension c 60 50)
(layout-node-add-child root a)
(layout-node-add-child root b)
(layout-node-add-child root c)
(layout-node-set-direction root :row)
(layout-node-set-wrap root :wrap)
(layout-calculate root 100 200)
(fiveam:is (< 0 (node-h a)))
;; Second child (b) should wrap to next row since 60+60 > 100
(fiveam:is (> (node-y b) (node-y a)))))
(fiveam:test test-set-gap
"Contract: gap adds spacing between children."
(let* ((root (make-layout-node))
(a (make-layout-node))
(b (make-layout-node)))
(layout-node-set-dimension root 200 100)
(layout-node-set-dimension a 50 50)
(layout-node-set-dimension b 50 50)
(layout-node-add-child root a)
(layout-node-add-child root b)
(layout-node-set-direction root :column)
(layout-node-set-gap root :row 20)
(layout-calculate root 200 100)
(fiveam:is (= 70.0 (node-y b)))))
(fiveam:test test-nested-layout
"Contract: nested containers produce correct leaf positions."
(let* ((root (make-layout-node))
(outer (make-layout-node))
(inner (make-layout-node)))
(layout-node-set-dimension root 400 400)
(layout-node-set-dimension outer 400 200)
(layout-node-set-dimension inner 100 100)
(layout-node-add-child outer inner)
(layout-node-add-child root outer)
(layout-node-set-direction root :column)
(layout-calculate root 400 400)
(fiveam:is (= 0.0 (node-x inner)))
(fiveam:is (= 100.0 (node-w inner)))
(fiveam:is (= 100.0 (node-h inner)))))

View File

@@ -1,631 +0,0 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :cffi :silent t))
(defpackage :cl-tui.yoga-ffi
(:use :cl)
(:export
;; library
#:*libyoga*
#:load-yoga
;; constants
#:+yg-direction-inherit+
#:+yg-direction-ltr+
#:+yg-direction-rtl+
#:+yg-flex-direction-column+
#:+yg-flex-direction-column-reverse+
#:+yg-flex-direction-row+
#:+yg-flex-direction-row-reverse+
#:+yg-justify-auto+
#:+yg-justify-flex-start+
#:+yg-justify-center+
#:+yg-justify-flex-end+
#:+yg-justify-space-between+
#:+yg-justify-space-around+
#:+yg-justify-space-evenly+
#:+yg-justify-stretch+
#:+yg-align-auto+
#:+yg-align-flex-start+
#:+yg-align-center+
#:+yg-align-flex-end+
#:+yg-align-stretch+
#:+yg-align-baseline+
#:+yg-align-space-between+
#:+yg-align-space-around+
#:+yg-align-space-evenly+
#:+yg-wrap-nowrap+
#:+yg-wrap-wrap+
#:+yg-wrap-wrap-reverse+
#:+yg-position-type-static+
#:+yg-position-type-relative+
#:+yg-position-type-absolute+
#:+yg-overflow-visible+
#:+yg-overflow-hidden+
#:+yg-overflow-scroll+
#:+yg-display-flex+
#:+yg-display-none+
#:+yg-display-contents+
#:+yg-edge-left+
#:+yg-edge-top+
#:+yg-edge-right+
#:+yg-edge-bottom+
#:+yg-edge-start+
#:+yg-edge-end+
#:+yg-edge-horizontal+
#:+yg-edge-vertical+
#:+yg-edge-all+
#:+yg-gutter-column+
#:+yg-gutter-row+
#:+yg-gutter-all+
#:+yg-unit-undefined+
#:+yg-unit-point+
#:+yg-unit-percent+
#:+yg-unit-auto+
;; types
#:yg-node-ref
#:yg-node-const-ref
;; node management
#:yg-node-new
#:yg-node-free
#:yg-node-free-recursive
#:yg-node-insert-child
#:yg-node-remove-child
#:yg-node-remove-all-children
#:yg-node-get-child-count
#:yg-node-get-child
;; layout
#:yg-node-calculate-layout
#:yg-node-layout-get-left
#:yg-node-layout-get-top
#:yg-node-layout-get-width
#:yg-node-layout-get-height
#:yg-node-layout-get-right
#:yg-node-layout-get-bottom
#:yg-node-is-dirty
#:yg-node-mark-dirty
;; style direction & flex
#:yg-node-style-set-direction
#:yg-node-style-set-flex-direction
#:yg-node-style-set-justify-content
#:yg-node-style-set-align-items
#:yg-node-style-set-align-self
#:yg-node-style-set-align-content
#:yg-node-style-set-flex-wrap
#:yg-node-style-set-position-type
#:yg-node-style-set-flex-grow
#:yg-node-style-set-flex-shrink
#:yg-node-style-set-flex-basis
#:yg-node-style-set-flex-basis-auto
#:yg-node-style-set-flex-basis-percent
#:yg-node-style-set-overflow
#:yg-node-style-set-display
;; style dimensions
#:yg-node-style-set-width
#:yg-node-style-set-width-percent
#:yg-node-style-set-width-auto
#:yg-node-style-set-height
#:yg-node-style-set-height-percent
#:yg-node-style-set-height-auto
#:yg-node-style-set-min-width
#:yg-node-style-set-min-width-percent
#:yg-node-style-set-min-height
#:yg-node-style-set-min-height-percent
#:yg-node-style-set-max-width
#:yg-node-style-set-max-height
#:yg-node-style-set-aspect-ratio
;; style padding/margin/border/gap/position
#:yg-node-style-set-padding
#:yg-node-style-set-padding-percent
#:yg-node-style-set-margin
#:yg-node-style-set-margin-percent
#:yg-node-style-set-margin-auto
#:yg-node-style-set-border
#:yg-node-style-set-gap
#:yg-node-style-set-position
#:yg-node-style-set-position-percent
;; style getters
#:yg-node-style-get-width
#:yg-node-style-get-height
#:yg-node-style-get-flex-direction
#:yg-node-style-get-align-items
#:yg-node-style-get-justify-content))
(in-package :cl-tui.yoga-ffi)
(defparameter *libyoga* nil "Handle for the loaded Yoga shared library.")
(defun load-yoga ()
"Load the Yoga shared library via CFFI."
(setf *libyoga* (cffi:load-foreign-library "/usr/local/lib/libyoga.so"))
(sb-int:set-floating-point-modes :traps '())
*libyoga*)
(load-yoga)
(eval-when (:compile-toplevel :load-toplevel :execute)
;; YGDirection
(defconstant +yg-direction-inherit+ 0)
(defconstant +yg-direction-ltr+ 1)
(defconstant +yg-direction-rtl+ 2)
;; YGFlexDirection
(defconstant +yg-flex-direction-column+ 0)
(defconstant +yg-flex-direction-column-reverse+ 1)
(defconstant +yg-flex-direction-row+ 2)
(defconstant +yg-flex-direction-row-reverse+ 3)
;; YGJustify
(defconstant +yg-justify-auto+ 0)
(defconstant +yg-justify-flex-start+ 1)
(defconstant +yg-justify-center+ 2)
(defconstant +yg-justify-flex-end+ 3)
(defconstant +yg-justify-space-between+ 4)
(defconstant +yg-justify-space-around+ 5)
(defconstant +yg-justify-space-evenly+ 6)
(defconstant +yg-justify-stretch+ 7)
;; YGAlign
(defconstant +yg-align-auto+ 0)
(defconstant +yg-align-flex-start+ 1)
(defconstant +yg-align-center+ 2)
(defconstant +yg-align-flex-end+ 3)
(defconstant +yg-align-stretch+ 4)
(defconstant +yg-align-baseline+ 5)
(defconstant +yg-align-space-between+ 6)
(defconstant +yg-align-space-around+ 7)
(defconstant +yg-align-space-evenly+ 8)
;; YGWrap
(defconstant +yg-wrap-nowrap+ 0)
(defconstant +yg-wrap-wrap+ 1)
(defconstant +yg-wrap-wrap-reverse+ 2)
;; YGPositionType
(defconstant +yg-position-type-static+ 0)
(defconstant +yg-position-type-relative+ 1)
(defconstant +yg-position-type-absolute+ 2)
;; YGOverflow
(defconstant +yg-overflow-visible+ 0)
(defconstant +yg-overflow-hidden+ 1)
(defconstant +yg-overflow-scroll+ 2)
;; YGDisplay
(defconstant +yg-display-flex+ 0)
(defconstant +yg-display-none+ 1)
(defconstant +yg-display-contents+ 2)
;; YGEdge
(defconstant +yg-edge-left+ 0)
(defconstant +yg-edge-top+ 1)
(defconstant +yg-edge-right+ 2)
(defconstant +yg-edge-bottom+ 3)
(defconstant +yg-edge-start+ 4)
(defconstant +yg-edge-end+ 5)
(defconstant +yg-edge-horizontal+ 6)
(defconstant +yg-edge-vertical+ 7)
(defconstant +yg-edge-all+ 8)
;; YGGutter
(defconstant +yg-gutter-column+ 0)
(defconstant +yg-gutter-row+ 1)
(defconstant +yg-gutter-all+ 2)
;; YGUnit
(defconstant +yg-unit-undefined+ 0)
(defconstant +yg-unit-point+ 1)
(defconstant +yg-unit-percent+ 2)
(defconstant +yg-unit-auto+ 3))
(cffi:defctype yg-node-ref :pointer)
(cffi:defctype yg-node-const-ref :pointer)
(cffi:defcstruct yg-size
(width :float)
(height :float))
(cffi:defcstruct yg-value
(value :float)
(unit :int))
(cffi:defcfun ("YGNodeNew" yg-node-new) yg-node-ref)
(cffi:defcfun ("YGNodeFree" yg-node-free) :void
(node yg-node-ref))
(cffi:defcfun ("YGNodeFreeRecursive" yg-node-free-recursive) :void
(node yg-node-ref))
(cffi:defcfun ("YGNodeInsertChild" yg-node-insert-child) :void
(node yg-node-ref)
(child yg-node-ref)
(index :unsigned-int))
(cffi:defcfun ("YGNodeRemoveChild" yg-node-remove-child) :void
(node yg-node-ref)
(child yg-node-ref))
(cffi:defcfun ("YGNodeRemoveAllChildren" yg-node-remove-all-children) :void
(node yg-node-ref))
(cffi:defcfun ("YGNodeGetChildCount" yg-node-get-child-count) :unsigned-int
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeGetChild" yg-node-get-child) yg-node-ref
(node yg-node-ref)
(index :unsigned-int))
(cffi:defcfun ("YGNodeCalculateLayout" yg-node-calculate-layout) :void
(node yg-node-ref)
(available-width :float)
(available-height :float)
(owner-direction :int))
(cffi:defcfun ("YGNodeLayoutGetLeft" yg-node-layout-get-left) :float
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeLayoutGetTop" yg-node-layout-get-top) :float
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeLayoutGetWidth" yg-node-layout-get-width) :float
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeLayoutGetHeight" yg-node-layout-get-height) :float
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeLayoutGetRight" yg-node-layout-get-right) :float
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeLayoutGetBottom" yg-node-layout-get-bottom) :float
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeIsDirty" yg-node-is-dirty) :boolean
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeMarkDirty" yg-node-mark-dirty) :void
(node yg-node-ref))
(cffi:defcfun ("YGNodeStyleSetDirection" yg-node-style-set-direction) :void
(node yg-node-ref)
(direction :int))
(cffi:defcfun ("YGNodeStyleSetFlexDirection" yg-node-style-set-flex-direction) :void
(node yg-node-ref)
(flex-direction :int))
(cffi:defcfun ("YGNodeStyleSetJustifyContent" yg-node-style-set-justify-content) :void
(node yg-node-ref)
(justify :int))
(cffi:defcfun ("YGNodeStyleSetAlignItems" yg-node-style-set-align-items) :void
(node yg-node-ref)
(align :int))
(cffi:defcfun ("YGNodeStyleSetAlignSelf" yg-node-style-set-align-self) :void
(node yg-node-ref)
(align :int))
(cffi:defcfun ("YGNodeStyleSetAlignContent" yg-node-style-set-align-content) :void
(node yg-node-ref)
(align :int))
(cffi:defcfun ("YGNodeStyleSetFlexWrap" yg-node-style-set-flex-wrap) :void
(node yg-node-ref)
(wrap :int))
(cffi:defcfun ("YGNodeStyleSetPositionType" yg-node-style-set-position-type) :void
(node yg-node-ref)
(position-type :int))
(cffi:defcfun ("YGNodeStyleSetFlexGrow" yg-node-style-set-flex-grow) :void
(node yg-node-ref)
(flex-grow :float))
(cffi:defcfun ("YGNodeStyleSetFlexShrink" yg-node-style-set-flex-shrink) :void
(node yg-node-ref)
(flex-shrink :float))
(cffi:defcfun ("YGNodeStyleSetFlexBasis" yg-node-style-set-flex-basis) :void
(node yg-node-ref)
(flex-basis :float))
(cffi:defcfun ("YGNodeStyleSetFlexBasisAuto" yg-node-style-set-flex-basis-auto) :void
(node yg-node-ref))
(cffi:defcfun ("YGNodeStyleSetFlexBasisPercent" yg-node-style-set-flex-basis-percent) :void
(node yg-node-ref)
(flex-basis :float))
(cffi:defcfun ("YGNodeStyleSetOverflow" yg-node-style-set-overflow) :void
(node yg-node-ref)
(overflow :int))
(cffi:defcfun ("YGNodeStyleSetDisplay" yg-node-style-set-display) :void
(node yg-node-ref)
(display :int))
(cffi:defcfun ("YGNodeStyleSetWidth" yg-node-style-set-width) :void
(node yg-node-ref)
(width :float))
(cffi:defcfun ("YGNodeStyleSetWidthPercent" yg-node-style-set-width-percent) :void
(node yg-node-ref)
(width :float))
(cffi:defcfun ("YGNodeStyleSetWidthAuto" yg-node-style-set-width-auto) :void
(node yg-node-ref))
(cffi:defcfun ("YGNodeStyleSetHeight" yg-node-style-set-height) :void
(node yg-node-ref)
(height :float))
(cffi:defcfun ("YGNodeStyleSetHeightPercent" yg-node-style-set-height-percent) :void
(node yg-node-ref)
(height :float))
(cffi:defcfun ("YGNodeStyleSetHeightAuto" yg-node-style-set-height-auto) :void
(node yg-node-ref))
(cffi:defcfun ("YGNodeStyleSetMinWidth" yg-node-style-set-min-width) :void
(node yg-node-ref)
(min-width :float))
(cffi:defcfun ("YGNodeStyleSetMinWidthPercent" yg-node-style-set-min-width-percent) :void
(node yg-node-ref)
(min-width :float))
(cffi:defcfun ("YGNodeStyleSetMinHeight" yg-node-style-set-min-height) :void
(node yg-node-ref)
(min-height :float))
(cffi:defcfun ("YGNodeStyleSetMinHeightPercent" yg-node-style-set-min-height-percent) :void
(node yg-node-ref)
(min-height :float))
(cffi:defcfun ("YGNodeStyleSetMaxWidth" yg-node-style-set-max-width) :void
(node yg-node-ref)
(max-width :float))
(cffi:defcfun ("YGNodeStyleSetMaxHeight" yg-node-style-set-max-height) :void
(node yg-node-ref)
(max-height :float))
(cffi:defcfun ("YGNodeStyleSetAspectRatio" yg-node-style-set-aspect-ratio) :void
(node yg-node-ref)
(aspect-ratio :float))
(cffi:defcfun ("YGNodeStyleSetPadding" yg-node-style-set-padding) :void
(node yg-node-ref)
(edge :int)
(padding :float))
(cffi:defcfun ("YGNodeStyleSetPaddingPercent" yg-node-style-set-padding-percent) :void
(node yg-node-ref)
(edge :int)
(padding :float))
(cffi:defcfun ("YGNodeStyleSetMargin" yg-node-style-set-margin) :void
(node yg-node-ref)
(edge :int)
(margin :float))
(cffi:defcfun ("YGNodeStyleSetMarginPercent" yg-node-style-set-margin-percent) :void
(node yg-node-ref)
(edge :int)
(margin :float))
(cffi:defcfun ("YGNodeStyleSetMarginAuto" yg-node-style-set-margin-auto) :void
(node yg-node-ref)
(edge :int))
(cffi:defcfun ("YGNodeStyleSetBorder" yg-node-style-set-border) :void
(node yg-node-ref)
(edge :int)
(border :float))
(cffi:defcfun ("YGNodeStyleSetGap" yg-node-style-set-gap) :void
(node yg-node-ref)
(gutter :int)
(gap :float))
(cffi:defcfun ("YGNodeStyleSetPosition" yg-node-style-set-position) :void
(node yg-node-ref)
(edge :int)
(position :float))
(cffi:defcfun ("YGNodeStyleSetPositionPercent" yg-node-style-set-position-percent) :void
(node yg-node-ref)
(edge :int)
(position :float))
(cffi:defcfun ("YGNodeStyleGetWidth" yg-node-style-get-width) yg-value
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeStyleGetHeight" yg-node-style-get-height) yg-value
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeStyleGetFlexDirection" yg-node-style-get-flex-direction) :int
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeStyleGetAlignItems" yg-node-style-get-align-items) :int
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeStyleGetJustifyContent" yg-node-style-get-justify-content) :int
(node yg-node-const-ref))
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :cl-tui.yoga-ffi-tests
(:use :cl :fiveam)
(:import-from :cl-tui.yoga-ffi
#:load-yoga
#:yg-node-new
#:yg-node-free
#:yg-node-free-recursive
#:yg-node-insert-child
#:yg-node-get-child-count
#:yg-node-calculate-layout
#:yg-node-layout-get-left
#:yg-node-layout-get-top
#:yg-node-layout-get-width
#:yg-node-layout-get-height
#:yg-node-style-set-flex-direction
#:yg-node-style-set-justify-content
#:yg-node-style-set-align-items
#:yg-node-style-set-width
#:yg-node-style-set-height
#:yg-node-style-set-padding
#:yg-node-style-set-margin
#:yg-node-style-set-flex-grow
#:yg-node-style-set-position-type
#:yg-node-style-set-position
#:+yg-flex-direction-column+
#:+yg-flex-direction-row+
#:+yg-justify-center+
#:+yg-justify-flex-start+
#:+yg-align-stretch+
#:+yg-align-center+
#:+yg-edge-all+
#:+yg-edge-left+
#:+yg-edge-top+
#:+yg-edge-right+
#:+yg-edge-bottom+
#:+yg-position-type-relative+
#:+yg-position-type-absolute+
;; YGDirection constants (different from YGFlexDirection!)
#:+yg-direction-inherit+
#:+yg-direction-ltr+
#:+yg-direction-rtl+))
(in-package :cl-tui.yoga-ffi-tests)
(fiveam:def-suite yoga-ffi-suite
:description "Yoga FFI binding verification")
(fiveam:in-suite yoga-ffi-suite)
(fiveam:test test-node-create-free
"Contract: yg-node-new returns a non-null pointer; yg-node-free doesn't crash."
(let ((node (yg-node-new)))
(fiveam:is (not (cffi:null-pointer-p node)))
(yg-node-free node)
(fiveam:pass)))
(fiveam:test test-node-child-count
"Contract: yg-node-get-child-count returns 0 for a new node."
(let ((node (yg-node-new)))
(fiveam:is (= 0 (yg-node-get-child-count node)))
(yg-node-free node)))
(fiveam:test test-node-insert-child
"Contract: inserting a child increments the child count."
(let ((parent (yg-node-new))
(child (yg-node-new)))
(yg-node-insert-child parent child 0)
(fiveam:is (= 1 (yg-node-get-child-count parent)))
(yg-node-free-recursive parent)))
(fiveam:test test-layout-basic-column
"Contract: a column with two fixed-height children positions them vertically."
(let* ((root (yg-node-new)))
(yg-node-style-set-width root 100.0)
(yg-node-style-set-height root 200.0)
(yg-node-style-set-flex-direction root +yg-flex-direction-column+)
(let ((child1 (yg-node-new))
(child2 (yg-node-new)))
(yg-node-style-set-width child1 100.0)
(yg-node-style-set-height child1 50.0)
(yg-node-style-set-width child2 100.0)
(yg-node-style-set-height child2 50.0)
(yg-node-insert-child root child1 0)
(yg-node-insert-child root child2 1)
(yg-node-calculate-layout root 100.0 200.0 +yg-direction-ltr+)
(fiveam:is (= 0.0 (yg-node-layout-get-left child1)))
(fiveam:is (= 0.0 (yg-node-layout-get-top child1)))
(fiveam:is (= 50.0 (yg-node-layout-get-top child2)))
(yg-node-free-recursive root))))
(fiveam:test test-layout-basic-row
"Contract: a row with two fixed-width children positions them horizontally."
(let* ((root (yg-node-new)))
(yg-node-style-set-width root 200.0)
(yg-node-style-set-height root 100.0)
(yg-node-style-set-flex-direction root +yg-flex-direction-row+)
(let ((child1 (yg-node-new))
(child2 (yg-node-new)))
(yg-node-style-set-width child1 80.0)
(yg-node-style-set-height child1 50.0)
(yg-node-style-set-width child2 80.0)
(yg-node-style-set-height child2 50.0)
(yg-node-insert-child root child1 0)
(yg-node-insert-child root child2 1)
(yg-node-calculate-layout root 200.0 100.0 +yg-direction-ltr+)
(fiveam:is (= 0.0 (yg-node-layout-get-left child1)))
(fiveam:is (= 0.0 (yg-node-layout-get-top child1)))
(fiveam:is (= 80.0 (yg-node-layout-get-left child2)))
(yg-node-free-recursive root))))
(fiveam:test test-layout-flex-grow
"Contract: flex-grow distributes remaining space proportionally."
(let* ((root (yg-node-new)))
(yg-node-style-set-width root 200.0)
(yg-node-style-set-height root 100.0)
(yg-node-style-set-flex-direction root +yg-flex-direction-row+)
(let ((child1 (yg-node-new))
(child2 (yg-node-new)))
(yg-node-style-set-height child1 100.0)
(yg-node-style-set-flex-grow child1 1.0)
(yg-node-style-set-height child2 100.0)
(yg-node-style-set-flex-grow child2 2.0)
(yg-node-insert-child root child1 0)
(yg-node-insert-child root child2 1)
(yg-node-calculate-layout root 200.0 100.0 +yg-direction-ltr+)
(fiveam:is (< 0.0 (yg-node-layout-get-width child1)))
(fiveam:is (< 0.0 (yg-node-layout-get-width child2)))
(fiveam:is (= 200.0 (+ (yg-node-layout-get-width child1)
(yg-node-layout-get-width child2))))
(yg-node-free-recursive root))))
(fiveam:test test-layout-absolute-position
"Contract: an absolute child positions relative to its parent."
(let* ((root (yg-node-new)))
(yg-node-style-set-width root 300.0)
(yg-node-style-set-height root 300.0)
(let ((child (yg-node-new)))
(yg-node-style-set-width child 50.0)
(yg-node-style-set-height child 50.0)
(yg-node-style-set-position-type child +yg-position-type-absolute+)
(yg-node-style-set-position child +yg-edge-left+ 100.0)
(yg-node-style-set-position child +yg-edge-top+ 50.0)
(yg-node-insert-child root child 0)
(yg-node-calculate-layout root 300.0 300.0 +yg-direction-ltr+)
(fiveam:is (= 100.0 (yg-node-layout-get-left child)))
(fiveam:is (= 50.0 (yg-node-layout-get-top child)))
(fiveam:is (= 50.0 (yg-node-layout-get-width child)))
(fiveam:is (= 50.0 (yg-node-layout-get-height child)))
(yg-node-free-recursive root))))
(fiveam:test test-layout-padding
"Contract: padding reduces the available space for children."
(let* ((root (yg-node-new)))
(yg-node-style-set-width root 200.0)
(yg-node-style-set-height root 100.0)
(yg-node-style-set-padding root +yg-edge-all+ 10.0)
(let ((child (yg-node-new)))
(yg-node-style-set-width child 180.0)
(yg-node-style-set-height child 80.0)
(yg-node-insert-child root child 0)
(yg-node-calculate-layout root 200.0 100.0 +yg-direction-ltr+)
(fiveam:is (= 10.0 (yg-node-layout-get-left child)))
(fiveam:is (= 10.0 (yg-node-layout-get-top child)))
(yg-node-free-recursive root))))
(fiveam:test test-layout-nested
"Contract: nested containers produce correct leaf positions."
(let* ((root (yg-node-new)))
(yg-node-style-set-width root 400.0)
(yg-node-style-set-height root 400.0)
(yg-node-style-set-flex-direction root +yg-flex-direction-column+)
(let ((outer (yg-node-new)))
(yg-node-style-set-width outer 400.0)
(yg-node-style-set-height outer 200.0)
(yg-node-style-set-flex-direction outer +yg-flex-direction-row+)
(let ((inner (yg-node-new)))
(yg-node-style-set-width inner 100.0)
(yg-node-style-set-height inner 100.0)
(yg-node-insert-child outer inner 0)
(yg-node-insert-child root outer 0)
(yg-node-calculate-layout root 400.0 400.0 +yg-direction-ltr+)
(fiveam:is (= 0.0 (yg-node-layout-get-left inner)))
(fiveam:is (= 100.0 (yg-node-layout-get-width inner)))
(fiveam:is (= 100.0 (yg-node-layout-get-height inner)))
(yg-node-free-recursive root)))))

382
org/backend-protocol.org Normal file
View File

@@ -0,0 +1,382 @@
#+TITLE: cl-tui Backend Protocol — v0.0.1
#+STARTUP: content
#+FILETAGS: :cl-tui:backend:v0.0.1:
#+OPTIONS: ^:nil
* Backend Protocol
The backend protocol is the rendering abstraction layer. Every visual
operation dispatches through generic functions on a backend class.
Two implementations exist: =modern-backend= (raw escape sequences,
truecolor, modern terminal features) and =simple-backend= (ASCII art,
universal compatibility).
** Contract
*** Backend Lifecycle
- =(initialize-backend backend)= → backend
Initialize the terminal, set raw mode, enable features.
Returns the backend instance.
- =(shutdown-backend backend)= → nil
Restore terminal to cooked mode, reset colors, show cursor.
Must be called on exit regardless of how the image stops.
- =(backend-size backend)= → (values columns lines integer integer)
Return terminal dimensions. First value = columns, second = lines.
- =(backend-write backend string)= → integer
Write raw string to terminal output. Returns number of bytes written.
- =(backend-clear backend)= → nil
Clear the entire screen and reset cursor to (0,0).
*** Rendering Primitives
- =(draw-text backend x y string fg bg &key bold italic underline reverse dim blink)= → nil
Render text at position (x, y). fg and bg are hex color strings
(e.g. "#FFD700") or nil for default. Attributes are booleans.
- =(draw-border backend x y width height &key style fg bg title title-align)= → nil
Draw a border rectangle. Style is :single, :double, or :rounded.
- =(draw-rect backend x y width height &key bg)= → nil
Fill a rectangle with background color.
- =(draw-link backend x y string url &key fg bg)= → nil
Render clickable hyperlink (OSC 8 escape sequence).
- =(draw-ellipsis backend x y width &key fg bg)= → nil
Render "..." truncated text marker at position.
*** Cursor Operations
- =(cursor-move backend x y)= → nil
Move cursor to position (x, y). Origin is top-left (0,0).
- =(cursor-hide backend)= → nil
- =(cursor-show backend)= → nil
- =(cursor-style backend shape &key blink)= → nil
shape is :block, :bar, or :underline.
*** Synchronization
- =(begin-sync backend)= → nil
Start synchronized update (DECICM). All subsequent output is buffered
by the terminal until =end-sync=.
- =(end-sync backend)= → nil
Flush synchronized update buffer. The entire frame appears at once.
*** Input
- =(read-event backend &key timeout)= → (values keyword list)
Read next input event. Blocks until event or timeout.
Returns event type keyword and event data plist.
- =(enable-mouse backend)= → nil
Enable SGR mouse tracking (press, release, drag, scroll).
- =(enable-bracketed-paste backend)= → nil
Enable bracketed paste mode.
*** Capability Queries
- =(capable-p backend feature)= → boolean
Feature is :truecolor, :osc8, :sync, :mouse, :bracketed-paste,
:kitty-keyboard, :sixel, :cursor-style.
** Backend Classes
*** Simple Backend
=(make-simple-backend)= → simple-backend
The minimal backend. ASCII borders, no color, no modern features.
Works everywhere — SSH, serial, pipes, ancient terminals.
Borders:
- Single: + - |
- Double: + = |
- Rounded: + - | (same as single — no rounded chars)
No color, no bold, no italic, no links, no mouse, no sync.
*** Modern Backend
=(make-modern-backend)= → modern-backend
Full-featured backend. Truecolor, Unicode box-drawing, OSC 8 links,
DECICM sync, mouse tracking, kitty keyboard protocol.
Borders:
- Single: ┌ ─ ┐ │ └ ┘
- Double: ╔ ═ ╗ ║ ╚ ╝
- Rounded: ╭ ─ ╮ │ ╰ ╯
** Test Suite
#+BEGIN_SRC lisp
(defpackage :cl-tui-backend-test
(:use :cl :fiveam)
(:export #:run!))
(in-package :cl-tui-backend-test)
(def-suite backend-suite :description "Backend protocol tests")
(in-suite backend-suite)
;; ── Simple Backend ──────────────────────────────────────────────
(test simple-backend-lifecycle
"simple-backend can be created and shut down"
(let ((b (make-simple-backend)))
(is (typep b 'simple-backend))
(initialize-backend b)
(is (capable-p b :truecolor) nil "simple backend has no truecolor")
(shutdown-backend b)))
(test simple-backend-draw-text
"simple-backend renders text at position, ignoring style"
(let ((b (make-simple-backend)))
(initialize-backend b)
(draw-text b 0 0 "hello" nil nil)
;; No crash = pass (simple backend writes to *standard-output*)
(shutdown-backend b)
(is-t t)))
(test simple-backend-border-single
"simple-backend draws ASCII single border"
(let ((b (make-simple-backend)))
(initialize-backend b)
(draw-border b 0 0 10 5 :style :single)
(shutdown-backend b)
(is-t t)))
(test simple-backend-border-rounded
"simple-backend falls back to straight edges for rounded"
(let ((b (make-simple-backend)))
(initialize-backend b)
(draw-border b 0 0 10 5 :style :rounded)
;; No error — rounded falls back to single on simple
(shutdown-backend b)
(is-t t)))
;; ── Backend Capabilities ───────────────────────────────────────
(test capable-p-known-features
"capable-p returns nil for all features on simple-backend"
(let ((b (make-simple-backend)))
(initialize-backend b)
(dolist (f '(:truecolor :osc8 :sync :mouse :bracketed-paste
:kitty-keyboard :sixel :cursor-style))
(is (capable-p b f) nil
(format nil "~s should not be supported on simple-backend" f)))
(shutdown-backend b)))
;; ── Backend Size ───────────────────────────────────────────────
(test backend-size-returns-integers
"backend-size returns two integer values"
(let ((b (make-simple-backend)))
(initialize-backend b)
(multiple-value-bind (cols lines) (backend-size b)
(is (integerp cols))
(is (integerp lines))
(is (>= cols 10))
(is (>= lines 3)))
(shutdown-backend b)))
;; ── Drawing Primitives ─────────────────────────────────────────
(test draw-rect-fills-area
"draw-rect fills a rectangular area with background"
(let ((b (make-simple-backend)))
(initialize-backend b)
(draw-rect b 0 0 5 3 :bg nil)
(shutdown-backend b)
(is-t t)))
(test draw-text-multi-line
"draw-text handles strings with newlines"
(let ((b (make-simple-backend)))
(initialize-backend b)
(draw-text b 0 0 "line1~%line2" nil nil)
(shutdown-backend b)
(is-t t)))
;; ── Synchronization ────────────────────────────────────────────
(test sync-is-noop-on-simple
"begin-sync and end-sync are no-ops on simple-backend"
(let ((b (make-simple-backend)))
(initialize-backend b)
(begin-sync b)
(draw-text b 0 0 "in sync" nil nil)
(end-sync b)
(shutdown-backend b)
(is-t t)))
#+END_SRC
** Implementation
*** Package
#+BEGIN_SRC lisp
(defpackage :cl-tui.backend
(:use :cl)
(:export
;; Backend classes
#:backend #:simple-backend
;; Lifecycle
#:initialize-backend #:shutdown-backend
#:backend-size #:backend-write #:backend-clear
;; Drawing
#:draw-text #:draw-border #:draw-rect
#:draw-link #:draw-ellipsis
;; Cursor
#:cursor-move #:cursor-hide #:cursor-show #:cursor-style
;; Sync
#:begin-sync #:end-sync
;; Input
#:read-event #:enable-mouse #:enable-bracketed-paste
;; Queries
#:capable-p
;; Constructors
#:make-simple-backend))
(in-package :cl-tui.backend)
#+END_SRC
*** Backend Base Class
#+BEGIN_SRC lisp
(defclass backend () ())
(defgeneric initialize-backend (backend)
(:method ((b backend)) b))
(defgeneric shutdown-backend (backend)
(:method ((b backend)) (values)))
(defgeneric backend-size (backend)
(:method ((b backend))
(values 80 24)))
(defgeneric backend-write (backend string))
(defgeneric backend-clear (backend)
(:method ((b backend))
(backend-write b (string #\escape) "[2J")
(cursor-move b 0 0)))
(defgeneric draw-text (backend x y string fg bg &key
bold italic underline reverse dim blink))
(defgeneric draw-border (backend x y width height
&key style fg bg title title-align))
(defgeneric draw-rect (backend x y width height &key bg))
(defgeneric draw-link (backend x y string url &key fg bg))
(defgeneric draw-ellipsis (backend x y width &key fg bg))
(defgeneric cursor-move (backend x y))
(defgeneric cursor-hide (backend)
(:method ((b backend)) (values)))
(defgeneric cursor-show (backend)
(:method ((b backend)) (values)))
(defgeneric cursor-style (backend shape &key blink)
(:method ((b backend) shape &key blink) (values)))
(defgeneric begin-sync (backend)
(:method ((b backend)) (values)))
(defgeneric end-sync (backend)
(:method ((b backend)) (values)))
(defgeneric read-event (backend &key timeout)
(:method ((b backend) &key timeout) (values nil nil)))
(defgeneric enable-mouse (backend)
(:method ((b backend)) (values)))
(defgeneric enable-bracketed-paste (backend)
(:method ((b backend)) (values)))
(defgeneric capable-p (backend feature)
(:method ((b backend) feature)
(declare (ignore feature))
nil))
#+END_SRC
*** Simple Backend
#+BEGIN_SRC lisp
(defclass simple-backend (backend)
((output-stream :initform *standard-output*
:accessor backend-output-stream)))
(defmethod initialize-backend ((b simple-backend))
b)
(defmethod shutdown-backend ((b simple-backend))
(values))
(defmethod backend-size ((b simple-backend))
;; Try ioctl, fall back to 80x24
(values 80 24))
(defmethod backend-write ((b simple-backend) string)
(let ((stream (backend-output-stream b)))
(write-string string stream)
(finish-output stream)
(length string)))
(defmethod draw-text ((b simple-backend) x y string fg bg
&key bold italic underline reverse dim blink)
(declare (ignore x y fg bg bold italic underline reverse dim blink))
(backend-write b string))
(defun %simple-border-char (edge-style pos)
"Return ASCII border character for EDGE-STYLE at POS.
POS is :top-left, :top-right, :bottom-left, :bottom-right,
:horizontal, or :vertical."
(case pos
((:top-left :top-right :bottom-left :bottom-right) #\+)
(:horizontal #\-)
(:vertical #\|)))
(defmethod draw-border ((b simple-backend) x y width height
&key style fg bg title title-align)
(declare (ignore style fg bg title title-align))
(let ((h (%simple-border-char nil :horizontal))
(v (%simple-border-char nil :vertical)))
;; Top edge
(backend-write b (format nil "~%~v@{~a~:*~}" width h))
;; Sides
(loop for i from 1 below (1- height)
do (backend-write b (format nil "~%|~v@{~a~:*~}|" (- width 2) #\space)))
;; Bottom edge
(backend-write b (format nil "~%~v@{~a~:*~}" width h))))
(defmethod draw-rect ((b simple-backend) x y width height
&key bg)
(declare (ignore x y width height bg))
;; On simple backend, background fill is a no-op
(values))
(defmethod draw-link ((b simple-backend) x y string url
&key fg bg)
(declare (ignore url fg bg))
(draw-text b x y string nil nil))
(defmethod draw-ellipsis ((b simple-backend) x y width
&key fg bg)
(declare (ignore x y width fg bg))
(backend-write b "..."))
#+END_SRC

169
org/box-renderable.org Normal file
View File

@@ -0,0 +1,169 @@
#+TITLE: cl-tui Box Renderable — v0.2.0
#+STARTUP: content
#+FILETAGS: :cl-tui:components:v0.2.0:
#+OPTIONS: ^:nil
* Box Renderable
The Box renderable draws a bordered rectangle with optional title and background
fill. It is the first renderable type and the foundation for all container
components (dialog, panel, group).
A Box has a =layout-node= slot for positioning via the layout engine. Its
=render-box= method dispatches through the backend protocol.
** Contract
- =(make-box &key border-style title title-align fg bg)= → box
Create a Box with optional border style, title, and colors.
- =(render-box box backend)= → nil
Render the box at its computed layout position. Draws background fill,
border, and title if configured.
- =(box-layout-node box)= → layout-node
Access the underlying layout-node for positioning.
** Tests
#+BEGIN_SRC lisp
(defpackage :cl-tui-box-test
(:use :cl :fiveam :cl-tui.backend :cl-tui.layout)
(:export #:run-tests))
(in-package :cl-tui-box-test)
(def-suite box-suite :description "Box renderable tests")
(in-suite box-suite)
(defun run-tests ()
(let ((result (run 'box-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
(defun make-capturing-backend ()
(let* ((s (make-string-output-stream))
(b (make-modern-backend :output-stream s)))
(values b s)))
(test box-creates-with-defaults
"A box created with no arguments has reasonable defaults"
(let ((b (make-box)))
(is (typep b 'box))
(is (typep (box-layout-node b) 'layout-node))))
(test box-renders-border
"A box with border draws border characters"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style :single :width 10 :height 5)))
(compute-layout (box-layout-node bx) 10 5)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "┌" out) "top-left corner")
(is (search "┐" out) "top-right corner")
(is (search "└" out) "bottom-left corner")
(is (search "┘" out) "bottom-right corner")))))
(test box-renders-background
"A box with background color fills interior"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :bg :red :width 5 :height 3)))
(compute-layout (box-layout-node bx) 5 3)
(render-box bx b)
(let ((out (get-output-stream-string s)))
;; Should contain SGR background escape for red
(is (search "48;2;255;0;0" out) "SGR background should be red")
(is (search "┌" out) "border with background")))))
(test box-renders-title
"A box with title renders the title text"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :title "Hello" :width 12 :height 3)))
(compute-layout (box-layout-node bx) 12 3)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "Hello" out) "title text should appear")))))
(test box-without-border
"A box with border-style nil draws no border"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style nil :bg :red :width 5 :height 3)))
(compute-layout (box-layout-node bx) 5 3)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "48;2;255;0;0" out) "background still renders")
;; No border chars
(is-false (search "┌" out) "no top-left corner")))))
(test box-zero-size
"A zero-size box renders nothing"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style :single :width 0 :height 0)))
(compute-layout (box-layout-node bx) 0 0)
(render-box bx b)
(is (string= (get-output-stream-string s) "")
"zero-size box produces no output"))))
(test box-minimum-size
"A box with minimum non-zero size still renders"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style :single :width 2 :height 2)))
(compute-layout (box-layout-node bx) 2 2)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "┌" out) "2x2 box still has borders")))))
#+END_SRC
** Implementation
#+BEGIN_SRC lisp
(in-package :cl-tui.box)
(defclass box ()
((layout-node :initform (make-layout-node) :accessor box-layout-node
:initarg :layout-node)
(border-style :initform :single :initarg :border-style
:accessor box-border-style)
(title :initform nil :initarg :title :accessor box-title)
(title-align :initform :left :initarg :title-align
:accessor box-title-align)
(fg :initform nil :initarg :fg :accessor box-fg)
(bg :initform nil :initarg :bg :accessor box-bg)))
(defun make-box (&key (border-style :single) title
(title-align :left) fg bg
width height)
(make-instance 'box
:border-style border-style
:title title
:title-align title-align
:fg fg
:bg bg
:layout-node (make-layout-node
:width width
:height height
:direction :column)))
(defun render-box (box backend)
"Render BOX at its computed layout position using BACKEND."
(let ((ln (box-layout-node box))
(bs (box-border-style box))
(title (box-title box))
(fg (box-fg box))
(bg (box-bg box)))
(let ((x (layout-node-x ln))
(y (layout-node-y ln))
(w (layout-node-width ln))
(h (layout-node-height ln)))
(when (and (zerop w) (zerop h))
(return-from render-box (values)))
(when bg
(draw-rect backend x y w h :bg bg))
(when bs
(draw-border backend x y w h
:style bs :fg fg :bg bg
:title title
:title-align (box-title-align box)))
(when (and title bs)
;; Title is rendered by draw-border — nothing extra needed
(values)))))
#+END_SRC

View File

@@ -1,248 +0,0 @@
#+TITLE: Layout Composable API
#+STARTUP: content
#+FILETAGS: :cl-tui:layout-composable:v010:
* Layout Composable API
Convenience macros for building layout trees declaratively. Each macro
creates a =layout-node=, applies style properties, and inserts child nodes.
Dependencies: =layout-primitives=.
** Contract
- =(vbox &key width height flex-grow flex-shrink flex-basis align justify gap
padding margin children ...)= → layout-node ::
Creates a column-direction container. All =children= are
layout-node instances, or plain non-node values are skipped.
- =(hbox &key width height flex-grow flex-shrink flex-basis align justify gap
padding margin children ...)= → layout-node ::
Creates a row-direction container.
- =(overlay base child &key top right bottom left)= → layout-node ::
Creates a container with a relative base and an absolute-positioned child
overlaid on top.
- =(spacer &key grow)= → layout-node ::
Creates an empty flexible spacer that fills available space.
* Package
#+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :cffi :silent t)
(ql:quickload :trivial-garbage :silent t))
(defpackage :cl-tui.layout-composable
(:use :cl :cl-tui.layout-primitives)
(:export
#:vbox
#:hbox
#:overlay
#:spacer))
(in-package :cl-tui.layout-composable)
#+end_src
* Internal Helpers
#+begin_src lisp
(defun apply-common-props (node &key width height flex-grow flex-shrink flex-basis
align justify gap padding margin
&allow-other-keys)
"Apply the shared style properties to a layout-node."
(when (or width height)
(layout-node-set-dimension node (or width 0) (or height 0)))
(when (or flex-grow flex-shrink flex-basis)
(layout-node-set-flex node :grow flex-grow :shrink flex-shrink :basis flex-basis))
(when align
(apply #'layout-node-set-align node align))
(when justify
(layout-node-set-justify node justify))
(when gap
(apply #'layout-node-set-gap node gap))
(when padding
(apply #'layout-node-set-padding node padding))
(when margin
(apply #'layout-node-set-margin node margin)))
(defun add-children (parent children)
"Add each child in CHILDREN to PARENT. Non-node values are skipped."
(dolist (child children)
(when (typep child 'layout-node)
(layout-node-add-child parent child))))
(defun make-props-list (args)
"Extract all properties except :children from ARGS plist."
(loop for (k v) on args by #'cddr
unless (eq k :children)
append (list k v)))
#+end_src
* vbox — Vertical Box
#+begin_src lisp
(defmacro vbox (&rest args &key children &allow-other-keys)
"Create a column-direction container with CHILDREN stacked vertically."
(declare (ignore children))
(let* ((node (gensym "VBOX"))
(props (make-props-list args)))
`(let ((,node (make-layout-node)))
(layout-node-set-direction ,node :column)
(apply #'cl-tui.layout-composable::apply-common-props ,node ',props)
(cl-tui.layout-composable::add-children ,node (list ,@children))
,node)))
#+end_src
* hbox — Horizontal Box
#+begin_src lisp
(defmacro hbox (&rest args &key children &allow-other-keys)
"Create a row-direction container with CHILDREN laid out horizontally."
(declare (ignore children))
(let* ((node (gensym "HBOX"))
(props (make-props-list args)))
`(let ((,node (make-layout-node)))
(layout-node-set-direction ,node :row)
(apply #'cl-tui.layout-composable::apply-common-props ,node ',props)
(cl-tui.layout-composable::add-children ,node (list ,@children))
,node)))
#+end_src
* overlay — Absolute Overlay
#+begin_src lisp
(defmacro overlay (base child &key top right bottom left)
"Create a container with BASE as the relative foundation and CHILD
positioned absolutely on top."
(let ((node (gensym "OVERLAY")))
`(let ((,node (make-layout-node)))
(layout-node-set-position ,node :relative)
(layout-node-add-child ,node ,base)
(layout-node-set-position ,child :absolute
,@(when top `(:top ,top))
,@(when right `(:right ,right))
,@(when bottom `(:bottom ,bottom))
,@(when left `(:left ,left)))
(layout-node-add-child ,node ,child)
,node)))
#+end_src
* spacer — Flex Spacer
#+begin_src lisp
(defun spacer (&key (grow 0))
"Create an empty spacer node that fills available space via flex-grow."
(let ((node (make-layout-node)))
(when (> grow 0)
(layout-node-set-flex node :grow grow))
node))
#+end_src
* Test Suite
#+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :cl-tui.layout-composable-tests
(:use :cl :fiveam)
(:import-from :cl-tui.layout-composable
#:vbox #:hbox #:overlay #:spacer)
(:import-from :cl-tui.layout-primitives
#:layout-node #:layout-node-ptr #:layout-calculate
#:make-layout-node #:layout-node-set-dimension)
(:import-from :cl-tui.yoga-ffi
#:yg-node-layout-get-left
#:yg-node-layout-get-top
#:yg-node-layout-get-width
#:yg-node-layout-get-height
#:yg-node-get-child))
(in-package :cl-tui.layout-composable-tests)
(defun node-x (n) (yg-node-layout-get-left (layout-node-ptr n)))
(defun node-y (n) (yg-node-layout-get-top (layout-node-ptr n)))
(defun node-w (n) (yg-node-layout-get-width (layout-node-ptr n)))
(defun node-h (n) (yg-node-layout-get-height (layout-node-ptr n)))
(defun child-x (p) (yg-node-layout-get-left p))
(defun child-y (p) (yg-node-layout-get-top p))
(defun child-w (p) (yg-node-layout-get-width p))
(defun child-h (p) (yg-node-layout-get-height p))
(defun nth-child (node n)
(yg-node-get-child (layout-node-ptr node) n))
(defun layout-dummy (w h)
(let ((n (make-layout-node)))
(layout-node-set-dimension n w h)
n))
(fiveam:def-suite layout-composable-suite
:description "Composable API macro verification")
(fiveam:in-suite layout-composable-suite)
(fiveam:test test-vbox-stacks-children
"Contract: vbox stacks children vertically."
(let* ((root (vbox :width 100 :height 200
:children ((layout-dummy 100 50)
(layout-dummy 100 50)))))
(layout-calculate root 100 200)
(let ((c1 (nth-child root 0))
(c2 (nth-child root 1)))
(fiveam:is (= 0.0 (child-y c1)))
(fiveam:is (= 50.0 (child-y c2))))))
(fiveam:test test-hbox-lays-out-horizontally
"Contract: hbox places children horizontally."
(let* ((root (hbox :width 200 :height 100
:children ((layout-dummy 80 50)
(layout-dummy 80 50)))))
(layout-calculate root 200 100)
(let ((c1 (nth-child root 0))
(c2 (nth-child root 1)))
(fiveam:is (= 0.0 (child-x c1)))
(fiveam:is (= 80.0 (child-x c2))))))
(fiveam:test test-spacer-flex-grow
"Contract: spacer with flex-grow expands to fill space."
(let* ((root (hbox :width 200 :height 100
:children ((layout-dummy 50 50)
(spacer :grow 1)
(layout-dummy 50 50)))))
(layout-calculate root 200 100)
(let ((c1 (nth-child root 0))
(c2 (nth-child root 1))
(c3 (nth-child root 2)))
(fiveam:is (= 0.0 (child-x c1)))
(fiveam:is (= 50.0 (child-w c1)))
(fiveam:is (= 100.0 (child-w c2))))))
(fiveam:test test-overlay-absolute-position
"Contract: overlay positions an absolute child over a relative base."
(let* ((base (layout-dummy 100 100))
(child (layout-dummy 30 30))
(root (overlay base child :top 10 :left 20)))
(layout-calculate root 200 200)
(fiveam:is (= 20.0 (node-x child)))
(fiveam:is (= 10.0 (node-y child)))))
(fiveam:test test-vbox-align-justify
"Contract: vbox accepts align and justify keywords."
(let* ((root (vbox :width 200 :height 100
:align (:items :center)
:justify :center
:children ((layout-dummy 50 50)))))
(layout-calculate root 200 100)
(let ((c (nth-child root 0)))
(fiveam:is (= 25.0 (child-y c)))
(fiveam:is (= 75.0 (child-x c))))))
(fiveam:test test-vbox-padding
"Contract: vbox padding offsets children."
(let* ((root (vbox :width 200 :height 100
:padding (:all 10)
:children ((layout-dummy 180 80)))))
(layout-calculate root 200 100)
(let ((c (nth-child root 0)))
(fiveam:is (= 10.0 (child-x c)))
(fiveam:is (= 10.0 (child-y c))))))
#+end_src

591
org/layout-engine.org Normal file
View File

@@ -0,0 +1,591 @@
#+TITLE: cl-tui Layout Engine — v0.0.3
#+STARTUP: content
#+FILETAGS: :cl-tui:layout:v0.0.3:
#+OPTIONS: ^:nil
* Layout Engine
Pure Common Lisp Flexbox layout engine. No Yoga, no CFFI, no external
dependencies. A two-pass constraint solver that handles direction, wrap,
grow/shrink, and absolute positioning. Terminal resolution (~200x80)
means a full Yoga FFI binding is unnecessary — ~200 lines of CL math.
** Contract
*** Layout Node
- =(make-layout-node &key direction wrap grow shrink basis
align-items justify-content padding margin border gap
position-type position-offset width height)= → layout-node
Create a layout node with the given properties.
Properties:
- =:direction==:row=, =:column=, =:row-reverse=, =:column-reverse=
- =:wrap==:nowrap=, =:wrap=, =:wrap-reverse=
- =:grow= — flex grow factor (0 = no grow)
- =:shrink= — flex shrink factor (1 = default)
- =:basis= — flex basis (:auto or integer)
- =:align-items==:flex-start=, =:center=, =:flex-end=, =:stretch=
- =:justify-content==:flex-start=, =:center=, =:flex-end=,
=:space-between=, =:space-around=, =:space-evenly=
- =:padding=, =:margin=, =:border= — plist with =:top=, =:right=,
=:bottom=, =:left=, =:x=, =:y=
- =:gap= — plist with =:row= and =:column=, or single integer
- =:position-type==:relative= or =:absolute=
- =:position-offset= — plist with =:top=, =:right=, =:bottom=, =:left=
- =:width=, =:height= — fixed dimensions (nil = auto)
*** Node Manipulation
- =(layout-node-add-child parent child)= → child
Add CHILD as the last child of PARENT. Sets child's parent.
- =(layout-node-remove-child parent child)= → child
Remove CHILD from PARENT's children list.
- =(layout-node-children node)= → list
Return list of child nodes.
*** Layout Calculation
- =(compute-layout root available-width available-height)= → root
Run the layout algorithm on the entire tree. Populates each node's
computed =:x=, =:y=, =:width=, =:height= slots.
Algorithm:
1. Resolve styles (inherit, defaults)
2. First pass (column direction): distribute Y positions
3. Second pass (row direction): distribute X positions
4. Resolve absolute-positioned children
5. Handle wrap (overflow → new row/column)
*** Composed Value Access
- =(layout-node-x node)= → integer
- =(layout-node-y node)= → integer
- =(layout-node-width node)= → integer
- =(layout-node-height node)= → integer
*** Composable Macros
- =(vbox (&key grow shrink basis align-items justify-content
padding margin border gap width height)
&body children)= → layout-node
Create a vertical column container.
- =(hbox (&key grow shrink basis align-items justify-content
padding margin border gap width height)
&body children)= → layout-node
Create a horizontal row container.
- =(spacer &key grow)= → layout-node
Create an empty flex spacer.
** Test Suite
#+BEGIN_SRC lisp
(defpackage :cl-tui-layout-test
(:use :cl :fiveam :cl-tui.layout)
(:export #:run-tests))
(in-package :cl-tui-layout-test)
(def-suite layout-suite :description "Layout engine tests")
(in-suite layout-suite)
(defun run-tests ()
(let ((result (run 'layout-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
;; ── Node Creation ──────────────────────────────────────────────
(test make-layout-node-defaults
"make-layout-node creates a node with default values"
(let ((n (make-layout-node)))
(is (typep n 'layout-node))
(is (eql (layout-node-direction n) :column))))
(test make-layout-node-row
"make-layout-node with :row direction"
(let ((n (make-layout-node :direction :row)))
(is (eql (layout-node-direction n) :row))))
;; ── Tree Building ──────────────────────────────────────────────
(test add-child-sets-parent
"layout-node-add-child sets parent on child"
(let ((parent (make-layout-node))
(child (make-layout-node)))
(layout-node-add-child parent child)
(is (eql (slot-value child 'parent) parent))
(is (= (length (slot-value parent 'children)) 1))))
(test remove-child-clears-parent
"layout-node-remove-child clears parent slot"
(let ((parent (make-layout-node))
(child (make-layout-node)))
(layout-node-add-child parent child)
(layout-node-remove-child parent child)
(is (null (slot-value child 'parent)))
(is (= (length (slot-value parent 'children)) 0))))
;; ── Simple Layout — Column ─────────────────────────────────────
(test column-two-children-vertical
"column stacks children vertically"
(let* ((root (make-layout-node :direction :column))
(c1 (make-layout-node :height 3))
(c2 (make-layout-node :height 5)))
(layout-node-add-child root c1)
(layout-node-add-child root c2)
(compute-layout root 20 20)
(is (= (layout-node-y c1) 0))
(is (= (layout-node-height c1) 3))
(is (= (layout-node-y c2) 3))
(is (= (layout-node-height c2) 5))))
(test row-two-children-horizontal
"row places children side by side"
(let* ((root (make-layout-node :direction :row))
(c1 (make-layout-node :width 10))
(c2 (make-layout-node :width 5)))
(layout-node-add-child root c1)
(layout-node-add-child root c2)
(compute-layout root 20 10)
(is (= (layout-node-x c1) 0))
(is (= (layout-node-width c1) 10))
(is (= (layout-node-x c2) 10))
(is (= (layout-node-width c2) 5))))
;; ── Flex Grow ──────────────────────────────────────────────────
(test flex-grow-distributes-space
"flex-grow distributes remaining space proportionally"
(let* ((root (make-layout-node :direction :row :width 20))
(c1 (make-layout-node :width 4 :grow 1))
(c2 (make-layout-node :width 4 :grow 2)))
(layout-node-add-child root c1)
(layout-node-add-child root c2)
(compute-layout root 20 10)
;; total fixed = 8, available = 12, c1 gets 4, c2 gets 8
(is (= (layout-node-width c1) 8))
(is (= (layout-node-width c2) 12))))
(test flex-grow-single-child
"single child with flex-grow fills remaining space"
(let* ((root (make-layout-node :direction :row :width 20))
(c (make-layout-node :width 5 :grow 1)))
(layout-node-add-child root c)
(compute-layout root 20 10)
(is (= (layout-node-width c) 20))))
;; ── Flex Shrink ────────────────────────────────────────────────
(test flex-shrink-reduces-overflow
"flex-shrink reduces children when content overflows"
(let* ((root (make-layout-node :direction :row :width 10))
(c1 (make-layout-node :width 8 :shrink 1))
(c2 (make-layout-node :width 8 :shrink 1)))
(layout-node-add-child root c1)
(layout-node-add-child root c2)
(compute-layout root 10 10)
;; Total = 16, available = 10, overflow = 6, each shrinks by 3
(is (= (layout-node-width c1) 5))
(is (= (layout-node-width c2) 5))))
;; ── Absolute Positioning ───────────────────────────────────────
(test absolute-positioned-child
"absolute child positions relative to parent"
(let* ((root (make-layout-node :width 20 :height 20))
(c (make-layout-node :position-type :absolute
:position-offset '(:top 2 :left 3)
:width 5 :height 5)))
(layout-node-add-child root c)
(compute-layout root 20 20)
(is (= (layout-node-x c) 3))
(is (= (layout-node-y c) 2))))
;; ── Padding ────────────────────────────────────────────────────
(test padding-reduces-content-area
"padding reduces available area for children"
(let* ((root (make-layout-node :direction :column
:padding '(:top 1 :left 1 :bottom 1 :right 1)))
(c (make-layout-node :height 3)))
(layout-node-add-child root c)
(compute-layout root 20 10)
(is (= (layout-node-x c) 1))
(is (= (layout-node-y c) 1))
;; content height = 10 - 2 = 8, child height = 3
(is (= (layout-node-height c) 3))))
;; ── Gap ────────────────────────────────────────────────────────
(test gap-between-children
"gap adds spacing between children"
(let* ((root (make-layout-node :direction :column :gap 2))
(c1 (make-layout-node :height 3))
(c2 (make-layout-node :height 3)))
(layout-node-add-child root c1)
(layout-node-add-child root c2)
(compute-layout root 20 20)
(is (= (layout-node-y c1) 0))
(is (= (layout-node-y c2) 5)))) ; 3 + 2 gap
;; ── Composable Macros ──────────────────────────────────────────
(test vbox-macro
"vbox creates a column container with children"
(let* ((root (vbox () (make-layout-node :height 3) (make-layout-node :height 5))))
(compute-layout root 20 20)
(is (= (length (layout-node-children root)) 2))
(is (= (layout-node-y (elt (layout-node-children root) 1)) 3))))
(test hbox-macro
"hbox creates a row container with children"
(let* ((root (hbox () (make-layout-node :width 5) (make-layout-node :width 3))))
(compute-layout root 20 10)
(is (= (length (layout-node-children root)) 2))
(is (= (layout-node-x (elt (layout-node-children root) 1)) 5))))
(test spacer-takes-grow
"spacer with grow fills remaining space"
(let* ((root (hbox (:width 20)
(make-layout-node :width 5)
(spacer :grow 1)
(make-layout-node :width 5))))
(compute-layout root 20 10)
(let ((children (layout-node-children root)))
(is (= (layout-node-x (elt children 2)) 15))
(is (= (layout-node-width (elt children 1)) 10)))))
;; ── Nested Layout ──────────────────────────────────────────────
(test nested-vbox-in-hbox
"nested vbox in hbox produces correct leaf positions"
(let* ((sidebar (vbox (:width 5 :height 10)
(make-layout-node :height 3)
(make-layout-node :height 7)))
(main (vbox (:grow 1 :height 10)
(make-layout-node :height 2)
(make-layout-node :grow 1)))
(root (hbox (:width 30 :height 10)
sidebar main)))
(compute-layout root 30 10)
;; sidebar takes 5 cols, main takes 25 cols (grows)
(is (= (layout-node-width sidebar) 5))
(is (>= (layout-node-width main) 20))
;; sidebar children positioned correctly
(let ((sidebar-children (layout-node-children sidebar)))
(is (= (layout-node-y (elt sidebar-children 0)) 0))
(is (= (layout-node-y (elt sidebar-children 1)) 3)))))
#+END_SRC
** Implementation
*** Package
#+BEGIN_SRC lisp
(defpackage :cl-tui.layout
(:use :cl)
(:export
;; Classes
#:layout-node
;; Construction
#:make-layout-node
;; Tree manipulation
#:layout-node-add-child #:layout-node-remove-child
#:layout-node-children
;; Computed values
#:layout-node-x #:layout-node-y
#:layout-node-width #:layout-node-height
#:layout-node-direction
;; Layout
#:compute-layout
;; Macros
#:vbox #:hbox #:spacer))
(in-package :cl-tui.layout)
#+END_SRC
*** Layout Node Class
#+BEGIN_SRC lisp
(defclass layout-node ()
;; Tree structure
((parent :initform nil :accessor layout-node-parent)
(children :initform '() :accessor layout-node-children)
;; Computed layout (populated by compute-layout)
(x :initform 0 :accessor layout-node-x)
(y :initform 0 :accessor layout-node-y)
(width :initform 0 :accessor layout-node-width)
(height :initform 0 :accessor layout-node-height)
;; Flex properties
(direction :initform :column
:initarg :direction :accessor layout-node-direction)
(wrap :initform :nowrap
:initarg :wrap :accessor layout-node-wrap)
(grow :initform 0 :initarg :grow
:accessor layout-node-grow)
(shrink :initform 1 :initarg :shrink
:accessor layout-node-shrink)
(basis :initform :auto :initarg :basis
:accessor layout-node-basis)
(align-items :initform :stretch :initarg :align-items
:accessor layout-node-align-items)
(justify-content :initform :flex-start :initarg :justify-content
:accessor layout-node-justify-content)
;; Box model
(padding :initform '(:top 0 :right 0 :bottom 0 :left 0)
:initarg :padding :accessor layout-node-padding)
(margin :initform '(:top 0 :right 0 :bottom 0 :left 0)
:initarg :margin :accessor layout-node-margin)
(border :initform '(:top 0 :right 0 :bottom 0 :left 0)
:initarg :border :accessor layout-node-border)
(gap :initform 0 :initarg :gap :accessor layout-node-gap)
;; Position
(position-type :initform :relative :initarg :position-type
:accessor layout-node-position-type)
(position-offset :initform nil :initarg :position-offset
:accessor layout-node-position-offset)
;; Fixed dimensions (nil = auto)
(fixed-width :initform nil :initarg :width
:accessor layout-node-fixed-width)
(fixed-height :initform nil :initarg :height
:accessor layout-node-fixed-height)))
#+END_SRC
*** Constructor
#+BEGIN_SRC lisp
(defun make-layout-node (&key direction wrap grow shrink basis
align-items justify-content
padding margin border gap
position-type position-offset
width height)
(make-instance 'layout-node
:direction (or direction :column)
:wrap (or wrap :nowrap)
:grow (or grow 0)
:shrink (or shrink 1)
:basis (or basis :auto)
:align-items (or align-items :stretch)
:justify-content (or justify-content :flex-start)
:padding (normalize-box padding)
:margin (normalize-box margin)
:border (normalize-box border)
:gap gap
:position-type (or position-type :relative)
:position-offset position-offset
:width width
:height height))
(defun normalize-box (spec)
"Convert a box property spec to ( :top N :right N :bottom N :left N )."
(cond ((null spec) '(:top 0 :right 0 :bottom 0 :left 0))
((numberp spec) `(:top ,spec :right ,spec :bottom ,spec :left ,spec))
((getf spec :top) spec)
(t `(:top 0 :right 0 :bottom 0 :left 0))))
#+END_SRC
*** Tree Manipulation
#+BEGIN_SRC lisp
(defun layout-node-add-child (parent child)
(setf (slot-value child 'parent) parent)
(push child (slot-value parent 'children))
child)
(defun layout-node-remove-child (parent child)
(setf (slot-value child 'parent) nil)
(setf (slot-value parent 'children)
(delete child (slot-value parent 'children)))
child)
(defun box-edge (box edge)
"Get a specific edge value from a box plist."
(or (getf box edge) 0))
#+END_SRC
*** Constraint Solver
#+BEGIN_SRC lisp
(defun compute-layout (root available-width available-height)
"Run the layout algorithm on the entire tree."
(labels
((resolve-main-size (node)
;; Get the main-axis size from fixed dimension or basis
(if (eql (layout-node-direction node) :row)
(layout-node-fixed-width node)
(layout-node-fixed-height node)))
(resolve-cross-size (node)
(if (eql (layout-node-direction node) :row)
(layout-node-fixed-height node)
(layout-node-fixed-width node)))
(compute-node (node x-offset y-offset max-w max-h)
(let* ((dir (layout-node-direction node))
(pad-top (box-edge (layout-node-padding node) :top))
(pad-right (box-edge (layout-node-padding node) :right))
(pad-bottom (box-edge (layout-node-padding node) :bottom))
(pad-left (box-edge (layout-node-padding node) :left))
(pad-x (+ pad-left pad-right))
(pad-y (+ pad-top pad-bottom))
(margin-top (box-edge (layout-node-margin node) :top))
(margin-left (box-edge (layout-node-margin node) :left))
(gap (layout-node-gap node))
;; Content area (minus padding)
(content-w (max 0 (- max-w pad-x)))
(content-h (max 0 (- max-h pad-y)))
(children (reverse (layout-node-children node)))
(is-row (eql dir :row))
(main-axis (if is-row :width :height))
(cross-axis (if is-row :height :width))
;; First pass: measure children
(child-count (length children)))
;; Set own position
(setf (layout-node-x node) (+ x-offset margin-left pad-left)
(layout-node-y node) (+ y-offset margin-top pad-top))
(when (plusp child-count)
;; Calculate main-axis sizes
(let* ((fixed-sizes (mapcar (lambda (c)
(or (resolve-main-size c)
(if is-row
(or (layout-node-fixed-width c)
(round content-w child-count))
(or (layout-node-fixed-height c)
(round content-h child-count)))))
children))
(total-fixed (reduce #'+ fixed-sizes))
(total-grow (reduce #'+ (mapcar #'layout-node-grow children)))
(total-shrink (reduce #'+ (mapcar #'layout-node-shrink children)))
(remaining (- (if is-row content-w content-h) total-fixed))
(available-without-gap (if is-row content-w content-h))
(gap-total (* gap (max 0 (1- child-count))))
;; Account for gap in available space
(available (- available-without-gap gap-total))
(overflow (- total-fixed available))
;; Distribute grow/shrink
(final-sizes
(mapcar (lambda (child fixed)
(let* ((g (layout-node-grow child))
(s (layout-node-shrink child))
(size fixed))
(when (and (plusp remaining) (plusp total-grow))
(incf size (round (* remaining (/ g total-grow)))))
(when (and (plusp overflow) (plusp total-shrink))
(decf size (round (* overflow (/ s total-shrink)))))
(max 0 size)))
children fixed-sizes)))
;; Second pass: position children
(let ((pos 0))
(mapc (lambda (child size)
(if is-row
(progn
(setf (layout-node-width child) size
(layout-node-x child) (+ pad-left x-offset pos)
(layout-node-height child) content-h
(layout-node-y child) (+ pad-top y-offset))
(compute-node child
(layout-node-x child)
(layout-node-y child)
size content-h))
(progn
(setf (layout-node-height child) size
(layout-node-y child) (+ pad-top y-offset pos)
(layout-node-width child) content-w
(layout-node-x child) (+ pad-left x-offset))
(compute-node child
(layout-node-x child)
(layout-node-y child)
content-w size)))
(incf pos (+ size gap)))
children final-sizes))))
;; Set own size to content size
(let ((last-child (first (last children))))
(if is-row
(progn
(setf (layout-node-width node)
(if (layout-node-fixed-width node)
(layout-node-fixed-width node)
(if last-child
(+ (layout-node-x last-child)
(layout-node-width last-child)
pad-right margin-left)
max-w)))
(setf (layout-node-height node) max-h))
(progn
(setf (layout-node-height node)
(if (layout-node-fixed-height node)
(layout-node-fixed-height node)
(if last-child
(+ (layout-node-y last-child)
(layout-node-height last-child)
pad-bottom margin-top)
max-h)))
(setf (layout-node-width node) max-w))))
node))
(compute-node root 0 0 available-width available-height)
root))
#+END_SRC
*** Composable Macros
#+BEGIN_SRC lisp
(defmacro vbox ((&key grow shrink basis align-items justify-content
padding margin border gap width height)
&body children)
"Create a vertical column container."
(let ((node (gensym)))
`(let ((,node (make-layout-node
:direction :column
,@(when grow `(:grow ,grow))
,@(when shrink `(:shrink ,shrink))
,@(when basis `(:basis ,basis))
,@(when align-items `(:align-items ,align-items))
,@(when justify-content `(:justify-content ,justify-content))
,@(when padding `(:padding ,padding))
,@(when margin `(:margin ,margin))
,@(when border `(:border ,border))
,@(when gap `(:gap ,gap))
,@(when width `(:width ,width))
,@(when height `(:height ,height)))))
,@(loop for child in children collect
`(layout-node-add-child ,node ,child))
,node)))
(defmacro hbox ((&key grow shrink basis align-items justify-content
padding margin border gap width height)
&body children)
"Create a horizontal row container."
(let ((node (gensym)))
`(let ((,node (make-layout-node
:direction :row
,@(when grow `(:grow ,grow))
,@(when shrink `(:shrink ,shrink))
,@(when basis `(:basis ,basis))
,@(when align-items `(:align-items ,align-items))
,@(when justify-content `(:justify-content ,justify-content))
,@(when padding `(:padding ,padding))
,@(when margin `(:margin ,margin))
,@(when border `(:border ,border))
,@(when gap `(:gap ,gap))
,@(when width `(:width ,width))
,@(when height `(:height ,height)))))
,@(loop for child in children collect
`(layout-node-add-child ,node ,child))
,node)))
(defmacro spacer (&key grow)
"Create an empty flex spacer."
`(make-layout-node :grow ,(or grow 1)))
#+END_SRC

View File

@@ -1,608 +0,0 @@
#+TITLE: Layout Primitives
#+STARTUP: content
#+FILETAGS: :cl-tui:layout-primitives:v010:
* Layout Primitives
CLOS wrappers around the raw Yoga FFI bindings. Each =layout-node= wraps a
=YGNodeRef= with automatic finalization. Setter functions translate Lisp
keywords to Yoga enum integers, providing a safe, idiomatic Common Lisp API.
This file depends on =yoga-ffi.lisp= (the CFFI bindings). The composable API
(=vbox=, =hbox=, =overlay=, =spacer=) is in =layout-composable.org=.
** Contract
- =(make-layout-node)= → layout-node :: allocates a new Yoga node, wraps it in
a CLOS instance. The YGNodeRef is freed when the layout-node is garbage
collected (via trivial-garbage).
- =(layout-node-ptr node)= → YGNodeRef :: returns the raw C pointer for use
with raw FFI functions.
- =(layout-node-add-child parent child)= :: inserts child at the end of
parent's children list. Throws if child is nil.
- =(layout-node-set-dimension node width height)= :: sets fixed width and
height in points.
- =(layout-node-set-flex node &key grow shrink basis)= :: sets flex-grow,
flex-shrink, flex-basis. Unspecified keys are left unchanged.
- =(layout-node-set-direction node direction)= :: sets flex-direction.
direction is one of: :column :column-reverse :row :row-reverse.
- =(layout-node-set-wrap node wrap)= :: sets flex-wrap.
wrap is one of: :nowrap :wrap :wrap-reverse.
- =(layout-node-set-align node &key items self content)= :: sets align-items,
align-self, align-content. Values from: :auto, :flex-start, :center,
:flex-end, :stretch, :baseline, :space-between, :space-around, :space-evenly.
- =(layout-node-set-justify node justify)= :: sets justify-content. Values
from: :auto :flex-start :center :flex-end :space-between :space-around
:space-evenly.
- =(layout-node-set-padding node &key all top right bottom left x y)= :: sets
padding in points on specified edges. :all sets all 4 edges.
- =(layout-node-set-margin node &key all top right bottom left x y)= :: sets
margin in points.
- =(layout-node-set-gap node &key row column)= :: sets gap between children.
- =(layout-node-set-position node type &key top right bottom left)= :: sets
position type (:static :relative :absolute) and offsets.
- =(layout-node-set-border node width &key top right bottom left all)= ::
sets border width on edges.
- =(layout-node-set-overflow node overflow)= :: sets overflow mode. Values:
:visible :hidden :scroll.
- =(layout-node-set-display node display)= :: sets display mode. Values: :flex
:none.
- =(layout-node-set-aspect-ratio node ratio)= :: sets aspect ratio.
- =(layout-calculate root width height &optional (direction :ltr))= :: runs
Yoga's calculateLayout, populating each node's computed x/y/w/h.
* Package and Dependencies
#+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :cffi :silent t)
(ql:quickload :trivial-garbage :silent t))
(defpackage :cl-tui.layout-primitives
(:use :cl)
(:import-from :cl-tui.yoga-ffi
#:load-yoga
#:yg-node-new
#:yg-node-free
#:yg-node-insert-child
#:yg-node-remove-child
#:yg-node-get-child-count
#:yg-node-calculate-layout
#:yg-node-layout-get-left
#:yg-node-layout-get-top
#:yg-node-layout-get-width
#:yg-node-layout-get-height
#:yg-node-layout-get-right
#:yg-node-layout-get-bottom
#:yg-node-style-set-direction
#:yg-node-style-set-flex-direction
#:yg-node-style-set-justify-content
#:yg-node-style-set-align-items
#:yg-node-style-set-align-self
#:yg-node-style-set-align-content
#:yg-node-style-set-flex-wrap
#:yg-node-style-set-position-type
#:yg-node-style-set-flex-grow
#:yg-node-style-set-flex-shrink
#:yg-node-style-set-flex-basis
#:yg-node-style-set-flex-basis-auto
#:yg-node-style-set-overflow
#:yg-node-style-set-display
#:yg-node-style-set-width
#:yg-node-style-set-width-auto
#:yg-node-style-set-height
#:yg-node-style-set-height-auto
#:yg-node-style-set-min-width
#:yg-node-style-set-min-height
#:yg-node-style-set-max-width
#:yg-node-style-set-max-height
#:yg-node-style-set-aspect-ratio
#:yg-node-style-set-padding
#:yg-node-style-set-margin
#:yg-node-style-set-margin-auto
#:yg-node-style-set-border
#:yg-node-style-set-gap
#:yg-node-style-set-position
;; enum constants
#:+yg-flex-direction-column+
#:+yg-flex-direction-column-reverse+
#:+yg-flex-direction-row+
#:+yg-flex-direction-row-reverse+
#:+yg-wrap-nowrap+
#:+yg-wrap-wrap+
#:+yg-wrap-wrap-reverse+
#:+yg-justify-auto+
#:+yg-justify-flex-start+
#:+yg-justify-center+
#:+yg-justify-flex-end+
#:+yg-justify-space-between+
#:+yg-justify-space-around+
#:+yg-justify-space-evenly+
#:+yg-align-auto+
#:+yg-align-flex-start+
#:+yg-align-center+
#:+yg-align-flex-end+
#:+yg-align-stretch+
#:+yg-align-baseline+
#:+yg-align-space-between+
#:+yg-align-space-around+
#:+yg-align-space-evenly+
#:+yg-position-type-static+
#:+yg-position-type-relative+
#:+yg-position-type-absolute+
#:+yg-overflow-visible+
#:+yg-overflow-hidden+
#:+yg-overflow-scroll+
#:+yg-display-flex+
#:+yg-display-none+
#:+yg-edge-left+
#:+yg-edge-top+
#:+yg-edge-right+
#:+yg-edge-bottom+
#:+yg-edge-all+
#:+yg-edge-start+
#:+yg-edge-end+
#:+yg-edge-horizontal+
#:+yg-edge-vertical+
#:+yg-gutter-column+
#:+yg-gutter-row+
#:+yg-gutter-all+
#:+yg-direction-inherit+
#:+yg-direction-ltr+
#:+yg-direction-rtl+)
(:export
#:layout-node
#:layout-node-ptr
#:make-layout-node
#:layout-node-add-child
#:layout-node-set-dimension
#:layout-node-set-flex
#:layout-node-set-direction
#:layout-node-set-wrap
#:layout-node-set-align
#:layout-node-set-justify
#:layout-node-set-padding
#:layout-node-set-margin
#:layout-node-set-gap
#:layout-node-set-position
#:layout-node-set-border
#:layout-node-set-overflow
#:layout-node-set-display
#:layout-node-set-aspect-ratio
#:layout-calculate))
(in-package :cl-tui.layout-primitives)
#+end_src
* Enum Translation Tables
#+begin_src lisp
;; Keyword → integer translation tables. Used by setter functions
;; so callers use (:flex-start) instead of (+yg-justify-flex-start+).
(defparameter *flex-direction-map*
'((:column . 0) (:column-reverse . 1) (:row . 2) (:row-reverse . 3)))
(defparameter *wrap-map*
'((:nowrap . 0) (:wrap . 1) (:wrap-reverse . 2)))
(defparameter *justify-map*
'((:auto . 0) (:flex-start . 1) (:center . 2) (:flex-end . 3)
(:space-between . 4) (:space-around . 5) (:space-evenly . 6)))
(defparameter *align-map*
'((:auto . 0) (:flex-start . 1) (:center . 2) (:flex-end . 3)
(:stretch . 4) (:baseline . 5) (:space-between . 6) (:space-around . 7)
(:space-evenly . 8)))
(defparameter *position-type-map*
'((:static . 0) (:relative . 1) (:absolute . 2)))
(defparameter *overflow-map*
'((:visible . 0) (:hidden . 1) (:scroll . 2)))
(defparameter *display-map*
'((:flex . 0) (:none . 1)))
(defparameter *edge-map*
'((:left . 0) (:top . 1) (:right . 2) (:bottom . 3)
(:start . 4) (:end . 5) (:horizontal . 6) (:vertical . 7) (:all . 8)))
(defparameter *direction-map*
'((:inherit . 0) (:ltr . 1) (:rtl . 2)))
(defun resolve-enum (map keyword)
"Look up KEYWORD in MAP (an alist). Throws if not found."
(or (cdr (assoc keyword map))
(error "Unknown enum keyword ~a" keyword)))
#+end_src
* Layout Node Class
#+begin_src lisp
(defclass layout-node ()
((ptr :initarg :ptr :reader layout-node-ptr
:documentation "Raw YGNodeRef pointer")))
(defmethod print-object ((node layout-node) stream)
(print-unreadable-object (node stream :type t)
(format stream "~a" (layout-node-ptr node))))
(defun make-layout-node ()
"Allocate a new Yoga node and wrap it in a layout-node."
(let ((node (make-instance 'layout-node :ptr (yg-node-new))))
(tg:finalize node (lambda () (yg-node-free (layout-node-ptr node))))
node))
(defun layout-node-add-child (parent child)
"Insert CHILD at the end of PARENT's children list."
(let ((count (yg-node-get-child-count (layout-node-ptr parent))))
(yg-node-insert-child (layout-node-ptr parent) (layout-node-ptr child) count)))
#+end_src
* Dimension Setters
#+begin_src lisp
(defun layout-node-set-dimension (node width height)
"Set fixed width and height in points."
(yg-node-style-set-width (layout-node-ptr node) (coerce width 'single-float))
(yg-node-style-set-height (layout-node-ptr node) (coerce height 'single-float)))
(defun layout-node-set-flex (node &key grow shrink basis)
"Set flex properties. Unspecified keys are left unchanged."
(let ((p (layout-node-ptr node)))
(when grow (yg-node-style-set-flex-grow p (coerce grow 'single-float)))
(when shrink (yg-node-style-set-flex-shrink p (coerce shrink 'single-float)))
(when basis (yg-node-style-set-flex-basis p (coerce basis 'single-float)))))
(defun layout-node-set-aspect-ratio (node ratio)
"Set aspect ratio (width/height)."
(yg-node-style-set-aspect-ratio (layout-node-ptr node) (coerce ratio 'single-float)))
#+end_src
* Layout Direction and Wrapping
#+begin_src lisp
(defun layout-node-set-direction (node direction)
"Set flex-direction. DIRECTION is :column, :column-reverse, :row, or :row-reverse."
(yg-node-style-set-flex-direction
(layout-node-ptr node)
(resolve-enum *flex-direction-map* direction)))
(defun layout-node-set-wrap (node wrap)
"Set flex-wrap. WRAP is :nowrap, :wrap, or :wrap-reverse."
(yg-node-style-set-flex-wrap
(layout-node-ptr node)
(resolve-enum *wrap-map* wrap)))
#+end_src
* Alignment and Justification
#+begin_src lisp
(defun layout-node-set-align (node &key items self content)
"Set align-items, align-self, align-content. Values are keywords like :flex-start."
(let ((p (layout-node-ptr node)))
(when items (yg-node-style-set-align-items p (resolve-enum *align-map* items)))
(when self (yg-node-style-set-align-self p (resolve-enum *align-map* self)))
(when content (yg-node-style-set-align-content p (resolve-enum *align-map* content)))))
(defun layout-node-set-justify (node justify)
"Set justify-content. JUSTIFY is :flex-start, :center, :flex-end, :space-between, etc."
(yg-node-style-set-justify-content
(layout-node-ptr node)
(resolve-enum *justify-map* justify)))
#+end_src
* Position Type and Offsets
#+begin_src lisp
(defun layout-node-set-position (node type &key top right bottom left)
"Set position type and offsets. TYPE is :static, :relative, or :absolute."
(let ((p (layout-node-ptr node)))
(yg-node-style-set-position-type p (resolve-enum *position-type-map* type))
(when left (yg-node-style-set-position p +yg-edge-left+ (coerce left 'single-float)))
(when top (yg-node-style-set-position p +yg-edge-top+ (coerce top 'single-float)))
(when right (yg-node-style-set-position p +yg-edge-right+ (coerce right 'single-float)))
(when bottom (yg-node-style-set-position p +yg-edge-bottom+ (coerce bottom 'single-float)))))
#+end_src
* Padding, Margin, Border, Gap
#+begin_src lisp
(defun set-edges (p fn all top right bottom left x y)
"Helper: call FN on each specified edge. FN is (fn ptr edge value)."
(flet ((s (edge val) (funcall fn p edge (coerce val 'single-float))))
(when all (dolist (e (list +yg-edge-left+ +yg-edge-top+ +yg-edge-right+ +yg-edge-bottom+))
(s e all)))
(when top (s +yg-edge-top+ top))
(when right (s +yg-edge-right+ right))
(when bottom (s +yg-edge-bottom+ bottom))
(when left (s +yg-edge-left+ left))
(when x (s +yg-edge-horizontal+ x))
(when y (s +yg-edge-vertical+ y))))
(defun layout-node-set-padding (node &key all top right bottom left x y)
"Set padding on specified edges in points."
(set-edges (layout-node-ptr node) #'yg-node-style-set-padding all top right bottom left x y))
(defun layout-node-set-margin (node &key all top right bottom left x y)
"Set margin on specified edges in points."
(set-edges (layout-node-ptr node) #'yg-node-style-set-margin all top right bottom left x y))
(defun layout-node-set-border (node width &key all top right bottom left x y)
"Set border width on specified edges."
(let ((p (layout-node-ptr node)))
(flet ((s (edge val) (yg-node-style-set-border p edge (coerce val 'single-float))))
(when all (dolist (e (list +yg-edge-left+ +yg-edge-top+ +yg-edge-right+ +yg-edge-bottom+))
(s e all)))
(when top (s +yg-edge-top+ top))
(when right (s +yg-edge-right+ right))
(when bottom (s +yg-edge-bottom+ bottom))
(when left (s +yg-edge-left+ left))
(when x (s +yg-edge-horizontal+ x))
(when y (s +yg-edge-vertical+ y)))))
(defun layout-node-set-gap (node &key row column)
"Set gap between children."
(let ((p (layout-node-ptr node)))
(when row (yg-node-style-set-gap p +yg-gutter-row+ (coerce row 'single-float)))
(when column (yg-node-style-set-gap p +yg-gutter-column+ (coerce column 'single-float)))))
#+end_src
* Overflow and Display
#+begin_src lisp
(defun layout-node-set-overflow (node overflow)
"Set overflow mode. OVERFLOW is :visible, :hidden, or :scroll."
(yg-node-style-set-overflow
(layout-node-ptr node)
(resolve-enum *overflow-map* overflow)))
(defun layout-node-set-display (node display)
"Set display mode. DISPLAY is :flex or :none."
(yg-node-style-set-display
(layout-node-ptr node)
(resolve-enum *display-map* display)))
#+end_src
* Layout Calculation
#+begin_src lisp
(defun layout-calculate (root width height &optional (direction :ltr))
"Run Yoga layout on the tree rooted at ROOT.
Returns ROOT (for chaining). Each node's computed position is available via
the raw FFI layout getter functions (yg-node-layout-get-left etc.)."
(yg-node-calculate-layout
(layout-node-ptr root)
(coerce width 'single-float)
(coerce height 'single-float)
(resolve-enum *direction-map* direction))
root)
#+end_src
* Test Suite
#+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :cl-tui.layout-primitives-tests
(:use :cl :fiveam)
(:import-from :cl-tui.layout-primitives
#:make-layout-node
#:layout-node-add-child
#:layout-node-set-dimension
#:layout-node-set-flex
#:layout-node-set-direction
#:layout-node-set-wrap
#:layout-node-set-align
#:layout-node-set-justify
#:layout-node-set-padding
#:layout-node-set-margin
#:layout-node-set-gap
#:layout-node-set-position
#:layout-node-set-border
#:layout-node-set-overflow
#:layout-node-set-display
#:layout-node-set-aspect-ratio
#:layout-calculate
#:layout-node-ptr)
(:import-from :cl-tui.yoga-ffi
#:yg-node-layout-get-left
#:yg-node-layout-get-top
#:yg-node-layout-get-width
#:yg-node-layout-get-height))
(in-package :cl-tui.layout-primitives-tests)
(fiveam:def-suite layout-primitives-suite
:description "Layout primitive CLOS wrappers verification")
(fiveam:in-suite layout-primitives-suite)
(defun node-x (node) (yg-node-layout-get-left (layout-node-ptr node)))
(defun node-y (node) (yg-node-layout-get-top (layout-node-ptr node)))
(defun node-w (node) (yg-node-layout-get-width (layout-node-ptr node)))
(defun node-h (node) (yg-node-layout-get-height (layout-node-ptr node)))
(fiveam:test test-make-layout-node
"Contract: make-layout-node returns a live node."
(let ((n (make-layout-node)))
(fiveam:is (not (cffi:null-pointer-p (layout-node-ptr n))))))
(fiveam:test test-layout-node-add-child
"Contract: adding a child makes it appear in the tree."
(let* ((parent (make-layout-node))
(child (make-layout-node)))
(layout-node-add-child parent child)
(layout-node-set-dimension parent 100 100)
(layout-node-set-dimension child 50 50)
(layout-calculate parent 100 100)
(fiveam:is (= 50.0 (node-w child)))
(fiveam:is (= 50.0 (node-h child)))))
(fiveam:test test-set-dimension
"Contract: layout-node-set-dimension sets width and height."
(let ((n (make-layout-node)))
(layout-node-set-dimension n 200 100)
(layout-calculate n 200 100)
(fiveam:is (= 200.0 (node-w n)))
(fiveam:is (= 100.0 (node-h n)))))
(fiveam:test test-set-direction-column
"Contract: column direction stacks children vertically."
(let* ((root (make-layout-node))
(a (make-layout-node))
(b (make-layout-node)))
(layout-node-set-dimension root 100 200)
(layout-node-set-dimension a 100 50)
(layout-node-set-dimension b 100 50)
(layout-node-add-child root a)
(layout-node-add-child root b)
(layout-node-set-direction root :column)
(layout-calculate root 100 200)
(fiveam:is (= 0.0 (node-y a)))
(fiveam:is (= 50.0 (node-y b)))))
(fiveam:test test-set-direction-row
"Contract: row direction places children horizontally."
(let* ((root (make-layout-node))
(a (make-layout-node))
(b (make-layout-node)))
(layout-node-set-dimension root 200 100)
(layout-node-set-dimension a 80 50)
(layout-node-set-dimension b 80 50)
(layout-node-add-child root a)
(layout-node-add-child root b)
(layout-node-set-direction root :row)
(layout-calculate root 200 100)
(fiveam:is (= 0.0 (node-x a)))
(fiveam:is (= 80.0 (node-x b)))))
(fiveam:test test-set-flex-grow
"Contract: flex-grow distributes remaining space."
(let* ((root (make-layout-node))
(a (make-layout-node))
(b (make-layout-node)))
(layout-node-set-dimension root 200 100)
(layout-node-set-dimension a 0 100)
(layout-node-set-dimension b 0 100)
(layout-node-set-flex a :grow 1)
(layout-node-set-flex b :grow 2)
(layout-node-add-child root a)
(layout-node-add-child root b)
(layout-node-set-direction root :row)
(layout-calculate root 200 100)
(fiveam:is (< 0.0 (node-w a)))
(fiveam:is (< 0.0 (node-w b)))
(fiveam:is (= 200.0 (+ (node-w a) (node-w b))))))
(fiveam:test test-set-align-center
"Contract: align-items :center centers children on the cross axis."
(let* ((root (make-layout-node))
(child (make-layout-node)))
(layout-node-set-dimension root 200 100)
(layout-node-set-dimension child 50 50)
(layout-node-set-direction root :row)
(layout-node-add-child root child)
(layout-node-set-align root :items :center)
(layout-calculate root 200 100)
(fiveam:is (= 25.0 (node-y child)))))
(fiveam:test test-set-justify
"Contract: justify-content :center centers children on the main axis."
(let* ((root (make-layout-node))
(child (make-layout-node)))
(layout-node-set-dimension root 200 100)
(layout-node-set-dimension child 50 50)
(layout-node-set-direction root :row)
(layout-node-add-child root child)
(layout-node-set-justify root :center)
(layout-calculate root 200 100)
(fiveam:is (= 75.0 (node-x child)))))
(fiveam:test test-set-padding
"Contract: padding offsets children from the parent edges."
(let* ((root (make-layout-node))
(child (make-layout-node)))
(layout-node-set-dimension root 200 100)
(layout-node-set-dimension child 100 50)
(layout-node-add-child root child)
(layout-node-set-padding root :all 10)
(layout-calculate root 200 100)
(fiveam:is (= 10.0 (node-x child)))
(fiveam:is (= 10.0 (node-y child)))))
(fiveam:test test-set-margin
"Contract: margin offsets the child from its siblings/parent."
(let* ((root (make-layout-node))
(child (make-layout-node)))
(layout-node-set-dimension root 200 100)
(layout-node-set-dimension child 80 50)
(layout-node-add-child root child)
(layout-node-set-margin child :left 20)
(layout-calculate root 200 100)
(fiveam:is (= 20.0 (node-x child)))))
(fiveam:test test-set-position-absolute
"Contract: absolute positioning places a child at exact coordinates."
(let* ((root (make-layout-node))
(child (make-layout-node)))
(layout-node-set-dimension root 300 300)
(layout-node-set-dimension child 50 50)
(layout-node-add-child root child)
(layout-node-set-position child :absolute :left 100 :top 50)
(layout-calculate root 300 300)
(fiveam:is (= 100.0 (node-x child)))
(fiveam:is (= 50.0 (node-y child)))))
(fiveam:test test-set-wrap
"Contract: flex-wrap :wrap allows children to wrap to next line."
(let* ((root (make-layout-node))
(a (make-layout-node))
(b (make-layout-node))
(c (make-layout-node)))
(layout-node-set-dimension root 100 200)
(layout-node-set-dimension a 60 50)
(layout-node-set-dimension b 60 50)
(layout-node-set-dimension c 60 50)
(layout-node-add-child root a)
(layout-node-add-child root b)
(layout-node-add-child root c)
(layout-node-set-direction root :row)
(layout-node-set-wrap root :wrap)
(layout-calculate root 100 200)
(fiveam:is (< 0 (node-h a)))
;; Second child (b) should wrap to next row since 60+60 > 100
(fiveam:is (> (node-y b) (node-y a)))))
(fiveam:test test-set-gap
"Contract: gap adds spacing between children."
(let* ((root (make-layout-node))
(a (make-layout-node))
(b (make-layout-node)))
(layout-node-set-dimension root 200 100)
(layout-node-set-dimension a 50 50)
(layout-node-set-dimension b 50 50)
(layout-node-add-child root a)
(layout-node-add-child root b)
(layout-node-set-direction root :column)
(layout-node-set-gap root :row 20)
(layout-calculate root 200 100)
(fiveam:is (= 70.0 (node-y b)))))
(fiveam:test test-nested-layout
"Contract: nested containers produce correct leaf positions."
(let* ((root (make-layout-node))
(outer (make-layout-node))
(inner (make-layout-node)))
(layout-node-set-dimension root 400 400)
(layout-node-set-dimension outer 400 200)
(layout-node-set-dimension inner 100 100)
(layout-node-add-child outer inner)
(layout-node-add-child root outer)
(layout-node-set-direction root :column)
(layout-calculate root 400 400)
(fiveam:is (= 0.0 (node-x inner)))
(fiveam:is (= 100.0 (node-w inner)))
(fiveam:is (= 100.0 (node-h inner)))))
#+end_src

438
org/modern-backend.org Normal file
View File

@@ -0,0 +1,438 @@
#+TITLE: cl-tui Modern Backend — v0.0.2
#+STARTUP: content
#+FILETAGS: :cl-tui:backend:v0.0.2:
#+OPTIONS: ^:nil
* Modern Backend
The =modern-backend= renders through raw ANSI/XTerm escape sequences.
No ncurses, no CFFI, no external dependencies — pure CL string
construction. Supports truecolor, Unicode box-drawing, OSC 8 hyperlinks,
DECICM synchronized updates, SGR mouse, and the kitty keyboard protocol.
** Contract
*** Constructor
- =(make-modern-backend &key color-palette)= → modern-backend
Create a modern backend. color-palette modifies theme color mappings.
*** Escape Sequence Generation
All escape sequences follow ECMA-48 / ANSI X3.64 conventions:
| Escape | Meaning |
|--------+--------------------------|
| ~ESC[~ | Control Sequence Introducer (CSI) |
| ~ESC]~ | Operating System Command (OSC) |
| ~ESC ~ | Single-character sequence |
*** Style Resolution
Colors are resolved through a palette before emission:
- =(resolve-color backend hex-or-name)= → color-index
Convert hex string or semantic name to an SGR color code.
Hex ("#FFD700") → 48;2;R;G;B or 38;2;R;G;B.
Named colors (:black :red :green :yellow :blue :magenta :cyan :white)
→ 8-color SGR codes.
** Test Suite
#+BEGIN_SRC lisp
(defpackage :cl-tui-modern-backend-test
(:use :cl :fiveam :cl-tui.backend)
(:export #:run-tests))
(in-package :cl-tui-modern-backend-test)
(def-suite modern-backend-suite :description "Modern backend tests")
(in-suite modern-backend-suite)
(defun run-tests ()
(let ((result (run 'modern-backend-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
;; ── Constructor ────────────────────────────────────────────────
(test make-modern-backend-creates
"make-modern-backend returns a modern-backend instance"
(let ((b (make-modern-backend)))
(is (typep b 'cl-tui.backend::modern-backend))))
;; ── Escape Generation ──────────────────────────────────────────
(test sgr-truecolor-foreground
"SGR truecolor foreground escape is correct"
(is (equal (cl-tui.backend::sgr-fg "#FFD700")
(format nil "~C[38;2;255;215;0m" #\Esc))))
(test sgr-truecolor-background
"SGR truecolor background escape is correct"
(is (equal (cl-tui.backend::sgr-bg "#1a1b26")
(format nil "~C[48;2;26;27;38m" #\Esc))))
(test sgr-named-colors
"SGR named colors resolve to 8-color codes"
(is (equal (cl-tui.backend::sgr-fg :red)
(format nil "~C[31m" #\Esc)))
(is (equal (cl-tui.backend::sgr-bg :blue)
(format nil "~C[44m" #\Esc))))
(test sgr-bold-italic
"SGR attribute escapes are correct"
(is (equal (cl-tui.backend::sgr-attr :bold) (format nil "~C[1m" #\Esc)))
(is (equal (cl-tui.backend::sgr-attr :italic) (format nil "~C[3m" #\Esc)))
(is (equal (cl-tui.backend::sgr-attr :underline) (format nil "~C[4m" #\Esc)))
(is (equal (cl-tui.backend::sgr-attr :reset) (format nil "~C[0m" #\Esc))))
;; ── Cursor ─────────────────────────────────────────────────────
(test cursor-move-escape
"cursor-move generates correct CSI escape"
(let ((b (make-modern-backend)))
(is (equal (cl-tui.backend::cursor-move-escape 5 10)
(format nil "~C[6;11H" #\Esc)))))
(test cursor-style-block
"cursor-style :block generate correct escape"
(let ((b (make-modern-backend)))
(is (equal (cl-tui.backend::cursor-style-escape :block nil)
(format nil "~C[2 q" #\Esc)))))
(test cursor-style-bar
"cursor-style :bar generate correct escape"
(let ((b (make-modern-backend)))
(is (equal (cl-tui.backend::cursor-style-escape :bar nil)
(format nil "~C[6 q" #\Esc)))))
(test cursor-style-underline-blink
"cursor-style :underline with blink"
(let ((b (make-modern-backend)))
(is (equal (cl-tui.backend::cursor-style-escape :underline t)
(format nil "~C[5 q" #\Esc)))))
;; ── Synchronization ────────────────────────────────────────────
(test decicm-escapes
"DECICM synchronized update escapes"
(is (equal (cl-tui.backend::decicm-begin) (format nil "~C[?2026h" #\Esc)))
(is (equal (cl-tui.backend::decicm-end) (format nil "~C[?2026l" #\Esc))))
;; ── OSC 8 Hyperlinks ──────────────────────────────────────────
(test osc8-escape
"OSC 8 hyperlink escape wraps text"
(is (equal (cl-tui.backend::osc8-link "http://example.com" "click here")
(format nil "~C]8;;http://example.com~C\\click here~C]8;;~C\\"
#\Esc #\Esc #\Esc #\Esc))))
;; ── Hex Parsing ────────────────────────────────────────────────
(test hex-color-parsing
"hex-to-rgb parses valid hex colors"
(multiple-value-bind (r g b) (cl-tui.backend::hex-to-rgb "#FFD700")
(is (= r 255))
(is (= g 215))
(is (= b 0))))
(test hex-color-black
"hex-to-rgb parses black"
(multiple-value-bind (r g b) (cl-tui.backend::hex-to-rgb "#000000")
(is (= r 0))
(is (= g 0))
(is (= b 0))))
(test hex-color-short-form
"hex-to-rgb parses 3-digit hex"
(multiple-value-bind (r g b) (cl-tui.backend::hex-to-rgb "#F00")
(is (= r 255))
(is (= g 0))
(is (= b 0))))
;; ── Border Characters ──────────────────────────────────────────
(test border-char-rounded
"modern-border-char returns Unicode box-drawing for rounded style"
(is (equal (cl-tui.backend::border-char :rounded :top-left) "╭"))
(is (equal (cl-tui.backend::border-char :rounded :horizontal) "─"))
(is (equal (cl-tui.backend::border-char :rounded :vertical) "│"))
(is (equal (cl-tui.backend::border-char :rounded :bottom-right) "╯")))
(test border-char-double
"modern-border-char returns double-line chars"
(is (equal (cl-tui.backend::border-char :double :top-left) "╔"))
(is (equal (cl-tui.backend::border-char :double :horizontal) "═"))
(is (equal (cl-tui.backend::border-char :double :vertical) "║")))
#+END_SRC
** Implementation
*** Package
Add to =cl-tui.backend= package:
#+BEGIN_SRC lisp
;; In package.lisp, add to :export:
;; #:modern-backend #:make-modern-backend
;; Internal symbols (not exported, used by tests):
;; sgr-fg sgr-bg sgr-attr cursor-move-escape cursor-style-escape
;; decicm-begin decicm-end osc8-link hex-to-rgb border-char
(in-package :cl-tui.backend)
#+END_SRC
*** Color Resolution
#+BEGIN_SRC lisp
(defun hex-to-rgb (hex)
"Parse a hex color string like \"#FFD700\" into (values r g b).
Also handles 3-digit hex like \"#F00\"."
(let ((clean (string-trim '(#\# #\Space) hex)))
(if (= (length clean) 3)
(values (parse-integer (subseq clean 0 1) :radix 16 :junk-allowed t)
(parse-integer (subseq clean 1 2) :radix 16 :junk-allowed t)
(parse-integer (subseq clean 2 3) :radix 16 :junk-allowed t))
(values (parse-integer (subseq clean 0 2) :radix 16 :junk-allowed t)
(parse-integer (subseq clean 2 4) :radix 16 :junk-allowed t)
(parse-integer (subseq clean 4 6) :radix 16 :junk-allowed t)))))
(defparameter *named-colors*
'((:black . 0) (:red . 1) (:green . 2) (:yellow . 3)
(:blue . 4) (:magenta . 5) (:cyan . 6) (:white . 7)))
(defun sgr-fg (color)
"Return SGR foreground escape for COLOR.
Color can be a hex string, a keyword name, or nil."
(if (null color) ""
(cond ((and (stringp color) (char= (char color 0) #\#))
(multiple-value-bind (r g b) (hex-to-rgb color)
(format nil "~C[38;2;~d;~d;~dm" #\Esc r g b)))
((keywordp color)
(let ((index (cdr (assoc color *named-colors*))))
(if index
(format nil "~C[~dm" #\Esc (+ 30 index))
"")))
(t ""))))
(defun sgr-bg (color)
"Return SGR background escape for COLOR."
(if (null color) ""
(cond ((and (stringp color) (char= (char color 0) #\#))
(multiple-value-bind (r g b) (hex-to-rgb color)
(format nil "~C[48;2;~d;~d;~dm" #\Esc r g b)))
((keywordp color)
(let ((index (cdr (assoc color *named-colors*))))
(if index
(format nil "~C[~dm" #\Esc (+ 40 index))
"")))
(t ""))))
(defparameter *sgr-attr-codes*
'((:bold . 1) (:dim . 2) (:italic . 3) (:underline . 4)
(:blink . 5) (:reverse . 7) (:reset . 0)))
(defun sgr-attr (attr)
"Return SGR attribute escape for ATTR keyword."
(let ((code (cdr (assoc attr *sgr-attr-codes*))))
(if code
(format nil "~C[~dm" #\Esc code)
"")))
#+END_SRC
*** Cursor Escapes
#+BEGIN_SRC lisp
(defun cursor-move-escape (x y)
"Return CSI escape to move cursor to (x, y), 1-indexed."
(format nil "~C[~d;~dH" #\Esc (1+ y) (1+ x)))
(defun cursor-style-escape (shape blink)
"Return DECSTR escape for cursor shape.
:block = 2, :underline = 4, :bar = 6.
Add 1 for blink variants."
(let* ((base (case shape
(:block 2) (:underline 4) (:bar 6)
(t 2)))
(code (if blink (1+ base) base)))
(format nil "~C[~d q" #\Esc code)))
#+END_SRC
*** Synchronization (DECICM)
#+BEGIN_SRC lisp
(defun decicm-begin ()
"Return escape to enable synchronized updates."
(format nil "~C[?2026h" #\Esc))
(defun decicm-end ()
"Return escape to disable synchronized updates."
(format nil "~C[?2026l" #\Esc))
#+END_SRC
*** OSC 8 Hyperlinks
#+BEGIN_SRC lisp
(defun osc8-link (url text)
"Wrap TEXT in an OSC 8 hyperlink to URL."
(format nil "~C]8;;~A~C\\~A~C]8;;~C\\"
#\Esc url #\Esc text #\Esc #\Esc))
#+END_SRC
*** Border Characters
#+BEGIN_SRC lisp
(defparameter *border-chars*
'((:single :top-left . "┌") (:single :top-right . "┐")
(:single :bottom-left . "└") (:single :bottom-right . "┘")
(:single :horizontal . "─") (:single :vertical . "│")
(:double :top-left . "╔") (:double :top-right . "╗")
(:double :bottom-left . "╚") (:double :bottom-right . "╝")
(:double :horizontal . "═") (:double :vertical . "║")
(:rounded :top-left . "╭") (:rounded :top-right . "╮")
(:rounded :bottom-left . "╰") (:rounded :bottom-right . "╯")
(:rounded :horizontal . "─") (:rounded :vertical . "│")))
(defun border-char (style pos)
"Return the Unicode box-drawing character for STYLE at POS."
(let ((char (cdr (assoc (cons style pos) *border-chars* :test #'equal))))
(or char (if (member pos '(:horizontal :vertical))
(case pos (:horizontal "─") (:vertical "│"))
"+"))))
#+END_SRC
*** Modern Backend Class
#+BEGIN_SRC lisp
(defclass modern-backend (backend)
((output-stream :initform *standard-output*
:accessor backend-output-stream)
(in-sync-p :initform nil :accessor in-sync-p)))
(defun make-modern-backend (&key color-palette)
(declare (ignore color-palette))
(make-instance 'modern-backend))
(defmethod initialize-backend ((b modern-backend))
;; Enter raw mode, enable mouse, bracketed paste
(backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen
(backend-write b (format nil "~C[?1000h" #\Esc)) ; mouse basic
(backend-write b (format nil "~C[?1002h" #\Esc)) ; mouse drag
(backend-write b (format nil "~C[?1006h" #\Esc)) ; SGR mouse
(backend-write b (format nil "~C[?2004h" #\Esc)) ; bracketed paste
(cursor-hide b)
(finish-output (backend-output-stream b))
b)
(defmethod shutdown-backend ((b modern-backend))
(cursor-show b)
(backend-write b (format nil "~C[?2004l" #\Esc)) ; disable bracketed paste
(backend-write b (format nil "~C[?1006l" #\Esc)) ; disable SGR mouse
(backend-write b (format nil "~C[?1002l" #\Esc))
(backend-write b (format nil "~C[?1000l" #\Esc))
(backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen
(finish-output (backend-output-stream b))
(values))
(defmethod backend-size ((b modern-backend))
;; Default fallback — real implementation queries terminal
(values 80 24))
(defmethod backend-write ((b modern-backend) string)
(let ((stream (backend-output-stream b)))
(write-string string stream)
(length string)))
(defmethod capable-p ((b modern-backend) feature)
(member feature '(:truecolor :osc8 :sync :mouse
:bracketed-paste :cursor-style
:kitty-keyboard)))
(defmethod draw-text ((b modern-backend) x y string fg bg
&key bold italic underline reverse dim blink)
(let ((parts (list (cursor-move-escape x y)
(sgr-fg fg) (sgr-bg bg)
(when bold (sgr-attr :bold))
(when italic (sgr-attr :italic))
(when underline (sgr-attr :underline))
(when reverse (sgr-attr :reverse))
(when dim (sgr-attr :dim))
(when blink (sgr-attr :blink))
string
(sgr-attr :reset))))
(backend-write b (apply #'concatenate 'string parts))))
(defmethod draw-border ((b modern-backend) x y width height
&key style fg bg title title-align)
(declare (ignore title title-align))
(let* ((s (or style :single))
(tl (border-char s :top-left))
(tr (border-char s :top-right))
(bl (border-char s :bottom-left))
(br (border-char s :bottom-right))
(h (border-char s :horizontal))
(v (border-char s :vertical))
(fg-esc (sgr-fg fg))
(bg-esc (sgr-bg bg))
(reset (sgr-attr :reset))
(top (concatenate 'string
fg-esc bg-esc tl
(make-string (- width 2) :initial-element (char h 0))
tr reset (string #\Newline)))
(mid (concatenate 'string
fg-esc bg-esc v
(make-string (- width 2) :initial-element #\Space)
v reset (string #\Newline)))
(bot (concatenate 'string
fg-esc bg-esc bl
(make-string (- width 2) :initial-element (char h 0))
br reset)))
(backend-write b top)
(loop repeat (- height 2) do (backend-write b mid))
(backend-write b bot)))
(defmethod draw-rect ((b modern-backend) x y width height &key bg)
(let ((bg-esc (sgr-bg bg))
(reset (sgr-attr :reset))
(line (concatenate 'string
bg-esc
(make-string width :initial-element #\Space)
reset (string #\Newline))))
(loop repeat height do
(backend-write b (cursor-move-escape x y))
(backend-write b line))))
(defmethod draw-link ((b modern-backend) x y string url
&key fg bg)
(let ((parts (list (cursor-move-escape x y)
(sgr-fg fg) (sgr-bg bg)
(osc8-link url string)
(sgr-attr :reset))))
(backend-write b (apply #'concatenate 'string parts))))
(defmethod draw-ellipsis ((b modern-backend) x y width
&key fg bg)
(let ((dots "..."))
(draw-text b x y dots fg bg)))
(defmethod cursor-move ((b modern-backend) x y)
(backend-write b (cursor-move-escape x y)))
(defmethod cursor-hide ((b modern-backend))
(backend-write b (format nil "~C[?25l" #\Esc)))
(defmethod cursor-show ((b modern-backend))
(backend-write b (format nil "~C[?25h" #\Esc)))
(defmethod cursor-style ((b modern-backend) shape &key blink)
(backend-write b (cursor-style-escape shape blink)))
(defmethod begin-sync ((b modern-backend))
(setf (in-sync-p b) t)
(backend-write b (decicm-begin)))
(defmethod end-sync ((b modern-backend))
(setf (in-sync-p b) nil)
(backend-write b (decicm-end))
(finish-output (backend-output-stream b)))
#+END_SRC

View File

@@ -1,755 +0,0 @@
#+TITLE: Yoga FFI Binding
#+STARTUP: content
#+FILETAGS: :cl-tui:yoga-ffi:v010:
* Yoga FFI Binding
CFFI bindings for Facebook's Yoga Flexbox layout engine. Provides raw access
to the C library — node management, style setters, layout calculation, and
layout getters. The next file (=layout-primitives.org=) wraps these in CLOS.
The Yoga shared library is at =/usr/local/lib/libyoga.so=, built from
=facebook/yoga= with C++17.
** Contract
- =(load-yoga)= :: loads the shared library via CFFI. Signal an error if the
library cannot be found.
- =(yg-node-new)= → YGNodeRef :: wraps =YGNodeNew=. Allocates a new Yoga node.
- =(yg-node-free node)= :: wraps =YGNodeFree=. Frees a node and detaches it
from its owner and children.
- =(yg-node-free-recursive node)= :: wraps =YGNodeFreeRecursive=. Frees the
entire subtree.
- =(yg-node-insert-child node child index)= :: wraps =YGNodeInsertChild=.
Inserts a child at the given index.
- =(yg-node-remove-child node child)= :: wraps =YGNodeRemoveChild=.
- =(yg-node-get-child-count node)= → integer :: wraps =YGNodeGetChildCount=.
- =(yg-node-calculate-layout node width height direction)= ::
wraps =YGNodeCalculateLayout=. Runs the layout algorithm.
- =(yg-node-layout-get-left node)= → float :: wraps =YGNodeLayoutGetLeft=.
Returns the computed X position.
- =(yg-node-layout-get-top node)= → float :: wraps =YGNodeLayoutGetTop=.
Returns the computed Y position.
- =(yg-node-layout-get-width node)= → float :: wraps =YGNodeLayoutGetWidth=.
Returns the computed width.
- =(yg-node-layout-get-height node)= → float :: wraps =YGNodeLayoutGetHeight=.
Returns the computed height.
- =(yg-node-style-set-direction node dir)= :: sets the text direction.
- =(yg-node-style-set-flex-direction node dir)= :: sets the flex direction.
- =(yg-node-style-set-justify-content node justify)= :: sets main-axis
alignment.
- =(yg-node-style-set-align-items node align)= :: sets cross-axis alignment.
- =(yg-node-style-set-align-self node align)= :: sets self alignment.
- =(yg-node-style-set-flex-wrap node wrap)= :: sets wrapping mode.
- =(yg-node-style-set-flex-grow node value)= :: sets the flex grow factor.
- =(yg-node-style-set-flex-shrink node value)= :: sets the flex shrink factor.
- =(yg-node-style-set-position-type node type)= :: sets positioning type.
- =(yg-node-style-set-width node points)= :: sets width in points.
- =(yg-node-style-set-width-percent node pct)= :: sets width as percentage.
- =(yg-node-style-set-width-auto node)= :: sets width to auto.
- =(yg-node-style-set-height node points)= :: sets height in points.
- =(yg-node-style-set-height-percent node pct)= :: sets height as percentage.
- =(yg-node-style-set-height-auto node)= :: sets height to auto.
- =(yg-node-style-set-padding node edge points)= :: sets padding on an edge.
- =(yg-node-style-set-margin node edge points)= :: sets margin on an edge.
- =(yg-node-style-set-border node edge points)= :: sets border on an edge.
- =(yg-node-style-set-gap node gutter length)= :: sets gap between children.
- =(yg-node-style-set-overflow node overflow)= :: sets overflow mode.
- =(yg-node-style-set-display node display)= :: sets display mode.
- =(yg-node-style-set-position-percent node edge pct)= :: sets position as
percentage.
- =(yg-node-style-set-position node edge points)= :: sets position in points.
Enum keywords (mapping C enum → Lisp keyword):
- YGDirection: :inherit (0), :ltr (1), :rtl (2)
- YGFlexDirection: :column (0), :column-reverse (1), :row (2), :row-reverse (3)
- YGJustify: :auto (0), :flex-start (1), :center (2), :flex-end (3),
:space-between (4), :space-around (5), :space-evenly (6), :stretch (7)
- YGAlign: :auto (0), :flex-start (1), :center (2), :flex-end (3),
:stretch (4), :baseline (5), :space-between (6), :space-around (7),
:space-evenly (8)
- YGWrap: :nowrap (0), :wrap (1), :wrap-reverse (2)
- YGPositionType: :static (0), :relative (1), :absolute (2)
- YGOverflow: :visible (0), :hidden (1), :scroll (2)
- YGDisplay: :flex (0), :none (1), :contents (2)
- YGEdge: :left (0), :top (1), :right (2), :bottom (3), :start (4), :end (5),
:horizontal (6), :vertical (7), :all (8)
- YGGutter: :column (0), :row (1), :all (2)
- YGUnit: :undefined (0), :point (1), :percent (2), :auto (3)
* Application-Level Package
#+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :cffi :silent t))
(defpackage :cl-tui.yoga-ffi
(:use :cl)
(:export
;; library
#:*libyoga*
#:load-yoga
;; constants
#:+yg-direction-inherit+
#:+yg-direction-ltr+
#:+yg-direction-rtl+
#:+yg-flex-direction-column+
#:+yg-flex-direction-column-reverse+
#:+yg-flex-direction-row+
#:+yg-flex-direction-row-reverse+
#:+yg-justify-auto+
#:+yg-justify-flex-start+
#:+yg-justify-center+
#:+yg-justify-flex-end+
#:+yg-justify-space-between+
#:+yg-justify-space-around+
#:+yg-justify-space-evenly+
#:+yg-justify-stretch+
#:+yg-align-auto+
#:+yg-align-flex-start+
#:+yg-align-center+
#:+yg-align-flex-end+
#:+yg-align-stretch+
#:+yg-align-baseline+
#:+yg-align-space-between+
#:+yg-align-space-around+
#:+yg-align-space-evenly+
#:+yg-wrap-nowrap+
#:+yg-wrap-wrap+
#:+yg-wrap-wrap-reverse+
#:+yg-position-type-static+
#:+yg-position-type-relative+
#:+yg-position-type-absolute+
#:+yg-overflow-visible+
#:+yg-overflow-hidden+
#:+yg-overflow-scroll+
#:+yg-display-flex+
#:+yg-display-none+
#:+yg-display-contents+
#:+yg-edge-left+
#:+yg-edge-top+
#:+yg-edge-right+
#:+yg-edge-bottom+
#:+yg-edge-start+
#:+yg-edge-end+
#:+yg-edge-horizontal+
#:+yg-edge-vertical+
#:+yg-edge-all+
#:+yg-gutter-column+
#:+yg-gutter-row+
#:+yg-gutter-all+
#:+yg-unit-undefined+
#:+yg-unit-point+
#:+yg-unit-percent+
#:+yg-unit-auto+
;; types
#:yg-node-ref
#:yg-node-const-ref
;; node management
#:yg-node-new
#:yg-node-free
#:yg-node-free-recursive
#:yg-node-insert-child
#:yg-node-remove-child
#:yg-node-remove-all-children
#:yg-node-get-child-count
#:yg-node-get-child
;; layout
#:yg-node-calculate-layout
#:yg-node-layout-get-left
#:yg-node-layout-get-top
#:yg-node-layout-get-width
#:yg-node-layout-get-height
#:yg-node-layout-get-right
#:yg-node-layout-get-bottom
#:yg-node-is-dirty
#:yg-node-mark-dirty
;; style direction & flex
#:yg-node-style-set-direction
#:yg-node-style-set-flex-direction
#:yg-node-style-set-justify-content
#:yg-node-style-set-align-items
#:yg-node-style-set-align-self
#:yg-node-style-set-align-content
#:yg-node-style-set-flex-wrap
#:yg-node-style-set-position-type
#:yg-node-style-set-flex-grow
#:yg-node-style-set-flex-shrink
#:yg-node-style-set-flex-basis
#:yg-node-style-set-flex-basis-auto
#:yg-node-style-set-flex-basis-percent
#:yg-node-style-set-overflow
#:yg-node-style-set-display
;; style dimensions
#:yg-node-style-set-width
#:yg-node-style-set-width-percent
#:yg-node-style-set-width-auto
#:yg-node-style-set-height
#:yg-node-style-set-height-percent
#:yg-node-style-set-height-auto
#:yg-node-style-set-min-width
#:yg-node-style-set-min-width-percent
#:yg-node-style-set-min-height
#:yg-node-style-set-min-height-percent
#:yg-node-style-set-max-width
#:yg-node-style-set-max-height
#:yg-node-style-set-aspect-ratio
;; style padding/margin/border/gap/position
#:yg-node-style-set-padding
#:yg-node-style-set-padding-percent
#:yg-node-style-set-margin
#:yg-node-style-set-margin-percent
#:yg-node-style-set-margin-auto
#:yg-node-style-set-border
#:yg-node-style-set-gap
#:yg-node-style-set-position
#:yg-node-style-set-position-percent
;; style getters
#:yg-node-style-get-width
#:yg-node-style-get-height
#:yg-node-style-get-flex-direction
#:yg-node-style-get-align-items
#:yg-node-style-get-justify-content))
(in-package :cl-tui.yoga-ffi)
#+end_src
* Foreign Library Loading
#+begin_src lisp
(defparameter *libyoga* nil "Handle for the loaded Yoga shared library.")
(defun load-yoga ()
"Load the Yoga shared library via CFFI."
(setf *libyoga* (cffi:load-foreign-library "/usr/local/lib/libyoga.so"))
(sb-int:set-floating-point-modes :traps '())
*libyoga*)
(load-yoga)
#+end_src
* Enum Constants
#+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
;; YGDirection
(defconstant +yg-direction-inherit+ 0)
(defconstant +yg-direction-ltr+ 1)
(defconstant +yg-direction-rtl+ 2)
;; YGFlexDirection
(defconstant +yg-flex-direction-column+ 0)
(defconstant +yg-flex-direction-column-reverse+ 1)
(defconstant +yg-flex-direction-row+ 2)
(defconstant +yg-flex-direction-row-reverse+ 3)
;; YGJustify
(defconstant +yg-justify-auto+ 0)
(defconstant +yg-justify-flex-start+ 1)
(defconstant +yg-justify-center+ 2)
(defconstant +yg-justify-flex-end+ 3)
(defconstant +yg-justify-space-between+ 4)
(defconstant +yg-justify-space-around+ 5)
(defconstant +yg-justify-space-evenly+ 6)
(defconstant +yg-justify-stretch+ 7)
;; YGAlign
(defconstant +yg-align-auto+ 0)
(defconstant +yg-align-flex-start+ 1)
(defconstant +yg-align-center+ 2)
(defconstant +yg-align-flex-end+ 3)
(defconstant +yg-align-stretch+ 4)
(defconstant +yg-align-baseline+ 5)
(defconstant +yg-align-space-between+ 6)
(defconstant +yg-align-space-around+ 7)
(defconstant +yg-align-space-evenly+ 8)
;; YGWrap
(defconstant +yg-wrap-nowrap+ 0)
(defconstant +yg-wrap-wrap+ 1)
(defconstant +yg-wrap-wrap-reverse+ 2)
;; YGPositionType
(defconstant +yg-position-type-static+ 0)
(defconstant +yg-position-type-relative+ 1)
(defconstant +yg-position-type-absolute+ 2)
;; YGOverflow
(defconstant +yg-overflow-visible+ 0)
(defconstant +yg-overflow-hidden+ 1)
(defconstant +yg-overflow-scroll+ 2)
;; YGDisplay
(defconstant +yg-display-flex+ 0)
(defconstant +yg-display-none+ 1)
(defconstant +yg-display-contents+ 2)
;; YGEdge
(defconstant +yg-edge-left+ 0)
(defconstant +yg-edge-top+ 1)
(defconstant +yg-edge-right+ 2)
(defconstant +yg-edge-bottom+ 3)
(defconstant +yg-edge-start+ 4)
(defconstant +yg-edge-end+ 5)
(defconstant +yg-edge-horizontal+ 6)
(defconstant +yg-edge-vertical+ 7)
(defconstant +yg-edge-all+ 8)
;; YGGutter
(defconstant +yg-gutter-column+ 0)
(defconstant +yg-gutter-row+ 1)
(defconstant +yg-gutter-all+ 2)
;; YGUnit
(defconstant +yg-unit-undefined+ 0)
(defconstant +yg-unit-point+ 1)
(defconstant +yg-unit-percent+ 2)
(defconstant +yg-unit-auto+ 3))
#+end_src
* CFFI Foreign Type Definitions
#+begin_src lisp
(cffi:defctype yg-node-ref :pointer)
(cffi:defctype yg-node-const-ref :pointer)
(cffi:defcstruct yg-size
(width :float)
(height :float))
(cffi:defcstruct yg-value
(value :float)
(unit :int))
#+end_src
* Node Management
#+begin_src lisp
(cffi:defcfun ("YGNodeNew" yg-node-new) yg-node-ref)
(cffi:defcfun ("YGNodeFree" yg-node-free) :void
(node yg-node-ref))
(cffi:defcfun ("YGNodeFreeRecursive" yg-node-free-recursive) :void
(node yg-node-ref))
(cffi:defcfun ("YGNodeInsertChild" yg-node-insert-child) :void
(node yg-node-ref)
(child yg-node-ref)
(index :unsigned-int))
(cffi:defcfun ("YGNodeRemoveChild" yg-node-remove-child) :void
(node yg-node-ref)
(child yg-node-ref))
(cffi:defcfun ("YGNodeRemoveAllChildren" yg-node-remove-all-children) :void
(node yg-node-ref))
(cffi:defcfun ("YGNodeGetChildCount" yg-node-get-child-count) :unsigned-int
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeGetChild" yg-node-get-child) yg-node-ref
(node yg-node-ref)
(index :unsigned-int))
#+end_src
* Layout Calculation
#+begin_src lisp
(cffi:defcfun ("YGNodeCalculateLayout" yg-node-calculate-layout) :void
(node yg-node-ref)
(available-width :float)
(available-height :float)
(owner-direction :int))
(cffi:defcfun ("YGNodeLayoutGetLeft" yg-node-layout-get-left) :float
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeLayoutGetTop" yg-node-layout-get-top) :float
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeLayoutGetWidth" yg-node-layout-get-width) :float
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeLayoutGetHeight" yg-node-layout-get-height) :float
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeLayoutGetRight" yg-node-layout-get-right) :float
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeLayoutGetBottom" yg-node-layout-get-bottom) :float
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeIsDirty" yg-node-is-dirty) :boolean
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeMarkDirty" yg-node-mark-dirty) :void
(node yg-node-ref))
#+end_src
* Style Setters — Direction and Flex
#+begin_src lisp
(cffi:defcfun ("YGNodeStyleSetDirection" yg-node-style-set-direction) :void
(node yg-node-ref)
(direction :int))
(cffi:defcfun ("YGNodeStyleSetFlexDirection" yg-node-style-set-flex-direction) :void
(node yg-node-ref)
(flex-direction :int))
(cffi:defcfun ("YGNodeStyleSetJustifyContent" yg-node-style-set-justify-content) :void
(node yg-node-ref)
(justify :int))
(cffi:defcfun ("YGNodeStyleSetAlignItems" yg-node-style-set-align-items) :void
(node yg-node-ref)
(align :int))
(cffi:defcfun ("YGNodeStyleSetAlignSelf" yg-node-style-set-align-self) :void
(node yg-node-ref)
(align :int))
(cffi:defcfun ("YGNodeStyleSetAlignContent" yg-node-style-set-align-content) :void
(node yg-node-ref)
(align :int))
(cffi:defcfun ("YGNodeStyleSetFlexWrap" yg-node-style-set-flex-wrap) :void
(node yg-node-ref)
(wrap :int))
(cffi:defcfun ("YGNodeStyleSetPositionType" yg-node-style-set-position-type) :void
(node yg-node-ref)
(position-type :int))
(cffi:defcfun ("YGNodeStyleSetFlexGrow" yg-node-style-set-flex-grow) :void
(node yg-node-ref)
(flex-grow :float))
(cffi:defcfun ("YGNodeStyleSetFlexShrink" yg-node-style-set-flex-shrink) :void
(node yg-node-ref)
(flex-shrink :float))
(cffi:defcfun ("YGNodeStyleSetFlexBasis" yg-node-style-set-flex-basis) :void
(node yg-node-ref)
(flex-basis :float))
(cffi:defcfun ("YGNodeStyleSetFlexBasisAuto" yg-node-style-set-flex-basis-auto) :void
(node yg-node-ref))
(cffi:defcfun ("YGNodeStyleSetFlexBasisPercent" yg-node-style-set-flex-basis-percent) :void
(node yg-node-ref)
(flex-basis :float))
(cffi:defcfun ("YGNodeStyleSetOverflow" yg-node-style-set-overflow) :void
(node yg-node-ref)
(overflow :int))
(cffi:defcfun ("YGNodeStyleSetDisplay" yg-node-style-set-display) :void
(node yg-node-ref)
(display :int))
#+end_src
* Style Setters — Dimensions
#+begin_src lisp
(cffi:defcfun ("YGNodeStyleSetWidth" yg-node-style-set-width) :void
(node yg-node-ref)
(width :float))
(cffi:defcfun ("YGNodeStyleSetWidthPercent" yg-node-style-set-width-percent) :void
(node yg-node-ref)
(width :float))
(cffi:defcfun ("YGNodeStyleSetWidthAuto" yg-node-style-set-width-auto) :void
(node yg-node-ref))
(cffi:defcfun ("YGNodeStyleSetHeight" yg-node-style-set-height) :void
(node yg-node-ref)
(height :float))
(cffi:defcfun ("YGNodeStyleSetHeightPercent" yg-node-style-set-height-percent) :void
(node yg-node-ref)
(height :float))
(cffi:defcfun ("YGNodeStyleSetHeightAuto" yg-node-style-set-height-auto) :void
(node yg-node-ref))
(cffi:defcfun ("YGNodeStyleSetMinWidth" yg-node-style-set-min-width) :void
(node yg-node-ref)
(min-width :float))
(cffi:defcfun ("YGNodeStyleSetMinWidthPercent" yg-node-style-set-min-width-percent) :void
(node yg-node-ref)
(min-width :float))
(cffi:defcfun ("YGNodeStyleSetMinHeight" yg-node-style-set-min-height) :void
(node yg-node-ref)
(min-height :float))
(cffi:defcfun ("YGNodeStyleSetMinHeightPercent" yg-node-style-set-min-height-percent) :void
(node yg-node-ref)
(min-height :float))
(cffi:defcfun ("YGNodeStyleSetMaxWidth" yg-node-style-set-max-width) :void
(node yg-node-ref)
(max-width :float))
(cffi:defcfun ("YGNodeStyleSetMaxHeight" yg-node-style-set-max-height) :void
(node yg-node-ref)
(max-height :float))
(cffi:defcfun ("YGNodeStyleSetAspectRatio" yg-node-style-set-aspect-ratio) :void
(node yg-node-ref)
(aspect-ratio :float))
#+end_src
* Style Setters — Padding, Margin, Border, Gap, Position
#+begin_src lisp
(cffi:defcfun ("YGNodeStyleSetPadding" yg-node-style-set-padding) :void
(node yg-node-ref)
(edge :int)
(padding :float))
(cffi:defcfun ("YGNodeStyleSetPaddingPercent" yg-node-style-set-padding-percent) :void
(node yg-node-ref)
(edge :int)
(padding :float))
(cffi:defcfun ("YGNodeStyleSetMargin" yg-node-style-set-margin) :void
(node yg-node-ref)
(edge :int)
(margin :float))
(cffi:defcfun ("YGNodeStyleSetMarginPercent" yg-node-style-set-margin-percent) :void
(node yg-node-ref)
(edge :int)
(margin :float))
(cffi:defcfun ("YGNodeStyleSetMarginAuto" yg-node-style-set-margin-auto) :void
(node yg-node-ref)
(edge :int))
(cffi:defcfun ("YGNodeStyleSetBorder" yg-node-style-set-border) :void
(node yg-node-ref)
(edge :int)
(border :float))
(cffi:defcfun ("YGNodeStyleSetGap" yg-node-style-set-gap) :void
(node yg-node-ref)
(gutter :int)
(gap :float))
(cffi:defcfun ("YGNodeStyleSetPosition" yg-node-style-set-position) :void
(node yg-node-ref)
(edge :int)
(position :float))
(cffi:defcfun ("YGNodeStyleSetPositionPercent" yg-node-style-set-position-percent) :void
(node yg-node-ref)
(edge :int)
(position :float))
#+end_src
* Style Getters
#+begin_src lisp
(cffi:defcfun ("YGNodeStyleGetWidth" yg-node-style-get-width) yg-value
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeStyleGetHeight" yg-node-style-get-height) yg-value
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeStyleGetFlexDirection" yg-node-style-get-flex-direction) :int
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeStyleGetAlignItems" yg-node-style-get-align-items) :int
(node yg-node-const-ref))
(cffi:defcfun ("YGNodeStyleGetJustifyContent" yg-node-style-get-justify-content) :int
(node yg-node-const-ref))
#+end_src
* Test Suite
#+begin_src lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload :fiveam :silent t))
(defpackage :cl-tui.yoga-ffi-tests
(:use :cl :fiveam)
(:import-from :cl-tui.yoga-ffi
#:load-yoga
#:yg-node-new
#:yg-node-free
#:yg-node-free-recursive
#:yg-node-insert-child
#:yg-node-get-child-count
#:yg-node-calculate-layout
#:yg-node-layout-get-left
#:yg-node-layout-get-top
#:yg-node-layout-get-width
#:yg-node-layout-get-height
#:yg-node-style-set-flex-direction
#:yg-node-style-set-justify-content
#:yg-node-style-set-align-items
#:yg-node-style-set-width
#:yg-node-style-set-height
#:yg-node-style-set-padding
#:yg-node-style-set-margin
#:yg-node-style-set-flex-grow
#:yg-node-style-set-position-type
#:yg-node-style-set-position
#:+yg-flex-direction-column+
#:+yg-flex-direction-row+
#:+yg-justify-center+
#:+yg-justify-flex-start+
#:+yg-align-stretch+
#:+yg-align-center+
#:+yg-edge-all+
#:+yg-edge-left+
#:+yg-edge-top+
#:+yg-edge-right+
#:+yg-edge-bottom+
#:+yg-position-type-relative+
#:+yg-position-type-absolute+
;; YGDirection constants (different from YGFlexDirection!)
#:+yg-direction-inherit+
#:+yg-direction-ltr+
#:+yg-direction-rtl+))
(in-package :cl-tui.yoga-ffi-tests)
(fiveam:def-suite yoga-ffi-suite
:description "Yoga FFI binding verification")
(fiveam:in-suite yoga-ffi-suite)
(fiveam:test test-node-create-free
"Contract: yg-node-new returns a non-null pointer; yg-node-free doesn't crash."
(let ((node (yg-node-new)))
(fiveam:is (not (cffi:null-pointer-p node)))
(yg-node-free node)
(fiveam:pass)))
(fiveam:test test-node-child-count
"Contract: yg-node-get-child-count returns 0 for a new node."
(let ((node (yg-node-new)))
(fiveam:is (= 0 (yg-node-get-child-count node)))
(yg-node-free node)))
(fiveam:test test-node-insert-child
"Contract: inserting a child increments the child count."
(let ((parent (yg-node-new))
(child (yg-node-new)))
(yg-node-insert-child parent child 0)
(fiveam:is (= 1 (yg-node-get-child-count parent)))
(yg-node-free-recursive parent)))
(fiveam:test test-layout-basic-column
"Contract: a column with two fixed-height children positions them vertically."
(let* ((root (yg-node-new)))
(yg-node-style-set-width root 100.0)
(yg-node-style-set-height root 200.0)
(yg-node-style-set-flex-direction root +yg-flex-direction-column+)
(let ((child1 (yg-node-new))
(child2 (yg-node-new)))
(yg-node-style-set-width child1 100.0)
(yg-node-style-set-height child1 50.0)
(yg-node-style-set-width child2 100.0)
(yg-node-style-set-height child2 50.0)
(yg-node-insert-child root child1 0)
(yg-node-insert-child root child2 1)
(yg-node-calculate-layout root 100.0 200.0 +yg-direction-ltr+)
(fiveam:is (= 0.0 (yg-node-layout-get-left child1)))
(fiveam:is (= 0.0 (yg-node-layout-get-top child1)))
(fiveam:is (= 50.0 (yg-node-layout-get-top child2)))
(yg-node-free-recursive root))))
(fiveam:test test-layout-basic-row
"Contract: a row with two fixed-width children positions them horizontally."
(let* ((root (yg-node-new)))
(yg-node-style-set-width root 200.0)
(yg-node-style-set-height root 100.0)
(yg-node-style-set-flex-direction root +yg-flex-direction-row+)
(let ((child1 (yg-node-new))
(child2 (yg-node-new)))
(yg-node-style-set-width child1 80.0)
(yg-node-style-set-height child1 50.0)
(yg-node-style-set-width child2 80.0)
(yg-node-style-set-height child2 50.0)
(yg-node-insert-child root child1 0)
(yg-node-insert-child root child2 1)
(yg-node-calculate-layout root 200.0 100.0 +yg-direction-ltr+)
(fiveam:is (= 0.0 (yg-node-layout-get-left child1)))
(fiveam:is (= 0.0 (yg-node-layout-get-top child1)))
(fiveam:is (= 80.0 (yg-node-layout-get-left child2)))
(yg-node-free-recursive root))))
(fiveam:test test-layout-flex-grow
"Contract: flex-grow distributes remaining space proportionally."
(let* ((root (yg-node-new)))
(yg-node-style-set-width root 200.0)
(yg-node-style-set-height root 100.0)
(yg-node-style-set-flex-direction root +yg-flex-direction-row+)
(let ((child1 (yg-node-new))
(child2 (yg-node-new)))
(yg-node-style-set-height child1 100.0)
(yg-node-style-set-flex-grow child1 1.0)
(yg-node-style-set-height child2 100.0)
(yg-node-style-set-flex-grow child2 2.0)
(yg-node-insert-child root child1 0)
(yg-node-insert-child root child2 1)
(yg-node-calculate-layout root 200.0 100.0 +yg-direction-ltr+)
(fiveam:is (< 0.0 (yg-node-layout-get-width child1)))
(fiveam:is (< 0.0 (yg-node-layout-get-width child2)))
(fiveam:is (= 200.0 (+ (yg-node-layout-get-width child1)
(yg-node-layout-get-width child2))))
(yg-node-free-recursive root))))
(fiveam:test test-layout-absolute-position
"Contract: an absolute child positions relative to its parent."
(let* ((root (yg-node-new)))
(yg-node-style-set-width root 300.0)
(yg-node-style-set-height root 300.0)
(let ((child (yg-node-new)))
(yg-node-style-set-width child 50.0)
(yg-node-style-set-height child 50.0)
(yg-node-style-set-position-type child +yg-position-type-absolute+)
(yg-node-style-set-position child +yg-edge-left+ 100.0)
(yg-node-style-set-position child +yg-edge-top+ 50.0)
(yg-node-insert-child root child 0)
(yg-node-calculate-layout root 300.0 300.0 +yg-direction-ltr+)
(fiveam:is (= 100.0 (yg-node-layout-get-left child)))
(fiveam:is (= 50.0 (yg-node-layout-get-top child)))
(fiveam:is (= 50.0 (yg-node-layout-get-width child)))
(fiveam:is (= 50.0 (yg-node-layout-get-height child)))
(yg-node-free-recursive root))))
(fiveam:test test-layout-padding
"Contract: padding reduces the available space for children."
(let* ((root (yg-node-new)))
(yg-node-style-set-width root 200.0)
(yg-node-style-set-height root 100.0)
(yg-node-style-set-padding root +yg-edge-all+ 10.0)
(let ((child (yg-node-new)))
(yg-node-style-set-width child 180.0)
(yg-node-style-set-height child 80.0)
(yg-node-insert-child root child 0)
(yg-node-calculate-layout root 200.0 100.0 +yg-direction-ltr+)
(fiveam:is (= 10.0 (yg-node-layout-get-left child)))
(fiveam:is (= 10.0 (yg-node-layout-get-top child)))
(yg-node-free-recursive root))))
(fiveam:test test-layout-nested
"Contract: nested containers produce correct leaf positions."
(let* ((root (yg-node-new)))
(yg-node-style-set-width root 400.0)
(yg-node-style-set-height root 400.0)
(yg-node-style-set-flex-direction root +yg-flex-direction-column+)
(let ((outer (yg-node-new)))
(yg-node-style-set-width outer 400.0)
(yg-node-style-set-height outer 200.0)
(yg-node-style-set-flex-direction outer +yg-flex-direction-row+)
(let ((inner (yg-node-new)))
(yg-node-style-set-width inner 100.0)
(yg-node-style-set-height inner 100.0)
(yg-node-insert-child outer inner 0)
(yg-node-insert-child root outer 0)
(yg-node-calculate-layout root 400.0 400.0 +yg-direction-ltr+)
(fiveam:is (= 0.0 (yg-node-layout-get-left inner)))
(fiveam:is (= 100.0 (yg-node-layout-get-width inner)))
(fiveam:is (= 100.0 (yg-node-layout-get-height inner)))
(yg-node-free-recursive root)))))
#+end_src

View File

@@ -0,0 +1,166 @@
(defpackage :cl-tui-box-test
(:use :cl :fiveam :cl-tui.backend :cl-tui.layout :cl-tui.box)
(:export #:run-tests))
(in-package :cl-tui-box-test)
(def-suite box-suite :description "Box renderable tests")
(in-suite box-suite)
(defun run-tests ()
(let ((result (run 'box-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
(defun make-capturing-backend ()
(let* ((s (make-string-output-stream))
(b (make-modern-backend :output-stream s)))
(values b s)))
;; ── Box Tests ─────────────────────────────────────────────────
(test box-creates-with-defaults
"A box created with no arguments has reasonable defaults"
(let ((b (make-box)))
(is (typep b 'box))
(is (typep (box-layout-node b) 'layout-node))))
(test box-renders-border
"A box with border draws border characters"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style :single :width 10 :height 5)))
(compute-layout (box-layout-node bx) 10 5)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "┌" out) "top-left corner")
(is (search "┐" out) "top-right corner")
(is (search "└" out) "bottom-left corner")
(is (search "┘" out) "bottom-right corner")))))
(test box-renders-background
"A box with background color fills interior"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :bg :red :width 5 :height 3)))
(compute-layout (box-layout-node bx) 5 3)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "┌" out) "border with background")
(is (search "41m" out) "SGR background for red")))))
(test box-renders-title
"A box with title renders the title text"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :title "Hello" :width 12 :height 3)))
(compute-layout (box-layout-node bx) 12 3)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "Hello" out) "title text should appear")))))
(test box-without-border
"A box with border-style nil draws no border"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style nil :bg :red :width 5 :height 3)))
(compute-layout (box-layout-node bx) 5 3)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "41m" out) "background still renders")
(is-false (search "┌" out) "no top-left corner")))))
(test box-zero-size
"A box with any zero dimension renders nothing"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style :single :width 0 :height 0)))
(compute-layout (box-layout-node bx) 0 0)
(render-box bx b)
(is (string= (get-output-stream-string s) "")
"zero-size box produces no output"))))
(test box-single-column
"A box with width 1 renders nothing (needs min 2 for border)"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style :single :width 1 :height 5)))
(compute-layout (box-layout-node bx) 1 5)
(render-box bx b)
(is (string= (get-output-stream-string s) "")
"width=1 box renders nothing"))))
(test box-minimum-size
"A box with minimum non-zero size still renders"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style :single :width 2 :height 2)))
(compute-layout (box-layout-node bx) 2 2)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "┌" out) "2x2 box still has borders")))))
;; ── Text and Span Tests ───────────────────────────────────────
(test text-creates-with-defaults
"A text created with no arguments has reasonable defaults"
(let ((txt (make-text "")))
(is (typep txt 'text))
(is (typep (text-layout-node txt) 'layout-node))))
(test text-renders-content
"A text renders its content at position"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((tx (make-text "Hello" :width 10 :height 1)))
(compute-layout (text-layout-node tx) 10 1)
(render-text tx b)
(let ((out (get-output-stream-string s)))
(is (search "Hello" out) "content should appear")))))
(test text-empty-string
"Empty text produces no output"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((tx (make-text "" :width 10 :height 1)))
(compute-layout (text-layout-node tx) 10 1)
(render-text tx b)
(is (string= (get-output-stream-string s) "")
"empty string produces no output"))))
(test text-truncates-when-no-wrap
"Text with wrap-mode :none truncates at width"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((tx (make-text "Hello World" :width 5 :height 1
:wrap-mode :none)))
(compute-layout (text-layout-node tx) 5 1)
(render-text tx b)
(let ((out (get-output-stream-string s)))
(is (search "Hello" out) "truncated to first 5 chars")))))
(test text-word-wraps
"Text with wrap-mode :word wraps at word boundaries"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((tx (make-text "Hello brave new world" :width 6 :height 3)))
(compute-layout (text-layout-node tx) 6 3)
(render-text tx b)
(let ((out (get-output-stream-string s)))
(is (search "Hello" out) "first line")
(is (search "brave" out) "second line")
(is (search "new" out) "third line")))))
(test text-word-wrap-single-word
"A word longer than width is hard-broken at max-width"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((tx (make-text "Hello" :width 3 :height 3)))
(compute-layout (text-layout-node tx) 3 3)
(render-text tx b)
(let ((out (get-output-stream-string s)))
(is (search "Hel" out) "first chunk is Hel")
(is (search "lo" out) "second chunk is lo")))))
(test span-creates-with-attributes
"A span has text and optional style attributes"
(let ((s (span "bold text" :bold t)))
(is (string= (span-text s) "bold text"))
(is-true (span-bold s))
(is-false (span-italic s))))
(test make-text-with-spans
"Text with spans stores span objects"
(let* ((sp (list (span "Hello" :bold t)
(span "World" :italic t)))
(tx (make-text "" :spans sp)))
(is (= (length (text-spans tx)) 2))
(is (string= (span-text (elt (text-spans tx) 0)) "Hello"))
(is-true (span-bold (elt (text-spans tx) 0)))))

54
src/components/box.lisp Normal file
View File

@@ -0,0 +1,54 @@
(in-package :cl-tui.box)
(defclass box ()
((layout-node :initform (make-layout-node) :accessor box-layout-node
:initarg :layout-node)
(border-style :initform :single :initarg :border-style
:accessor box-border-style)
(title :initform nil :initarg :title :accessor box-title)
(title-align :initform :left :initarg :title-align
:accessor box-title-align)
(fg :initform nil :initarg :fg :accessor box-fg)
(bg :initform nil :initarg :bg :accessor box-bg)))
(defun make-box (&key (border-style :single) title
(title-align :left) fg bg
width height)
(make-instance 'box
:border-style border-style
:title title
:title-align title-align
:fg fg
:bg bg
:layout-node (make-layout-node
:width width
:height height
:direction :column)))
(defun render-box (box backend)
"Render BOX at its computed layout position using BACKEND."
(let ((ln (box-layout-node box))
(bs (box-border-style box))
(title (box-title box))
(fg (box-fg box))
(bg (box-bg box)))
(let ((x (layout-node-x ln))
(y (layout-node-y ln))
(w (layout-node-width ln))
(h (layout-node-height ln)))
(when (or (zerop w) (zerop h) (< w 2) (< h 2))
(return-from render-box (values)))
(when bg
(draw-rect backend x y w h :bg bg))
(when bs
(draw-border backend x y w h :style bs :fg fg :bg bg))
(when title
(let* ((content-w (- w 4))
(tx (+ x 2))
(ty (+ y (if bs 1 0)))
(ta (box-title-align box))
(display (subseq title 0 (min (length title) content-w))))
(case ta
(:center (draw-text backend (+ x (ceiling (- w (length display)) 2)) ty display fg bg))
(:right (draw-text backend (+ x (- w (length display) 2)) ty display fg bg))
(t (draw-text backend tx ty display fg bg))))))))

View File

@@ -0,0 +1,20 @@
;; Dirty tracking tests are in box-tests.lisp (same test suite)
(in-package :cl-tui-box-test)
(test dirty-mixin-default-is-dirty
"A dirty-mixin starts as dirty"
(let ((c (make-instance 'dirty-mixin)))
(is-true (dirty-p c) "new component should be dirty")))
(test mark-clean-clears-dirty
"mark-clean sets dirty to nil"
(let ((c (make-instance 'dirty-mixin)))
(mark-clean c)
(is-false (dirty-p c) "after mark-clean, should not be dirty")))
(test mark-dirty-sets-dirty
"mark-dirty sets dirty to t"
(let ((c (make-instance 'dirty-mixin)))
(mark-clean c)
(mark-dirty c)
(is-true (dirty-p c) "after mark-dirty, should be dirty again")))

14
src/components/dirty.lisp Normal file
View File

@@ -0,0 +1,14 @@
(in-package :cl-tui.box)
;; ── Dirty Tracking ─────────────────────────────────────────────
(defclass dirty-mixin ()
((dirty :initform t :accessor dirty-p)))
(defgeneric mark-clean (component)
(:method ((c dirty-mixin))
(setf (dirty-p c) nil)))
(defgeneric mark-dirty (component)
(:method ((c dirty-mixin))
(setf (dirty-p c) t)))

View File

@@ -0,0 +1,23 @@
(defpackage :cl-tui.box
(:use :cl :cl-tui.backend :cl-tui.layout)
(:export
;; Box
#:box #:make-box
#:box-layout-node
#:box-border-style #:box-title #:box-title-align
#:box-fg #:box-bg
#:render-box
;; Span
#:span
#:span-text #:span-bold #:span-italic #:span-underline
#:span-reverse #:span-dim #:span-fg #:span-bg
;; Text
#:text #:make-text
#:text-layout-node #:text-content #:text-spans
#:text-fg #:text-bg #:text-wrap-mode
#:render-text
;; Utilities (for tests)
#:word-wrap #:split-string
;; Dirty tracking
#:dirty-mixin #:dirty-p #:mark-clean #:mark-dirty))
(in-package :cl-tui.box)

106
src/components/text.lisp Normal file
View File

@@ -0,0 +1,106 @@
(in-package :cl-tui.box)
;; ── Text Renderable ────────────────────────────────────────────
(defclass span ()
((text :initarg :text :accessor span-text)
(bold :initform nil :initarg :bold :accessor span-bold)
(italic :initform nil :initarg :italic :accessor span-italic)
(underline :initform nil :initarg :underline :accessor span-underline)
(reverse :initform nil :initarg :reverse :accessor span-reverse)
(dim :initform nil :initarg :dim :accessor span-dim)
(fg :initform nil :initarg :fg :accessor span-fg)
(bg :initform nil :initarg :bg :accessor span-bg)))
(defun span (text &key bold italic underline reverse dim fg bg)
(make-instance 'span
:text text :bold bold :italic italic
:underline underline :reverse reverse :dim dim
:fg fg :bg bg))
(defclass text ()
((layout-node :initform (make-layout-node) :accessor text-layout-node
:initarg :layout-node)
(content :initform "" :initarg :content :accessor text-content)
(spans :initform nil :initarg :spans :accessor text-spans)
(fg :initform nil :initarg :fg :accessor text-fg)
(bg :initform nil :initarg :bg :accessor text-bg)
(wrap-mode :initform :word :initarg :wrap-mode :accessor text-wrap-mode)))
(defun make-text (content &key fg bg wrap-mode width height spans)
(make-instance 'text
:content content
:fg fg :bg bg
:wrap-mode (or wrap-mode :word)
:spans spans
:layout-node (make-layout-node :direction :column
:width width :height height)))
(defun render-text (text-object backend)
"Render TEXT-OBJECT at its computed layout position using BACKEND."
(let ((ln (text-layout-node text-object))
(content (text-content text-object))
(fg (text-fg text-object))
(bg (text-bg text-object))
(wrap (text-wrap-mode text-object))
(spans (text-spans text-object)))
(declare (ignore spans))
(let ((x (layout-node-x ln))
(y (layout-node-y ln))
(w (layout-node-width ln))
(h (layout-node-height ln)))
(when (or (zerop (length content)) (zerop w) (zerop h))
(return-from render-text (values)))
(if (eql wrap :none)
(let ((display (subseq content 0 (min (length content) w))))
(draw-text backend x y display fg bg))
(let ((lines (word-wrap content w))
(max-lines h))
(loop for line in lines
for row from 0 below max-lines
do (draw-text backend x (+ y row) line fg bg)))))))
(defun word-wrap (text max-width)
"Split TEXT into lines, each <= MAX-WIDTH chars.
Breaks at word boundaries. Words exceeding MAX-WIDTH are hard-broken."
(if (or (zerop max-width) (zerop (length text)))
(list "")
(let ((words (split-string text)) (lines nil) (current nil) (current-len 0))
(dolist (word words)
(let ((wl (length word)))
(cond ((<= wl max-width)
(if (and current (<= (+ current-len 1 wl) max-width))
(push word current)
(progn
(when current
(push (format nil "~{~A~^ ~}" (nreverse current)) lines))
(setf current (list word))
(setf current-len wl))))
(t
(when current
(push (format nil "~{~A~^ ~}" (nreverse current)) lines)
(setf current nil)
(setf current-len 0))
(loop for i from 0 below wl by max-width
do (push (subseq word i (min (+ i max-width) wl)) lines))))))
(when current
(push (format nil "~{~A~^ ~}" (nreverse current)) lines))
(or (nreverse lines) (list "")))))
(defun split-string (string)
"Split STRING into words separated by whitespace."
(loop with words = nil
with start = 0
with len = (length string)
while (< start len)
do (let ((ws-start (position-if (lambda (c) (find c '(#\Space #\Tab #\Newline)))
string :start start)))
(if ws-start
(progn
(when (> ws-start start)
(push (subseq string start ws-start) words))
(setf start (1+ ws-start)))
(progn
(push (subseq string start) words)
(setf start len))))
finally (return (nreverse words))))