diff --git a/cl-tui.asd b/cl-tui.asd index 8d4a08d..e07c66a 100644 --- a/cl-tui.asd +++ b/cl-tui.asd @@ -18,7 +18,8 @@ (:module "src/components" :components ((:file "package") - (:file "box" :depends-on ("package"))))) + (:file "box" :depends-on ("package")) + (:file "text" :depends-on ("package" "box"))))) :in-order-to ((test-op (test-op :cl-tui-tests)))) (asdf:defsystem :cl-tui-tests diff --git a/src/components/box-tests.lisp b/src/components/box-tests.lisp index ad123b7..a4d95e2 100644 --- a/src/components/box-tests.lisp +++ b/src/components/box-tests.lisp @@ -16,6 +16,8 @@ (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))) @@ -42,7 +44,6 @@ (render-box bx b) (let ((out (get-output-stream-string s))) (is (search "┌" out) "border with background") - ;; :red is a named color → indexed SGR (41m, not 48;2;...) (is (search "41m" out) "SGR background for red"))))) (test box-renders-title @@ -81,3 +82,75 @@ (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 + "Text wraps even a single word if it exceeds 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) "word truncated to width"))))) + +(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))))) diff --git a/src/components/package.lisp b/src/components/package.lisp index 6e44d55..8a3a6a7 100644 --- a/src/components/package.lisp +++ b/src/components/package.lisp @@ -1,9 +1,21 @@ (defpackage :cl-tui.box (:use :cl :cl-tui.backend :cl-tui.layout) (:export + ;; Box #:box #:make-box #:box-layout-node #:box-border-style #:box-title #:box-title-align #:box-fg #:box-bg - #:render-box)) + #:render-box + ;; Span + #:span + #:span-text #:span-bold #:span-italic #:span-underline + #:span-reverse #:span-dim #:span-fg #:span-bg + ;; Text + #:text #:make-text + #:text-layout-node #:text-content #:text-spans + #:text-fg #:text-bg #:text-wrap-mode + #:render-text + ;; Utilities (for tests) + #:word-wrap #:split-string)) (in-package :cl-tui.box) diff --git a/src/components/text.lisp b/src/components/text.lisp new file mode 100644 index 0000000..915bfea --- /dev/null +++ b/src/components/text.lisp @@ -0,0 +1,106 @@ +(in-package :cl-tui.box) + +;; ── Text Renderable ──────────────────────────────────────────── + +(defclass span () + ((text :initarg :text :accessor span-text) + (bold :initform nil :initarg :bold :accessor span-bold) + (italic :initform nil :initarg :italic :accessor span-italic) + (underline :initform nil :initarg :underline :accessor span-underline) + (reverse :initform nil :initarg :reverse :accessor span-reverse) + (dim :initform nil :initarg :dim :accessor span-dim) + (fg :initform nil :initarg :fg :accessor span-fg) + (bg :initform nil :initarg :bg :accessor span-bg))) + +(defun span (text &key bold italic underline reverse dim fg bg) + (make-instance 'span + :text text :bold bold :italic italic + :underline underline :reverse reverse :dim dim + :fg fg :bg bg)) + +(defclass text () + ((layout-node :initform (make-layout-node) :accessor text-layout-node + :initarg :layout-node) + (content :initform "" :initarg :content :accessor text-content) + (spans :initform nil :initarg :spans :accessor text-spans) + (fg :initform nil :initarg :fg :accessor text-fg) + (bg :initform nil :initarg :bg :accessor text-bg) + (wrap-mode :initform :word :initarg :wrap-mode :accessor text-wrap-mode))) + +(defun make-text (content &key fg bg wrap-mode width height spans) + (make-instance 'text + :content content + :fg fg :bg bg + :wrap-mode (or wrap-mode :word) + :spans spans + :layout-node (make-layout-node :direction :column + :width width :height height))) + +(defun render-text (text-object backend) + "Render TEXT-OBJECT at its computed layout position using BACKEND." + (let ((ln (text-layout-node text-object)) + (content (text-content text-object)) + (fg (text-fg text-object)) + (bg (text-bg text-object)) + (wrap (text-wrap-mode text-object)) + (spans (text-spans text-object))) + (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) + ;; No wrap — truncate to width + (let ((display (subseq content 0 (min (length content) w)))) + (draw-text backend x y display fg bg)) + ;; Word wrap + (let ((lines (word-wrap content w)) + (max-lines h)) + (loop for line in lines + for row from 0 below max-lines + do (draw-text backend x (+ y row) line fg bg))))))) + +(defun word-wrap (text max-width) + "Split TEXT into lines, each no longer than MAX-WIDTH characters. + Breaks at word boundaries when possible." + (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 ((word-len (length word))) + (if (and current (<= (+ current-len 1 word-len) max-width)) + ;; Add to current line + (progn + (push word current) + (incf current-len (1+ word-len))) + ;; Start new line + (progn + (when current + (push (format nil "~{~A~^ ~}" (nreverse current)) lines)) + (setf current (list word)) + (setf current-len word-len))))) + (when current + (push (format nil "~{~A~^ ~}" (nreverse current)) lines)) + (or (nreverse lines) (list ""))))) + +(defun split-string (string) + "Split STRING into words separated by whitespace." + (loop with words = nil + with start = 0 + with len = (length string) + while (< start len) + do (let ((ws-start (position-if (lambda (c) (find c '(#\Space #\Tab #\Newline))) + string :start start))) + (if ws-start + (progn + (when (> ws-start start) + (push (subseq string start ws-start) words)) + (setf start (1+ ws-start))) + (progn + (push (subseq string start) words) + (setf start len)))) + finally (return (nreverse words))))