amr/cl-tty
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix: add draw-text method for raw 2D arrays

Browse Source 
Application code (passepartout TUI) calls draw-text with a framebuffer
(2D array) as the first argument, but draw-text only had methods for
framebuffer-backend CLOS instances. Added a method on array that sets
cells directly on the framebuffer array, matching make-framebuffer's
return type.
This commit is contained in:
Amr Gharbeia
2026-05-13 16:06:05 -04:00
parent 66e86734cb
commit 22886c1794
8 changed files with 95 additions and 45 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
org/backend-protocol.org
View File

@@ -850,8 +850,9 @@ This means simple backends are always a "scroll and dump" mode —
no cursor positioning, no escape sequences. no cursor positioning, no escape sequences.
#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp #+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp
(defmethod draw-text ((b simple-backend) x y string fg bg (defmethod draw-text ((b simple-backend) x y string fg bg
&key bold italic underline reverse dim blink) &key bold italic underline reverse dim blink
&allow-other-keys)
(declare (ignore x y fg bg bold italic underline reverse dim blink)) (declare (ignore x y fg bg bold italic underline reverse dim blink))
(backend-write b string)) (backend-write b string))
#+END_SRC #+END_SRC

25
org/framebuffer.org
View File

@@ -356,9 +356,32 @@ does not need (e.g., reverse, dim, blink).
do (%set-cell fb (+ x i) y (char string i) do (%set-cell fb (+ x i) y (char string i)
:fg fg :bg bg :fg fg :bg bg
:bold bold :italic italic :underline underline :bold bold :italic italic :underline underline
:link-url link-url))) :link-url link-url)))
#+END_SRC #+END_SRC
*** draw-text (raw array)
Direct rendering onto a raw 2D framebuffer array (the type returned by
~make-framebuffer~). This lets application code call ~draw-text~ directly on a
framebuffer without wrapping it in a ~framebuffer-backend~.
#+begin_src lisp :tangle ../src/rendering/framebuffer.lisp
(defmethod draw-text ((fb array) x y string fg bg
&key bold italic underline reverse dim blink
&allow-other-keys)
(declare (ignore reverse dim blink))
(let ((h (array-dimension fb 0))
(w (array-dimension fb 1)))
(loop for i from 0 below (length string)
for cx from x
while (< cx w)
when (and (< y h) (>= cx 0) (>= y 0))
do (setf (aref fb y cx)
(make-cell :char (char string i)
:fg fg :bg bg
:bold bold :italic italic :underline underline)))))
#+end_src
*** draw-rect *** draw-rect
Fill a rectangular region with space characters and an optional background Fill a rectangular region with space characters and an optional background

27
org/modern-backend.org
View File

