f50d0e61d1
Now tangles to box.lisp + text.lisp + box-tests.lisp. Deleted hand-written originals and regenerated — GREEN.
16 KiB
16 KiB
Box and Text Renderables
Overview
Box and Text are the two fundamental renderable component types. Box provides a bordered container with optional background fill and title. Text renders strings with word-wrap, color, and inline style spans.
Both inherit from dirty-mixin for incremental rendering support and
carry a layout-node for position/size computed by the layout engine.
Contract
Box
(make-box &key border-style title title-align fg bg width height)→ box(render-box box backend)— draw the box at its layout position- Border styles:
:single,:double,:rounded,nil(no border)
Span
(span text &key bold italic underline reverse dim fg bg)→ span- Inline text segment with per-run style attributes.
Text
(make-text content &key fg bg wrap-mode width height spans)→ text(render-text text-object backend)— render text at layout position- Wrap modes:
:word(break at word boundaries),:none(truncate)
Utilities
(word-wrap text max-width)→ list of strings(split-string string)→ list of words
Tests
(defpackage :cl-tty-box-test
(:use :cl :fiveam :cl-tty.backend :cl-tty.layout :cl-tty.box)
(:export #:run-tests))
(in-package :cl-tty-box-test)
(def-suite box-suite :description "Box renderable tests")
(in-suite box-suite)
(defun run-tests ()
(let ((result (run 'box-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
(defun make-capturing-backend ()
(let* ((s (make-string-output-stream))
(b (make-modern-backend :output-stream s)))
(values b s)))
;; ── Box Tests ─────────────────────────────────────────────────
(test box-creates-with-defaults
"A box created with no arguments has reasonable defaults"
(let ((b (make-box)))
(is (typep b 'box))
(is (typep (box-layout-node b) 'layout-node))))
(test box-renders-border
"A box with border draws border characters"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style :single :width 10 :height 5)))
(compute-layout (box-layout-node bx) 10 5)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "┌" out) "top-left corner")
(is (search "┐" out) "top-right corner")
(is (search "└" out) "bottom-left corner")
(is (search "┘" out) "bottom-right corner")))))
(test box-renders-background
"A box with background color fills interior"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :bg :red :width 5 :height 3)))
(compute-layout (box-layout-node bx) 5 3)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "┌" out) "border with background")
(is (search "41m" out) "SGR background for red")))))
(test box-renders-title
"A box with title renders the title text"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :title "Hello" :width 12 :height 3)))
(compute-layout (box-layout-node bx) 12 3)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "Hello" out) "title text should appear")))))
(test box-without-border
"A box with border-style nil draws no border"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style nil :bg :red :width 5 :height 3)))
(compute-layout (box-layout-node bx) 5 3)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "41m" out) "background still renders")
(is-false (search "┌" out) "no top-left corner")))))
(test box-zero-size
"A box with any zero dimension renders nothing"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style :single :width 0 :height 0)))
(compute-layout (box-layout-node bx) 0 0)
(render-box bx b)
(is (string= (get-output-stream-string s) "")
"zero-size box produces no output"))))
(test box-single-column
"A box with width 1 renders nothing (needs min 2 for border)"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style :single :width 1 :height 5)))
(compute-layout (box-layout-node bx) 1 5)
(render-box bx b)
(is (string= (get-output-stream-string s) "")
"width=1 box renders nothing"))))
(test box-minimum-size
"A box with minimum non-zero size still renders"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style :single :width 2 :height 2)))
(compute-layout (box-layout-node bx) 2 2)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "┌" out) "2x2 box still has borders")))))
;; ── Text and Span Tests ───────────────────────────────────────
(test text-creates-with-defaults
"A text created with no arguments has reasonable defaults"
(let ((txt (make-text "")))
(is (typep txt 'text))
(is (typep (text-layout-node txt) 'layout-node))))
(test text-renders-content
"A text renders its content at position"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((tx (make-text "Hello" :width 10 :height 1)))
(compute-layout (text-layout-node tx) 10 1)
(render-text tx b)
(let ((out (get-output-stream-string s)))
(is (search "Hello" out) "content should appear")))))
(test text-empty-string
"Empty text produces no output"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((tx (make-text "" :width 10 :height 1)))
(compute-layout (text-layout-node tx) 10 1)
(render-text tx b)
(is (string= (get-output-stream-string s) "")
"empty string produces no output"))))
(test text-truncates-when-no-wrap
"Text with wrap-mode :none truncates at width"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((tx (make-text "Hello World" :width 5 :height 1
:wrap-mode :none)))
(compute-layout (text-layout-node tx) 5 1)
(render-text tx b)
(let ((out (get-output-stream-string s)))
(is (search "Hello" out) "truncated to first 5 chars")))))
(test text-word-wraps
"Text with wrap-mode :word wraps at word boundaries"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((tx (make-text "Hello brave new world" :width 6 :height 3)))
(compute-layout (text-layout-node tx) 6 3)
(render-text tx b)
(let ((out (get-output-stream-string s)))
(is (search "Hello" out) "first line")
(is (search "brave" out) "second line")
(is (search "new" out) "third line")))))
(test text-word-wrap-single-word
"A word longer than width is hard-broken at max-width"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((tx (make-text "Hello" :width 3 :height 3)))
(compute-layout (text-layout-node tx) 3 3)
(render-text tx b)
(let ((out (get-output-stream-string s)))
(is (search "Hel" out) "first chunk is Hel")
(is (search "lo" out) "second chunk is lo")))))
(test span-creates-with-attributes
"A span has text and optional style attributes"
(let ((s (span "bold text" :bold t)))
(is (string= (span-text s) "bold text"))
(is-true (span-bold s))
(is-false (span-italic s))))
(test make-text-with-spans
"Text with spans stores span objects"
(let* ((sp (list (span "Hello" :bold t)
(span "World" :italic t)))
(tx (make-text "" :spans sp)))
(is (= (length (text-spans tx)) 2))
(is (string= (span-text (elt (text-spans tx) 0)) "Hello"))
(is-true (span-bold (elt (text-spans tx) 0)))))Implementation
Box class
box inherits from dirty-mixin so changes (resize, title update,
color change) trigger incremental re-render. The layout-node slot
holds the computed position and size from the layout engine.
(in-package :cl-tty.box)
(defclass box (dirty-mixin)
((layout-node :initform (make-layout-node) :accessor box-layout-node
:initarg :layout-node)
(border-style :initform :single :initarg :border-style
:accessor box-border-style)
(title :initform nil :initarg :title :accessor box-title)
(title-align :initform :left :initarg :title-align
:accessor box-title-align)
(fg :initform nil :initarg :fg :accessor box-fg)
(bg :initform nil :initarg :bg :accessor box-bg)))
The constructor wraps make-instance and passes layout parameters
through to the layout node:
(defun make-box (&key (border-style :single) title
(title-align :left) fg bg
width height)
(make-instance 'box
:border-style border-style
:title title
:title-align title-align
:fg fg
:bg bg
:layout-node (make-layout-node
:width width
:height height
:direction :column)))
render-box draws the border at the component's layout position.
It handles zero-size (returns immediately) and optional background
fill.
(defun render-box (box backend)
"Render BOX at its computed layout position using BACKEND."
(let ((ln (box-layout-node box))
(bs (box-border-style box))
(title (box-title box))
(fg (box-fg box))
(bg (box-bg box)))
(let ((x (layout-node-x ln))
(y (layout-node-y ln))
(w (layout-node-width ln))
(h (layout-node-height ln)))
(when (or (zerop w) (zerop h) (< w 2) (< h 2))
(return-from render-box (values)))
(when bg
(draw-rect backend x y w h :bg bg))
(when bs
(draw-border backend x y w h :style bs :fg fg :bg bg))
(when title
(let* ((content-w (- w 4))
(tx (+ x 2))
(ty (+ y (if bs 1 0)))
(ta (box-title-align box))
(display (subseq title 0 (min (length title) content-w))))
(case ta
(:center (draw-text backend (+ x (ceiling (- w (length display)) 2)) ty display fg bg))
(:right (draw-text backend (+ x (- w (length display) 2)) ty display fg bg))
(t (draw-text backend tx ty display fg bg))))))))
The early return for (< w 2) is important: draw-border requires
at least 2 columns of width to draw corner characters.
Span class
span represents an inline styled segment within a Text component.
Multiple spans let a single Text contain bold, colored, or italicized
runs.
(in-package :cl-tty.box)
;; ── Text Renderable ────────────────────────────────────────────
(defclass span ()
((text :initarg :text :accessor span-text)
(bold :initform nil :initarg :bold :accessor span-bold)
(italic :initform nil :initarg :italic :accessor span-italic)
(underline :initform nil :initarg :underline :accessor span-underline)
(reverse :initform nil :initarg :reverse :accessor span-reverse)
(dim :initform nil :initarg :dim :accessor span-dim)
(fg :initform nil :initarg :fg :accessor span-fg)
(bg :initform nil :initarg :bg :accessor span-bg)))
(defun span (text &key bold italic underline reverse dim fg bg)
(make-instance 'span
:text text :bold bold :italic italic
:underline underline :reverse reverse :dim dim
:fg fg :bg bg))Text class
text renders a string at a layout position with word-wrapping.
Spans are stored but not yet rendered with per-run styling in the
current implementation.
(defclass text (dirty-mixin)
((layout-node :initform (make-layout-node) :accessor text-layout-node
:initarg :layout-node)
(content :initform "" :initarg :content :accessor text-content)
(spans :initform nil :initarg :spans :accessor text-spans)
(fg :initform nil :initarg :fg :accessor text-fg)
(bg :initform nil :initarg :bg :accessor text-bg)
(wrap-mode :initform :word :initarg :wrap-mode :accessor text-wrap-mode)))
(defun make-text (content &key fg bg wrap-mode width height spans)
(make-instance 'text
:content content
:fg fg :bg bg
:wrap-mode (or wrap-mode :word)
:spans spans
:layout-node (make-layout-node :direction :column
:width width :height height)))
render-text handles both wrap modes. For :word, it calls
word-wrap to break the content into lines, then renders each line
at successive row positions.
(defun render-text (text-object backend)
"Render TEXT-OBJECT at its computed layout position using BACKEND."
(let ((ln (text-layout-node text-object))
(content (text-content text-object))
(fg (text-fg text-object))
(bg (text-bg text-object))
(wrap (text-wrap-mode text-object))
(spans (text-spans text-object)))
(declare (ignore spans))
(let ((x (layout-node-x ln))
(y (layout-node-y ln))
(w (layout-node-width ln))
(h (layout-node-height ln)))
(when (or (zerop (length content)) (zerop w) (zerop h))
(return-from render-text (values)))
(if (eql wrap :none)
(let ((display (subseq content 0 (min (length content) w))))
(draw-text backend x y display fg bg))
(let ((lines (word-wrap content w))
(max-lines h))
(loop for line in lines
for row from 0 below max-lines
do (draw-text backend x (+ y row) line fg bg)))))))Word wrapping utility
word-wrap implements the line-breaking algorithm. It splits the
input into words, then packs them into lines respecting max-width.
Words that exceed max-width are hard-broken at character boundaries.
(defun word-wrap (text max-width)
"Split TEXT into lines, each <= MAX-WIDTH chars."
(if (or (zerop max-width) (zerop (length text)))
(list "")
(let ((words (split-string text)) (lines nil) (current nil) (current-len 0))
(dolist (word words)
(let ((wl (length word)))
(cond ((<= wl max-width)
(if (and current (<= (+ current-len 1 wl) max-width))
(progn
(push word current)
(incf current-len (1+ wl)))
(progn
(when current
(push (format nil "~{~A~^ ~}" (nreverse current)) lines))
(setf current (list word))
(setf current-len wl))))
(t
(when current
(push (format nil "~{~A~^ ~}" (nreverse current)) lines)
(setf current nil)
(setf current-len 0))
(loop for i from 0 below wl by max-width
do (push (subseq word i (min (+ i max-width) wl)) lines))))))
(when current
(push (format nil "~{~A~^ ~}" (nreverse current)) lines))
(or (nreverse lines) (list "")))))
split-string tokenizes on whitespace (space, tab, newline):
(defun split-string (string)
"Split STRING into words separated by whitespace."
(loop with words = nil
with start = 0
with len = (length string)
while (< start len)
do (let ((ws-start (position-if (lambda (c) (find c '(#\Space #\Tab #\Newline)))
string :start start)))
(if ws-start
(progn
(when (> ws-start start)
(push (subseq string start ws-start) words))
(setf start (1+ ws-start)))
(progn
(push (subseq string start) words)
(setf start len))))
finally (return (nreverse words))))