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..8842dcc --- /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 () + ((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))) + diff --git a/backend/package.lisp b/backend/package.lisp index 1a4c1da..0b50b26 100644 --- a/backend/package.lisp +++ b/backend/package.lisp @@ -18,5 +18,12 @@ ;; Queries #:capable-p ;; Constructors - #:make-simple-backend)) + #: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/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