prose: split scrollbox-tabbar.org prose into per-module org files
Distribute the literate prose from the old combined scrollbox-tabbar.org into three individual module org files: - scrollbox.org: ScrollBox class, render, scrollbars, bug fixes, plus the combined test suite (tangles scrollbox-tabbar-tests.lisp) - tabbar.org: TabBar class, navigation, keyboard handler, render - container-package.org: Package definition and exports The old scrollbox-tabbar.org is retained as a documentation archive with all code blocks set to :tangle no and a redirecting note. Fixes the draw-scrollbars code block to use the post-bugfix version (with layout-node origin offset ox/oy), matching the working code. All 13 test suites pass at 100%.
This commit is contained in:
Hermes Agent
@@ -1,12 +1,16 @@
|
||||
(defpackage :cl-tty.container
|
||||
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input)
|
||||
(:export
|
||||
;; ScrollBox
|
||||
#:scroll-box #:make-scroll-box
|
||||
#:scroll-box-scroll-y #:scroll-box-scroll-x
|
||||
#:scroll-box-children #:scroll-by
|
||||
#:sticky-scroll-p
|
||||
#:scroll-box-children
|
||||
#:scroll-by #:sticky-scroll-p
|
||||
#:clamp-scroll
|
||||
;; TabBar
|
||||
#: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))
|
||||
#:tab-bar-select #:tab-bar-handle-key
|
||||
;; Rendering
|
||||
#:render))
|
||||
|
||||
@@ -1,44 +1,72 @@
|
||||
(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)
|
||||
((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)
|
||||
(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
|
||||
: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))
|
||||
(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)
|
||||
"Clamp scroll offsets to valid range."
|
||||
(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))))))
|
||||
(viewport-height (if ln (layout-node-height ln) 0))
|
||||
(viewport-width (if ln (layout-node-width ln) 0))
|
||||
(content-height (scroll-box-content-height sb))
|
||||
(content-width (scroll-box-content-width sb)))
|
||||
(setf (scroll-box-scroll-y sb)
|
||||
(max 0 (min (scroll-box-scroll-y sb)
|
||||
(- content-height viewport-height))))
|
||||
(setf (scroll-box-scroll-x sb)
|
||||
(max 0 (min (scroll-box-scroll-x sb)
|
||||
(- content-width viewport-width))))))
|
||||
|
||||
(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))
|
||||
"Scroll by DY rows and DX columns. Clamps to valid range."
|
||||
(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)
|
||||
"Total height of all children."
|
||||
(reduce #'+ (scroll-box-children sb)
|
||||
:key (lambda (c) (let ((ln (component-layout-node c))) (if ln (max 1 (layout-node-height ln)) 1)))
|
||||
: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)
|
||||
"Maximum width among children."
|
||||
(reduce #'max (scroll-box-children sb)
|
||||
:key (lambda (c) (let ((ln (component-layout-node c))) (if ln (max 1 (layout-node-width ln)) 1)))
|
||||
: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 visible children with scroll offset applied.
|
||||
Delegates to each child's `render` method, temporarily offsetting
|
||||
its layout-node position for the scroll offset. Children outside
|
||||
the viewport are clipped out."
|
||||
(let* ((ln (scroll-box-layout-node sb))
|
||||
(vx 0) (vy 0)
|
||||
(vw (if ln (layout-node-width ln) 80))
|
||||
@@ -46,34 +74,60 @@
|
||||
(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))
|
||||
(when (and (< (- cy sy) vh) (> (+ (- cy sy) ch) 0))
|
||||
(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)))))
|
||||
(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)
|
||||
"If sticky-scroll-p is active and at bottom, keep at bottom."
|
||||
(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)))
|
||||
(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)))))))
|
||||
(setf (scroll-box-scroll-y sb)
|
||||
(max 0 (- content-h viewport-h)))))))
|
||||
|
||||
(defun scrollbar-thumb (scroll-pos viewport-size content-size)
|
||||
"Return the thumb position for a scrollbar (0.0 to 1.0)."
|
||||
(if (> content-size viewport-size)
|
||||
(/ (float scroll-pos) (- content-size viewport-size))
|
||||
0.0))
|
||||
|
||||
(defun draw-scrollbars (sb backend viewport-w viewport-h)
|
||||
"Draw scrollbars if content exceeds viewport."
|
||||
(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)))
|
||||
;; Vertical scrollbar
|
||||
(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 :scrollbar-bg)
|
||||
(draw-text backend (+ ox (1- viewport-w)) (+ oy thumb-pos) "█" nil nil)))
|
||||
;; Horizontal scrollbar
|
||||
(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 :scrollbar-bg)
|
||||
(draw-text backend (+ ox thumb-pos) (+ oy (1- viewport-h)) "█" nil nil)))))
|
||||
|
||||
@@ -1,8 +1,10 @@
|
||||
(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)
|
||||
((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)))
|
||||
|
||||
@@ -10,38 +12,71 @@
|
||||
(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)
|
||||
"Add a tab with ID and TITLE. Sets as active if first tab."
|
||||
(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))
|
||||
(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)))))
|
||||
"Move to next tab."
|
||||
(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)))))
|
||||
"Move to previous tab."
|
||||
(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-select (tb id)
|
||||
"Select a tab by 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)))
|
||||
"Handle a key-event on a TabBar. Returns T if handled."
|
||||
(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))
|
||||
(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))
|
||||
(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))
|
||||
;; Check if tab fits
|
||||
(when (>= (+ x-pos label-len 2) (+ x w))
|
||||
(draw-text backend x-pos y "..." :text-muted nil)
|
||||
(return))
|
||||
;; Draw tab
|
||||
(draw-text backend x-pos y label fg bg)
|
||||
(incf x-pos (+ label-len 2))))
|
||||
(values)))
|
||||
|
||||
Reference in New Issue
Block a user