diff --git a/README.org b/README.org index 642f104..55e55c8 100644 --- a/README.org +++ b/README.org @@ -50,3 +50,4 @@ See ~docs/ROADMAP.org~ for the full release plan. ** License TBD +# Test diff --git a/backend/classes.lisp b/backend/classes.lisp new file mode 100644 index 0000000..368f9d2 --- /dev/null +++ b/backend/classes.lisp @@ -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)) diff --git a/backend/modern-tests.lisp b/backend/modern-tests.lisp new file mode 100644 index 0000000..2c698a1 --- /dev/null +++ b/backend/modern-tests.lisp @@ -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) "║"))) diff --git a/backend/modern.lisp b/backend/modern.lisp new file mode 100644 index 0000000..b83597a --- /dev/null +++ b/backend/modern.lisp @@ -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))) + diff --git a/backend/package.lisp b/backend/package.lisp new file mode 100644 index 0000000..0b50b26 --- /dev/null +++ b/backend/package.lisp @@ -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) diff --git a/backend/simple.lisp b/backend/simple.lisp new file mode 100644 index 0000000..ab82279 --- /dev/null +++ b/backend/simple.lisp @@ -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 "...")) diff --git a/backend/tests.lisp b/backend/tests.lisp new file mode 100644 index 0000000..01d8359 --- /dev/null +++ b/backend/tests.lisp @@ -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"))) diff --git a/cl-tui.asd b/cl-tui.asd new file mode 100644 index 0000000..d22a94a --- /dev/null +++ b/cl-tui.asd @@ -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!))) diff --git a/docs/ARCHITECTURE.org b/docs/ARCHITECTURE.org new file mode 100644 index 0000000..7234f63 --- /dev/null +++ b/docs/ARCHITECTURE.org @@ -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) diff --git a/docs/ROADMAP.org b/docs/ROADMAP.org index 1d1f0e5..c9d2bf0 100644 --- a/docs/ROADMAP.org +++ b/docs/ROADMAP.org @@ -5,10 +5,81 @@ * The Roadmap Each phase is one minor release. Phases ship in dependency order — each depends on -the components from prior phases. The layout engine ships first because everything -else builds on it. +the components from prior phases. The backend protocol ships first because +everything else builds on it. -Feature releases increment the minor version (v0.X.0). Bugfix releases increment +** v0.0.1: Foundation — Backend Protocol + +The abstraction layer that makes everything portable. Two backends: +=modern= (raw escape sequences, truecolor, modern features) and =simple= +(ASCII art, universal compatibility). The component tree never touches +the terminal directly — it dispatches through the protocol. + +*** TODO Backend protocol definition +:PROPERTIES: +:ID: id-v000-protocol +:CREATED: [2026-05-10 Sat] +:END: + +- Define =backend= abstract class with generic functions: + - =initialize-backend=, =shutdown-backend=, =suspend-backend=, =resume-backend= + - =backend-size=, =backend-write=, =backend-clear= + - =begin-sync=, =end-sync= — DECICM synchronized updates + - =draw-rect=, =draw-text=, =draw-border=, =draw-ellipsis=, =draw-link= + - =cursor-move=, =cursor-hide=, =cursor-show=, =cursor-style= + - =read-event=, =enable-mouse=, =enable-bracketed-paste=, =set-keyboard-mode= + - =capable-p= — query feature support +- Style plist structure: ~(:fg :error :bg :background-panel :bold t :italic nil ...)~ +- ~100 lines + +*** TODO Simple backend +:PROPERTIES: +:ID: id-v000-simple +:CREATED: [2026-05-10 Sat] +:END: + +- =simple-backend= class — inherits =backend= +- Borders: ASCII (~+-|~), no rounded corners +- No color, no bold/italic — plain characters only +- No OSC 8 links, no mouse, no synchronized updates +- Works on any terminal, any SSH connection, piped output +- ~100 lines + +*** TODO Modern backend +:PROPERTIES: +:ID: id-v000-modern +:CREATED: [2026-05-10 Sat] +:END: + +- =modern-backend= class — inherits =backend= +- Truecolor 24-bit foreground/background +- Rounded, single, double border styles via Unicode box-drawing +- OSC 8 hyperlinks (clickable URLs) +- DECICM synchronized updates (flicker-free) +- SGR mouse tracking + kitty keyboard protocol +- Bracketed paste detection +- Bold, italic, underline, dim, blink, reverse, strikethrough +- Cursor style: =:bar=, =:block=, =:underline=, with blink option +- ~250 lines + +*** TODO Terminal capability detection +:PROPERTIES: +:ID: id-v000-detection +:CREATED: [2026-05-10 Sat] +:END: + +- =detect-backend= → returns =modern-backend= or =simple-backend= +- Check if stdout is a TTY (if not → =simple-backend=) +- Send DA1 (~ESC[c~) query, 100ms timeout +- Send DA3 (~ESC[?c~) for kitty/wezterm identification +- Query DECRPM (~ESC[?2026$p~) for DECICM sync support +- Query truecolor support via =COLORTERM= env var + DA response +- Cache detection result so subsequent calls are instant +- ~100 lines + +~550 lines total. Dependencies: None (pure CL, no FFI, no external libs). + +** v0.0.2: Layout Engine the patch version (v0.X.Y). ** File Update Checklist diff --git a/layout/layout.lisp b/layout/layout.lisp new file mode 100644 index 0000000..e1a3a2e --- /dev/null +++ b/layout/layout.lisp @@ -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))) diff --git a/layout/tests.lisp b/layout/tests.lisp new file mode 100644 index 0000000..5054bea --- /dev/null +++ b/layout/tests.lisp @@ -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))))) diff --git a/org/backend-protocol.org b/org/backend-protocol.org new file mode 100644 index 0000000..f1830fe --- /dev/null +++ b/org/backend-protocol.org @@ -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 diff --git a/org/layout-engine.org b/org/layout-engine.org new file mode 100644 index 0000000..d68b814 --- /dev/null +++ b/org/layout-engine.org @@ -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 diff --git a/org/modern-backend.org b/org/modern-backend.org new file mode 100644 index 0000000..84a8854 --- /dev/null +++ b/org/modern-backend.org @@ -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