811d51a4f2
Rename: cl-tty avoids naming collision with Quicklisp's cl-tui (naryl/cl-tui, a cl-charms-based ncurses library). Our project is pure escape-sequence CL. v0.9.0 adds: - Dialog base class: modal overlay with backdrop, centered panel, size variants (:small/:medium/:large), stack-based management - Dialog subclasses: alert, confirm, select-dialog, prompt-dialog - Toast notifications: transient, top-right corner, auto-dismiss, colored variants (info/success/warning/error) - 78 tests total, 100% passing ASDF: read-time package references (+fiveam:+) replaced with find-symbol so .asd loads without FiveAM pre-loaded
82 lines
3.9 KiB
Common Lisp
82 lines
3.9 KiB
Common Lisp
(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)
|
|
(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))
|
|
(when (and (< (+ cy (- sy)) (+ vh vy)) (> (+ cy (- sy) ch) vy))
|
|
(draw-text backend (- sx) (+ vy cy (- sy))
|
|
(format nil "child at ~D" vy) nil nil))
|
|
(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)))
|
|
(when (> content-h viewport-h)
|
|
(let* ((thumb (scrollbar-thumb sy viewport-h content-h))
|
|
(thumb-pos (round (* thumb viewport-h))))
|
|
(draw-rect backend (1- viewport-w) 0 1 viewport-h :bg :background-element)
|
|
(draw-text backend (1- viewport-w) 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 0 (1- viewport-h) viewport-w 1 :bg :background-element)
|
|
(draw-text backend thumb-pos (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)))))))
|