fix: tangle.py write-once-then-append logic (was always-appending, triplicating files); confirm-dialog option plist comparison; mouse-event button type (or keyword null)
This commit is contained in:
Hermes Agent
@@ -10,29 +10,3 @@
|
||||
#:tab-bar-active #:tab-bar-tabs
|
||||
#:tab-bar-add #:tab-bar-next #:tab-bar-prev
|
||||
#:tab-bar-select #:tab-bar-handle-key))
|
||||
|
||||
(defpackage :cl-tty.container
|
||||
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input)
|
||||
(:export
|
||||
#:scroll-box #:make-scroll-box
|
||||
#:scroll-box-scroll-y #:scroll-box-scroll-x
|
||||
#:scroll-box-children #:scroll-by
|
||||
#:sticky-scroll-p
|
||||
#:clamp-scroll
|
||||
#:tab-bar #:make-tab-bar
|
||||
#:tab-bar-active #:tab-bar-tabs
|
||||
#:tab-bar-add #:tab-bar-next #:tab-bar-prev
|
||||
#:tab-bar-select #:tab-bar-handle-key))
|
||||
|
||||
(defpackage :cl-tty.container
|
||||
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input)
|
||||
(:export
|
||||
#:scroll-box #:make-scroll-box
|
||||
#:scroll-box-scroll-y #:scroll-box-scroll-x
|
||||
#:scroll-box-children #:scroll-by
|
||||
#:sticky-scroll-p
|
||||
#:clamp-scroll
|
||||
#:tab-bar #:make-tab-bar
|
||||
#:tab-bar-active #:tab-bar-tabs
|
||||
#:tab-bar-add #:tab-bar-next #:tab-bar-prev
|
||||
#:tab-bar-select #:tab-bar-handle-key))
|
||||
|
||||
@@ -23,55 +23,3 @@
|
||||
#:render-toast
|
||||
#:dismiss-toast
|
||||
#:*toasts*))
|
||||
|
||||
;;; dialog-package.lisp — Package definition for cl-tty.dialog
|
||||
|
||||
(defpackage :cl-tty.dialog
|
||||
(:use :cl :cl-tty.backend :cl-tty.input :cl-tty.select)
|
||||
(:export
|
||||
#:dialog
|
||||
#:dialog-title
|
||||
#:dialog-content
|
||||
#:dialog-on-dismiss
|
||||
#:dialog-size
|
||||
#:dialog-size-pixels
|
||||
#:render-dialog
|
||||
#:push-dialog
|
||||
#:pop-dialog
|
||||
#:*dialog-stack*
|
||||
#:alert-dialog
|
||||
#:confirm-dialog
|
||||
#:select-dialog
|
||||
#:prompt-dialog
|
||||
#:toast
|
||||
#:toast-message
|
||||
#:toast-variant
|
||||
#:render-toast
|
||||
#:dismiss-toast
|
||||
#:*toasts*))
|
||||
|
||||
;;; dialog-package.lisp — Package definition for cl-tty.dialog
|
||||
|
||||
(defpackage :cl-tty.dialog
|
||||
(:use :cl :cl-tty.backend :cl-tty.input :cl-tty.select)
|
||||
(:export
|
||||
#:dialog
|
||||
#:dialog-title
|
||||
#:dialog-content
|
||||
#:dialog-on-dismiss
|
||||
#:dialog-size
|
||||
#:dialog-size-pixels
|
||||
#:render-dialog
|
||||
#:push-dialog
|
||||
#:pop-dialog
|
||||
#:*dialog-stack*
|
||||
#:alert-dialog
|
||||
#:confirm-dialog
|
||||
#:select-dialog
|
||||
#:prompt-dialog
|
||||
#:toast
|
||||
#:toast-message
|
||||
#:toast-variant
|
||||
#:render-toast
|
||||
#:dismiss-toast
|
||||
#:*toasts*))
|
||||
|
||||
@@ -73,261 +73,7 @@
|
||||
(list :title "No" :value :no))
|
||||
:on-select (lambda (opt)
|
||||
(pop-dialog)
|
||||
(if (eql opt :yes)
|
||||
(when on-yes (funcall on-yes))
|
||||
(when on-no (funcall on-no)))))))
|
||||
|
||||
(defun select-dialog (title options &key on-select)
|
||||
(make-instance 'dialog
|
||||
:title title
|
||||
:size :medium
|
||||
:content (make-instance 'select
|
||||
:options options
|
||||
:on-select (lambda (opt)
|
||||
(pop-dialog)
|
||||
(when on-select (funcall on-select opt))))))
|
||||
|
||||
(defun prompt-dialog (title &key on-submit)
|
||||
(make-instance 'dialog
|
||||
:title title
|
||||
:size :small
|
||||
:content (make-instance 'text-input
|
||||
:on-submit (lambda (value)
|
||||
(pop-dialog)
|
||||
(when on-submit (funcall on-submit value))))))
|
||||
|
||||
;; ─── Toast system ─────────────────────────────────────────────────────────────
|
||||
|
||||
(defclass toast ()
|
||||
((message :initarg :message :accessor toast-message)
|
||||
(variant :initarg :variant :initform :info :accessor toast-variant)))
|
||||
|
||||
(defun render-toast (toast screen w)
|
||||
(let* ((msg (toast-message toast))
|
||||
(variant (toast-variant toast))
|
||||
(color (case variant
|
||||
(:info :blue) (:success :green)
|
||||
(:warning :yellow) (:error :red)))
|
||||
(max-w (min 60 (1- w)))
|
||||
(x (- w max-w 1))
|
||||
(text (if (> (length msg) (- max-w 2))
|
||||
(concatenate 'string (subseq msg 0 (- max-w 5)) "...")
|
||||
msg)))
|
||||
(draw-rect screen x 0 max-w 1 :bg color)
|
||||
(draw-text screen (1+ x) 0 text :white color :bold t)))
|
||||
|
||||
(defun toast (message &key (variant :info) (duration 0))
|
||||
(let ((toast (make-instance 'toast :message message :variant variant)))
|
||||
(push toast *toasts*)
|
||||
(when (plusp duration) (dismiss-toast toast))
|
||||
toast))
|
||||
|
||||
(defun dismiss-toast (toast)
|
||||
(setf *toasts* (remove toast *toasts*)))
|
||||
|
||||
;;; dialog.lisp — Dialog System + Toast for cl-tty
|
||||
|
||||
(in-package :cl-tty.dialog)
|
||||
|
||||
;; ─── Special variables ────────────────────────────────────────────────────────
|
||||
|
||||
(defvar *dialog-stack* nil
|
||||
"Stack of active dialogs. (list) of dialog instances.")
|
||||
|
||||
(defvar *toasts* nil
|
||||
"List of active toast notifications.")
|
||||
|
||||
;; ─── Dialog class ─────────────────────────────────────────────────────────────
|
||||
|
||||
(defclass dialog ()
|
||||
((title :initarg :title :accessor dialog-title)
|
||||
(size :initarg :size :initform :medium :accessor dialog-size)
|
||||
(content :initarg :content :initform nil :accessor dialog-content)
|
||||
(on-dismiss :initarg :on-dismiss :initform nil :accessor dialog-on-dismiss)))
|
||||
|
||||
(defun dialog-size-pixels (size &optional (max-w 80) (max-h 24))
|
||||
(multiple-value-bind (dw dh)
|
||||
(case size
|
||||
(:small (values 40 8))
|
||||
(:medium (values 60 16))
|
||||
(:large (values 88 24))
|
||||
(t (values 60 16)))
|
||||
(values (min dw max-w) (min dh max-h))))
|
||||
|
||||
(defun render-dialog (dialog screen w h)
|
||||
(multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog) w h)
|
||||
(let ((x (floor (- w dw) 2))
|
||||
(y (floor (- h dh) 2)))
|
||||
;; Backdrop — dim the full screen
|
||||
(dotimes (row h)
|
||||
(draw-rect screen 0 row w 1 :bg :bright-black))
|
||||
;; Dialog panel
|
||||
(draw-border screen x y dw dh :style :single :title (dialog-title dialog))
|
||||
(when (dialog-content dialog)
|
||||
;; Content rendering delegated to component system
|
||||
(draw-text screen (1+ x) (1+ y)
|
||||
(format nil "~a" (dialog-content dialog))
|
||||
:white :default)))))
|
||||
|
||||
(defun push-dialog (dialog)
|
||||
(push dialog *dialog-stack*)
|
||||
dialog)
|
||||
|
||||
(defun pop-dialog ()
|
||||
(when *dialog-stack*
|
||||
(let ((dialog (pop *dialog-stack*)))
|
||||
(when (dialog-on-dismiss dialog)
|
||||
(funcall (dialog-on-dismiss dialog)))
|
||||
dialog)))
|
||||
|
||||
;; ─── Dialog sub-classes ──────────────────────────────────────────────────────
|
||||
|
||||
(defun alert-dialog (title message)
|
||||
(make-instance 'dialog
|
||||
:title title
|
||||
:size :small
|
||||
:content (make-instance 'select
|
||||
:options (list (list :title "OK" :value :ok))
|
||||
:on-select (lambda (opt) (declare (ignore opt)) (pop-dialog)))
|
||||
:on-dismiss (lambda () (pop-dialog))))
|
||||
|
||||
(defun confirm-dialog (title message &key on-yes on-no)
|
||||
(make-instance 'dialog
|
||||
:title title
|
||||
:size :small
|
||||
:content (make-instance 'select
|
||||
:options (list (list :title "Yes" :value :yes)
|
||||
(list :title "No" :value :no))
|
||||
:on-select (lambda (opt)
|
||||
(pop-dialog)
|
||||
(if (eql opt :yes)
|
||||
(when on-yes (funcall on-yes))
|
||||
(when on-no (funcall on-no)))))))
|
||||
|
||||
(defun select-dialog (title options &key on-select)
|
||||
(make-instance 'dialog
|
||||
:title title
|
||||
:size :medium
|
||||
:content (make-instance 'select
|
||||
:options options
|
||||
:on-select (lambda (opt)
|
||||
(pop-dialog)
|
||||
(when on-select (funcall on-select opt))))))
|
||||
|
||||
(defun prompt-dialog (title &key on-submit)
|
||||
(make-instance 'dialog
|
||||
:title title
|
||||
:size :small
|
||||
:content (make-instance 'text-input
|
||||
:on-submit (lambda (value)
|
||||
(pop-dialog)
|
||||
(when on-submit (funcall on-submit value))))))
|
||||
|
||||
;; ─── Toast system ─────────────────────────────────────────────────────────────
|
||||
|
||||
(defclass toast ()
|
||||
((message :initarg :message :accessor toast-message)
|
||||
(variant :initarg :variant :initform :info :accessor toast-variant)))
|
||||
|
||||
(defun render-toast (toast screen w)
|
||||
(let* ((msg (toast-message toast))
|
||||
(variant (toast-variant toast))
|
||||
(color (case variant
|
||||
(:info :blue) (:success :green)
|
||||
(:warning :yellow) (:error :red)))
|
||||
(max-w (min 60 (1- w)))
|
||||
(x (- w max-w 1))
|
||||
(text (if (> (length msg) (- max-w 2))
|
||||
(concatenate 'string (subseq msg 0 (- max-w 5)) "...")
|
||||
msg)))
|
||||
(draw-rect screen x 0 max-w 1 :bg color)
|
||||
(draw-text screen (1+ x) 0 text :white color :bold t)))
|
||||
|
||||
(defun toast (message &key (variant :info) (duration 0))
|
||||
(let ((toast (make-instance 'toast :message message :variant variant)))
|
||||
(push toast *toasts*)
|
||||
(when (plusp duration) (dismiss-toast toast))
|
||||
toast))
|
||||
|
||||
(defun dismiss-toast (toast)
|
||||
(setf *toasts* (remove toast *toasts*)))
|
||||
|
||||
;;; dialog.lisp — Dialog System + Toast for cl-tty
|
||||
|
||||
(in-package :cl-tty.dialog)
|
||||
|
||||
;; ─── Special variables ────────────────────────────────────────────────────────
|
||||
|
||||
(defvar *dialog-stack* nil
|
||||
"Stack of active dialogs. (list) of dialog instances.")
|
||||
|
||||
(defvar *toasts* nil
|
||||
"List of active toast notifications.")
|
||||
|
||||
;; ─── Dialog class ─────────────────────────────────────────────────────────────
|
||||
|
||||
(defclass dialog ()
|
||||
((title :initarg :title :accessor dialog-title)
|
||||
(size :initarg :size :initform :medium :accessor dialog-size)
|
||||
(content :initarg :content :initform nil :accessor dialog-content)
|
||||
(on-dismiss :initarg :on-dismiss :initform nil :accessor dialog-on-dismiss)))
|
||||
|
||||
(defun dialog-size-pixels (size &optional (max-w 80) (max-h 24))
|
||||
(multiple-value-bind (dw dh)
|
||||
(case size
|
||||
(:small (values 40 8))
|
||||
(:medium (values 60 16))
|
||||
(:large (values 88 24))
|
||||
(t (values 60 16)))
|
||||
(values (min dw max-w) (min dh max-h))))
|
||||
|
||||
(defun render-dialog (dialog screen w h)
|
||||
(multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog) w h)
|
||||
(let ((x (floor (- w dw) 2))
|
||||
(y (floor (- h dh) 2)))
|
||||
;; Backdrop — dim the full screen
|
||||
(dotimes (row h)
|
||||
(draw-rect screen 0 row w 1 :bg :bright-black))
|
||||
;; Dialog panel
|
||||
(draw-border screen x y dw dh :style :single :title (dialog-title dialog))
|
||||
(when (dialog-content dialog)
|
||||
;; Content rendering delegated to component system
|
||||
(draw-text screen (1+ x) (1+ y)
|
||||
(format nil "~a" (dialog-content dialog))
|
||||
:white :default)))))
|
||||
|
||||
(defun push-dialog (dialog)
|
||||
(push dialog *dialog-stack*)
|
||||
dialog)
|
||||
|
||||
(defun pop-dialog ()
|
||||
(when *dialog-stack*
|
||||
(let ((dialog (pop *dialog-stack*)))
|
||||
(when (dialog-on-dismiss dialog)
|
||||
(funcall (dialog-on-dismiss dialog)))
|
||||
dialog)))
|
||||
|
||||
;; ─── Dialog sub-classes ──────────────────────────────────────────────────────
|
||||
|
||||
(defun alert-dialog (title message)
|
||||
(make-instance 'dialog
|
||||
:title title
|
||||
:size :small
|
||||
:content (make-instance 'select
|
||||
:options (list (list :title "OK" :value :ok))
|
||||
:on-select (lambda (opt) (declare (ignore opt)) (pop-dialog)))
|
||||
:on-dismiss (lambda () (pop-dialog))))
|
||||
|
||||
(defun confirm-dialog (title message &key on-yes on-no)
|
||||
(make-instance 'dialog
|
||||
:title title
|
||||
:size :small
|
||||
:content (make-instance 'select
|
||||
:options (list (list :title "Yes" :value :yes)
|
||||
(list :title "No" :value :no))
|
||||
:on-select (lambda (opt)
|
||||
(pop-dialog)
|
||||
(if (eql opt :yes)
|
||||
(if (eql (getf opt :value) :yes)
|
||||
(when on-yes (funcall on-yes))
|
||||
(when on-no (funcall on-no)))))))
|
||||
|
||||
|
||||
@@ -1,80 +1,3 @@
|
||||
(defpackage :cl-tty.input
|
||||
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout)
|
||||
(:export
|
||||
;; Key events
|
||||
#:key-event #:make-key-event
|
||||
#:key-event-p #:key-event-key #:key-event-ctrl
|
||||
#:key-event-alt #:key-event-shift #:key-event-code
|
||||
#:key-event-raw #:key-event-text
|
||||
;; Mouse events
|
||||
#:mouse-event #:make-mouse-event
|
||||
#:mouse-event-p #:mouse-event-type #:mouse-event-button
|
||||
#:mouse-event-x #:mouse-event-y
|
||||
;; Terminal raw mode
|
||||
#:save-terminal-state #:set-raw-mode #:restore-terminal-state
|
||||
#:with-raw-terminal
|
||||
;; Event reading
|
||||
#:read-event
|
||||
#:utf8-decode
|
||||
;; Terminal resize flag
|
||||
#:*terminal-resized-p*
|
||||
;; TextInput
|
||||
#:text-input #:make-text-input
|
||||
#:text-input-value #:text-input-cursor
|
||||
#:text-input-placeholder #:text-input-max-length
|
||||
#:text-input-on-submit #:text-input-layout-node
|
||||
#:handle-text-input #:render-text-input
|
||||
;; Textarea
|
||||
#:textarea #:make-textarea
|
||||
#:textarea-value #:textarea-cursor-row #:textarea-cursor-col
|
||||
#:textarea-on-submit #:textarea-undo-stack #:textarea-redo-stack
|
||||
#:textarea-layout-node
|
||||
#:textarea-lines
|
||||
#:handle-textarea-input #:render-textarea
|
||||
;; Keybindings
|
||||
#:keymap #:make-keymap #:keymap-name #:keymap-bindings #:keymap-parent
|
||||
#:*keymaps* #:*chord-timeout*
|
||||
#:defkeymap #:dispatch-key-event #:key-match-p
|
||||
#:component-keymap))
|
||||
|
||||
(defpackage :cl-tty.input
|
||||
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout)
|
||||
(:export
|
||||
;; Key events
|
||||
#:key-event #:make-key-event
|
||||
#:key-event-p #:key-event-key #:key-event-ctrl
|
||||
#:key-event-alt #:key-event-shift #:key-event-code
|
||||
#:key-event-raw #:key-event-text
|
||||
;; Mouse events
|
||||
#:mouse-event #:make-mouse-event
|
||||
#:mouse-event-p #:mouse-event-type #:mouse-event-button
|
||||
#:mouse-event-x #:mouse-event-y
|
||||
;; Terminal raw mode
|
||||
#:save-terminal-state #:set-raw-mode #:restore-terminal-state
|
||||
#:with-raw-terminal
|
||||
;; Event reading
|
||||
#:read-event
|
||||
;; UTF-8 input support
|
||||
#:utf8-decode
|
||||
;; TextInput
|
||||
#:text-input #:make-text-input
|
||||
#:text-input-value #:text-input-cursor
|
||||
#:text-input-placeholder #:text-input-max-length
|
||||
#:text-input-on-submit #:text-input-layout-node
|
||||
#:handle-text-input #:render-text-input
|
||||
;; Textarea
|
||||
#:textarea #:make-textarea
|
||||
#:textarea-value #:textarea-cursor-row #:textarea-cursor-col
|
||||
#:textarea-lines
|
||||
#:textarea-on-submit #:textarea-undo-stack #:textarea-redo-stack
|
||||
#:textarea-layout-node
|
||||
#:handle-textarea-input #:render-textarea
|
||||
;; Keybindings
|
||||
#:keymap #:make-keymap #:keymap-name #:keymap-bindings #:keymap-parent
|
||||
#:*keymaps* #:*chord-timeout*
|
||||
#:defkeymap #:dispatch-key-event #:key-match-p
|
||||
#:component-keymap))
|
||||
|
||||
(defpackage :cl-tty.input
|
||||
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout)
|
||||
(:export
|
||||
|
||||
@@ -28,7 +28,7 @@
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defstruct mouse-event
|
||||
(type nil :type (or keyword null))
|
||||
(button nil :type (or keyword nil))
|
||||
(button nil :type (or keyword null))
|
||||
(x 0 :type fixnum)
|
||||
(y 0 :type fixnum)
|
||||
(raw nil :type (or string null)))
|
||||
|
||||
@@ -90,189 +90,3 @@
|
||||
;;; --- Component protocol integration ---
|
||||
(defgeneric component-keymap (component)
|
||||
(:method ((c t)) nil))
|
||||
|
||||
(in-package #:cl-tty.input)
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Key map struct
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defstruct keymap
|
||||
(name nil :type (or keyword null))
|
||||
(bindings nil :type list)
|
||||
(parent nil :type (or keymap null)))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Global keymap registry
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defparameter *keymaps* (make-hash-table :test #'equal))
|
||||
(defparameter *chord-timeout* 0.5)
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Key spec matching
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun key-match-p (spec event)
|
||||
"T if SPEC matches EVENT. Spec is :ctrl+p (modifier+key keyword)
|
||||
or (:ctrl+p) for single-spec in a list, or (:ctrl+x :ctrl+s) for chords."
|
||||
(etypecase spec
|
||||
;; Keyword like :ctrl+p, :alt+f, :enter, :space, :f1
|
||||
(keyword
|
||||
(let* ((name (string spec))
|
||||
(plus (position #\+ name)))
|
||||
(if plus
|
||||
;; Modified key: :ctrl+p → mod-str="CTRL", key-str="P"
|
||||
(let ((mod-str (subseq name 0 plus))
|
||||
(key-str (subseq name (1+ plus))))
|
||||
(and (eql (intern key-str :keyword)
|
||||
(key-event-key event))
|
||||
(cond
|
||||
((string= mod-str "CTRL") (key-event-ctrl event))
|
||||
((string= mod-str "ALT") (key-event-alt event))
|
||||
((string= mod-str "SHIFT") (key-event-shift event))
|
||||
(t t))))
|
||||
;; Plain keyword: :enter, :escape, :f1, etc.
|
||||
(eql spec (key-event-key event)))))
|
||||
;; List: (:ctrl+p) or (:ctrl+x :ctrl+s)
|
||||
(list
|
||||
(when spec
|
||||
(key-match-p (first spec) event)))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Dispatch
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; dispatch-key-event — main entry point for keymap-based dispatch.
|
||||
;;;
|
||||
;;; IMPORTANT: This function is NOT called by the demo's event loop
|
||||
;;; or by any built-in widget event handlers. Users who want to use
|
||||
;;; the keymap system MUST call dispatch-key-event explicitly in their
|
||||
;;; own event loops, e.g.:
|
||||
;;;
|
||||
;;; (defun handle-event (event)
|
||||
;;; (or (dispatch-key-event event)
|
||||
;;; (handle-text-input my-input event)
|
||||
;;; ...))
|
||||
;;;
|
||||
;;; Chords ((:ctrl+x :ctrl+s)) are not yet supported; only single
|
||||
;;; key specs work. The *chord-timeout* and list-of-lists syntax
|
||||
;;; are reserved for future implementation.
|
||||
(defun dispatch-key-event (event &key component)
|
||||
(labels ((try-keymap (km)
|
||||
(when km
|
||||
(loop for (spec . handler) in (keymap-bindings km)
|
||||
thereis (when (key-match-p spec event)
|
||||
(funcall handler event)
|
||||
t))))
|
||||
(find-keymap (name)
|
||||
(gethash name *keymaps*)))
|
||||
(or (and component
|
||||
(let ((km (component-keymap component)))
|
||||
(when km (try-keymap km))))
|
||||
(try-keymap (find-keymap :local))
|
||||
(try-keymap (find-keymap :global)))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; defkeymap macro
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defmacro defkeymap (name &body bindings)
|
||||
`(setf (gethash ',name *keymaps*)
|
||||
(make-keymap :name ',name
|
||||
:bindings (list ,@(loop for b in bindings
|
||||
collect (if (consp (cdr b))
|
||||
`(cons ',(car b) ,(cadr b))
|
||||
`(cons ',(car b) ,(cdr b))))))))
|
||||
|
||||
;;; --- Component protocol integration ---
|
||||
(defgeneric component-keymap (component)
|
||||
(:method ((c t)) nil))
|
||||
|
||||
(in-package #:cl-tty.input)
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Key map struct
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defstruct keymap
|
||||
(name nil :type (or keyword null))
|
||||
(bindings nil :type list)
|
||||
(parent nil :type (or keymap null)))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Global keymap registry
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defparameter *keymaps* (make-hash-table :test #'equal))
|
||||
(defparameter *chord-timeout* 0.5)
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Key spec matching
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun key-match-p (spec event)
|
||||
"T if SPEC matches EVENT. Spec is :ctrl+p (modifier+key keyword)
|
||||
or (:ctrl+p) for single-spec in a list, or (:ctrl+x :ctrl+s) for chords."
|
||||
(etypecase spec
|
||||
;; Keyword like :ctrl+p, :alt+f, :enter, :space, :f1
|
||||
(keyword
|
||||
(let* ((name (string spec))
|
||||
(plus (position #\+ name)))
|
||||
(if plus
|
||||
;; Modified key: :ctrl+p → mod-str="CTRL", key-str="P"
|
||||
(let ((mod-str (subseq name 0 plus))
|
||||
(key-str (subseq name (1+ plus))))
|
||||
(and (eql (intern key-str :keyword)
|
||||
(key-event-key event))
|
||||
(cond
|
||||
((string= mod-str "CTRL") (key-event-ctrl event))
|
||||
((string= mod-str "ALT") (key-event-alt event))
|
||||
((string= mod-str "SHIFT") (key-event-shift event))
|
||||
(t t))))
|
||||
;; Plain keyword: :enter, :escape, :f1, etc.
|
||||
(eql spec (key-event-key event)))))
|
||||
;; List: (:ctrl+p) or (:ctrl+x :ctrl+s)
|
||||
(list
|
||||
(when spec
|
||||
(key-match-p (first spec) event)))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Dispatch
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; dispatch-key-event — main entry point for keymap-based dispatch.
|
||||
;;;
|
||||
;;; IMPORTANT: This function is NOT called by the demo's event loop
|
||||
;;; or by any built-in widget event handlers. Users who want to use
|
||||
;;; the keymap system MUST call dispatch-key-event explicitly in their
|
||||
;;; own event loops, e.g.:
|
||||
;;;
|
||||
;;; (defun handle-event (event)
|
||||
;;; (or (dispatch-key-event event)
|
||||
;;; (handle-text-input my-input event)
|
||||
;;; ...))
|
||||
;;;
|
||||
;;; Chords ((:ctrl+x :ctrl+s)) are not yet supported; only single
|
||||
;;; key specs work. The *chord-timeout* and list-of-lists syntax
|
||||
;;; are reserved for future implementation.
|
||||
(defun dispatch-key-event (event &key component)
|
||||
(labels ((try-keymap (km)
|
||||
(when km
|
||||
(loop for (spec . handler) in (keymap-bindings km)
|
||||
thereis (when (key-match-p spec event)
|
||||
(funcall handler event)
|
||||
t))))
|
||||
(find-keymap (name)
|
||||
(gethash name *keymaps*)))
|
||||
(or (and component
|
||||
(let ((km (component-keymap component)))
|
||||
(when km (try-keymap km))))
|
||||
(try-keymap (find-keymap :local))
|
||||
(try-keymap (find-keymap :global)))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; defkeymap macro
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defmacro defkeymap (name &body bindings)
|
||||
`(setf (gethash ',name *keymaps*)
|
||||
(make-keymap :name ',name
|
||||
:bindings (list ,@(loop for b in bindings
|
||||
collect (if (consp (cdr b))
|
||||
`(cons ',(car b) ,(cadr b))
|
||||
`(cons ',(car b) ,(cdr b))))))))
|
||||
|
||||
;;; --- Component protocol integration ---
|
||||
(defgeneric component-keymap (component)
|
||||
(:method ((c t)) nil))
|
||||
|
||||
@@ -10,29 +10,3 @@
|
||||
#:start-selection #:update-selection #:finalize-selection
|
||||
#:selection-active-p
|
||||
#:cell-link-at #:open-link-at))
|
||||
|
||||
(defpackage :cl-tty.mouse
|
||||
(:use :cl :cl-tty.layout :cl-tty.input :cl-tty.box :cl-tty.rendering)
|
||||
(:export
|
||||
#:mouse-mixin
|
||||
#:on-mouse-down #:on-mouse-up #:on-mouse-move #:on-mouse-scroll
|
||||
#:handle-mouse-event
|
||||
#:hit-test
|
||||
#:selection #:get-selection #:copy-to-clipboard
|
||||
#:make-selection #:selection-p
|
||||
#:start-selection #:update-selection #:finalize-selection
|
||||
#:selection-active-p
|
||||
#:cell-link-at #:open-link-at))
|
||||
|
||||
(defpackage :cl-tty.mouse
|
||||
(:use :cl :cl-tty.layout :cl-tty.input :cl-tty.box :cl-tty.rendering)
|
||||
(:export
|
||||
#:mouse-mixin
|
||||
#:on-mouse-down #:on-mouse-up #:on-mouse-move #:on-mouse-scroll
|
||||
#:handle-mouse-event
|
||||
#:hit-test
|
||||
#:selection #:get-selection #:copy-to-clipboard
|
||||
#:make-selection #:selection-p
|
||||
#:start-selection #:update-selection #:finalize-selection
|
||||
#:selection-active-p
|
||||
#:cell-link-at #:open-link-at))
|
||||
|
||||
@@ -111,231 +111,3 @@ Components without a layout-node or position return nil."
|
||||
#+linux (sb-ext:run-program "xdg-open" (list url) :wait nil)
|
||||
#+darwin (sb-ext:run-program "open" (list url) :wait nil))
|
||||
url))
|
||||
|
||||
(in-package :cl-tty.mouse)
|
||||
|
||||
(defclass mouse-mixin ()
|
||||
((on-mouse-down :initarg :on-mouse-down :initform nil :accessor on-mouse-down)
|
||||
(on-mouse-up :initarg :on-mouse-up :initform nil :accessor on-mouse-up)
|
||||
(on-mouse-move :initarg :on-mouse-move :initform nil :accessor on-mouse-move)
|
||||
(on-mouse-scroll :initarg :on-mouse-scroll :initform nil :accessor on-mouse-scroll)))
|
||||
|
||||
(defun handle-mouse-event (component event)
|
||||
(let* ((type (mouse-event-type event))
|
||||
(handler (case type
|
||||
(:press (on-mouse-down component))
|
||||
(:release (on-mouse-up component))
|
||||
(:drag (on-mouse-move component))
|
||||
(t nil))))
|
||||
(when handler (funcall handler event))))
|
||||
|
||||
(defun hit-test (root x y)
|
||||
"Find the deepest component at (X, Y) by testing layout-node bounds.
|
||||
Recurses into component-children to find the innermost match.
|
||||
Components without a layout-node or position return nil."
|
||||
(labels ((recurse (node)
|
||||
(let ((ln (ignore-errors (component-layout-node node)))
|
||||
(best nil))
|
||||
(when ln
|
||||
(let ((nx (layout-node-x ln))
|
||||
(ny (layout-node-y ln))
|
||||
(nw (layout-node-width ln))
|
||||
(nh (layout-node-height ln)))
|
||||
;; Check children first for deeper match
|
||||
(dolist (child (ignore-errors (component-children node)))
|
||||
(let ((child-hit (recurse child)))
|
||||
(when child-hit
|
||||
(setf best child-hit))))
|
||||
;; If no child matched, check self
|
||||
(or best
|
||||
(when (and (>= x nx) (< x (+ nx nw))
|
||||
(>= y ny) (< y (+ ny nh)))
|
||||
node)))))))
|
||||
(recurse root)))
|
||||
|
||||
;; Selection
|
||||
(defvar *selection* nil)
|
||||
|
||||
(defstruct (selection (:conc-name sel-))
|
||||
(start-x 0) (start-y 0) (end-x 0) (end-y 0) (text ""))
|
||||
|
||||
(defun get-selection ()
|
||||
(when *selection* (sel-text *selection*)))
|
||||
|
||||
(defun copy-to-clipboard (text)
|
||||
#+linux
|
||||
(cond
|
||||
((sb-ext:posix-getenv "WAYLAND_DISPLAY")
|
||||
(sb-ext:run-program "wl-copy" nil :input text :wait nil))
|
||||
(t
|
||||
(sb-ext:run-program "xclip" (list "-selection" "clipboard")
|
||||
:input text :wait nil)))
|
||||
#+darwin (sb-ext:run-program "pbcopy" nil :input text :wait nil))
|
||||
|
||||
;;; --- Selection tracking (mouse drag) ---------------------------------------
|
||||
|
||||
(defvar *selection-active* nil
|
||||
"T when a drag selection is in progress.")
|
||||
|
||||
(defvar *selection-start* nil
|
||||
"Cons (X . Y) of mouse-down position during drag.")
|
||||
|
||||
(defvar *selection-end* nil
|
||||
"Cons (X . Y) of current mouse position during drag.")
|
||||
|
||||
(defun start-selection (x y)
|
||||
"Begin a drag selection at (X Y)."
|
||||
(setf *selection-start* (cons x y)
|
||||
*selection-end* (cons x y)
|
||||
*selection-active* t))
|
||||
|
||||
(defun update-selection (x y)
|
||||
"Update the drag selection end position to (X Y)."
|
||||
(setf *selection-end* (cons x y)))
|
||||
|
||||
(defun selection-active-p ()
|
||||
"Return T if a drag selection is in progress."
|
||||
*selection-active*)
|
||||
|
||||
(defun finalize-selection (fb)
|
||||
"End the drag selection and extract text from the framebuffer."
|
||||
(setf *selection-active* nil)
|
||||
(when (and *selection-start* *selection-end* fb)
|
||||
(let* ((x1 (car *selection-start*))
|
||||
(y1 (cdr *selection-start*))
|
||||
(x2 (car *selection-end*))
|
||||
(y2 (cdr *selection-end*))
|
||||
(text (cl-tty.rendering:extract-text fb x1 y1 x2 y2)))
|
||||
(setf *selection* (make-selection :start-x x1 :start-y y1
|
||||
:end-x x2 :end-y y2
|
||||
:text text))
|
||||
(setf *selection-start* nil *selection-end* nil)
|
||||
text)))
|
||||
|
||||
;;; --- Link clicking ---------------------------------------------------------
|
||||
|
||||
(defun cell-link-at (fb x y)
|
||||
"Return the link URL at (X Y) in framebuffer FB, or nil."
|
||||
(cl-tty.rendering:fb-cell-link-url fb x y))
|
||||
|
||||
(defun open-link-at (fb x y)
|
||||
"If there is a link URL at (X Y) in FB, open it via xdg-open."
|
||||
(let ((url (cell-link-at fb x y)))
|
||||
(when url
|
||||
#+linux (sb-ext:run-program "xdg-open" (list url) :wait nil)
|
||||
#+darwin (sb-ext:run-program "open" (list url) :wait nil))
|
||||
url))
|
||||
|
||||
(in-package :cl-tty.mouse)
|
||||
|
||||
(defclass mouse-mixin ()
|
||||
((on-mouse-down :initarg :on-mouse-down :initform nil :accessor on-mouse-down)
|
||||
(on-mouse-up :initarg :on-mouse-up :initform nil :accessor on-mouse-up)
|
||||
(on-mouse-move :initarg :on-mouse-move :initform nil :accessor on-mouse-move)
|
||||
(on-mouse-scroll :initarg :on-mouse-scroll :initform nil :accessor on-mouse-scroll)))
|
||||
|
||||
(defun handle-mouse-event (component event)
|
||||
(let* ((type (mouse-event-type event))
|
||||
(handler (case type
|
||||
(:press (on-mouse-down component))
|
||||
(:release (on-mouse-up component))
|
||||
(:drag (on-mouse-move component))
|
||||
(t nil))))
|
||||
(when handler (funcall handler event))))
|
||||
|
||||
(defun hit-test (root x y)
|
||||
"Find the deepest component at (X, Y) by testing layout-node bounds.
|
||||
Recurses into component-children to find the innermost match.
|
||||
Components without a layout-node or position return nil."
|
||||
(labels ((recurse (node)
|
||||
(let ((ln (ignore-errors (component-layout-node node)))
|
||||
(best nil))
|
||||
(when ln
|
||||
(let ((nx (layout-node-x ln))
|
||||
(ny (layout-node-y ln))
|
||||
(nw (layout-node-width ln))
|
||||
(nh (layout-node-height ln)))
|
||||
;; Check children first for deeper match
|
||||
(dolist (child (ignore-errors (component-children node)))
|
||||
(let ((child-hit (recurse child)))
|
||||
(when child-hit
|
||||
(setf best child-hit))))
|
||||
;; If no child matched, check self
|
||||
(or best
|
||||
(when (and (>= x nx) (< x (+ nx nw))
|
||||
(>= y ny) (< y (+ ny nh)))
|
||||
node)))))))
|
||||
(recurse root)))
|
||||
|
||||
;; Selection
|
||||
(defvar *selection* nil)
|
||||
|
||||
(defstruct (selection (:conc-name sel-))
|
||||
(start-x 0) (start-y 0) (end-x 0) (end-y 0) (text ""))
|
||||
|
||||
(defun get-selection ()
|
||||
(when *selection* (sel-text *selection*)))
|
||||
|
||||
(defun copy-to-clipboard (text)
|
||||
#+linux
|
||||
(cond
|
||||
((sb-ext:posix-getenv "WAYLAND_DISPLAY")
|
||||
(sb-ext:run-program "wl-copy" nil :input text :wait nil))
|
||||
(t
|
||||
(sb-ext:run-program "xclip" (list "-selection" "clipboard")
|
||||
:input text :wait nil)))
|
||||
#+darwin (sb-ext:run-program "pbcopy" nil :input text :wait nil))
|
||||
|
||||
;;; --- Selection tracking (mouse drag) ---------------------------------------
|
||||
|
||||
(defvar *selection-active* nil
|
||||
"T when a drag selection is in progress.")
|
||||
|
||||
(defvar *selection-start* nil
|
||||
"Cons (X . Y) of mouse-down position during drag.")
|
||||
|
||||
(defvar *selection-end* nil
|
||||
"Cons (X . Y) of current mouse position during drag.")
|
||||
|
||||
(defun start-selection (x y)
|
||||
"Begin a drag selection at (X Y)."
|
||||
(setf *selection-start* (cons x y)
|
||||
*selection-end* (cons x y)
|
||||
*selection-active* t))
|
||||
|
||||
(defun update-selection (x y)
|
||||
"Update the drag selection end position to (X Y)."
|
||||
(setf *selection-end* (cons x y)))
|
||||
|
||||
(defun selection-active-p ()
|
||||
"Return T if a drag selection is in progress."
|
||||
*selection-active*)
|
||||
|
||||
(defun finalize-selection (fb)
|
||||
"End the drag selection and extract text from the framebuffer."
|
||||
(setf *selection-active* nil)
|
||||
(when (and *selection-start* *selection-end* fb)
|
||||
(let* ((x1 (car *selection-start*))
|
||||
(y1 (cdr *selection-start*))
|
||||
(x2 (car *selection-end*))
|
||||
(y2 (cdr *selection-end*))
|
||||
(text (cl-tty.rendering:extract-text fb x1 y1 x2 y2)))
|
||||
(setf *selection* (make-selection :start-x x1 :start-y y1
|
||||
:end-x x2 :end-y y2
|
||||
:text text))
|
||||
(setf *selection-start* nil *selection-end* nil)
|
||||
text)))
|
||||
|
||||
;;; --- Link clicking ---------------------------------------------------------
|
||||
|
||||
(defun cell-link-at (fb x y)
|
||||
"Return the link URL at (X Y) in framebuffer FB, or nil."
|
||||
(cl-tty.rendering:fb-cell-link-url fb x y))
|
||||
|
||||
(defun open-link-at (fb x y)
|
||||
"If there is a link URL at (X Y) in FB, open it via xdg-open."
|
||||
(let ((url (cell-link-at fb x y)))
|
||||
(when url
|
||||
#+linux (sb-ext:run-program "xdg-open" (list url) :wait nil)
|
||||
#+darwin (sb-ext:run-program "open" (list url) :wait nil))
|
||||
url))
|
||||
|
||||
@@ -95,199 +95,3 @@ Children outside the viewport are skipped."
|
||||
(viewport-h (if ln (layout-node-height ln) 24)))
|
||||
(when (>= (scroll-box-scroll-y sb) (- content-h viewport-h 1))
|
||||
(setf (scroll-box-scroll-y sb) (max 0 (- content-h viewport-h)))))))
|
||||
|
||||
(in-package #:cl-tty.container)
|
||||
|
||||
(defclass scroll-box (dirty-mixin)
|
||||
((children :initform nil :initarg :children :accessor scroll-box-children :type list)
|
||||
(scroll-y :initform 0 :initarg :scroll-y :accessor scroll-box-scroll-y :type fixnum)
|
||||
(scroll-x :initform 0 :initarg :scroll-x :accessor scroll-box-scroll-x :type fixnum)
|
||||
(sticky-scroll-p :initform t :initarg :sticky-scroll-p :accessor sticky-scroll-p :type boolean)
|
||||
(layout-node :initform (make-layout-node) :accessor scroll-box-layout-node)))
|
||||
|
||||
(defun make-scroll-box (&key (children nil) (scroll-y 0) (scroll-x 0) sticky-scroll-p)
|
||||
(make-instance 'scroll-box
|
||||
:children children :scroll-y scroll-y :scroll-x scroll-x
|
||||
:sticky-scroll-p (if (null sticky-scroll-p) t sticky-scroll-p)))
|
||||
|
||||
(defmethod component-children ((sb scroll-box)) (scroll-box-children sb))
|
||||
(defmethod component-layout-node ((sb scroll-box)) (scroll-box-layout-node sb))
|
||||
|
||||
(defun clamp-scroll (sb)
|
||||
(let* ((ln (scroll-box-layout-node sb))
|
||||
(viewport-h (if ln (layout-node-height ln) 0))
|
||||
(viewport-w (if ln (layout-node-width ln) 0))
|
||||
(content-h (scroll-box-content-height sb))
|
||||
(content-w (scroll-box-content-width sb)))
|
||||
(setf (scroll-box-scroll-y sb) (max 0 (min (scroll-box-scroll-y sb) (- content-h viewport-h))))
|
||||
(setf (scroll-box-scroll-x sb) (max 0 (min (scroll-box-scroll-x sb) (- content-w viewport-w))))))
|
||||
|
||||
(defun scroll-by (sb dy dx)
|
||||
(incf (scroll-box-scroll-y sb) dy) (incf (scroll-box-scroll-x sb) dx)
|
||||
(clamp-scroll sb) (mark-dirty sb))
|
||||
|
||||
(defun scroll-box-content-height (sb)
|
||||
(reduce #'+ (scroll-box-children sb)
|
||||
:key (lambda (c) (let ((ln (component-layout-node c))) (if ln (max 1 (layout-node-height ln)) 1)))
|
||||
:initial-value 0))
|
||||
|
||||
(defun scroll-box-content-width (sb)
|
||||
(reduce #'max (scroll-box-children sb)
|
||||
:key (lambda (c) (let ((ln (component-layout-node c))) (if ln (max 1 (layout-node-width ln)) 1)))
|
||||
:initial-value 0))
|
||||
|
||||
(defmethod render ((sb scroll-box) backend)
|
||||
"Render ScrollBox children within the viewport, offset by scroll position.
|
||||
Children outside the viewport are skipped."
|
||||
(let* ((ln (scroll-box-layout-node sb))
|
||||
(vx 0) (vy 0)
|
||||
(vw (if ln (layout-node-width ln) 80))
|
||||
(vh (if ln (layout-node-height ln) 24))
|
||||
(sy (scroll-box-scroll-y sb))
|
||||
(sx (scroll-box-scroll-x sb)))
|
||||
(dolist (child (scroll-box-children sb))
|
||||
(let* ((cln (component-layout-node child))
|
||||
(ch (if cln (layout-node-height cln) 1))
|
||||
(cy vy))
|
||||
;; Only render children that are visible in the viewport
|
||||
(when (and (< (- cy sy) vh)
|
||||
(> (+ (- cy sy) ch) 0))
|
||||
;; Temporarily offset child's layout-node position for rendering
|
||||
(let ((orig-x (if cln (layout-node-x cln) 0))
|
||||
(orig-y (if cln (layout-node-y cln) 0)))
|
||||
(when cln
|
||||
(setf (layout-node-x cln) (- vx sx)
|
||||
(layout-node-y cln) (- vy sy)))
|
||||
(unwind-protect
|
||||
(render child backend)
|
||||
(when cln
|
||||
(setf (layout-node-x cln) orig-x
|
||||
(layout-node-y cln) orig-y)))))
|
||||
(incf vy ch)))
|
||||
(draw-scrollbars sb backend vw vh)))
|
||||
|
||||
(defun scrollbar-thumb (scroll-pos viewport-size content-size)
|
||||
(if (> content-size viewport-size) (/ (float scroll-pos) (- content-size viewport-size)) 0.0))
|
||||
|
||||
(defun draw-scrollbars (sb backend viewport-w viewport-h)
|
||||
(let* ((content-h (scroll-box-content-height sb)) (content-w (scroll-box-content-width sb))
|
||||
(sy (scroll-box-scroll-y sb)) (sx (scroll-box-scroll-x sb))
|
||||
(ln (scroll-box-layout-node sb))
|
||||
(ox (if ln (layout-node-x ln) 0))
|
||||
(oy (if ln (layout-node-y ln) 0)))
|
||||
(when (> content-h viewport-h)
|
||||
(let* ((thumb (scrollbar-thumb sy viewport-h content-h))
|
||||
(thumb-pos (round (* thumb viewport-h))))
|
||||
(draw-rect backend (+ ox (1- viewport-w)) oy 1 viewport-h :bg :bright-black)
|
||||
(draw-text backend (+ ox (1- viewport-w)) (+ oy thumb-pos) "█" nil nil)))
|
||||
(when (> content-w viewport-w)
|
||||
(let* ((thumb (scrollbar-thumb sx viewport-w content-w))
|
||||
(thumb-pos (round (* thumb viewport-w))))
|
||||
(draw-rect backend ox (+ oy (1- viewport-h)) viewport-w 1 :bg :bright-black)
|
||||
(draw-text backend (+ ox thumb-pos) (+ oy (1- viewport-h)) "█" nil nil)))))
|
||||
|
||||
(defun update-sticky-scroll (sb)
|
||||
(when (sticky-scroll-p sb)
|
||||
(let* ((content-h (scroll-box-content-height sb))
|
||||
(ln (scroll-box-layout-node sb))
|
||||
(viewport-h (if ln (layout-node-height ln) 24)))
|
||||
(when (>= (scroll-box-scroll-y sb) (- content-h viewport-h 1))
|
||||
(setf (scroll-box-scroll-y sb) (max 0 (- content-h viewport-h)))))))
|
||||
|
||||
(in-package #:cl-tty.container)
|
||||
|
||||
(defclass scroll-box (dirty-mixin)
|
||||
((children :initform nil :initarg :children :accessor scroll-box-children :type list)
|
||||
(scroll-y :initform 0 :initarg :scroll-y :accessor scroll-box-scroll-y :type fixnum)
|
||||
(scroll-x :initform 0 :initarg :scroll-x :accessor scroll-box-scroll-x :type fixnum)
|
||||
(sticky-scroll-p :initform t :initarg :sticky-scroll-p :accessor sticky-scroll-p :type boolean)
|
||||
(layout-node :initform (make-layout-node) :accessor scroll-box-layout-node)))
|
||||
|
||||
(defun make-scroll-box (&key (children nil) (scroll-y 0) (scroll-x 0) sticky-scroll-p)
|
||||
(make-instance 'scroll-box
|
||||
:children children :scroll-y scroll-y :scroll-x scroll-x
|
||||
:sticky-scroll-p (if (null sticky-scroll-p) t sticky-scroll-p)))
|
||||
|
||||
(defmethod component-children ((sb scroll-box)) (scroll-box-children sb))
|
||||
(defmethod component-layout-node ((sb scroll-box)) (scroll-box-layout-node sb))
|
||||
|
||||
(defun clamp-scroll (sb)
|
||||
(let* ((ln (scroll-box-layout-node sb))
|
||||
(viewport-h (if ln (layout-node-height ln) 0))
|
||||
(viewport-w (if ln (layout-node-width ln) 0))
|
||||
(content-h (scroll-box-content-height sb))
|
||||
(content-w (scroll-box-content-width sb)))
|
||||
(setf (scroll-box-scroll-y sb) (max 0 (min (scroll-box-scroll-y sb) (- content-h viewport-h))))
|
||||
(setf (scroll-box-scroll-x sb) (max 0 (min (scroll-box-scroll-x sb) (- content-w viewport-w))))))
|
||||
|
||||
(defun scroll-by (sb dy dx)
|
||||
(incf (scroll-box-scroll-y sb) dy) (incf (scroll-box-scroll-x sb) dx)
|
||||
(clamp-scroll sb) (mark-dirty sb))
|
||||
|
||||
(defun scroll-box-content-height (sb)
|
||||
(reduce #'+ (scroll-box-children sb)
|
||||
:key (lambda (c) (let ((ln (component-layout-node c))) (if ln (max 1 (layout-node-height ln)) 1)))
|
||||
:initial-value 0))
|
||||
|
||||
(defun scroll-box-content-width (sb)
|
||||
(reduce #'max (scroll-box-children sb)
|
||||
:key (lambda (c) (let ((ln (component-layout-node c))) (if ln (max 1 (layout-node-width ln)) 1)))
|
||||
:initial-value 0))
|
||||
|
||||
(defmethod render ((sb scroll-box) backend)
|
||||
"Render ScrollBox children within the viewport, offset by scroll position.
|
||||
Children outside the viewport are skipped."
|
||||
(let* ((ln (scroll-box-layout-node sb))
|
||||
(vx 0) (vy 0)
|
||||
(vw (if ln (layout-node-width ln) 80))
|
||||
(vh (if ln (layout-node-height ln) 24))
|
||||
(sy (scroll-box-scroll-y sb))
|
||||
(sx (scroll-box-scroll-x sb)))
|
||||
(dolist (child (scroll-box-children sb))
|
||||
(let* ((cln (component-layout-node child))
|
||||
(ch (if cln (layout-node-height cln) 1))
|
||||
(cy vy))
|
||||
;; Only render children that are visible in the viewport
|
||||
(when (and (< (- cy sy) vh)
|
||||
(> (+ (- cy sy) ch) 0))
|
||||
;; Temporarily offset child's layout-node position for rendering
|
||||
(let ((orig-x (if cln (layout-node-x cln) 0))
|
||||
(orig-y (if cln (layout-node-y cln) 0)))
|
||||
(when cln
|
||||
(setf (layout-node-x cln) (- vx sx)
|
||||
(layout-node-y cln) (- vy sy)))
|
||||
(unwind-protect
|
||||
(render child backend)
|
||||
(when cln
|
||||
(setf (layout-node-x cln) orig-x
|
||||
(layout-node-y cln) orig-y)))))
|
||||
(incf vy ch)))
|
||||
(draw-scrollbars sb backend vw vh)))
|
||||
|
||||
(defun scrollbar-thumb (scroll-pos viewport-size content-size)
|
||||
(if (> content-size viewport-size) (/ (float scroll-pos) (- content-size viewport-size)) 0.0))
|
||||
|
||||
(defun draw-scrollbars (sb backend viewport-w viewport-h)
|
||||
(let* ((content-h (scroll-box-content-height sb)) (content-w (scroll-box-content-width sb))
|
||||
(sy (scroll-box-scroll-y sb)) (sx (scroll-box-scroll-x sb))
|
||||
(ln (scroll-box-layout-node sb))
|
||||
(ox (if ln (layout-node-x ln) 0))
|
||||
(oy (if ln (layout-node-y ln) 0)))
|
||||
(when (> content-h viewport-h)
|
||||
(let* ((thumb (scrollbar-thumb sy viewport-h content-h))
|
||||
(thumb-pos (round (* thumb viewport-h))))
|
||||
(draw-rect backend (+ ox (1- viewport-w)) oy 1 viewport-h :bg :bright-black)
|
||||
(draw-text backend (+ ox (1- viewport-w)) (+ oy thumb-pos) "█" nil nil)))
|
||||
(when (> content-w viewport-w)
|
||||
(let* ((thumb (scrollbar-thumb sx viewport-w content-w))
|
||||
(thumb-pos (round (* thumb viewport-w))))
|
||||
(draw-rect backend ox (+ oy (1- viewport-h)) viewport-w 1 :bg :bright-black)
|
||||
(draw-text backend (+ ox thumb-pos) (+ oy (1- viewport-h)) "█" nil nil)))))
|
||||
|
||||
(defun update-sticky-scroll (sb)
|
||||
(when (sticky-scroll-p sb)
|
||||
(let* ((content-h (scroll-box-content-height sb))
|
||||
(ln (scroll-box-layout-node sb))
|
||||
(viewport-h (if ln (layout-node-height ln) 24)))
|
||||
(when (>= (scroll-box-scroll-y sb) (- content-h viewport-h 1))
|
||||
(setf (scroll-box-scroll-y sb) (max 0 (- content-h viewport-h)))))))
|
||||
|
||||
@@ -11,31 +11,3 @@
|
||||
#:select-handle-key
|
||||
#:render
|
||||
#:fuzzy-match-p))
|
||||
|
||||
(defpackage :cl-tty.select
|
||||
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input)
|
||||
(:export
|
||||
#:select #:make-select
|
||||
#:select-options #:select-filter
|
||||
#:select-selected-index #:select-on-select
|
||||
#:select-layout-node
|
||||
#:select-filtered-options
|
||||
#:select-next #:select-prev
|
||||
#:select-visible-options
|
||||
#:select-handle-key
|
||||
#:render
|
||||
#:fuzzy-match-p))
|
||||
|
||||
(defpackage :cl-tty.select
|
||||
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input)
|
||||
(:export
|
||||
#:select #:make-select
|
||||
#:select-options #:select-filter
|
||||
#:select-selected-index #:select-on-select
|
||||
#:select-layout-node
|
||||
#:select-filtered-options
|
||||
#:select-next #:select-prev
|
||||
#:select-visible-options
|
||||
#:select-handle-key
|
||||
#:render
|
||||
#:fuzzy-match-p))
|
||||
|
||||
@@ -94,197 +94,3 @@
|
||||
(t (draw-text backend x y display nil nil)))
|
||||
(incf y 1)))
|
||||
(values)))
|
||||
|
||||
(in-package #:cl-tty.select)
|
||||
|
||||
(defclass select (dirty-mixin)
|
||||
((options :initform nil :initarg :options :accessor select-options :type list)
|
||||
(filter :initform nil :initarg :filter :accessor select-filter :type (or string null))
|
||||
(selected-index :initform 0 :initarg :selected-index :accessor select-selected-index :type fixnum)
|
||||
(on-select :initform nil :initarg :on-select :accessor select-on-select)
|
||||
(layout-node :initform (make-layout-node) :initarg :layout-node :accessor select-layout-node)))
|
||||
|
||||
(defun make-select (&key options filter on-select)
|
||||
(make-instance 'select :options (or options nil) :filter filter :on-select on-select))
|
||||
|
||||
(defmethod component-layout-node ((sel select)) (select-layout-node sel))
|
||||
|
||||
(defun select-filtered-options (sel)
|
||||
(let* ((filter (select-filter sel)) (all-options (select-options sel))
|
||||
(filtered (if (null filter) all-options
|
||||
(let ((lower (string-downcase filter)))
|
||||
(remove-if-not
|
||||
(lambda (opt)
|
||||
(or (getf opt :category)
|
||||
(let ((title (string-downcase (getf opt :title))))
|
||||
(or (search lower title) (fuzzy-match-p lower title)))))
|
||||
all-options)))))
|
||||
(loop for opt in filtered for i from 0
|
||||
collect (list i (position opt all-options) opt))))
|
||||
|
||||
(defun fuzzy-match-p (query target)
|
||||
(let* ((q (remove-duplicates (coerce (string-downcase query) 'list)))
|
||||
(tg (remove-duplicates (coerce (string-downcase target) 'list)))
|
||||
(intersection (length (intersection q tg)))
|
||||
(union (length (union q tg))))
|
||||
(if (zerop union) nil (> (/ (float intersection) union) 0.3))))
|
||||
|
||||
(defun select-clamp-index (sel)
|
||||
(let* ((filtered (select-filtered-options sel)) (count (length filtered)))
|
||||
(if (zerop count) (setf (select-selected-index sel) 0)
|
||||
(setf (select-selected-index sel) (max 0 (min (select-selected-index sel) (1- count)))))))
|
||||
|
||||
(defun select-next (sel)
|
||||
(let* ((filtered (select-filtered-options sel)) (count (length filtered))
|
||||
(current (select-selected-index sel)))
|
||||
(when (plusp count)
|
||||
(loop for i from 1 below count
|
||||
for idx = (mod (+ current i) count)
|
||||
for opt = (third (nth idx filtered))
|
||||
when (not (getf opt :category))
|
||||
do (setf (select-selected-index sel) idx) (mark-dirty sel) (return)))))
|
||||
|
||||
(defun select-prev (sel)
|
||||
(let* ((filtered (select-filtered-options sel)) (count (length filtered))
|
||||
(current (select-selected-index sel)))
|
||||
(when (plusp count)
|
||||
(loop for i from 1 below count
|
||||
for idx = (mod (- current i) count)
|
||||
for opt = (third (nth idx filtered))
|
||||
when (not (getf opt :category))
|
||||
do (setf (select-selected-index sel) idx) (mark-dirty sel) (return)))))
|
||||
|
||||
(defun select-handle-key (sel event)
|
||||
(let ((key (key-event-key event)) (ctrl (key-event-ctrl event)))
|
||||
(cond
|
||||
((or (eql key :down) (and ctrl (eql key :n))) (select-next sel) t)
|
||||
((or (eql key :up) (and ctrl (eql key :p))) (select-prev sel) t)
|
||||
((eql key :enter)
|
||||
(let* ((filtered (select-filtered-options sel)) (idx (select-selected-index sel))
|
||||
(item (when (< idx (length filtered)) (third (nth idx filtered)))))
|
||||
(when item (let ((cb (select-on-select sel))) (when cb (funcall cb item)))) t))
|
||||
((eql key :escape) nil) (t nil))))
|
||||
|
||||
(defun select-visible-options (sel)
|
||||
(let* ((ln (select-layout-node sel)) (height (if ln (layout-node-height ln) 80))
|
||||
(filtered (select-filtered-options sel)) (sel-idx (select-selected-index sel))
|
||||
(half (floor (1- height) 2)) (start (max 0 (- sel-idx half)))
|
||||
(end (min (length filtered) (+ start height))))
|
||||
(subseq filtered start end)))
|
||||
|
||||
(defmethod render ((sel select) backend)
|
||||
(let* ((ln (select-layout-node sel))
|
||||
(x (if ln (layout-node-x ln) 0))
|
||||
(y (if ln (layout-node-y ln) 0))
|
||||
(w (if ln (layout-node-width ln) 80))
|
||||
(visible (select-visible-options sel)) (sel-idx (select-selected-index sel)))
|
||||
(dolist (item visible)
|
||||
(let* ((display-idx (first item)) (option (third item))
|
||||
(title (getf option :title)) (cat (getf option :category))
|
||||
(selected (eql display-idx sel-idx))
|
||||
(display (if (> (length title) (1- w))
|
||||
(concatenate 'string (subseq title 0 (1- w)) "…") title)))
|
||||
(cond (cat (draw-text backend x y display :text-muted nil))
|
||||
(selected
|
||||
(draw-rect backend x y w 1 :bg :accent)
|
||||
(draw-text backend x y display :background :accent))
|
||||
(t (draw-text backend x y display nil nil)))
|
||||
(incf y 1)))
|
||||
(values)))
|
||||
|
||||
(in-package #:cl-tty.select)
|
||||
|
||||
(defclass select (dirty-mixin)
|
||||
((options :initform nil :initarg :options :accessor select-options :type list)
|
||||
(filter :initform nil :initarg :filter :accessor select-filter :type (or string null))
|
||||
(selected-index :initform 0 :initarg :selected-index :accessor select-selected-index :type fixnum)
|
||||
(on-select :initform nil :initarg :on-select :accessor select-on-select)
|
||||
(layout-node :initform (make-layout-node) :initarg :layout-node :accessor select-layout-node)))
|
||||
|
||||
(defun make-select (&key options filter on-select)
|
||||
(make-instance 'select :options (or options nil) :filter filter :on-select on-select))
|
||||
|
||||
(defmethod component-layout-node ((sel select)) (select-layout-node sel))
|
||||
|
||||
(defun select-filtered-options (sel)
|
||||
(let* ((filter (select-filter sel)) (all-options (select-options sel))
|
||||
(filtered (if (null filter) all-options
|
||||
(let ((lower (string-downcase filter)))
|
||||
(remove-if-not
|
||||
(lambda (opt)
|
||||
(or (getf opt :category)
|
||||
(let ((title (string-downcase (getf opt :title))))
|
||||
(or (search lower title) (fuzzy-match-p lower title)))))
|
||||
all-options)))))
|
||||
(loop for opt in filtered for i from 0
|
||||
collect (list i (position opt all-options) opt))))
|
||||
|
||||
(defun fuzzy-match-p (query target)
|
||||
(let* ((q (remove-duplicates (coerce (string-downcase query) 'list)))
|
||||
(tg (remove-duplicates (coerce (string-downcase target) 'list)))
|
||||
(intersection (length (intersection q tg)))
|
||||
(union (length (union q tg))))
|
||||
(if (zerop union) nil (> (/ (float intersection) union) 0.3))))
|
||||
|
||||
(defun select-clamp-index (sel)
|
||||
(let* ((filtered (select-filtered-options sel)) (count (length filtered)))
|
||||
(if (zerop count) (setf (select-selected-index sel) 0)
|
||||
(setf (select-selected-index sel) (max 0 (min (select-selected-index sel) (1- count)))))))
|
||||
|
||||
(defun select-next (sel)
|
||||
(let* ((filtered (select-filtered-options sel)) (count (length filtered))
|
||||
(current (select-selected-index sel)))
|
||||
(when (plusp count)
|
||||
(loop for i from 1 below count
|
||||
for idx = (mod (+ current i) count)
|
||||
for opt = (third (nth idx filtered))
|
||||
when (not (getf opt :category))
|
||||
do (setf (select-selected-index sel) idx) (mark-dirty sel) (return)))))
|
||||
|
||||
(defun select-prev (sel)
|
||||
(let* ((filtered (select-filtered-options sel)) (count (length filtered))
|
||||
(current (select-selected-index sel)))
|
||||
(when (plusp count)
|
||||
(loop for i from 1 below count
|
||||
for idx = (mod (- current i) count)
|
||||
for opt = (third (nth idx filtered))
|
||||
when (not (getf opt :category))
|
||||
do (setf (select-selected-index sel) idx) (mark-dirty sel) (return)))))
|
||||
|
||||
(defun select-handle-key (sel event)
|
||||
(let ((key (key-event-key event)) (ctrl (key-event-ctrl event)))
|
||||
(cond
|
||||
((or (eql key :down) (and ctrl (eql key :n))) (select-next sel) t)
|
||||
((or (eql key :up) (and ctrl (eql key :p))) (select-prev sel) t)
|
||||
((eql key :enter)
|
||||
(let* ((filtered (select-filtered-options sel)) (idx (select-selected-index sel))
|
||||
(item (when (< idx (length filtered)) (third (nth idx filtered)))))
|
||||
(when item (let ((cb (select-on-select sel))) (when cb (funcall cb item)))) t))
|
||||
((eql key :escape) nil) (t nil))))
|
||||
|
||||
(defun select-visible-options (sel)
|
||||
(let* ((ln (select-layout-node sel)) (height (if ln (layout-node-height ln) 80))
|
||||
(filtered (select-filtered-options sel)) (sel-idx (select-selected-index sel))
|
||||
(half (floor (1- height) 2)) (start (max 0 (- sel-idx half)))
|
||||
(end (min (length filtered) (+ start height))))
|
||||
(subseq filtered start end)))
|
||||
|
||||
(defmethod render ((sel select) backend)
|
||||
(let* ((ln (select-layout-node sel))
|
||||
(x (if ln (layout-node-x ln) 0))
|
||||
(y (if ln (layout-node-y ln) 0))
|
||||
(w (if ln (layout-node-width ln) 80))
|
||||
(visible (select-visible-options sel)) (sel-idx (select-selected-index sel)))
|
||||
(dolist (item visible)
|
||||
(let* ((display-idx (first item)) (option (third item))
|
||||
(title (getf option :title)) (cat (getf option :category))
|
||||
(selected (eql display-idx sel-idx))
|
||||
(display (if (> (length title) (1- w))
|
||||
(concatenate 'string (subseq title 0 (1- w)) "…") title)))
|
||||
(cond (cat (draw-text backend x y display :text-muted nil))
|
||||
(selected
|
||||
(draw-rect backend x y w 1 :bg :accent)
|
||||
(draw-text backend x y display :background :accent))
|
||||
(t (draw-text backend x y display nil nil)))
|
||||
(incf y 1)))
|
||||
(values)))
|
||||
|
||||
@@ -7,23 +7,3 @@
|
||||
#:clear-slot
|
||||
#:list-slots
|
||||
#:*slots*))
|
||||
|
||||
(defpackage :cl-tty.slot
|
||||
(:use :cl)
|
||||
(:export
|
||||
#:defslot
|
||||
#:slot-render
|
||||
#:slot-p
|
||||
#:clear-slot
|
||||
#:list-slots
|
||||
#:*slots*))
|
||||
|
||||
(defpackage :cl-tty.slot
|
||||
(:use :cl)
|
||||
(:export
|
||||
#:defslot
|
||||
#:slot-render
|
||||
#:slot-p
|
||||
#:clear-slot
|
||||
#:list-slots
|
||||
#:*slots*))
|
||||
|
||||
@@ -28,65 +28,3 @@
|
||||
|
||||
(defun list-slots ()
|
||||
(loop for key being the hash-keys of *slots* collect key))
|
||||
|
||||
(in-package :cl-tty.slot)
|
||||
|
||||
(defvar *slots* (make-hash-table :test #'equal)
|
||||
"Hash table mapping slot name (string) -> list of (order . render-fn) pairs.")
|
||||
|
||||
(defun defslot (name &key (order 0) render-fn)
|
||||
(let* ((key (string name))
|
||||
(entries (gethash key *slots*)))
|
||||
(if (null entries)
|
||||
(setf (gethash key *slots*) (list (cons order render-fn)))
|
||||
(setf (gethash key *slots*)
|
||||
(sort (cons (cons order render-fn) entries) #'< :key #'car))))
|
||||
render-fn)
|
||||
|
||||
(defun slot-render (slot-name &rest args)
|
||||
(let ((entries (gethash (string slot-name) *slots*)))
|
||||
(when entries
|
||||
(mapcar (lambda (entry)
|
||||
(let ((fn (cdr entry)))
|
||||
(when fn (apply fn args))))
|
||||
entries))))
|
||||
|
||||
(defun slot-p (slot-name)
|
||||
(nth-value 1 (gethash (string slot-name) *slots*)))
|
||||
|
||||
(defun clear-slot (slot-name)
|
||||
(remhash (string slot-name) *slots*))
|
||||
|
||||
(defun list-slots ()
|
||||
(loop for key being the hash-keys of *slots* collect key))
|
||||
|
||||
(in-package :cl-tty.slot)
|
||||
|
||||
(defvar *slots* (make-hash-table :test #'equal)
|
||||
"Hash table mapping slot name (string) -> list of (order . render-fn) pairs.")
|
||||
|
||||
(defun defslot (name &key (order 0) render-fn)
|
||||
(let* ((key (string name))
|
||||
(entries (gethash key *slots*)))
|
||||
(if (null entries)
|
||||
(setf (gethash key *slots*) (list (cons order render-fn)))
|
||||
(setf (gethash key *slots*)
|
||||
(sort (cons (cons order render-fn) entries) #'< :key #'car))))
|
||||
render-fn)
|
||||
|
||||
(defun slot-render (slot-name &rest args)
|
||||
(let ((entries (gethash (string slot-name) *slots*)))
|
||||
(when entries
|
||||
(mapcar (lambda (entry)
|
||||
(let ((fn (cdr entry)))
|
||||
(when fn (apply fn args))))
|
||||
entries))))
|
||||
|
||||
(defun slot-p (slot-name)
|
||||
(nth-value 1 (gethash (string slot-name) *slots*)))
|
||||
|
||||
(defun clear-slot (slot-name)
|
||||
(remhash (string slot-name) *slots*))
|
||||
|
||||
(defun list-slots ()
|
||||
(loop for key being the hash-keys of *slots* collect key))
|
||||
|
||||
@@ -51,111 +51,3 @@
|
||||
(draw-text backend x-pos y label fg bg)
|
||||
(incf x-pos (+ label-len 2)))))
|
||||
(values))
|
||||
|
||||
(in-package #:cl-tty.container)
|
||||
|
||||
(defclass tab-bar (dirty-mixin)
|
||||
((tabs :initform nil :initarg :tabs :accessor tab-bar-tabs :type list)
|
||||
(active :initform nil :initarg :active :accessor tab-bar-active)
|
||||
(layout-node :initform (make-layout-node) :accessor tab-bar-layout-node)
|
||||
(focusable :initform t :accessor tab-bar-focusable)))
|
||||
|
||||
(defun make-tab-bar (&key tabs active)
|
||||
(make-instance 'tab-bar :tabs (or tabs nil) :active active))
|
||||
|
||||
(defun tab-bar-add (tb id title)
|
||||
(setf (tab-bar-tabs tb) (nconc (tab-bar-tabs tb) (list (list :id id :title title))))
|
||||
(unless (tab-bar-active tb) (setf (tab-bar-active tb) id)) id)
|
||||
|
||||
(defmethod component-layout-node ((tb tab-bar)) (tab-bar-layout-node tb))
|
||||
|
||||
(defun tab-bar-next (tb)
|
||||
(let* ((tabs (tab-bar-tabs tb)) (current (tab-bar-active tb))
|
||||
(ids (mapcar (lambda (tab) (getf tab :id)) tabs))
|
||||
(pos (position current ids)))
|
||||
(when pos (let ((next (nth (mod (1+ pos) (length ids)) ids)))
|
||||
(setf (tab-bar-active tb) next) (mark-dirty tb)))))
|
||||
|
||||
(defun tab-bar-prev (tb)
|
||||
(let* ((tabs (tab-bar-tabs tb)) (current (tab-bar-active tb))
|
||||
(ids (mapcar (lambda (tab) (getf tab :id)) tabs))
|
||||
(pos (position current ids)))
|
||||
(when pos (let ((prev (nth (mod (1- pos) (length ids)) ids)))
|
||||
(setf (tab-bar-active tb) prev) (mark-dirty tb)))))
|
||||
|
||||
(defun tab-bar-select (tb id) (setf (tab-bar-active tb) id) (mark-dirty tb))
|
||||
|
||||
(defun tab-bar-handle-key (tb event)
|
||||
(case (key-event-key event) (:left (tab-bar-prev tb) t) (:right (tab-bar-next tb) t) (t nil)))
|
||||
|
||||
(defmethod render ((tb tab-bar) backend)
|
||||
(let* ((ln (tab-bar-layout-node tb))
|
||||
(x (if ln (layout-node-x ln) 0))
|
||||
(y (if ln (layout-node-y ln) 0))
|
||||
(w (if ln (layout-node-width ln) 80))
|
||||
(active-id (tab-bar-active tb)) (tabs (tab-bar-tabs tb)) (x-pos x))
|
||||
(dolist (tab tabs)
|
||||
(let* ((id (getf tab :id)) (title (getf tab :title))
|
||||
(label (format nil " ~A " title)) (label-len (length label))
|
||||
(is-active (eql id active-id))
|
||||
(fg (if is-active :accent :text-muted))
|
||||
(bg (if is-active :background-element nil)))
|
||||
(when (>= (+ x-pos label-len 2) w)
|
||||
(draw-text backend x-pos y "..." :text-muted nil) (return))
|
||||
(draw-text backend x-pos y label fg bg)
|
||||
(incf x-pos (+ label-len 2)))))
|
||||
(values))
|
||||
|
||||
(in-package #:cl-tty.container)
|
||||
|
||||
(defclass tab-bar (dirty-mixin)
|
||||
((tabs :initform nil :initarg :tabs :accessor tab-bar-tabs :type list)
|
||||
(active :initform nil :initarg :active :accessor tab-bar-active)
|
||||
(layout-node :initform (make-layout-node) :accessor tab-bar-layout-node)
|
||||
(focusable :initform t :accessor tab-bar-focusable)))
|
||||
|
||||
(defun make-tab-bar (&key tabs active)
|
||||
(make-instance 'tab-bar :tabs (or tabs nil) :active active))
|
||||
|
||||
(defun tab-bar-add (tb id title)
|
||||
(setf (tab-bar-tabs tb) (nconc (tab-bar-tabs tb) (list (list :id id :title title))))
|
||||
(unless (tab-bar-active tb) (setf (tab-bar-active tb) id)) id)
|
||||
|
||||
(defmethod component-layout-node ((tb tab-bar)) (tab-bar-layout-node tb))
|
||||
|
||||
(defun tab-bar-next (tb)
|
||||
(let* ((tabs (tab-bar-tabs tb)) (current (tab-bar-active tb))
|
||||
(ids (mapcar (lambda (tab) (getf tab :id)) tabs))
|
||||
(pos (position current ids)))
|
||||
(when pos (let ((next (nth (mod (1+ pos) (length ids)) ids)))
|
||||
(setf (tab-bar-active tb) next) (mark-dirty tb)))))
|
||||
|
||||
(defun tab-bar-prev (tb)
|
||||
(let* ((tabs (tab-bar-tabs tb)) (current (tab-bar-active tb))
|
||||
(ids (mapcar (lambda (tab) (getf tab :id)) tabs))
|
||||
(pos (position current ids)))
|
||||
(when pos (let ((prev (nth (mod (1- pos) (length ids)) ids)))
|
||||
(setf (tab-bar-active tb) prev) (mark-dirty tb)))))
|
||||
|
||||
(defun tab-bar-select (tb id) (setf (tab-bar-active tb) id) (mark-dirty tb))
|
||||
|
||||
(defun tab-bar-handle-key (tb event)
|
||||
(case (key-event-key event) (:left (tab-bar-prev tb) t) (:right (tab-bar-next tb) t) (t nil)))
|
||||
|
||||
(defmethod render ((tb tab-bar) backend)
|
||||
(let* ((ln (tab-bar-layout-node tb))
|
||||
(x (if ln (layout-node-x ln) 0))
|
||||
(y (if ln (layout-node-y ln) 0))
|
||||
(w (if ln (layout-node-width ln) 80))
|
||||
(active-id (tab-bar-active tb)) (tabs (tab-bar-tabs tb)) (x-pos x))
|
||||
(dolist (tab tabs)
|
||||
(let* ((id (getf tab :id)) (title (getf tab :title))
|
||||
(label (format nil " ~A " title)) (label-len (length label))
|
||||
(is-active (eql id active-id))
|
||||
(fg (if is-active :accent :text-muted))
|
||||
(bg (if is-active :background-element nil)))
|
||||
(when (>= (+ x-pos label-len 2) w)
|
||||
(draw-text backend x-pos y "..." :text-muted nil) (return))
|
||||
(draw-text backend x-pos y label fg bg)
|
||||
(incf x-pos (+ label-len 2)))))
|
||||
(values))
|
||||
|
||||
@@ -183,524 +183,6 @@
|
||||
(textarea-ensure-cursor ta)
|
||||
(mark-dirty ta)))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Key event handler
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun handle-textarea-input (ta event)
|
||||
"Process a key-event on a textarea widget."
|
||||
(cond
|
||||
((key-event-ctrl event)
|
||||
(case (key-event-key event)
|
||||
(:z (textarea-undo ta))
|
||||
(:y (textarea-redo ta))
|
||||
;; Ctrl+A/E: home/end
|
||||
(:a (setf (textarea-cursor-col ta) 0))
|
||||
(:e (let ((lines (textarea-lines ta)))
|
||||
(when (< (textarea-cursor-row ta) (length lines))
|
||||
(setf (textarea-cursor-col ta)
|
||||
(length (nth (textarea-cursor-row ta) lines))))))
|
||||
(t nil)))
|
||||
(t
|
||||
(case (key-event-key event)
|
||||
(:left (decf (textarea-cursor-col ta))
|
||||
(textarea-ensure-cursor ta))
|
||||
(:right (incf (textarea-cursor-col ta))
|
||||
(textarea-ensure-cursor ta))
|
||||
(:up (textarea-move-up ta))
|
||||
(:down (textarea-move-down ta))
|
||||
(:home (setf (textarea-cursor-col ta) 0)
|
||||
(textarea-ensure-cursor ta))
|
||||
(:end (let ((lines (textarea-lines ta)))
|
||||
(when (< (textarea-cursor-row ta) (length lines))
|
||||
(setf (textarea-cursor-col ta)
|
||||
(length (nth (textarea-cursor-row ta) lines))))
|
||||
(textarea-ensure-cursor ta)))
|
||||
(:enter (let ((cb (textarea-on-submit ta)))
|
||||
(if cb
|
||||
(funcall cb (textarea-value ta))
|
||||
(textarea-newline ta))))
|
||||
(:backspace (textarea-backspace ta))
|
||||
(:delete (let* ((lines (textarea-lines ta))
|
||||
(row (textarea-cursor-row ta))
|
||||
(col (textarea-cursor-col ta))
|
||||
(line (nth row lines)))
|
||||
(when (and line (< col (length line)))
|
||||
(textarea-push-undo ta)
|
||||
(setf (nth row lines)
|
||||
(concatenate 'string
|
||||
(subseq line 0 col)
|
||||
(subseq line (1+ col))))
|
||||
(setf (textarea-value ta)
|
||||
(%join-lines lines))
|
||||
(mark-dirty ta))))
|
||||
;; Character insertion
|
||||
(otherwise
|
||||
(let ((ch (code-char (key-event-code event))))
|
||||
(when (and ch (graphic-char-p ch))
|
||||
(textarea-insert-char ta ch))))))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Rendering
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defmethod render ((ta textarea) (backend t))
|
||||
"Render textarea lines at layout position."
|
||||
(let* ((ln (textarea-layout-node ta))
|
||||
(x (if ln (layout-node-x ln) 0))
|
||||
(y (if ln (layout-node-y ln) 0))
|
||||
(w (if ln (layout-node-width ln) 80))
|
||||
(h (if ln (layout-node-height ln) 24))
|
||||
(lines (textarea-lines ta))
|
||||
(max-lines (min (length lines) h)))
|
||||
(loop for i from 0 below max-lines
|
||||
for line in lines
|
||||
do (draw-text backend x (+ y i)
|
||||
(subseq line 0 (min (length line) w))
|
||||
nil nil))))
|
||||
|
||||
(in-package #:cl-tty.input)
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Textarea class
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defclass textarea (dirty-mixin)
|
||||
((value :initform "" :initarg :value :accessor textarea-value :type string)
|
||||
(cursor-row :initform 0 :accessor textarea-cursor-row :type fixnum)
|
||||
(cursor-col :initform 0 :accessor textarea-cursor-col :type fixnum)
|
||||
(selection-start :initform nil :accessor textarea-selection-start)
|
||||
(undo-stack :initform (make-array 100 :fill-pointer 0)
|
||||
:accessor textarea-undo-stack)
|
||||
(redo-stack :initform (make-array 100 :fill-pointer 0)
|
||||
:accessor textarea-redo-stack)
|
||||
(on-submit :initform nil :initarg :on-submit :accessor textarea-on-submit)
|
||||
(layout-node :initform (make-layout-node) :accessor textarea-layout-node)
|
||||
(focusable :initform t :accessor textarea-focusable)))
|
||||
|
||||
(defun make-textarea (&key value on-submit)
|
||||
(make-instance 'textarea
|
||||
:value (or value "")
|
||||
:on-submit on-submit))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Line helpers
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun textarea-lines (ta)
|
||||
"Split value into lines."
|
||||
(%split-string (textarea-value ta) #\Newline))
|
||||
|
||||
(defun textarea-line-count (ta)
|
||||
"Number of lines in value."
|
||||
(length (textarea-lines ta)))
|
||||
|
||||
(defun textarea-ensure-cursor (ta)
|
||||
"Clamp cursor to valid range."
|
||||
(let ((lines (textarea-lines ta)))
|
||||
(setf (textarea-cursor-row ta)
|
||||
(max 0 (min (textarea-cursor-row ta) (1- (length lines)))))
|
||||
(let ((line-len (length (nth (textarea-cursor-row ta) lines))))
|
||||
(setf (textarea-cursor-col ta)
|
||||
(max 0 (min (textarea-cursor-col ta) line-len)))))
|
||||
(mark-dirty ta))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Utility: join strings with newline
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun %join-lines (lines)
|
||||
"Join a sequence of strings with newlines."
|
||||
(with-output-to-string (s)
|
||||
(loop for line across (if (listp lines) (coerce lines 'vector) lines)
|
||||
for first = t then nil
|
||||
do (unless first (write-char #\Newline s))
|
||||
(write-string line s))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Text manipulation
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun textarea-insert-char (ta char)
|
||||
"Insert CHAR at the cursor position."
|
||||
(textarea-push-undo ta)
|
||||
(let* ((lines (coerce (textarea-lines ta) 'vector))
|
||||
(row (textarea-cursor-row ta))
|
||||
(col (textarea-cursor-col ta)))
|
||||
(if (< row (length lines))
|
||||
(let* ((line (aref lines row))
|
||||
(new-line (concatenate 'string
|
||||
(subseq line 0 col)
|
||||
(string char)
|
||||
(subseq line col))))
|
||||
(setf (aref lines row) new-line)
|
||||
(setf (textarea-value ta)
|
||||
(%join-lines lines))
|
||||
(incf (textarea-cursor-col ta))
|
||||
(mark-dirty ta))
|
||||
(progn
|
||||
(setf (textarea-value ta)
|
||||
(concatenate 'string (textarea-value ta) (string char)))
|
||||
(incf (textarea-cursor-col ta))
|
||||
(mark-dirty ta)))))
|
||||
|
||||
(defun textarea-newline (ta)
|
||||
"Insert a newline at the cursor."
|
||||
(textarea-push-undo ta)
|
||||
(let* ((lines (coerce (textarea-lines ta) 'vector))
|
||||
(row (textarea-cursor-row ta))
|
||||
(col (textarea-cursor-col ta)))
|
||||
(if (< row (length lines))
|
||||
(let* ((line (aref lines row))
|
||||
(before (subseq line 0 col))
|
||||
(after (subseq line col)))
|
||||
(setf (aref lines row) before)
|
||||
(let ((new-lines (concatenate 'vector
|
||||
(subseq lines 0 (1+ row))
|
||||
(vector after)
|
||||
(subseq lines (1+ row)))))
|
||||
(setf (textarea-value ta)
|
||||
(%join-lines new-lines)))
|
||||
(incf (textarea-cursor-row ta))
|
||||
(setf (textarea-cursor-col ta) 0)
|
||||
(mark-dirty ta))
|
||||
(progn
|
||||
(setf (textarea-value ta)
|
||||
(concatenate 'string (textarea-value ta) (string #\Newline)))
|
||||
(incf (textarea-cursor-row ta))
|
||||
(setf (textarea-cursor-col ta) 0)
|
||||
(mark-dirty ta)))))
|
||||
|
||||
(defun textarea-backspace (ta)
|
||||
"Delete character before cursor."
|
||||
(textarea-push-undo ta)
|
||||
(let* ((lines (coerce (textarea-lines ta) 'vector))
|
||||
(row (textarea-cursor-row ta))
|
||||
(col (textarea-cursor-col ta)))
|
||||
(cond
|
||||
((and (zerop row) (zerop col))
|
||||
nil) ;; nothing to delete
|
||||
((zerop col)
|
||||
;; Join with previous line
|
||||
(let* ((prev (aref lines (1- row)))
|
||||
(curr (aref lines row))
|
||||
(new-pos (length prev)))
|
||||
(setf (aref lines (1- row))
|
||||
(concatenate 'string prev curr))
|
||||
(let ((new-lines (concatenate 'vector
|
||||
(subseq lines 0 row)
|
||||
(subseq lines (1+ row)))))
|
||||
(setf (textarea-value ta)
|
||||
(%join-lines new-lines)))
|
||||
(decf (textarea-cursor-row ta))
|
||||
(setf (textarea-cursor-col ta) new-pos)
|
||||
(mark-dirty ta)))
|
||||
(t
|
||||
(let* ((line (aref lines row))
|
||||
(new-line (concatenate 'string
|
||||
(subseq line 0 (1- col))
|
||||
(subseq line col))))
|
||||
(setf (aref lines row) new-line)
|
||||
(setf (textarea-value ta)
|
||||
(%join-lines lines))
|
||||
(decf (textarea-cursor-col ta))
|
||||
(mark-dirty ta))))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Cursor movement
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun textarea-move-up (ta)
|
||||
(decf (textarea-cursor-row ta))
|
||||
(textarea-ensure-cursor ta))
|
||||
|
||||
(defun textarea-move-down (ta)
|
||||
(incf (textarea-cursor-row ta))
|
||||
(textarea-ensure-cursor ta))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Undo/redo
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun textarea-push-undo (ta)
|
||||
"Save current value on undo stack."
|
||||
(let ((stack (textarea-undo-stack ta)))
|
||||
(when (>= (length stack) (array-total-size stack))
|
||||
(loop for i from 1 below (length stack)
|
||||
do (setf (aref stack (1- i)) (aref stack i)))
|
||||
(decf (fill-pointer stack)))
|
||||
(vector-push (textarea-value ta) stack)
|
||||
(setf (fill-pointer (textarea-redo-stack ta)) 0)))
|
||||
|
||||
(defun textarea-undo (ta)
|
||||
(let ((stack (textarea-undo-stack ta)))
|
||||
(when (plusp (length stack))
|
||||
(let ((prev (vector-pop stack)))
|
||||
(vector-push (textarea-value ta) (textarea-redo-stack ta))
|
||||
(setf (textarea-value ta) prev)
|
||||
(textarea-ensure-cursor ta)
|
||||
(mark-dirty ta)))))
|
||||
|
||||
(defun textarea-redo (ta)
|
||||
(let ((stack (textarea-redo-stack ta)))
|
||||
(when (plusp (length stack))
|
||||
(let ((next (vector-pop stack)))
|
||||
(vector-push (textarea-value ta) (textarea-undo-stack ta))
|
||||
(setf (textarea-value ta) next)
|
||||
(textarea-ensure-cursor ta)
|
||||
(mark-dirty ta)))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Key event handler
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun handle-textarea-input (ta event)
|
||||
"Process a key-event on a textarea widget."
|
||||
(cond
|
||||
((key-event-ctrl event)
|
||||
(case (key-event-key event)
|
||||
(:z (textarea-undo ta))
|
||||
(:y (textarea-redo ta))
|
||||
;; Ctrl+A/E: home/end
|
||||
(:a (setf (textarea-cursor-col ta) 0))
|
||||
(:e (let ((lines (textarea-lines ta)))
|
||||
(when (< (textarea-cursor-row ta) (length lines))
|
||||
(setf (textarea-cursor-col ta)
|
||||
(length (nth (textarea-cursor-row ta) lines))))))
|
||||
(t nil)))
|
||||
(t
|
||||
(case (key-event-key event)
|
||||
(:left (decf (textarea-cursor-col ta))
|
||||
(textarea-ensure-cursor ta))
|
||||
(:right (incf (textarea-cursor-col ta))
|
||||
(textarea-ensure-cursor ta))
|
||||
(:up (textarea-move-up ta))
|
||||
(:down (textarea-move-down ta))
|
||||
(:home (setf (textarea-cursor-col ta) 0)
|
||||
(textarea-ensure-cursor ta))
|
||||
(:end (let ((lines (textarea-lines ta)))
|
||||
(when (< (textarea-cursor-row ta) (length lines))
|
||||
(setf (textarea-cursor-col ta)
|
||||
(length (nth (textarea-cursor-row ta) lines))))
|
||||
(textarea-ensure-cursor ta)))
|
||||
(:enter (let ((cb (textarea-on-submit ta)))
|
||||
(if cb
|
||||
(funcall cb (textarea-value ta))
|
||||
(textarea-newline ta))))
|
||||
(:backspace (textarea-backspace ta))
|
||||
(:delete (let* ((lines (textarea-lines ta))
|
||||
(row (textarea-cursor-row ta))
|
||||
(col (textarea-cursor-col ta))
|
||||
(line (nth row lines)))
|
||||
(when (and line (< col (length line)))
|
||||
(textarea-push-undo ta)
|
||||
(setf (nth row lines)
|
||||
(concatenate 'string
|
||||
(subseq line 0 col)
|
||||
(subseq line (1+ col))))
|
||||
(setf (textarea-value ta)
|
||||
(%join-lines lines))
|
||||
(mark-dirty ta))))
|
||||
;; Character insertion
|
||||
(otherwise
|
||||
(let ((ch (code-char (key-event-code event))))
|
||||
(when (and ch (graphic-char-p ch))
|
||||
(textarea-insert-char ta ch))))))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Rendering
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defmethod render ((ta textarea) (backend t))
|
||||
"Render textarea lines at layout position."
|
||||
(let* ((ln (textarea-layout-node ta))
|
||||
(x (if ln (layout-node-x ln) 0))
|
||||
(y (if ln (layout-node-y ln) 0))
|
||||
(w (if ln (layout-node-width ln) 80))
|
||||
(h (if ln (layout-node-height ln) 24))
|
||||
(lines (textarea-lines ta))
|
||||
(max-lines (min (length lines) h)))
|
||||
(loop for i from 0 below max-lines
|
||||
for line in lines
|
||||
do (draw-text backend x (+ y i)
|
||||
(subseq line 0 (min (length line) w))
|
||||
nil nil))))
|
||||
|
||||
(in-package #:cl-tty.input)
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Textarea class
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defclass textarea (dirty-mixin)
|
||||
((value :initform "" :initarg :value :accessor textarea-value :type string)
|
||||
(cursor-row :initform 0 :accessor textarea-cursor-row :type fixnum)
|
||||
(cursor-col :initform 0 :accessor textarea-cursor-col :type fixnum)
|
||||
(selection-start :initform nil :accessor textarea-selection-start)
|
||||
(undo-stack :initform (make-array 100 :fill-pointer 0)
|
||||
:accessor textarea-undo-stack)
|
||||
(redo-stack :initform (make-array 100 :fill-pointer 0)
|
||||
:accessor textarea-redo-stack)
|
||||
(on-submit :initform nil :initarg :on-submit :accessor textarea-on-submit)
|
||||
(layout-node :initform (make-layout-node) :accessor textarea-layout-node)
|
||||
(focusable :initform t :accessor textarea-focusable)))
|
||||
|
||||
(defun make-textarea (&key value on-submit)
|
||||
(make-instance 'textarea
|
||||
:value (or value "")
|
||||
:on-submit on-submit))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Line helpers
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun textarea-lines (ta)
|
||||
"Split value into lines."
|
||||
(%split-string (textarea-value ta) #\Newline))
|
||||
|
||||
(defun textarea-line-count (ta)
|
||||
"Number of lines in value."
|
||||
(length (textarea-lines ta)))
|
||||
|
||||
(defun textarea-ensure-cursor (ta)
|
||||
"Clamp cursor to valid range."
|
||||
(let ((lines (textarea-lines ta)))
|
||||
(setf (textarea-cursor-row ta)
|
||||
(max 0 (min (textarea-cursor-row ta) (1- (length lines)))))
|
||||
(let ((line-len (length (nth (textarea-cursor-row ta) lines))))
|
||||
(setf (textarea-cursor-col ta)
|
||||
(max 0 (min (textarea-cursor-col ta) line-len)))))
|
||||
(mark-dirty ta))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Utility: join strings with newline
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun %join-lines (lines)
|
||||
"Join a sequence of strings with newlines."
|
||||
(with-output-to-string (s)
|
||||
(loop for line across (if (listp lines) (coerce lines 'vector) lines)
|
||||
for first = t then nil
|
||||
do (unless first (write-char #\Newline s))
|
||||
(write-string line s))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Text manipulation
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun textarea-insert-char (ta char)
|
||||
"Insert CHAR at the cursor position."
|
||||
(textarea-push-undo ta)
|
||||
(let* ((lines (coerce (textarea-lines ta) 'vector))
|
||||
(row (textarea-cursor-row ta))
|
||||
(col (textarea-cursor-col ta)))
|
||||
(if (< row (length lines))
|
||||
(let* ((line (aref lines row))
|
||||
(new-line (concatenate 'string
|
||||
(subseq line 0 col)
|
||||
(string char)
|
||||
(subseq line col))))
|
||||
(setf (aref lines row) new-line)
|
||||
(setf (textarea-value ta)
|
||||
(%join-lines lines))
|
||||
(incf (textarea-cursor-col ta))
|
||||
(mark-dirty ta))
|
||||
(progn
|
||||
(setf (textarea-value ta)
|
||||
(concatenate 'string (textarea-value ta) (string char)))
|
||||
(incf (textarea-cursor-col ta))
|
||||
(mark-dirty ta)))))
|
||||
|
||||
(defun textarea-newline (ta)
|
||||
"Insert a newline at the cursor."
|
||||
(textarea-push-undo ta)
|
||||
(let* ((lines (coerce (textarea-lines ta) 'vector))
|
||||
(row (textarea-cursor-row ta))
|
||||
(col (textarea-cursor-col ta)))
|
||||
(if (< row (length lines))
|
||||
(let* ((line (aref lines row))
|
||||
(before (subseq line 0 col))
|
||||
(after (subseq line col)))
|
||||
(setf (aref lines row) before)
|
||||
(let ((new-lines (concatenate 'vector
|
||||
(subseq lines 0 (1+ row))
|
||||
(vector after)
|
||||
(subseq lines (1+ row)))))
|
||||
(setf (textarea-value ta)
|
||||
(%join-lines new-lines)))
|
||||
(incf (textarea-cursor-row ta))
|
||||
(setf (textarea-cursor-col ta) 0)
|
||||
(mark-dirty ta))
|
||||
(progn
|
||||
(setf (textarea-value ta)
|
||||
(concatenate 'string (textarea-value ta) (string #\Newline)))
|
||||
(incf (textarea-cursor-row ta))
|
||||
(setf (textarea-cursor-col ta) 0)
|
||||
(mark-dirty ta)))))
|
||||
|
||||
(defun textarea-backspace (ta)
|
||||
"Delete character before cursor."
|
||||
(textarea-push-undo ta)
|
||||
(let* ((lines (coerce (textarea-lines ta) 'vector))
|
||||
(row (textarea-cursor-row ta))
|
||||
(col (textarea-cursor-col ta)))
|
||||
(cond
|
||||
((and (zerop row) (zerop col))
|
||||
nil) ;; nothing to delete
|
||||
((zerop col)
|
||||
;; Join with previous line
|
||||
(let* ((prev (aref lines (1- row)))
|
||||
(curr (aref lines row))
|
||||
(new-pos (length prev)))
|
||||
(setf (aref lines (1- row))
|
||||
(concatenate 'string prev curr))
|
||||
(let ((new-lines (concatenate 'vector
|
||||
(subseq lines 0 row)
|
||||
(subseq lines (1+ row)))))
|
||||
(setf (textarea-value ta)
|
||||
(%join-lines new-lines)))
|
||||
(decf (textarea-cursor-row ta))
|
||||
(setf (textarea-cursor-col ta) new-pos)
|
||||
(mark-dirty ta)))
|
||||
(t
|
||||
(let* ((line (aref lines row))
|
||||
(new-line (concatenate 'string
|
||||
(subseq line 0 (1- col))
|
||||
(subseq line col))))
|
||||
(setf (aref lines row) new-line)
|
||||
(setf (textarea-value ta)
|
||||
(%join-lines lines))
|
||||
(decf (textarea-cursor-col ta))
|
||||
(mark-dirty ta))))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Cursor movement
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun textarea-move-up (ta)
|
||||
(decf (textarea-cursor-row ta))
|
||||
(textarea-ensure-cursor ta))
|
||||
|
||||
(defun textarea-move-down (ta)
|
||||
(incf (textarea-cursor-row ta))
|
||||
(textarea-ensure-cursor ta))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Undo/redo
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun textarea-push-undo (ta)
|
||||
"Save current value on undo stack."
|
||||
(let ((stack (textarea-undo-stack ta)))
|
||||
(when (>= (length stack) (array-total-size stack))
|
||||
(loop for i from 1 below (length stack)
|
||||
do (setf (aref stack (1- i)) (aref stack i)))
|
||||
(decf (fill-pointer stack)))
|
||||
(vector-push (textarea-value ta) stack)
|
||||
(setf (fill-pointer (textarea-redo-stack ta)) 0)))
|
||||
|
||||
(defun textarea-undo (ta)
|
||||
(let ((stack (textarea-undo-stack ta)))
|
||||
(when (plusp (length stack))
|
||||
(let ((prev (vector-pop stack)))
|
||||
(vector-push (textarea-value ta) (textarea-redo-stack ta))
|
||||
(setf (textarea-value ta) prev)
|
||||
(textarea-ensure-cursor ta)
|
||||
(mark-dirty ta)))))
|
||||
|
||||
(defun textarea-redo (ta)
|
||||
(let ((stack (textarea-redo-stack ta)))
|
||||
(when (plusp (length stack))
|
||||
(let ((next (vector-pop stack)))
|
||||
(vector-push (textarea-value ta) (textarea-undo-stack ta))
|
||||
(setf (textarea-value ta) next)
|
||||
(textarea-ensure-cursor ta)
|
||||
(mark-dirty ta)))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Key event handler
|
||||
;;; ---------------------------------------------------------------------------
|
||||
|
||||
@@ -57,447 +57,6 @@
|
||||
|
||||
;;; ─── 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
|
||||
&key bold italic underline reverse dim blink
|
||||
(link-url nil link-url-p)
|
||||
&allow-other-keys)
|
||||
(declare (ignore reverse dim blink link-url-p))
|
||||
(loop for i from 0 below (length string)
|
||||
do (%set-cell fb (+ x i) y (char string i)
|
||||
:fg fg :bg bg
|
||||
:bold bold :italic italic :underline underline
|
||||
:link-url link-url)))
|
||||
|
||||
(defmethod draw-rect ((fb framebuffer-backend) x y w h &key bg)
|
||||
(dotimes (row h)
|
||||
(dotimes (col w)
|
||||
(%set-cell fb (+ x col) (+ y row) #\space :fg nil :bg bg))))
|
||||
|
||||
(defmethod draw-border ((fb framebuffer-backend) x y w h &key (style :single) title title-align fg bg)
|
||||
(declare (ignore title-align))
|
||||
(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)))))
|
||||
|
||||
(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
|
||||
&key bold italic underline reverse dim blink
|
||||
(link-url nil link-url-p)
|
||||
&allow-other-keys)
|
||||
(declare (ignore reverse dim blink link-url-p))
|
||||
(loop for i from 0 below (length string)
|
||||
do (%set-cell fb (+ x i) y (char string i)
|
||||
:fg fg :bg bg
|
||||
:bold bold :italic italic :underline underline
|
||||
:link-url link-url)))
|
||||
|
||||
(defmethod draw-rect ((fb framebuffer-backend) x y w h &key bg)
|
||||
(dotimes (row h)
|
||||
(dotimes (col w)
|
||||
(%set-cell fb (+ x col) (+ y row) #\space :fg nil :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)))))
|
||||
|
||||
(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))
|
||||
|
||||
Reference in New Issue
Block a user