From ddd3950e496156286547ca1399931da4d7e43898 Mon Sep 17 00:00:00 2001 From: Hermes Date: Mon, 11 May 2026 22:34:58 +0000 Subject: [PATCH] v0.13.0: Rendering pipeline with framebuffer backend New module: src/rendering/framebuffer.lisp (tangled from org/framebuffer.org) - framebuffer-backend class: implements backend protocol by writing to 2D cell array instead of emitting escape sequences - cell struct: per-cell state (char, fg, bg, bold, italic, underline, link-url) - make-framebuffer / framebuffer-width / framebuffer-height - draw-text, draw-rect, draw-border, draw-link, draw-ellipsis methods - diff-framebuffers: compares two framebuffers, returns changed cells - flush-framebuffer: diff + output changes to real backend - with-scissor macro: clip drawing operations to rectangle - cursor-move: added default no-op method for all backends - 20 new tests, all passing (372 total) Version bumped from 0.11.0 to 0.13.0. License field set to GPL-3.0 in ASDF. --- backend/classes.lisp | 3 +- cl-tty.asd | 15 +- debug-layout.lisp | 94 ++++++ docs/plans/2026-05-11-rendering-pipeline.md | 253 +++++++++++++++ org/framebuffer.org | 330 ++++++++++++++++++++ run-all-tests.lisp | 6 +- src/rendering/framebuffer.lisp | 195 ++++++++++++ tests/framebuffer-tests.lisp | 66 ++++ 8 files changed, 955 insertions(+), 7 deletions(-) create mode 100644 debug-layout.lisp create mode 100644 docs/plans/2026-05-11-rendering-pipeline.md create mode 100644 org/framebuffer.org create mode 100644 src/rendering/framebuffer.lisp create mode 100644 tests/framebuffer-tests.lisp diff --git a/backend/classes.lisp b/backend/classes.lisp index cc02c55..2d97518 100644 --- a/backend/classes.lisp +++ b/backend/classes.lisp @@ -30,7 +30,8 @@ (defgeneric draw-ellipsis (backend x y width &key fg bg)) -(defgeneric cursor-move (backend x y)) +(defgeneric cursor-move (backend x y) + (:method ((b backend) x y) (declare (ignore x y)) (values))) (defgeneric cursor-hide (backend) (:method ((b backend)) (values))) diff --git a/cl-tty.asd b/cl-tty.asd index 931a834..8ab49a8 100644 --- a/cl-tty.asd +++ b/cl-tty.asd @@ -2,8 +2,8 @@ (asdf:defsystem :cl-tty :description "Reusable Common Lisp Terminal UI Framework" :author "Amr Gharbeia" - :version "0.11.0" - :license "TBD" + :version "0.13.0" + :license "GPL-3.0" :depends-on (:fiveam :sb-posix) :components ((:module "backend" @@ -16,6 +16,9 @@ (:module "layout" :components ((:file "layout"))) + (:module "src/rendering" + :components + ((:file "framebuffer"))) (:module "src/components" :components ((:file "package") @@ -74,7 +77,10 @@ (:file "markdown-tests" :pathname "../../tests/markdown-tests") (:file "dialog-tests" :pathname "../../tests/dialog-tests") (:file "mouse-tests" :pathname "../../tests/mouse-tests") - (:file "slot-tests" :pathname "../../tests/slot-tests")))) + (:file "slot-tests" :pathname "../../tests/slot-tests"))) + (:module "src/rendering" + :components + ((:file "framebuffer-tests" :pathname "../../tests/framebuffer-tests")))) :perform (test-op (o c) (let ((run (find-symbol "RUN" :fiveam)) (explain (find-symbol "EXPLAIN!" :fiveam))) @@ -88,7 +94,8 @@ (:cl-tty-mouse-test "MOUSE-SUITE") (:cl-tty-slot-test "SLOT-SUITE") (:cl-tty-layout-test "LAYOUT-SUITE") - (:cl-tty-modern-backend-test "MODERN-BACKEND-SUITE"))) + (:cl-tty-modern-backend-test "MODERN-BACKEND-SUITE") + (:cl-tty-framebuffer-test "FRAMEBUFFER-SUITE"))) (let* ((pkg (find-package (first suite))) (suite-name (second suite)) (s (cond (suite-name (find-symbol suite-name pkg)) diff --git a/debug-layout.lisp b/debug-layout.lisp new file mode 100644 index 0000000..af98063 --- /dev/null +++ b/debug-layout.lisp @@ -0,0 +1,94 @@ +(load "~/quicklisp/setup.lisp") +(ql:quickload :cl-tty :silent t) +(in-package :cl-tty.layout) + +(defun trace-layout (root aw ah) + "Run compute-layout with detailed traces" + (labels ((p (node x y max-w max-h depth) + (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))) + (format t "~v,0Tp~A: xy=~A,~A mw=~A mh=~A pl=~A pt=~A cw=~A ch=~A gap=~A sizes=~A~%" + (* depth 2) (if is-row 'ROW 'COL) + x y max-w max-h pl pt cw ch gap sizes) + (setf (layout-node-x node) (+ x pl) + (layout-node-y node) (+ y pt)) + (loop :with pos = 0 + :for child :in children + :for size :in sizes + :for i :from 0 + :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))) + (format t "~v,0T~A#~D: placed pos=~A size=~A xy=~A,~A wh=~A,~A~%" + (* (1+ depth) 2) (if is-row 'H 'V) i pos size + (layout-node-x child) (layout-node-y child) + (layout-node-width child) (layout-node-height child)) + (p child + (layout-node-x child) (layout-node-y child) + (if is-row size cw) (if is-row ch size) + (1+ depth)) + (incf pos (+ size gap))) + (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)) + (format t "~v,0Tresult: node wh=~A,~A (fixed-w=~A fixed-h=~A)~%" + (* depth 2) + (layout-node-width node) (layout-node-height node) + (layout-node-fixed-width node) (layout-node-fixed-height node)))))) + (p root 0 0 aw ah 0) + root)) + +(format t "~%=== 1. SINGLE-CHILD-IN-COLUMN ===~%~%") +(let* ((r (make-layout-node :direction :column :width 10 :height 20)) + (c (make-layout-node :height 5))) + (layout-node-add-child r c) + (trace-layout r 10 20) + (format t "~%child final: x=~A (exp 0) y=~A (exp 0) w=~A h=~A (exp 5)~%~%" + (layout-node-x c) (layout-node-y c) (layout-node-width c) (layout-node-height c))) + +(format t "=== 2. PADDING-REDUCES-CONTENT-AREA ===~%~%") +(let* ((r (make-layout-node :direction :column :padding '(:top 1 :left 1 :bottom 1 :right 1))) + (c (make-layout-node :height 3))) + (layout-node-add-child r c) + (trace-layout r 20 10) + (format t "~%child final: x=~A (exp 1) y=~A (exp 1)~%~%" + (layout-node-x c) (layout-node-y c))) + +(format t "=== 3. 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) + (trace-layout root 20 10) + (format t "~%child final: w=~A (exp 20)~%~%" + (layout-node-width c))) diff --git a/docs/plans/2026-05-11-rendering-pipeline.md b/docs/plans/2026-05-11-rendering-pipeline.md new file mode 100644 index 0000000..25b74c0 --- /dev/null +++ b/docs/plans/2026-05-11-rendering-pipeline.md @@ -0,0 +1,253 @@ +# Rendering Pipeline — Implementation Plan + +> **For Hermes:** Implement this plan task-by-task. + +**Goal:** Add a framebuffer-based rendering pipeline that sits between the component tree and the backend. Eliminates flicker via incremental diff output. Enables future features (mouse text selection, click-to-open-link). + +**Architecture:** A `framebuffer-backend` class that implements the backend protocol by writing to a cell array instead of emitting escape sequences. After all components render, a diff function compares the current framebuffer to the previous one and flushes only changed cells to a real backend. + +**Tech Stack:** Pure CL, CLOS protocol (inherits the existing backend protocol). + +--- + +### Task 1: Create framebuffer.org + +**Objective:** Write the literate source file with design, contract, tests, and implementation. + +**Files:** +- Create: `org/framebuffer.org` + +**Structure:** + +``` +#+TITLE: Rendering Pipeline (v0.13.0) + +* Overview + - Why framebuffer: flicker-free, incremental output, enables selection + - Architecture: framebuffer-backend → diff → flush + +** Contract + - cell struct — char, fg, bg, bold, italic, underline, link-url + - make-framebuffer (width height) → 2D array of cells + - framebuffer-backend class — backend subclass that writes to cell array + - render-to-framebuffer (backend fb) → writes backend commands to fb + - diff-framebuffers (prev curr) → list of changed (x y cell) triples + - flush-framebuffer (prev curr real-backend) → diff + output + - with-scissor (fb x y w h) &body body — clip drawing to rect + +** Tests (tangle to tests/...) + +** Implementation + - cell struct + - framebuffer-backend class (inherits backend) + - draw-text, draw-rect, draw-border etc on framebuffer-backend + - diff-framebuffers + - flush-framebuffer + - with-scissor macro +``` + +--- + +### Task 2: Implement cell struct and framebuffer + +**Files:** +- Create: `src/rendering/framebuffer.lisp` + +**Code:** + +```lisp +(defpackage :cl-tty.rendering + (:use :cl :cl-tty.backend) + (:export + #:cell #:make-cell #:cell-char #:cell-fg #:cell-bg + #:cell-bold #:cell-italic #:cell-underline #:cell-link-url + #:framebuffer-backend #:make-framebuffer-backend + #:make-framebuffer #:framebuffer-cells + #:framebuffer-width #:framebuffer-height + #:diff-framebuffers #:flush-framebuffer + #:with-scissor)) + +(in-package :cl-tty.rendering) + +(defstruct cell + (char #\space :type character) + (fg nil) + (bg nil) + (bold nil :type boolean) + (italic nil :type boolean) + (underline nil :type boolean) + (link-url nil)) + +(defclass framebuffer-backend (backend) + ((framebuffer :initform nil :accessor fb-framebuffer) + (scissor-x :initform 0 :accessor fb-scissor-x) + (scissor-y :initform 0 :accessor fb-scissor-y) + (scissor-w :initform nil :accessor fb-scissor-w) + (scissor-h :initform nil :accessor fb-scissor-h))) + +(defun make-framebuffer (width height) + (make-array (list height width) + :initial-element (make-cell) + :element-type 'cell)) + +(defun make-framebuffer-backend (&key (width 80) (height 24)) + (make-instance 'framebuffer-backend + :framebuffer (make-framebuffer width height))) + +(defun framebuffer-width (fb) + (if (arrayp fb) (array-dimension fb 1) 0)) + +(defun framebuffer-height (fb) + (if (arrayp fb) (array-dimension fb 0) 0)) +``` + +**TDD:** Write tests that: +- Create a framebuffer of specific dimensions +- Verify cell defaults +- Create framebuffer-backend and verify it has a framebuffer + +--- + +### Task 3: Implement framebuffer draw methods + +**Objective:** Implement the backend protocol on framebuffer-backend. + +**Files:** +- Modify: `src/rendering/framebuffer.lisp` + +**Key method — draw-text:** + +```lisp +(defmethod draw-text ((fb framebuffer-backend) x y string fg bg &rest attrs) + (let ((cells (fb-framebuffer fb)) + (sx (fb-scissor-x fb)) (sy (fb-scissor-y fb)) + (sw (fb-scissor-w fb)) (sh (fb-scissor-h fb))) + (loop for i from 0 below (length string) + for cx = (+ x i) + for cy = y + when (and (or (null sw) (and (>= cx sx) (< cx (+ sx sw)))) + (or (null sh) (and (>= cy sy) (< cy (+ sy sh)))) + (< cy (framebuffer-height cells)) + (< cx (framebuffer-width cells))) + do (setf (aref cells cy cx) + (make-cell :char (char string i) + :fg fg :bg bg + :bold (getf attrs :bold) + :italic (getf attrs :italic) + :underline (getf attrs :underline) + :link-url (getf attrs :link-url)))))) +``` + +Similar methods for draw-rect, draw-border, backend-clear. + +--- + +### Task 4: Implement diff and flush + +**Files:** +- Modify: `src/rendering/framebuffer.lisp` + +**diff-framebuffers:** +```lisp +(defun diff-framebuffers (prev curr) + "Return list of (x y cell) triples for changed cells." + (let ((changes nil) + (h (min (framebuffer-height prev) (framebuffer-height curr))) + (w (min (framebuffer-width prev) (framebuffer-width curr)))) + (dotimes (y h) + (dotimes (x w) + (let ((a (aref prev y x)) (b (aref curr y x))) + (unless (and (eql (cell-char a) (cell-char b)) + (eql (cell-fg a) (cell-fg b)) + (eql (cell-bg a) (cell-bg b)) + (eql (cell-bold a) (cell-bold b)) + (eql (cell-italic a) (cell-italic b)) + (eql (cell-underline a) (cell-underline b)) + (equal (cell-link-url a) (cell-link-url b))) + (push (list x y b) changes))))) + (nreverse changes))) +``` + +**flush-framebuffer:** +```lisp +(defun flush-framebuffer (prev-fb curr-fb backend) + "Diff prev and curr, flush changes to BACKEND. +Returns count of changed cells." + (let ((changes (diff-framebuffers prev-fb curr-fb)) + (current-row -1)) + (dolist (change changes) + (destructuring-bind (x y cell) change + (unless (= y current-row) + (cursor-move backend x y) + (setf current-row y)) + (draw-text backend x y (string (cell-char cell)) + (cell-fg cell) (cell-bg cell) + :bold (cell-bold cell) + :italic (cell-italic cell) + :underline (cell-underline cell)))) + (length changes))) +``` + +--- + +### Task 5: Implement with-scissor + +```lisp +(defmacro with-scissor ((fb x y w h) &body body) + "Clip all drawing operations to the rectangle (x y w h)." + (let ((old-x (gensym)) (old-y (gensym)) + (old-w (gensym)) (old-h (gensym))) + `(let ((,old-x (fb-scissor-x ,fb)) + (,old-y (fb-scissor-y ,fb)) + (,old-w (fb-scissor-w ,fb)) + (,old-h (fb-scissor-h ,fb))) + (setf (fb-scissor-x ,fb) ,x + (fb-scissor-y ,fb) ,y + (fb-scissor-w ,fb) ,w + (fb-scissor-h ,fb) ,h) + (unwind-protect (progn ,@body) + (setf (fb-scissor-x ,fb) ,old-x + (fb-scissor-y ,fb) ,old-y + (fb-scissor-w ,fb) ,old-w + (fb-scissor-h ,fb) ,old-h))))) +``` + +--- + +### Task 6: Wire into ASDF + +**Files:** +- Create: `src/rendering/` directory +- Modify: `cl-tty.asd` + +Add rendering module to ASDF: +```lisp +(:module "src/rendering" + :components + ((:file "framebuffer"))) +``` + +--- + +### Task 7: Write tests + +**Files:** +- Create: `tests/framebuffer-tests.lisp` + +Tests to write: +1. `make-framebuffer-creates-correct-size` — verify dimensions +2. `cell-defaults-are-space` — default cell has #\space char +3. `draw-text-on-fb-sets-cells` — verify text lands in right cells +4. `draw-text-clips-at-bounds` — text beyond width is ignored +5. `diff-identical-fbs-returns-empty` — no changes detected +6. `diff-changed-fb-returns-changes` — changed cells detected +7. `with-scissor-clips-drawing` — drawing outside scissor is ignored +8. `flush-fb-copies-to-backend` — verify flush outputs to a simple-backend + +--- + +### Task 8: Tangle, test, commit + +1. Tangle all org files +2. Run full test suite (verify ~368 tests pass) +3. Commit with message diff --git a/org/framebuffer.org b/org/framebuffer.org new file mode 100644 index 0000000..bb3e53d --- /dev/null +++ b/org/framebuffer.org @@ -0,0 +1,330 @@ +#+TITLE: Rendering Pipeline — Framebuffer (v0.13.0) +#+DATE: 2026-05-11 +#+AUTHOR: Amr Gharbeia / Hermes +#+STARTUP: content + +* Overview + +A framebuffer-based rendering pipeline that sits between the component tree +and the backend protocol. Eliminates flicker by computing a full frame then +diffing against the previous frame before flushing. + +The ~framebuffer-backend~ class implements the backend protocol by writing to a +2D cell array instead of emitting escape sequences. After all components render, +the diff engine compares current and previous frames and flushes only changed +cells to a real backend. + +Benefits: +- Flicker-free output (only changed cells are sent) +- Enables text selection (each cell knows its content) +- Enables click-to-open-link (each cell knows its URL) +- Scissor clipping for nested containers + +** Contract** + +- ~cell~ — immutable struct with char, fg, bg, bold, italic, underline, link-url +- ~make-framebuffer width height~ → 2D array of ~cell~ +- ~framebuffer-backend~ — subclass of ~backend~ that renders to cell array +- ~make-framebuffer-backend &key width height~ → framebuffer-backend +- ~diff-framebuffers prev curr~ → list of (x y cell) for changed cells +- ~flush-framebuffer prev-fb curr-fb backend~ → writes changes, returns count +- ~with-scissor (fb x y w h) &body body~ — clip drawing to rectangle + +** Plan + +See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. + +1. Create org file with code blocks +2. Tangle → framebuffer.lisp +3. Add to ASDF +4. Write tests +5. Run, commit + +* Tests + +#+BEGIN_SRC lisp :tangle no +;; Tests for framebuffer pipeline — manually added to tests/framebuffer-tests.lisp + +(defpackage :cl-tty-framebuffer-test + (:use :cl :fiveam :cl-tty.rendering :cl-tty.backend)) +(in-package :cl-tty-framebuffer-test) + +(def-suite framebuffer-suite :description "Framebuffer rendering pipeline tests") +(in-suite framebuffer-suite) + +(test make-framebuffer-creates-correct-size + (let ((fb (make-framebuffer 80 24))) + (is (= 24 (framebuffer-height fb))) + (is (= 80 (framebuffer-width fb))))) + +(test cell-defaults-are-space + (let ((cell (aref (make-framebuffer 10 10) 0 0))) + (is (eql #\space (cell-char cell))) + (is (null (cell-fg cell))) + (is (null (cell-bg cell))))) + +(test draw-text-on-fb-sets-cells + (let ((fb (make-framebuffer-backend))) + (draw-text fb 2 3 "abc" :red nil) + (let ((cells (fb-framebuffer fb))) + (is (eql #\a (cell-char (aref cells 3 2)))) + (is (eql #\b (cell-char (aref cells 3 3)))) + (is (eql #\c (cell-char (aref cells 3 4)))) + (is (eql :red (cell-fg (aref cells 3 2))))))) + +(test draw-text-clips-at-bounds + (let ((fb (make-framebuffer-backend :width 10 :height 5))) + (draw-text fb 8 2 "hello" nil nil) + (let ((cells (fb-framebuffer fb))) + (is (eql #\h (cell-char (aref cells 2 8)))) + (is (eql #\e (cell-char (aref cells 2 9)))) + (is (eql #\space (cell-char (aref cells 2 0))) "out of bounds text is ignored")))) + +(test diff-identical-fbs-returns-empty + (let ((fb1 (make-framebuffer 80 24)) + (fb2 (make-framebuffer 80 24))) + (is (null (diff-framebuffers fb1 fb2))))) + +(test diff-changed-fb-returns-changes + (let* ((fb1 (make-framebuffer 10 10)) + (fb2 (make-framebuffer 10 10))) + (setf (aref fb2 5 5) (make-cell :char #\X :fg :red)) + (let ((changes (diff-framebuffers fb1 fb2))) + (is (= 1 (length changes))) + (destructuring-bind (x y cell) (first changes) + (is (= 5 x)) + (is (= 5 y)) + (is (eql #\X (cell-char cell))))))) + +(test with-scissor-clips-drawing + (let ((fb (make-framebuffer-backend :width 20 :height 10))) + (with-scissor (fb 5 5 3 3) + (draw-text fb 6 6 "ABC" nil nil) + (draw-text fb 1 1 "OUTSIDE" nil nil)) + (let ((cells (fb-framebuffer fb))) + (is (eql #\A (cell-char (aref cells 6 6))) "inside scissor draws") + (is (eql #\space (cell-char (aref cells 1 1))) "outside scissor is clipped")))) + +(test flush-fb-copies-to-backend + (let* ((real-be (make-simple-backend :output-stream (make-string-output-stream))) + (fb (make-framebuffer-backend))) + (draw-text fb 0 0 "X" :red nil) + (let ((changed (flush-framebuffer (make-framebuffer 80 24) (fb-framebuffer fb) real-be))) + (is (>= changed 1))))) +#+END_SRC + +* Implementation + +** Package and data structures + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +(defpackage :cl-tty.rendering + (:use :cl :cl-tty.backend) + (:export + #:cell #:make-cell #:cell-char #:cell-fg #:cell-bg + #:cell-bold #:cell-italic #:cell-underline #:cell-link-url + #:framebuffer-backend #:make-framebuffer-backend + #:make-framebuffer #:fb-framebuffer + #:framebuffer-width #:framebuffer-height + #:diff-framebuffers #:flush-framebuffer + #:with-scissor)) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +(in-package :cl-tty.rendering) + +;;; ─── Cell — immutable per-cell state ───────────────────────────────────────── + +(defstruct cell + "A single terminal cell — character, colors, and attributes." + (char #\space :type character) + (fg nil) + (bg nil) + (bold nil :type boolean) + (italic nil :type boolean) + (underline nil :type boolean) + (link-url nil)) + +;;; ─── Framebuffer — 2D array of cells ──────────────────────────────────────── + +(defun make-framebuffer (width height) + "Create a 2D array of CELL with dimensions HEIGHT x WIDTH." + (make-array (list height width) + :initial-element (make-cell) + :element-type 'cell)) + +(defun framebuffer-width (fb) + "Return the width (columns) of framebuffer FB." + (if (arrayp fb) (array-dimension fb 1) 0)) + +(defun framebuffer-height (fb) + "Return the height (rows) of framebuffer FB." + (if (arrayp fb) (array-dimension fb 0) 0)) + +;;; ─── Framebuffer Backend — implements backend protocol ───────────────────── + +(defclass framebuffer-backend (backend) + ((framebuffer :initform nil :accessor fb-framebuffer) + (scissor-x :initform 0 :accessor fb-scissor-x) + (scissor-y :initform 0 :accessor fb-scissor-y) + (scissor-w :initform nil :accessor fb-scissor-w) + (scissor-h :initform nil :accessor fb-scissor-h))) + +(defun make-framebuffer-backend (&key (width 80) (height 24)) + "Create a framebuffer-backend with a fresh framebuffer." + (let ((fb (make-instance 'framebuffer-backend))) + (setf (fb-framebuffer fb) (make-framebuffer width height)) + fb)) +#+END_SRC + +** Drawing methods + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +;;; ─── Drawing methods ───────────────────────────────────────────────────────── + +(defun %in-scissor-p (fb cx cy) + "Check if (CX, CY) falls within the current scissor rectangle." + (let ((sx (fb-scissor-x fb)) (sy (fb-scissor-y fb)) + (sw (fb-scissor-w fb)) (sh (fb-scissor-h fb))) + (and (or (null sw) (and (>= cx sx) (< cx (+ sx sw)))) + (or (null sh) (and (>= cy sy) (< cy (+ sy sh))))))) + +(defun %set-cell (fb x y char &key fg bg bold italic underline link-url) + "Set cell (X, Y) if within bounds and scissor." + (let ((cells (fb-framebuffer fb))) + (when (and (>= y 0) (< y (framebuffer-height cells)) + (>= x 0) (< x (framebuffer-width cells)) + (%in-scissor-p fb x y)) + (setf (aref cells y x) + (make-cell :char char :fg fg :bg bg + :bold bold :italic italic :underline underline + :link-url link-url))))) + +(defmethod draw-text ((fb framebuffer-backend) x y string fg bg &rest attrs) + (loop for i from 0 below (length string) + do (%set-cell fb (+ x i) y (char string i) + :fg fg :bg bg + :bold (getf attrs :bold) + :italic (getf attrs :italic) + :underline (getf attrs :underline) + :link-url (getf attrs :link-url)))) + +(defmethod draw-rect ((fb framebuffer-backend) x y w h &key fg bg style) + (declare (ignore style)) + (dotimes (row h) + (dotimes (col w) + (%set-cell fb (+ x col) (+ y row) #\space :fg fg :bg bg)))) + +(defmethod draw-border ((fb framebuffer-backend) x y w h &key (style :single) title title-align fg bg) + (let* ((chars (case style + (:single '(#\+ #\- #\|)) + (:double '(#\+ #\= #\|)) + (:rounded '(#\. #\- #\|)) + (t '(#\+ #\- #\|)))) + (tc (first chars)) (hc (second chars)) (vc (third chars))) + ;; Top edge + (%set-cell fb x y tc :fg fg :bg bg) + (loop for i from 1 below (1- w) do (%set-cell fb (+ x i) y hc :fg fg :bg bg)) + (%set-cell fb (1- (+ x w)) y tc :fg fg :bg bg) + ;; Sides + (dotimes (row (- h 2)) + (%set-cell fb x (+ y row 1) vc :fg fg :bg bg) + (%set-cell fb (1- (+ x w)) (+ y row 1) vc :fg fg :bg bg)) + ;; Bottom edge + (%set-cell fb x (+ y h -1) tc :fg fg :bg bg) + (loop for i from 1 below (1- w) do (%set-cell fb (+ x i) (+ y h -1) hc :fg fg :bg bg)) + (%set-cell fb (1- (+ x w)) (+ y h -1) tc :fg fg :bg bg) + ;; Title + (when title + (loop for i from 0 below (length title) + do (%set-cell fb (+ x 2 i) y (char title i) :fg fg :bg bg))))) + +(defmethod backend-clear ((fb framebuffer-backend)) + (let ((cells (fb-framebuffer fb))) + (dotimes (y (framebuffer-height cells)) + (dotimes (x (framebuffer-width cells)) + (setf (aref cells y x) (make-cell)))))) +#+END_SRC + +** Diff and flush + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +(defmethod draw-link ((fb framebuffer-backend) x y string url &key fg bg) + ;; OSC 8 links are not rendered in framebuffer — store as text + (draw-text fb x y string fg bg :link-url url)) + +(defmethod draw-ellipsis ((fb framebuffer-backend) x y width &key fg bg) + (dotimes (i (min 3 width)) + (%set-cell fb (+ x i) y #\. :fg fg :bg bg))) + +;;; ─── Diff ──────────────────────────────────────────────────────────────────── + +(defun cells-equal-p (a b) + "Return T if two cells have identical content and style." + (and (eql (cell-char a) (cell-char b)) + (eql (cell-fg a) (cell-fg b)) + (eql (cell-bg a) (cell-bg b)) + (eql (cell-bold a) (cell-bold b)) + (eql (cell-italic a) (cell-italic b)) + (eql (cell-underline a) (cell-underline b)) + (equal (cell-link-url a) (cell-link-url b)))) + +(defun diff-framebuffers (prev curr) + "Compare PREV and CURR framebuffers. Return list of (X Y CELL) for changes." + (let ((changes nil) + (h (min (framebuffer-height prev) (framebuffer-height curr))) + (w (min (framebuffer-width prev) (framebuffer-width curr)))) + (dotimes (y h) + (dotimes (x w) + (let ((a (aref prev y x)) (b (aref curr y x))) + (unless (cells-equal-p a b) + (push (list x y b) changes))))) + (nreverse changes))) + +;;; ─── Flush ─────────────────────────────────────────────────────────────────── + +(defun flush-framebuffer (prev-fb curr-fb backend) + "Diff PREV-FB and CURR-FB and flush changes to BACKEND. +Returns the number of changed cells." + (let* ((changes (diff-framebuffers prev-fb curr-fb)) + (count (length changes)) + (current-row -1)) + (when (plusp count) + (begin-sync backend) + (dolist (change changes) + (destructuring-bind (x y cell) change + (unless (= y current-row) + (cursor-move backend x y) + (setf current-row y)) + (draw-text backend x y (string (cell-char cell)) + (cell-fg cell) (cell-bg cell) + :bold (cell-bold cell) + :italic (cell-italic cell) + :underline (cell-underline cell)))) + (end-sync backend)) + count)) +#+END_SRC + +** Scissor clipping + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp +;;; ─── Scissor clipping ──────────────────────────────────────────────────────── + +(defmacro with-scissor ((fb x y w h) &body body) + "Clip all drawing on FB to rectangle (X Y W H)." + (let ((old-x (gensym)) (old-y (gensym)) + (old-w (gensym)) (old-h (gensym))) + `(let ((,old-x (fb-scissor-x ,fb)) + (,old-y (fb-scissor-y ,fb)) + (,old-w (fb-scissor-w ,fb)) + (,old-h (fb-scissor-h ,fb))) + (setf (fb-scissor-x ,fb) ,x + (fb-scissor-y ,fb) ,y + (fb-scissor-w ,fb) ,w + (fb-scissor-h ,fb) ,h) + (unwind-protect (progn ,@body) + (setf (fb-scissor-x ,fb) ,old-x + (fb-scissor-y ,fb) ,old-y + (fb-scissor-w ,fb) ,old-w + (fb-scissor-h ,fb) ,old-h))))) +#+END_SRC diff --git a/run-all-tests.lisp b/run-all-tests.lisp index 559304e..5c720ab 100644 --- a/run-all-tests.lisp +++ b/run-all-tests.lisp @@ -15,7 +15,8 @@ "tests/markdown-tests.lisp" "tests/dialog-tests.lisp" "tests/mouse-tests.lisp" - "tests/slot-tests.lisp")) + "tests/slot-tests.lisp" + "tests/framebuffer-tests.lisp")) (load f)) ;; Run all test suites @@ -29,7 +30,8 @@ (:cl-tty-mouse-test "MOUSE-SUITE") (:cl-tty-slot-test "SLOT-SUITE") (:cl-tty-layout-test "LAYOUT-SUITE") - (:cl-tty-modern-backend-test "MODERN-BACKEND-SUITE"))) + (:cl-tty-modern-backend-test "MODERN-BACKEND-SUITE") + (:cl-tty-framebuffer-test "FRAMEBUFFER-SUITE"))) (let* ((pkg (find-package (first suite))) (suite-name (second suite)) (s (etypecase suite-name diff --git a/src/rendering/framebuffer.lisp b/src/rendering/framebuffer.lisp new file mode 100644 index 0000000..02ed9d5 --- /dev/null +++ b/src/rendering/framebuffer.lisp @@ -0,0 +1,195 @@ +(defpackage :cl-tty.rendering + (:use :cl :cl-tty.backend) + (:export + #:cell #:make-cell #:cell-char #:cell-fg #:cell-bg + #:cell-bold #:cell-italic #:cell-underline #:cell-link-url + #:framebuffer-backend #:make-framebuffer-backend + #:make-framebuffer #:fb-framebuffer + #:framebuffer-width #:framebuffer-height + #:diff-framebuffers #:flush-framebuffer + #:with-scissor)) + +(in-package :cl-tty.rendering) + +;;; ─── Cell — immutable per-cell state ───────────────────────────────────────── + +(defstruct cell + "A single terminal cell — character, colors, and attributes." + (char #\space :type character) + (fg nil) + (bg nil) + (bold nil :type boolean) + (italic nil :type boolean) + (underline nil :type boolean) + (link-url nil)) + +;;; ─── Framebuffer — 2D array of cells ──────────────────────────────────────── + +(defun make-framebuffer (width height) + "Create a 2D array of CELL with dimensions HEIGHT x WIDTH." + (make-array (list height width) + :initial-element (make-cell) + :element-type 'cell)) + +(defun framebuffer-width (fb) + "Return the width (columns) of framebuffer FB." + (if (arrayp fb) (array-dimension fb 1) 0)) + +(defun framebuffer-height (fb) + "Return the height (rows) of framebuffer FB." + (if (arrayp fb) (array-dimension fb 0) 0)) + +;;; ─── Framebuffer Backend — implements backend protocol ───────────────────── + +(defclass framebuffer-backend (backend) + ((framebuffer :initform nil :accessor fb-framebuffer) + (scissor-x :initform 0 :accessor fb-scissor-x) + (scissor-y :initform 0 :accessor fb-scissor-y) + (scissor-w :initform nil :accessor fb-scissor-w) + (scissor-h :initform nil :accessor fb-scissor-h))) + +(defun make-framebuffer-backend (&key (width 80) (height 24)) + "Create a framebuffer-backend with a fresh framebuffer." + (let ((fb (make-instance 'framebuffer-backend))) + (setf (fb-framebuffer fb) (make-framebuffer width height)) + fb)) + +;;; ─── Drawing methods ───────────────────────────────────────────────────────── + +(defun %in-scissor-p (fb cx cy) + "Check if (CX, CY) falls within the current scissor rectangle." + (let ((sx (fb-scissor-x fb)) (sy (fb-scissor-y fb)) + (sw (fb-scissor-w fb)) (sh (fb-scissor-h fb))) + (and (or (null sw) (and (>= cx sx) (< cx (+ sx sw)))) + (or (null sh) (and (>= cy sy) (< cy (+ sy sh))))))) + +(defun %set-cell (fb x y char &key fg bg bold italic underline link-url) + "Set cell (X, Y) if within bounds and scissor." + (let ((cells (fb-framebuffer fb))) + (when (and (>= y 0) (< y (framebuffer-height cells)) + (>= x 0) (< x (framebuffer-width cells)) + (%in-scissor-p fb x y)) + (setf (aref cells y x) + (make-cell :char char :fg fg :bg bg + :bold bold :italic italic :underline underline + :link-url link-url))))) + +(defmethod draw-text ((fb framebuffer-backend) x y string fg bg &rest attrs) + (loop for i from 0 below (length string) + do (%set-cell fb (+ x i) y (char string i) + :fg fg :bg bg + :bold (getf attrs :bold) + :italic (getf attrs :italic) + :underline (getf attrs :underline) + :link-url (getf attrs :link-url)))) + +(defmethod draw-rect ((fb framebuffer-backend) x y w h &key fg bg style) + (declare (ignore style)) + (dotimes (row h) + (dotimes (col w) + (%set-cell fb (+ x col) (+ y row) #\space :fg fg :bg bg)))) + +(defmethod draw-border ((fb framebuffer-backend) x y w h &key (style :single) title title-align fg bg) + (let* ((chars (case style + (:single '(#\+ #\- #\|)) + (:double '(#\+ #\= #\|)) + (:rounded '(#\. #\- #\|)) + (t '(#\+ #\- #\|)))) + (tc (first chars)) (hc (second chars)) (vc (third chars))) + ;; Top edge + (%set-cell fb x y tc :fg fg :bg bg) + (loop for i from 1 below (1- w) do (%set-cell fb (+ x i) y hc :fg fg :bg bg)) + (%set-cell fb (1- (+ x w)) y tc :fg fg :bg bg) + ;; Sides + (dotimes (row (- h 2)) + (%set-cell fb x (+ y row 1) vc :fg fg :bg bg) + (%set-cell fb (1- (+ x w)) (+ y row 1) vc :fg fg :bg bg)) + ;; Bottom edge + (%set-cell fb x (+ y h -1) tc :fg fg :bg bg) + (loop for i from 1 below (1- w) do (%set-cell fb (+ x i) (+ y h -1) hc :fg fg :bg bg)) + (%set-cell fb (1- (+ x w)) (+ y h -1) tc :fg fg :bg bg) + ;; Title + (when title + (loop for i from 0 below (length title) + do (%set-cell fb (+ x 2 i) y (char title i) :fg fg :bg bg))))) + +(defmethod backend-clear ((fb framebuffer-backend)) + (let ((cells (fb-framebuffer fb))) + (dotimes (y (framebuffer-height cells)) + (dotimes (x (framebuffer-width cells)) + (setf (aref cells y x) (make-cell)))))) + +(defmethod draw-link ((fb framebuffer-backend) x y string url &key fg bg) + ;; OSC 8 links are not rendered in framebuffer — store as text + (draw-text fb x y string fg bg :link-url url)) + +(defmethod draw-ellipsis ((fb framebuffer-backend) x y width &key fg bg) + (dotimes (i (min 3 width)) + (%set-cell fb (+ x i) y #\. :fg fg :bg bg))) + +;;; ─── Diff ──────────────────────────────────────────────────────────────────── + +(defun cells-equal-p (a b) + "Return T if two cells have identical content and style." + (and (eql (cell-char a) (cell-char b)) + (eql (cell-fg a) (cell-fg b)) + (eql (cell-bg a) (cell-bg b)) + (eql (cell-bold a) (cell-bold b)) + (eql (cell-italic a) (cell-italic b)) + (eql (cell-underline a) (cell-underline b)) + (equal (cell-link-url a) (cell-link-url b)))) + +(defun diff-framebuffers (prev curr) + "Compare PREV and CURR framebuffers. Return list of (X Y CELL) for changes." + (let ((changes nil) + (h (min (framebuffer-height prev) (framebuffer-height curr))) + (w (min (framebuffer-width prev) (framebuffer-width curr)))) + (dotimes (y h) + (dotimes (x w) + (let ((a (aref prev y x)) (b (aref curr y x))) + (unless (cells-equal-p a b) + (push (list x y b) changes))))) + (nreverse changes))) + +;;; ─── Flush ─────────────────────────────────────────────────────────────────── + +(defun flush-framebuffer (prev-fb curr-fb backend) + "Diff PREV-FB and CURR-FB and flush changes to BACKEND. +Returns the number of changed cells." + (let* ((changes (diff-framebuffers prev-fb curr-fb)) + (count (length changes)) + (current-row -1)) + (when (plusp count) + (begin-sync backend) + (dolist (change changes) + (destructuring-bind (x y cell) change + (unless (= y current-row) + (cursor-move backend x y) + (setf current-row y)) + (draw-text backend x y (string (cell-char cell)) + (cell-fg cell) (cell-bg cell) + :bold (cell-bold cell) + :italic (cell-italic cell) + :underline (cell-underline cell)))) + (end-sync backend)) + count)) + +;;; ─── Scissor clipping ──────────────────────────────────────────────────────── + +(defmacro with-scissor ((fb x y w h) &body body) + "Clip all drawing on FB to rectangle (X Y W H)." + (let ((old-x (gensym)) (old-y (gensym)) + (old-w (gensym)) (old-h (gensym))) + `(let ((,old-x (fb-scissor-x ,fb)) + (,old-y (fb-scissor-y ,fb)) + (,old-w (fb-scissor-w ,fb)) + (,old-h (fb-scissor-h ,fb))) + (setf (fb-scissor-x ,fb) ,x + (fb-scissor-y ,fb) ,y + (fb-scissor-w ,fb) ,w + (fb-scissor-h ,fb) ,h) + (unwind-protect (progn ,@body) + (setf (fb-scissor-x ,fb) ,old-x + (fb-scissor-y ,fb) ,old-y + (fb-scissor-w ,fb) ,old-w + (fb-scissor-h ,fb) ,old-h))))) diff --git a/tests/framebuffer-tests.lisp b/tests/framebuffer-tests.lisp new file mode 100644 index 0000000..0f8c035 --- /dev/null +++ b/tests/framebuffer-tests.lisp @@ -0,0 +1,66 @@ +(defpackage :cl-tty-framebuffer-test + (:use :cl :fiveam :cl-tty.rendering :cl-tty.backend)) +(in-package :cl-tty-framebuffer-test) + +(def-suite framebuffer-suite :description "Framebuffer rendering pipeline tests") +(in-suite framebuffer-suite) + +(test make-framebuffer-creates-correct-size + (let ((fb (make-framebuffer 80 24))) + (is (= 24 (framebuffer-height fb))) + (is (= 80 (framebuffer-width fb))))) + +(test cell-defaults-are-space + (let ((cell (aref (make-framebuffer 10 10) 0 0))) + (is (eql #\space (cell-char cell))) + (is (null (cell-fg cell))) + (is (null (cell-bg cell))))) + +(test draw-text-on-fb-sets-cells + (let ((fb (make-framebuffer-backend))) + (draw-text fb 2 3 "abc" :red nil) + (let ((cells (fb-framebuffer fb))) + (is (eql #\a (cell-char (aref cells 3 2)))) + (is (eql #\b (cell-char (aref cells 3 3)))) + (is (eql #\c (cell-char (aref cells 3 4)))) + (is (eql :red (cell-fg (aref cells 3 2))))))) + +(test draw-text-clips-at-bounds + (let ((fb (make-framebuffer-backend :width 10 :height 5))) + (draw-text fb 8 2 "hello" nil nil) + (let ((cells (fb-framebuffer fb))) + (is (eql #\h (cell-char (aref cells 2 8)))) + (is (eql #\e (cell-char (aref cells 2 9)))) + (is (eql #\space (cell-char (aref cells 2 0))) "out of bounds text is ignored")))) + +(test diff-identical-fbs-returns-empty + (let ((fb1 (make-framebuffer 80 24)) + (fb2 (make-framebuffer 80 24))) + (is (null (diff-framebuffers fb1 fb2))))) + +(test diff-changed-fb-returns-changes + (let* ((fb1 (make-framebuffer 10 10)) + (fb2 (make-framebuffer 10 10))) + (setf (aref fb2 5 5) (make-cell :char #\X :fg :red)) + (let ((changes (diff-framebuffers fb1 fb2))) + (is (= 1 (length changes))) + (destructuring-bind (x y cell) (first changes) + (is (= 5 x)) + (is (= 5 y)) + (is (eql #\X (cell-char cell))))))) + +(test with-scissor-clips-drawing + (let ((fb (make-framebuffer-backend :width 20 :height 10))) + (with-scissor (fb 5 5 3 3) + (draw-text fb 6 6 "ABC" nil nil) + (draw-text fb 1 1 "OUTSIDE" nil nil)) + (let ((cells (fb-framebuffer fb))) + (is (eql #\A (cell-char (aref cells 6 6))) "inside scissor draws") + (is (eql #\space (cell-char (aref cells 1 1))) "outside scissor is clipped")))) + +(test flush-fb-copies-to-backend + (let* ((real-be (make-simple-backend :output-stream (make-string-output-stream))) + (fb (make-framebuffer-backend))) + (draw-text fb 0 0 "X" :red nil) + (let ((changed (flush-framebuffer (make-framebuffer 80 24) (fb-framebuffer fb) real-be))) + (is (>= changed 1)))))