diff --git a/src/backend/modern.lisp b/src/backend/modern.lisp index b63de17..498b824 100644 --- a/src/backend/modern.lisp +++ b/src/backend/modern.lisp @@ -1,22 +1,320 @@ +(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." + (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)) + (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." + (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)) + (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." + (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)) + (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)) + (backend-write b (format nil "~C[?2004l" #\Esc)) + (backend-write b (format nil "~C[?1006l" #\Esc)) + (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 suspend-backend ((b modern-backend)) + (cursor-show b) + (backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen + (cursor-move b 0 0) + (finish-output (backend-output-stream b)) + (values)) + +(defmethod resume-backend ((b modern-backend)) + (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)) + (values)) + (defmethod backend-size ((b modern-backend)) - (flet ((try-ioctl (fd) - (let* ((winsize (sb-alien:make-alien sb-alien:unsigned-short 4))) - (unwind-protect - (progn - (sb-unix:unix-ioctl fd 21523 (sb-alien:alien-sap winsize)) - (let ((cols (sb-alien:deref winsize 1)) - (rows (sb-alien:deref winsize 0))) - (when (and (integerp cols) (integerp rows) - (> cols 0) (> rows 0)) - (values cols rows)))) - (sb-alien:free-alien winsize))))) - (or (try-ioctl 0) - (try-ioctl 1) - (ignore-errors - (let* ((cstr (sb-ext:posix-getenv "COLUMNS")) - (rstr (sb-ext:posix-getenv "LINES")) - (cols (when cstr (parse-integer cstr :junk-allowed t))) - (rows (when rstr (parse-integer rstr :junk-allowed t)))) - (when (and cols rows (> cols 0) (> rows 0)) - (values cols rows)))) - (values 80 24)))) \ No newline at end of file + (or (ignore-errors + (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)))) + ;; $COLUMNS/$LINES fallback — some systems return 80x24 from + ;; ioctl on stdout's fd even when the terminal is larger. + (ignore-errors + (let* ((cstr (sb-ext:posix-getenv "COLUMNS")) + (rstr (sb-ext:posix-getenv "LINES")) + (cols (when cstr (parse-integer cstr :junk-allowed t))) + (rows (when rstr (parse-integer rstr :junk-allowed t)))) + (when (and cols rows (> cols 0) (> rows 0)) + (values cols rows)))) + (values 80 24))) + +(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 + &allow-other-keys) + (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) + (declare (ignore width)) + (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)) + (backend-write b (format nil "~C[?1002h" #\Esc)) + (backend-write b (format nil "~C[?1006h" #\Esc)) + (finish-output (backend-output-stream b))) + +(defmethod enable-bracketed-paste ((b modern-backend)) + (backend-write b (format nil "~C[?2004h" #\Esc)) + (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))) diff --git a/src/backend/simple.lisp b/src/backend/simple.lisp index e1a9205..4a524e1 100644 --- a/src/backend/simple.lisp +++ b/src/backend/simple.lisp @@ -1,22 +1,133 @@ +(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 suspend-backend ((b simple-backend)) + (values)) + +(defmethod resume-backend ((b simple-backend)) + (values)) + (defmethod backend-size ((b simple-backend)) - (flet ((try-ioctl (fd) - (let* ((winsize (sb-alien:make-alien sb-alien:unsigned-short 4))) - (unwind-protect - (progn - (sb-unix:unix-ioctl fd 21523 (sb-alien:alien-sap winsize)) - (let ((cols (sb-alien:deref winsize 1)) - (rows (sb-alien:deref winsize 0))) - (when (and (integerp cols) (integerp rows) - (> cols 0) (> rows 0)) - (values cols rows)))) - (sb-alien:free-alien winsize))))) - (or (try-ioctl 0) - (try-ioctl 1) - (ignore-errors - (let* ((cstr (sb-ext:posix-getenv "COLUMNS")) - (rstr (sb-ext:posix-getenv "LINES")) - (cols (when cstr (parse-integer cstr :junk-allowed t))) - (rows (when rstr (parse-integer rstr :junk-allowed t)))) - (when (and cols rows (> cols 0) (> rows 0)) - (values cols rows)))) - (values 80 24)))) \ No newline at end of file + (or (ignore-errors + (let* ((+tiocgwinsz+ 21523) + (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) + (sb-alien:deref winsize 0))) + (sb-alien:free-alien winsize)))) + (ignore-errors + (let* ((cstr (sb-ext:posix-getenv "COLUMNS")) + (rstr (sb-ext:posix-getenv "LINES")) + (cols (when cstr (parse-integer cstr :junk-allowed t))) + (rows (when rstr (parse-integer rstr :junk-allowed t)))) + (when (and cols rows (> cols 0) (> rows 0)) + (values cols rows)))) + (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 + &allow-other-keys) + (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 "..."))