cl-tty/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
   #:extract-text #:fb-cell-link-url))

(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))

;;; --- Frame inspection ---------------------------------------------------

(defun fb-cell-link-url (fb x y)
  "Return the link URL at (X Y) in framebuffer FB, or nil."
  (when (and (arrayp fb) (>= y 0) (< y (array-dimension fb 0))
             (>= x 0) (< x (array-dimension fb 1)))
    (let ((c (aref fb y x)))
      (cell-link-url c))))

(defun extract-text (fb x1 y1 x2 y2)
  "Extract visible text from the rectangle between (X1,Y1) and (X2,Y2)."
  (let ((x-min (max 0 (min x1 x2))) (x-max (max 0 (max x1 x2)))
        (y-min (max 0 (min y1 y2))) (y-max (max 0 (max y1 y2)))
        (h (if (arrayp fb) (array-dimension fb 0) 0))
        (w (if (arrayp fb) (array-dimension fb 1) 0)))
    (with-output-to-string (s)
      (loop for y from y-min to (min y-max (1- h))
            do (loop for x from x-min to (min x-max (1- w))
                     do (let ((c (aref fb y x)))
                          (princ (cell-char c) s)))
               (when (< y y-max) (princ #\Newline s))))))

;;; ─── 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)))))