restructure: move backend/ and layout/ into src/; convert README to org syntax; fix demo package conflict and alien-sap ioctl; update ROADMAP with v0.15.0; remove stale files
- Move backend/ and layout/ directories into src/ - Update all path references in ASD, scripts, docs - Convert README.org from Markdown syntax to proper Org-mode - Fix demo.lisp use-package conflict (both backend and input export #:read-event) - Fix modern-backend TIOCGWINSZ ioctl alien type (alien-sap wrapper) - Add v0.15.0 section to ROADMAP, update line count to 5760 - Add known gaps (suspend/resume-backend, slot modes) to v1.0.0 checklist - Remove docs/plans/, debug-layout.lisp, system-index.txt, ci-watchdog.sh - Move tangle.py to Hermes skill (org-babel-tangle) - Add .gitignore for fasl files
This commit is contained in:
Hermes Agent
64
src/backend/classes.lisp
Normal file
64
src/backend/classes.lisp
Normal file
@@ -0,0 +1,64 @@
|
||||
(in-package :cl-tty.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
|
||||
&allow-other-keys))
|
||||
|
||||
(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)
|
||||
(:method ((b backend) x y) (declare (ignore x y)) (values)))
|
||||
|
||||
(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))
|
||||
62
src/backend/detection.lisp
Normal file
62
src/backend/detection.lisp
Normal file
@@ -0,0 +1,62 @@
|
||||
(in-package :cl-tty.backend)
|
||||
|
||||
;;; ─── Detection cache ────────────────────────────────────────────────────────
|
||||
|
||||
(defvar *detected-backend* nil
|
||||
"Cached backend instance from detect-backend. Nil = not yet detected.")
|
||||
|
||||
;;; ─── Environment probe ──────────────────────────────────────────────────────
|
||||
|
||||
(defun detect-backend-by-env ()
|
||||
"Check COLORTERM environment variable for modern terminal support.
|
||||
Returns :modern if COLORTERM contains 'truecolor' or '24bit', nil otherwise."
|
||||
(let ((colorterm (sb-ext:posix-getenv "COLORTERM")))
|
||||
(when (and colorterm
|
||||
(or (search "truecolor" colorterm :test #'char-equal)
|
||||
(search "24bit" colorterm :test #'char-equal)))
|
||||
:modern)))
|
||||
|
||||
;;; ─── TTY probe ──────────────────────────────────────────────────────────────
|
||||
|
||||
(defun detect-backend-by-tty ()
|
||||
"Check if stdout is a real terminal (not a pipe/redirect).
|
||||
Returns T if stdout is interactive, nil otherwise."
|
||||
(interactive-stream-p *standard-output*))
|
||||
|
||||
;;; ─── DA1 terminal query ─────────────────────────────────────────────────────
|
||||
|
||||
(defun query-terminal (query &optional (timeout 0.1))
|
||||
"Send QUERY string to terminal and return any response received within
|
||||
TIMEOUT seconds. Returns the response string, or nil if no response."
|
||||
(write-string query *standard-output*)
|
||||
(force-output *standard-output*)
|
||||
(sleep timeout)
|
||||
(let ((response (make-array 0 :element-type 'character
|
||||
:fill-pointer 0 :adjustable t)))
|
||||
(loop while (listen *standard-input*)
|
||||
do (vector-push-extend (read-char-no-hang *standard-input*) response))
|
||||
(when (plusp (length response))
|
||||
response)))
|
||||
|
||||
(defun detect-backend-by-da1 ()
|
||||
"Send DA1 (ESC[c) query and check for kitty terminal response code.
|
||||
Returns T if terminal reports kitty compatibility codes."
|
||||
(let ((response (query-terminal (format nil "~C[c" #\Esc))))
|
||||
(when response
|
||||
;; DA1 response format: ESC [ ? digits ; digits c
|
||||
;; Kitty reports code 62 in the response
|
||||
(search "?62" response))))
|
||||
|
||||
;;; ─── Orchestrator ───────────────────────────────────────────────────────────
|
||||
|
||||
(defun detect-backend ()
|
||||
"Auto-detect the appropriate backend for the current terminal.
|
||||
Returns a backend instance (modern-backend or simple-backend).
|
||||
Result is cached in *detected-backend* for subsequent calls."
|
||||
(or *detected-backend*
|
||||
(setf *detected-backend*
|
||||
(if (and (detect-backend-by-tty)
|
||||
(or (eql (detect-backend-by-env) :modern)
|
||||
(detect-backend-by-da1)))
|
||||
(make-modern-backend)
|
||||
(make-simple-backend)))))
|
||||
124
src/backend/modern-tests.lisp
Normal file
124
src/backend/modern-tests.lisp
Normal file
@@ -0,0 +1,124 @@
|
||||
(defpackage :cl-tty-modern-backend-test
|
||||
(:use :cl :fiveam :cl-tty.backend)
|
||||
(:export #:run-tests))
|
||||
(in-package :cl-tty-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-tty.backend::modern-backend))))
|
||||
|
||||
;; ── Escape Generation ──────────────────────────────────────────
|
||||
|
||||
(test sgr-truecolor-foreground
|
||||
"SGR truecolor foreground escape is correct"
|
||||
(is (equal (cl-tty.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-tty.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-tty.backend::sgr-fg :red)
|
||||
(format nil "~C[31m" #\Esc)))
|
||||
(is (equal (cl-tty.backend::sgr-bg :blue)
|
||||
(format nil "~C[44m" #\Esc))))
|
||||
|
||||
(test sgr-bold-italic
|
||||
"SGR attribute escapes are correct"
|
||||
(is (equal (cl-tty.backend::sgr-attr :bold) (format nil "~C[1m" #\Esc)))
|
||||
(is (equal (cl-tty.backend::sgr-attr :italic) (format nil "~C[3m" #\Esc)))
|
||||
(is (equal (cl-tty.backend::sgr-attr :underline) (format nil "~C[4m" #\Esc)))
|
||||
(is (equal (cl-tty.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-tty.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-tty.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-tty.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-tty.backend::cursor-style-escape :underline t)
|
||||
(format nil "~C[5 q" #\Esc)))))
|
||||
|
||||
;; ── Synchronization ────────────────────────────────────────────
|
||||
|
||||
(test decicm-escapes
|
||||
"DECICM synchronized update escapes"
|
||||
(is (equal (cl-tty.backend::decicm-begin) (format nil "~C[?2026h" #\Esc)))
|
||||
(is (equal (cl-tty.backend::decicm-end) (format nil "~C[?2026l" #\Esc))))
|
||||
|
||||
;; ── OSC 8 Hyperlinks ──────────────────────────────────────────
|
||||
|
||||
(test osc8-escape
|
||||
"OSC 8 hyperlink escape wraps text"
|
||||
(is (equal (cl-tty.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-tty.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-tty.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-tty.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-tty.backend::border-char :rounded :top-left) "╭"))
|
||||
(is (equal (cl-tty.backend::border-char :rounded :horizontal) "─"))
|
||||
(is (equal (cl-tty.backend::border-char :rounded :vertical) "│"))
|
||||
(is (equal (cl-tty.backend::border-char :rounded :bottom-right) "╯")))
|
||||
|
||||
(test border-char-double
|
||||
"modern-border-char returns double-line chars"
|
||||
(is (equal (cl-tty.backend::border-char :double :top-left) "╔"))
|
||||
(is (equal (cl-tty.backend::border-char :double :horizontal) "═"))
|
||||
(is (equal (cl-tty.backend::border-char :double :vertical) "║")))
|
||||
310
src/backend/modern.lisp
Normal file
310
src/backend/modern.lisp
Normal file
@@ -0,0 +1,310 @@
|
||||
;;; 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-tty.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)))
|
||||
|
||||
(defvar *theme-colors* (make-hash-table :test 'eq)
|
||||
"Hash table mapping theme keywords to hex color strings.
|
||||
Populated by the theme system's load-preset. Checked by sgr-fg/sgr-bg
|
||||
as a fallback when a keyword is not in *named-colors*.")
|
||||
|
||||
(defun sgr-fg (color)
|
||||
"Return SGR foreground escape for COLOR.
|
||||
Color can be a hex string, a keyword name, or nil.
|
||||
Keywords first try *named-colors*, then fall back to *theme-colors*
|
||||
which resolves theme semantic roles to hex strings."
|
||||
(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))
|
||||
;; Fall back to theme-colors hash
|
||||
(let ((hex (gethash color *theme-colors*)))
|
||||
(if hex
|
||||
(multiple-value-bind (r g b) (hex-to-rgb hex)
|
||||
(format nil "~C[38;2;~d;~d;~dm" #\Esc r g b))
|
||||
"")))))
|
||||
(t ""))))
|
||||
|
||||
(defun sgr-bg (color)
|
||||
"Return SGR background escape for COLOR.
|
||||
Keywords first try *named-colors*, then fall back to *theme-colors*."
|
||||
(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))
|
||||
;; Fall back to theme-colors hash
|
||||
(let ((hex (gethash color *theme-colors*)))
|
||||
(if hex
|
||||
(multiple-value-bind (r g b) (hex-to-rgb hex)
|
||||
(format nil "~C[48;2;~d;~d;~dm" #\Esc r g b))
|
||||
"")))))
|
||||
(t ""))))
|
||||
|
||||
(defparameter *sgr-attr-codes*
|
||||
'((:bold . 1) (:dim . 2) (:italic . 3) (:underline . 4)
|
||||
(:blink . 5) (:reverse . 7) (:reset . 0)))
|
||||
|
||||
(defun sgr-attr (attr)
|
||||
"Return SGR attribute escape for ATTR keyword."
|
||||
(let ((code (cdr (assoc attr *sgr-attr-codes*))))
|
||||
(if code
|
||||
(format nil "~C[~dm" #\Esc code)
|
||||
"")))
|
||||
|
||||
(defun cursor-move-escape (x y)
|
||||
"Return CSI escape to move cursor to (x, y), 1-indexed."
|
||||
(format nil "~C[~d;~dH" #\Esc (1+ y) (1+ x)))
|
||||
|
||||
(defun cursor-style-escape (shape blink)
|
||||
"Return DECSTR escape for cursor shape.
|
||||
:block = 2, :underline = 4, :bar = 6.
|
||||
Add 1 for blink variants."
|
||||
(let* ((base (case shape
|
||||
(:block 2) (:underline 4) (:bar 6)
|
||||
(t 2)))
|
||||
(code (if blink (1+ base) base)))
|
||||
(format nil "~C[~d q" #\Esc code)))
|
||||
|
||||
(defun decicm-begin ()
|
||||
"Return escape to enable synchronized updates."
|
||||
(format nil "~C[?2026h" #\Esc))
|
||||
|
||||
(defun decicm-end ()
|
||||
"Return escape to disable synchronized updates."
|
||||
(format nil "~C[?2026l" #\Esc))
|
||||
|
||||
(defun osc8-link (url text)
|
||||
"Wrap TEXT in an OSC 8 hyperlink to URL."
|
||||
(format nil "~C]8;;~A~C\\~A~C]8;;~C\\"
|
||||
#\Esc url #\Esc text #\Esc #\Esc))
|
||||
|
||||
(defparameter *border-chars*
|
||||
'(((:single :top-left) . "┌") ((:single :top-right) . "┐")
|
||||
((:single :bottom-left) . "└") ((:single :bottom-right) . "┘")
|
||||
((:single :horizontal) . "─") ((:single :vertical) . "│")
|
||||
((:double :top-left) . "╔") ((:double :top-right) . "╗")
|
||||
((:double :bottom-left) . "╚") ((:double :bottom-right) . "╝")
|
||||
((:double :horizontal) . "═") ((:double :vertical) . "║")
|
||||
((:rounded :top-left) . "╭") ((:rounded :top-right) . "╮")
|
||||
((:rounded :bottom-left) . "╰") ((:rounded :bottom-right) . "╯")
|
||||
((:rounded :horizontal) . "─") ((:rounded :vertical) . "│")))
|
||||
|
||||
(defun border-char (style pos)
|
||||
"Return the Unicode box-drawing character for STYLE at POS."
|
||||
(let ((char (cdr (assoc (list style pos) *border-chars* :test #'equal))))
|
||||
(or char (if (member pos '(:horizontal :vertical))
|
||||
(case pos (:horizontal "─") (:vertical "│"))
|
||||
"+"))))
|
||||
|
||||
(defclass modern-backend (backend)
|
||||
((output-stream :initform *standard-output*
|
||||
:initarg :output-stream
|
||||
:accessor backend-output-stream)
|
||||
(in-sync-p :initform nil :accessor in-sync-p)))
|
||||
|
||||
(defun make-modern-backend (&key color-palette output-stream)
|
||||
(declare (ignore color-palette))
|
||||
(make-instance 'modern-backend :output-stream (or output-stream *standard-output*)))
|
||||
|
||||
(defmethod initialize-backend ((b modern-backend))
|
||||
;; Enter raw mode, enable mouse, bracketed paste, kitty keyboard
|
||||
(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
|
||||
(backend-write b (format nil "~C[?u" #\Esc)) ; kitty keyboard
|
||||
(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[?u" #\Esc)) ; restore default keyboard
|
||||
(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))
|
||||
;; Query actual terminal dimensions via TIOCGWINSZ ioctl
|
||||
(let* ((+tiocgwinsz+ 21523) ; 0x5413 on Linux
|
||||
(winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(sb-unix:unix-ioctl (sb-sys:fd-stream-fd (backend-output-stream b))
|
||||
+tiocgwinsz+
|
||||
(sb-alien:alien-sap winsize))
|
||||
(values (sb-alien:deref winsize 1) ;; cols
|
||||
(sb-alien:deref winsize 0))) ;; rows
|
||||
(sb-alien:free-alien winsize))))
|
||||
|
||||
(defmethod backend-write ((b modern-backend) string)
|
||||
(let ((stream (backend-output-stream b)))
|
||||
(write-string string stream)
|
||||
(finish-output 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)
|
||||
(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))
|
||||
(inner-width (- width 2))
|
||||
(hc (char h 0))
|
||||
(top (if (and title (plusp (length title)))
|
||||
(let* ((align (or title-align :left))
|
||||
(max-tlen (- inner-width 2))
|
||||
(tlen (min (length title) max-tlen))
|
||||
(trunc-title (subseq title 0 tlen)))
|
||||
(ecase align
|
||||
(:left
|
||||
(let ((right-hyphens (- inner-width tlen 2)))
|
||||
(concatenate 'string
|
||||
fg-esc bg-esc tl (string #\Space)
|
||||
trunc-title (string #\Space)
|
||||
(make-string (max 0 right-hyphens) :initial-element hc)
|
||||
tr reset (string #\Newline))))
|
||||
(:center
|
||||
(let* ((total-pad (- inner-width tlen))
|
||||
(left-pad (floor total-pad 2))
|
||||
(right-pad (- total-pad left-pad)))
|
||||
(concatenate 'string
|
||||
fg-esc bg-esc tl
|
||||
(make-string left-pad :initial-element hc)
|
||||
trunc-title
|
||||
(make-string right-pad :initial-element hc)
|
||||
tr reset (string #\Newline))))))
|
||||
(concatenate 'string
|
||||
fg-esc bg-esc tl
|
||||
(make-string inner-width :initial-element hc)
|
||||
tr reset (string #\Newline))))
|
||||
(mid (concatenate 'string
|
||||
fg-esc bg-esc v
|
||||
(make-string inner-width :initial-element #\Space)
|
||||
v reset (string #\Newline)))
|
||||
(bot (concatenate 'string
|
||||
fg-esc bg-esc bl
|
||||
(make-string inner-width :initial-element hc)
|
||||
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 enable-mouse ((b modern-backend))
|
||||
(backend-write b (format nil "~C[?1000h" #\Esc)) ; basic
|
||||
(backend-write b (format nil "~C[?1002h" #\Esc)) ; drag
|
||||
(backend-write b (format nil "~C[?1006h" #\Esc)) ; SGR
|
||||
(finish-output (backend-output-stream b)))
|
||||
|
||||
(defmethod enable-bracketed-paste ((b modern-backend))
|
||||
(backend-write b (format nil "~C[?2004h" #\Esc)) ; bracketed paste
|
||||
(finish-output (backend-output-stream b)))
|
||||
|
||||
(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)))
|
||||
|
||||
33
src/backend/package.lisp
Normal file
33
src/backend/package.lisp
Normal file
@@ -0,0 +1,33 @@
|
||||
(defpackage :cl-tty.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
|
||||
;; Detection
|
||||
#:detect-backend #:*detected-backend*
|
||||
;; Theme color resolution (populated by theme system)
|
||||
#:*theme-colors*
|
||||
;; 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-tty.backend)
|
||||
108
src/backend/simple.lisp
Normal file
108
src/backend/simple.lisp
Normal file
@@ -0,0 +1,108 @@
|
||||
(in-package :cl-tty.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 (pos)
|
||||
"Return ASCII border character 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))
|
||||
(let ((h (%simple-border-char :horizontal))
|
||||
(v (%simple-border-char :vertical))
|
||||
(tl (%simple-border-char :top-left))
|
||||
(tr (%simple-border-char :top-right))
|
||||
(bl (%simple-border-char :bottom-left))
|
||||
(br (%simple-border-char :bottom-right)))
|
||||
;; Position cursor with newlines and spaces (no escape sequences)
|
||||
(dotimes (row y) (backend-write b (string #\Newline)))
|
||||
;; Top edge with optional title
|
||||
(backend-write b (make-string x :initial-element #\space))
|
||||
(backend-write b (string tl))
|
||||
(if (and title (plusp (length title)))
|
||||
(let* ((align (or title-align :left))
|
||||
(inner-width (- width 2))
|
||||
(max-tlen (- inner-width 2))
|
||||
(tlen (min (length title) max-tlen))
|
||||
(trunc-title (subseq title 0 tlen)))
|
||||
(ecase align
|
||||
(:left
|
||||
(backend-write b (string #\Space))
|
||||
(backend-write b trunc-title)
|
||||
(backend-write b (string #\Space))
|
||||
(backend-write b (make-string (- inner-width tlen 2) :initial-element h)))
|
||||
(:center
|
||||
(let* ((total-pad (- inner-width tlen))
|
||||
(left-pad (floor total-pad 2))
|
||||
(right-pad (- total-pad left-pad)))
|
||||
(backend-write b (make-string left-pad :initial-element h))
|
||||
(backend-write b trunc-title)
|
||||
(backend-write b (make-string right-pad :initial-element h))))))
|
||||
(backend-write b (make-string (- width 2) :initial-element h)))
|
||||
(backend-write b (string tr))
|
||||
;; Sides
|
||||
(loop for i from 1 below (1- height)
|
||||
do (backend-write b (string #\Newline))
|
||||
(backend-write b (make-string x :initial-element #\space))
|
||||
(backend-write b (string v))
|
||||
(backend-write b (make-string (- width 2) :initial-element #\space))
|
||||
(backend-write b (string v)))
|
||||
;; Bottom edge
|
||||
(backend-write b (string #\Newline))
|
||||
(backend-write b (make-string x :initial-element #\space))
|
||||
(backend-write b (string bl))
|
||||
(backend-write b (make-string (- width 2) :initial-element h))
|
||||
(backend-write b (string br))))
|
||||
|
||||
(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 width fg bg))
|
||||
;; Position using newlines+spaces (simple-backend pattern)
|
||||
(dotimes (row y) (backend-write b (string #\Newline)))
|
||||
(backend-write b (make-string x :initial-element #\Space))
|
||||
(backend-write b "..."))
|
||||
151
src/backend/tests.lisp
Normal file
151
src/backend/tests.lisp
Normal file
@@ -0,0 +1,151 @@
|
||||
(defpackage :cl-tty-backend-test
|
||||
(:use :cl :fiveam :cl-tty.backend)
|
||||
(:export #:run-tests))
|
||||
(in-package :cl-tty-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 +---+")
|
||||
(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")))
|
||||
|
||||
;; ── Detection ──────────────────────────────────────────────────
|
||||
|
||||
(test detection-returns-backend-instance
|
||||
"detect-backend returns a valid backend instance"
|
||||
(let ((be (cl-tty.backend:detect-backend)))
|
||||
(is (typep be 'cl-tty.backend:backend))))
|
||||
|
||||
(test detection-caches-result
|
||||
"detect-backend caches the result in *detected-backend*"
|
||||
(let ((*detected-backend* nil))
|
||||
(cl-tty.backend:detect-backend)
|
||||
(is-true (not (null cl-tty.backend::*detected-backend*)))))
|
||||
@@ -73,7 +73,7 @@
|
||||
(list :title "No" :value :no))
|
||||
:on-select (lambda (opt)
|
||||
(pop-dialog)
|
||||
(if (eql (getf opt :value) :yes)
|
||||
(if (eql opt :yes)
|
||||
(when on-yes (funcall on-yes))
|
||||
(when on-no (funcall on-no)))))))
|
||||
|
||||
|
||||
Binary file not shown.
202
src/layout/layout.lisp
Normal file
202
src/layout/layout.lisp
Normal file
@@ -0,0 +1,202 @@
|
||||
;;; layout — Pure CL Flexbox layout engine
|
||||
|
||||
(defpackage :cl-tty.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-tty.layout)
|
||||
|
||||
(defun normalize-box (spec)
|
||||
(cond ((null spec) (list :top 0 :right 0 :bottom 0 :left 0))
|
||||
((numberp spec) (list :top spec :right spec :bottom spec :left spec))
|
||||
(t (loop with result = (list :top 0 :right 0 :bottom 0 :left 0)
|
||||
for (key val) on spec by #'cddr
|
||||
do (setf (getf result key) val)
|
||||
finally (return result)))))
|
||||
|
||||
(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 (list :top 0 :right 0 :bottom 0 :left 0) :initarg :padding :accessor layout-node-padding)
|
||||
(margin :initform (list :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.
|
||||
Rounding errors are amortized across the first N children."
|
||||
(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))))
|
||||
(let ((sizes (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)))
|
||||
;; Distribute rounding remainder to first N children so that
|
||||
;; the total of sizes exactly fills avail minus gap-total.
|
||||
;; Only correct when grow or shrink was actually applied —
|
||||
;; otherwise children keep their fixed sizes and may not fill space.
|
||||
(when (or (and (plusp remaining) (plusp grow-total))
|
||||
(and (minusp remaining) (plusp shrink-total)))
|
||||
(let ((delta (- avail gap-total (reduce #'+ sizes))))
|
||||
(when (/= delta 0)
|
||||
(loop :for i :from 0 :below (min (abs delta) n)
|
||||
:do (incf (nth i sizes) (signum delta))))))
|
||||
sizes)))
|
||||
|
||||
(defun compute-layout (root available-width available-height)
|
||||
"Layout all children of ROOT within the given dimensions.
|
||||
Recursively computes position and size for every node."
|
||||
(labels ((place-children (node x y max-w max-h)
|
||||
(let* ((children (layout-node-children node))
|
||||
(is-row (eql (layout-node-direction node) :row))
|
||||
(pl (box-edge (layout-node-padding node) :left))
|
||||
(pt (box-edge (layout-node-padding node) :top))
|
||||
(pr (box-edge (layout-node-padding node) :right))
|
||||
(pb (box-edge (layout-node-padding node) :bottom))
|
||||
(cw (max 0 (- max-w pl pr)))
|
||||
(ch (max 0 (- max-h pt pb)))
|
||||
(gap (layout-node-gap node))
|
||||
(sizes (distribute-sizes children (if is-row cw ch) gap is-row)))
|
||||
;; Position the node (content area starts at padding inset)
|
||||
(setf (layout-node-x node) (+ x pl)
|
||||
(layout-node-y node) (+ y pt))
|
||||
;; Place each child sequentially
|
||||
(loop :with pos = 0
|
||||
:for child :in children
|
||||
:for size :in sizes
|
||||
:do (if is-row
|
||||
(setf (layout-node-width child) size
|
||||
(layout-node-x child) (+ x pl pos)
|
||||
(layout-node-height child) ch
|
||||
(layout-node-y child) (+ y pt))
|
||||
(setf (layout-node-height child) size
|
||||
(layout-node-y child) (+ y pt pos)
|
||||
(layout-node-width child) cw
|
||||
(layout-node-x child) (+ x pl)))
|
||||
(place-children child
|
||||
(layout-node-x child)
|
||||
(layout-node-y child)
|
||||
(if is-row size cw)
|
||||
(if is-row ch size))
|
||||
(incf pos (+ size gap)))
|
||||
;; Compute own size from children
|
||||
(let ((last-child (car (last children))))
|
||||
(if is-row
|
||||
(setf (layout-node-width node)
|
||||
(or (layout-node-fixed-width node)
|
||||
(if last-child
|
||||
(+ (layout-node-x node)
|
||||
(layout-node-width last-child)
|
||||
pr)
|
||||
max-w))
|
||||
(layout-node-height node)
|
||||
max-h)
|
||||
(setf (layout-node-height node)
|
||||
(or (layout-node-fixed-height node)
|
||||
(if last-child
|
||||
(let ((last-y (layout-node-y last-child))
|
||||
(last-h (layout-node-height last-child)))
|
||||
(+ last-y last-h pb))
|
||||
max-h))
|
||||
(layout-node-width node)
|
||||
max-w))))))
|
||||
(place-children root 0 0 available-width available-height)
|
||||
root))
|
||||
|
||||
;; ── Macros ─────────────────────────────────────────────────────
|
||||
|
||||
(defmacro vbox ((&key grow shrink padding margin gap width height) &body children)
|
||||
(let ((n (gensym)))
|
||||
`(let ((,n (make-layout-node :direction :column
|
||||
,@(when grow `(:grow ,grow))
|
||||
,@(when shrink `(:shrink ,shrink))
|
||||
,@(when padding `(:padding ,padding))
|
||||
,@(when margin `(:margin ,margin))
|
||||
,@(when gap `(:gap ,gap))
|
||||
,@(when width `(:width ,width))
|
||||
,@(when height `(:height ,height)))))
|
||||
,@(loop for c in children collect `(layout-node-add-child ,n ,c))
|
||||
,n)))
|
||||
|
||||
(defmacro hbox ((&key grow shrink padding margin gap width height) &body children)
|
||||
(let ((n (gensym)))
|
||||
`(let ((,n (make-layout-node :direction :row
|
||||
,@(when grow `(:grow ,grow))
|
||||
,@(when shrink `(:shrink ,shrink))
|
||||
,@(when padding `(:padding ,padding))
|
||||
,@(when margin `(:margin ,margin))
|
||||
,@(when gap `(:gap ,gap))
|
||||
,@(when width `(:width ,width))
|
||||
,@(when height `(:height ,height)))))
|
||||
,@(loop for c in children collect `(layout-node-add-child ,n ,c))
|
||||
,n)))
|
||||
|
||||
(defmacro spacer (&key grow)
|
||||
`(make-layout-node :grow ,(or grow 1)))
|
||||
175
src/layout/tests.lisp
Normal file
175
src/layout/tests.lisp
Normal file
@@ -0,0 +1,175 @@
|
||||
(defpackage :cl-tty-layout-test
|
||||
(:use :cl :fiveam :cl-tty.layout)
|
||||
(:export #:run-tests))
|
||||
(in-package :cl-tty-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)))))
|
||||
Reference in New Issue
Block a user