@@ -652,16 +652,18 @@ compatibility across SBCL versions. Returns (values cols rows).
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp #+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod backend-size ((b modern-backend)) (defmethod backend-size ((b modern-backend))
(let* ((+tiocgwinsz+ 21523) ; 0x5413 on Linux (or (ignore-errors
(winsize (sb-alien:make-alien sb-alien:unsigned-short 4))) (let* ((+tiocgwinsz+ 21523) ; 0x5413 on Linux
(unwind-protect (winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
(progn (unwind-protect
(sb-unix:unix-ioctl (sb-sys:fd-stream-fd (backend-output-stream b)) (progn
+tiocgwinsz+ (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (backend-output-stream b))
(sb-alien:alien-sap winsize)) +tiocgwinsz+
(values (sb-alien:deref winsize 1) ;; cols (sb-alien:alien-sap winsize))
(sb-alien:deref winsize 0))) ;; rows (values (sb-alien:deref winsize 1) ;; cols
(sb-alien:free-alien winsize)))) (sb-alien:deref winsize 0))) ;; rows
(sb-alien:free-alien winsize))))
(values 80 24)))
#+END_SRC #+END_SRC
** Capability query and write ** Capability query and write
@@ -703,8 +705,9 @@ calls --- one =backend-write= per draw operation --- by packing everything
into one buffer. into one buffer.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp #+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod draw-text ((b modern-backend) x y string fg bg (defmethod draw-text ((b modern-backend) x y string fg bg
&key bold italic underline reverse dim blink) &key bold italic underline reverse dim blink
&allow-other-keys)
(let ((parts (list (cursor-move-escape x y) (let ((parts (list (cursor-move-escape x y)
(sgr-fg fg) (sgr-bg bg) (sgr-fg fg) (sgr-bg bg)
(when bold (sgr-attr :bold)) (when bold (sgr-attr :bold))

6
org/text-input.org
View File

@@ -772,10 +772,12 @@ portability.
#+BEGIN_SRC lisp :tangle ../src/components/input.lisp #+BEGIN_SRC lisp :tangle ../src/components/input.lisp
(defun %raw-mode-on () (defun %raw-mode-on ()
(uiop:run-program '("stty" "raw" "-echo" "-echoe" "-echok" "-onlcr") :output nil :error-output nil)) (uiop:run-program '("stty" "raw" "-echo" "-echoe" "-echok" "-onlcr")
:output nil :error-output nil :ignore-error-status t))
(defun %raw-mode-off () (defun %raw-mode-off ()
(uiop:run-program '("stty" "sane") :output nil :error-output nil)) (uiop:run-program '("stty" "sane")
:output nil :error-output nil :ignore-error-status t))
(defmacro with-raw-terminal (&body body) (defmacro with-raw-terminal (&body body)
"Execute BODY with the terminal in raw mode." "Execute BODY with the terminal in raw mode."

47
src/backend/modern.lisp
View File

@@ -162,16 +162,18 @@ as a fallback when a keyword is not in *named-colors*.")
(values)) (values))
(defmethod backend-size ((b modern-backend)) (defmethod backend-size ((b modern-backend))
(let* ((+tiocgwinsz+ 21523) ; 0x5413 on Linux (or (ignore-errors
(winsize (sb-alien:make-alien sb-alien:unsigned-short 4))) (let* ((+tiocgwinsz+ 21523) ; 0x5413 on Linux
(unwind-protect (winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
(progn (unwind-protect
(sb-unix:unix-ioctl (sb-sys:fd-stream-fd (backend-output-stream b)) (progn
+tiocgwinsz+ (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (backend-output-stream b))
(sb-alien:alien-sap winsize)) +tiocgwinsz+
(values (sb-alien:deref winsize 1) ;; cols (sb-alien:alien-sap winsize))
(sb-alien:deref winsize 0))) ;; rows (values (sb-alien:deref winsize 1) ;; cols
(sb-alien:free-alien winsize)))) (sb-alien:deref winsize 0))) ;; rows
(sb-alien:free-alien winsize))))
(values 80 24)))
(defmethod backend-write ((b modern-backend) string) (defmethod backend-write ((b modern-backend) string)
(let ((stream (backend-output-stream b))) (let ((stream (backend-output-stream b)))
@@ -185,18 +187,19 @@ as a fallback when a keyword is not in *named-colors*.")
:kitty-keyboard))) :kitty-keyboard)))
(defmethod draw-text ((b modern-backend) x y string fg bg (defmethod draw-text ((b modern-backend) x y string fg bg
&key bold italic underline reverse dim blink) &key bold italic underline reverse dim blink
(let ((parts (list (cursor-move-escape x y) &allow-other-keys)
(sgr-fg fg) (sgr-bg bg) (let ((parts (list (cursor-move-escape x y)
(when bold (sgr-attr :bold)) (sgr-fg fg) (sgr-bg bg)
(when italic (sgr-attr :italic)) (when bold (sgr-attr :bold))
(when underline (sgr-attr :underline)) (when italic (sgr-attr :italic))
(when reverse (sgr-attr :reverse)) (when underline (sgr-attr :underline))
(when dim (sgr-attr :dim)) (when reverse (sgr-attr :reverse))
(when blink (sgr-attr :blink)) (when dim (sgr-attr :dim))
string (when blink (sgr-attr :blink))
(sgr-attr :reset)))) string
(backend-write b (apply #'concatenate 'string parts)))) (sgr-attr :reset))))
(backend-write b (apply #'concatenate 'string parts))))
(defmethod draw-border ((b modern-backend) x y width height (defmethod draw-border ((b modern-backend) x y width height
&key style fg bg title title-align) &key style fg bg title title-align)

7
src/backend/simple.lisp
View File

@@ -32,9 +32,10 @@
(length string))) (length string)))
(defmethod draw-text ((b simple-backend) x y string fg bg (defmethod draw-text ((b simple-backend) x y string fg bg
&key bold italic underline reverse dim blink) &key bold italic underline reverse dim blink
(declare (ignore x y fg bg bold italic underline reverse dim blink)) &allow-other-keys)
(backend-write b string)) (declare (ignore x y fg bg bold italic underline reverse dim blink))
(backend-write b string))
(defun %simple-border-char (pos) (defun %simple-border-char (pos)
"Return ASCII border character at POS. "Return ASCII border character at POS.

6
src/components/input.lisp
View File

@@ -228,10 +228,12 @@ Returns a mouse-event struct."
(setf *terminal-resized-p* t)))) (setf *terminal-resized-p* t))))
(defun %raw-mode-on () (defun %raw-mode-on ()
(uiop:run-program '("stty" "raw" "-echo" "-echoe" "-echok" "-onlcr") :output nil :error-output nil)) (uiop:run-program '("stty" "raw" "-echo" "-echoe" "-echok" "-onlcr")
:output nil :error-output nil :ignore-error-status t))
(defun %raw-mode-off () (defun %raw-mode-off ()
(uiop:run-program '("stty" "sane") :output nil :error-output nil)) (uiop:run-program '("stty" "sane")
:output nil :error-output nil :ignore-error-status t))
(defmacro with-raw-terminal (&body body) (defmacro with-raw-terminal (&body body)
"Execute BODY with the terminal in raw mode." "Execute BODY with the terminal in raw mode."

17
src/rendering/framebuffer.lisp
View File

@@ -76,7 +76,22 @@
do (%set-cell fb (+ x i) y (char string i) do (%set-cell fb (+ x i) y (char string i)
:fg fg :bg bg :fg fg :bg bg
:bold bold :italic italic :underline underline :bold bold :italic italic :underline underline
:link-url link-url))) :link-url link-url)))
(defmethod draw-text ((fb array) x y string fg bg
&key bold italic underline reverse dim blink
&allow-other-keys)
(declare (ignore reverse dim blink))
(let ((h (array-dimension fb 0))
(w (array-dimension fb 1)))
(loop for i from 0 below (length string)
for cx from x
while (< cx w)
when (and (< y h) (>= cx 0) (>= y 0))
do (setf (aref fb y cx)
(make-cell :char (char string i)
:fg fg :bg bg
:bold bold :italic italic :underline underline)))))
(defmethod draw-rect ((fb framebuffer-backend) x y w h &key bg) (defmethod draw-rect ((fb framebuffer-backend) x y w h &key bg)
(dotimes (row h) (dotimes (row h)