6 Commits

Author SHA1 Message Date
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
15 changed files with 2865 additions and 3 deletions

View File

@@ -50,3 +50,4 @@ See ~docs/ROADMAP.org~ for the full release plan.
** License ** License
TBD 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) "║")))

245
backend/modern.lisp Normal file
View File

@@ -0,0 +1,245 @@
;;; 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*
: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 :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")))

31
cl-tui.asd Normal file
View File

@@ -0,0 +1,31 @@
;;; cl-tui.asd — Common Lisp Terminal UI Framework
(asdf:defsystem :cl-tui
:description "Reusable Common Lisp Terminal UI Framework"
:author "Amr Gharbeia"
:version "0.0.3"
: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"))))
: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"))))
:perform (test-op (o c)
(uiop:symbol-call :cl-tui-backend-test '#:run!)))

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 * The Roadmap
Each phase is one minor release. Phases ship in dependency order — each depends on 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 the components from prior phases. The backend protocol ships first because
else builds on it. 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). the patch version (v0.X.Y).
** File Update Checklist ** File Update Checklist

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

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

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

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