literate: restructure all 19 org files with per-function blocks and prose
Every function, defclass, defstruct, defgeneric, defmethod, defmacro, defvar, and defparameter in every org file now has its own #+BEGIN_SRC block with literate prose above it explaining the design reasoning. Block counts before → after: package.org: 1 → 7 container-package.org: 1 → 1 (prose expanded) dirty.org: 4 → 6 render.org: 10 → 25 theme.org: 6 → 19 box-renderable.org: 9 → 29 scrollbox.org: 8 → 26 tabbar.org: 5 → 10 backend-protocol.org: 8 → 66 modern-backend.org: 17 → 53 detection.org: 4 → 6 layout-engine.org: 9 → 36 framebuffer.org: 8 → 37 markdown-renderer.org:13 → 38 dialog.org: 17 → 23 (merged dual structure) mouse.org: 4 → 25 select.org: 12 → 30 slot.org: 4 → 12 text-input.org: 11 → 53 Total: ~153 blocks → ~502 blocks Bugs fixed during restructuring: - render.org: stray π character typo (backenπd → backend) - modern-backend.org: sgr-attr missing closing paren + #+END_SRC - detection.org: invalid #\Esc character reference - select.org: extra closing paren in select-visible-options All 13 test suites pass at 100%.
This commit is contained in:
Hermes Agent
375
org/select.org
375
org/select.org
@@ -40,20 +40,39 @@ fallback, and category grouping with dimmed headers.
|
||||
|
||||
** Tests
|
||||
|
||||
*** Test package and suite setup
|
||||
|
||||
The test file uses FiveAM. The ~defpackage~ pulls in all the dependencies needed
|
||||
by the select widget tests — FiveAM itself, the backend/box/layout/input infrastructure,
|
||||
and the ~cl-tty.select~ package under test. ~run-tests~ is the entry point for
|
||||
CI and interactive use.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
|
||||
(defpackage :cl-tty-select-test
|
||||
(:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.select)
|
||||
(:export #:run-tests))
|
||||
(in-package #:cl-tty-select-test)
|
||||
#+END_SRC
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
|
||||
(def-suite select-suite :description "Select widget tests")
|
||||
(in-suite select-suite)
|
||||
#+END_SRC
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
|
||||
(defun run-tests ()
|
||||
(let ((result (run 'select-suite)))
|
||||
(fiveam:explain! result)
|
||||
(uiop:quit 0)))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-creates
|
||||
|
||||
Verifies that a select widget can be constructed with default values. The
|
||||
~selected-index~ should start at 0, and both ~options~ and ~filter~ should
|
||||
be nil. This establishes the baseline contract for the default constructor.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
|
||||
(test select-creates
|
||||
"A Select can be created with defaults."
|
||||
(let ((sel (make-select)))
|
||||
@@ -61,13 +80,29 @@ fallback, and category grouping with dimmed headers.
|
||||
(is-false (select-options sel))
|
||||
(is-false (select-filter sel))
|
||||
(is (= (select-selected-index sel) 0))))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-with-options
|
||||
|
||||
Ensures that passing ~:options~ to ~make-select~ stores them correctly. The
|
||||
length check is the simplest invariant — two options in, two options out.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
|
||||
(test select-with-options
|
||||
"A Select stores options."
|
||||
(let ((sel (make-select :options '((:title "Red" :value :red)
|
||||
(:title "Blue" :value :blue)))))
|
||||
(is (= (length (select-options sel)) 2))))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-filtered-exact
|
||||
|
||||
Tests case-insensitive substring filtering: setting filter to ~\"bl\"~ should
|
||||
match \"Blue\" but not \"Red\" or \"Green\". The return value is an alist of
|
||||
~(display-index original-index option)~, so we dig into the third element
|
||||
to check the ~:value~.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
|
||||
(test select-filtered-exact
|
||||
"Filter returns case-insensitive substring matches."
|
||||
(let ((sel (make-select
|
||||
@@ -78,7 +113,15 @@ fallback, and category grouping with dimmed headers.
|
||||
(let ((filtered (select-filtered-options sel)))
|
||||
(is (= (length filtered) 1))
|
||||
(is (eql (getf (third (first filtered)) :value) :blue)))))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-filtered-all
|
||||
|
||||
When the filter is nil ~select-filtered-options~ must return every option
|
||||
unchanged. This is the unfiltered/identity case and the most common state
|
||||
when the user hasn't typed anything.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
|
||||
(test select-filtered-all
|
||||
"Nil filter returns all options."
|
||||
(let ((sel (make-select
|
||||
@@ -86,7 +129,15 @@ fallback, and category grouping with dimmed headers.
|
||||
(:title "Blue" :value :blue)))))
|
||||
(let ((filtered (select-filtered-options sel)))
|
||||
(is (= (length filtered) 2)))))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-navigation
|
||||
|
||||
Exercises ~select-next~ and ~select-prev~ through a three-item list,
|
||||
confirming that forward and backward movement works and that both directions
|
||||
wrap around at list boundaries.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
|
||||
(test select-navigation
|
||||
"Select-next and select-prev navigate through options."
|
||||
(let ((sel (make-select
|
||||
@@ -102,7 +153,16 @@ fallback, and category grouping with dimmed headers.
|
||||
(is (= (select-selected-index sel) 0) "wraps forward")
|
||||
(select-prev sel)
|
||||
(is (= (select-selected-index sel) 2) "wraps backward")))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-navigation-skips-categories
|
||||
|
||||
Category headers (options with ~:category t~) should be invisible to
|
||||
navigation — ~select-next~ and ~select-prev~ skip over them. This test
|
||||
sets up a list with two category headers interleaved and verifies they
|
||||
are transparent to movement.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
|
||||
(test select-navigation-skips-categories
|
||||
"Navigation skips category header options."
|
||||
(let ((sel (make-select
|
||||
@@ -118,7 +178,15 @@ fallback, and category grouping with dimmed headers.
|
||||
(is (= (select-selected-index sel) 2))
|
||||
(select-next sel)
|
||||
(is (= (select-selected-index sel) 4) "skipped category header at 3")))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-handle-key
|
||||
|
||||
Validates that ~select-handle-key~ dispatches correctly: Down moves forward,
|
||||
Up moves backward, and Enter invokes the ~on-select~ callback with the
|
||||
currently highlighted option's plist.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
|
||||
(test select-handle-key
|
||||
"Select handle-key dispatches navigation and selection."
|
||||
(let* ((result (list nil))
|
||||
@@ -131,7 +199,15 @@ fallback, and category grouping with dimmed headers.
|
||||
(is (= (select-selected-index sel) 0))
|
||||
(select-handle-key sel (make-key-event :key :enter))
|
||||
(is (eql (car result) :a))))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-handle-key-ctrl
|
||||
|
||||
Ctrl+N and Ctrl+P are Emacs-compatible alternatives to Down/Up. They must
|
||||
produce identical navigation behavior. This test confirms the control-key
|
||||
dispatch paths.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
|
||||
(test select-handle-key-ctrl
|
||||
"Ctrl+N and Ctrl+P navigate like down/up."
|
||||
(let ((sel (make-select
|
||||
@@ -140,7 +216,15 @@ fallback, and category grouping with dimmed headers.
|
||||
(is (= (select-selected-index sel) 1))
|
||||
(select-handle-key sel (make-key-event :key :p :ctrl t))
|
||||
(is (= (select-selected-index sel) 0))))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-visible-count
|
||||
|
||||
~select-visible-options~ should never return more items than the viewport
|
||||
height. This test creates 20 options, sets the layout height to 5, and
|
||||
asserts the visible subset fits within that constraint.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
|
||||
(test select-visible-count
|
||||
"Visible options respects viewport height."
|
||||
(let* ((ln (make-layout-node))
|
||||
@@ -150,7 +234,15 @@ fallback, and category grouping with dimmed headers.
|
||||
(setf (layout-node-height ln) 5)
|
||||
(let ((visible (select-visible-options sel)))
|
||||
(is (<= (length visible) 5)))))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-fuzzy-fallback
|
||||
|
||||
When exact substring matching fails, the filter falls back to character-set
|
||||
Jaccard similarity. ~\"nrd\"~ should match ~\"Nord\"~ because the character
|
||||
overlap (n, o, r, d → 3 of 4) exceeds the 0.3 threshold.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
|
||||
(test select-fuzzy-fallback
|
||||
"Fuzzy filter catches near-misses."
|
||||
(let ((sel (make-select
|
||||
@@ -167,7 +259,13 @@ fallback, and category grouping with dimmed headers.
|
||||
|
||||
** Package
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
The ~cl-tty.select~ package depends on the backend, box model, layout,
|
||||
and input subsystems. The exported symbols cover the public API: the
|
||||
~select~ class, constructor, accessors, filtering, navigation, key
|
||||
handling, rendering, and the fuzzy matching predicate (exposed for
|
||||
testing and extensibility).
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../src/components/select-package.lisp
|
||||
(defpackage :cl-tty.select
|
||||
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input)
|
||||
(:export
|
||||
@@ -185,12 +283,16 @@ fallback, and category grouping with dimmed headers.
|
||||
|
||||
** Select class
|
||||
|
||||
~select~ inherits from ~dirty-mixin~. Options are stored as a list of
|
||||
plists. ~selected-index~ tracks the currently highlighted option.
|
||||
~filter~ is a string (or nil for unfiltered). ~on-select~ is a callback
|
||||
receiving the selected option plist.
|
||||
*** defclass select
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
~select~ inherits from ~dirty-mixin~ so the rendering layer knows when
|
||||
the widget state has changed (after navigation, filter updates, etc.).
|
||||
Options are stored as a list of plists. ~selected-index~ tracks the
|
||||
currently highlighted option. ~filter~ is a string (or nil for
|
||||
unfiltered). ~on-select~ is a callback receiving the selected option
|
||||
plist. ~layout-node~ positions the widget in the window.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
|
||||
(in-package #:cl-tty.select)
|
||||
|
||||
(defclass select (dirty-mixin)
|
||||
@@ -204,7 +306,15 @@ receiving the selected option plist.
|
||||
:accessor select-on-select)
|
||||
(layout-node :initform (make-layout-node) :initarg :layout-node
|
||||
:accessor select-layout-node)))
|
||||
#+END_SRC
|
||||
|
||||
*** defun make-select
|
||||
|
||||
A convenience constructor that wraps ~make-instance~ with keyword
|
||||
arguments. Defaults to nil for all optional parameters, matching the
|
||||
~defclass~ initforms.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
|
||||
(defun make-select (&key options filter on-select)
|
||||
(make-instance 'select
|
||||
:options (or options nil)
|
||||
@@ -214,16 +324,21 @@ receiving the selected option plist.
|
||||
|
||||
** Component protocol
|
||||
|
||||
~component-layout-node~ returns the layout node so the layout engine
|
||||
can position the select widget.
|
||||
*** defmethod component-layout-node
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
The layout engine needs a uniform way to access a component's position.
|
||||
~component-layout-node~ is part of the component protocol; this method
|
||||
for ~select~ simply delegates to the ~select-layout-node~ accessor.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
|
||||
(defmethod component-layout-node ((sel select))
|
||||
(select-layout-node sel))
|
||||
#+END_SRC
|
||||
|
||||
** Option filtering: substring match
|
||||
|
||||
*** defun select-filtered-options
|
||||
|
||||
~select-filtered-options~ returns options whose ~:title~ contains the
|
||||
filter string (case-insensitive). When ~filter~ is nil, returns all
|
||||
options. Category headers are NOT filtered out — they remain in the
|
||||
@@ -232,7 +347,12 @@ list so the user can see category context.
|
||||
The function returns an alist of ~(filtered-index original-index option)~
|
||||
to preserve the original index for selection tracking.
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
Internally, the filter first checks for exact substring containment via
|
||||
~search~. If no option matches that way, it falls through to the
|
||||
character-set ~fuzzy-match-p~ predicate. Category headers short-circuit
|
||||
so they always pass through the filter.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
|
||||
(defun select-filtered-options (sel)
|
||||
"Return list of options matching the current filter, in display order.
|
||||
Each item: (display-index original-index option-plist)."
|
||||
@@ -243,27 +363,29 @@ to preserve the original index for selection tracking.
|
||||
(let ((lower (string-downcase filter)))
|
||||
(remove-if-not
|
||||
(lambda (opt)
|
||||
(when (getf opt :category)
|
||||
(return-from select-filtered-options all-options))
|
||||
(let ((title (string-downcase (getf opt :title))))
|
||||
(or (search lower title)
|
||||
(fuzzy-match-p lower title))))
|
||||
(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))))
|
||||
#+END_SRC
|
||||
|
||||
** Fuzzy matching: trigram Jaccard similarity
|
||||
** Fuzzy matching: character-set Jaccard similarity
|
||||
|
||||
~trigram-score~ converts a string into a set of 3-character sliding
|
||||
window n-grams. ~fuzzy-match-p~ returns T if the Jaccard similarity
|
||||
between the query trigrams and the target trigrams exceeds 0.3.
|
||||
*** defun string-trigrams
|
||||
|
||||
Trigrams capture character-level similarity without requiring exact
|
||||
substring matches. "nrd" matches "Nord" because both contain ~nor~,
|
||||
~ord~ and ~nrd~ contributes ~nrd~ — the overlap is enough to exceed
|
||||
the threshold.
|
||||
Converts a string into a set of 3-character sliding window n-grams.
|
||||
Short strings (fewer than 3 characters) return the whole string as a
|
||||
single trigram. Duplicates are removed so the set can be used for
|
||||
Jaccard intersection/union calculations.
|
||||
|
||||
Note: the running tangle does not call this function directly — the
|
||||
simpler character-set ~fuzzy-match-p~ is used instead. Trigram
|
||||
matching is retained here as a documented alternative for future
|
||||
experimentation.
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
(defun string-trigrams (str)
|
||||
@@ -275,7 +397,17 @@ the threshold.
|
||||
(loop for i from 0 to (- (length s) 3)
|
||||
do (push (subseq s i (+ i 3)) result))
|
||||
(delete-duplicates result :test #'string=)))
|
||||
#+END_SRC
|
||||
|
||||
*** defun trigram-score
|
||||
|
||||
Jaccard similarity of two trigram sets: the size of the intersection
|
||||
divided by the size of the union. A score of 1.0 means identical sets;
|
||||
0.0 means no overlap. This is used by ~fuzzy-match-p~ if trigram mode
|
||||
is enabled (currently unused in the default filter path — see
|
||||
~string-trigrams~).
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
(defun trigram-score (query target)
|
||||
"Jaccard similarity of trigram sets: |intersection| / |union|."
|
||||
(let* ((q-trigrams (string-trigrams query))
|
||||
@@ -283,7 +415,16 @@ the threshold.
|
||||
(intersection (length (intersection q-trigrams t-trigrams :test #'string=)))
|
||||
(union (length (union q-trigrams t-trigrams :test #'string=))))
|
||||
(if (zerop union) 0.0 (/ (float intersection) union))))
|
||||
#+END_SRC
|
||||
|
||||
*** defun fuzzy-match-p
|
||||
|
||||
Returns T if the Jaccard similarity between the character sets of the
|
||||
query and target exceeds 0.3. The character-set approach is simpler
|
||||
and cheaper than trigrams while still catching common typos and
|
||||
near-misses like ~\"nrd\"~ for ~\"Nord\"~.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
|
||||
(defun fuzzy-match-p (query target)
|
||||
"T if character-set Jaccard similarity exceeds threshold (0.3)."
|
||||
(let* ((q-chars (remove-duplicates (coerce (string-downcase query) 'list)))
|
||||
@@ -295,12 +436,14 @@ the threshold.
|
||||
|
||||
** Navigation
|
||||
|
||||
~select-next~ and ~select-prev~ move the selection forward/backward
|
||||
through the filtered options list. They skip category headers (options
|
||||
with ~:category t~). The selection wraps at list boundaries.
|
||||
~select-clamp-index~ ensures the index is valid after filtering changes.
|
||||
*** defun select-clamp-index
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
After the filter changes (user types or clears input), the selected
|
||||
index may point beyond the filtered list. ~select-clamp-index~ ensures
|
||||
the index stays within valid bounds. If the list is empty the index
|
||||
resets to 0.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
|
||||
(defun select-clamp-index (sel)
|
||||
"Ensure selected-index is valid. Wraps if empty."
|
||||
(let* ((filtered (select-filtered-options sel))
|
||||
@@ -309,7 +452,16 @@ with ~:category t~). The selection wraps at list boundaries.
|
||||
(setf (select-selected-index sel) 0)
|
||||
(setf (select-selected-index sel)
|
||||
(max 0 (min (select-selected-index sel) (1- count)))))))
|
||||
#+END_SRC
|
||||
|
||||
*** defun select-next
|
||||
|
||||
Moves the selection forward to the next non-category option. Iterates
|
||||
through the filtered list starting from the current index, wrapping
|
||||
around at the end. Each candidate is checked for ~:category t~ and
|
||||
skipped. Marks the widget dirty so the render pass picks up the change.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
|
||||
(defun select-next (sel)
|
||||
"Move selection to next non-category option. Wraps at end."
|
||||
(let* ((filtered (select-filtered-options sel))
|
||||
@@ -323,7 +475,15 @@ with ~:category t~). The selection wraps at list boundaries.
|
||||
do (setf (select-selected-index sel) idx)
|
||||
(mark-dirty sel)
|
||||
(return)))))
|
||||
#+END_SRC
|
||||
|
||||
*** defun select-prev
|
||||
|
||||
Moves the selection backward to the previous non-category option.
|
||||
Mirrors ~select-next~ but decrements the index (with modular arithmetic
|
||||
for wrap-around). Category headers are skipped identically.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
|
||||
(defun select-prev (sel)
|
||||
"Move selection to previous non-category option. Wraps at start."
|
||||
(let* ((filtered (select-filtered-options sel))
|
||||
@@ -341,15 +501,18 @@ with ~:category t~). The selection wraps at list boundaries.
|
||||
|
||||
** Key event handler
|
||||
|
||||
~select-handle-key~ dispatches keyboard events:
|
||||
- Down, Ctrl+N → select-next
|
||||
- Up, Ctrl+P → select-prev
|
||||
- Enter → on-select callback with the selected option
|
||||
- Esc → return NIL (caller can dismiss)
|
||||
*** defun select-handle-key
|
||||
|
||||
Returns T if the key was handled, NIL otherwise.
|
||||
Dispatches keyboard events:
|
||||
- Down, Ctrl+N → ~select-next~
|
||||
- Up, Ctrl+P → ~select-prev~
|
||||
- Enter → ~on-select~ callback with the selected option
|
||||
- Esc → return NIL (caller can dismiss the widget)
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
Returns T if the key was handled (consumed), NIL otherwise so the
|
||||
caller knows not to propagate the event further.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
|
||||
(defun select-handle-key (sel event)
|
||||
"Handle a key-event. Returns T if handled."
|
||||
(let ((key (key-event-key event))
|
||||
@@ -374,11 +537,15 @@ Returns T if the key was handled, NIL otherwise.
|
||||
|
||||
** Visible options (viewport culling)
|
||||
|
||||
~select-visible-options~ returns only the filtered options that fit
|
||||
within the widget's available height. Each option occupies 1 row.
|
||||
This prevents rendering hundreds of items when the viewport shows 10.
|
||||
*** defun select-visible-options
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
Returns only the filtered options that fit within the widget's
|
||||
available height. Each option occupies 1 row. This prevents rendering
|
||||
hundreds of items when the viewport shows only 10. The window is
|
||||
centered around the currently selected index so the user always sees
|
||||
context around their cursor.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
|
||||
(defun select-visible-options (sel)
|
||||
"Return filtered options that fit within the viewport."
|
||||
(let* ((ln (select-layout-node sel))
|
||||
@@ -394,12 +561,15 @@ This prevents rendering hundreds of items when the viewport shows 10.
|
||||
|
||||
** Rendering
|
||||
|
||||
~render~ draws each visible option on its own line. The selected
|
||||
option is highlighted with ~:accent~ foreground and ~:background-element~
|
||||
background. Category headers are rendered dimmed (~:text-muted~) and
|
||||
not selectable (visually distinct).
|
||||
*** defmethod render
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
Draws each visible option on its own line. The selected option is
|
||||
highlighted with ~:accent~ foreground and ~:background-element~
|
||||
background. Category headers are rendered dimmed (~:text-muted~) and
|
||||
visually distinct from selectable items. Long titles are truncated with
|
||||
an ellipsis character to fit the viewport width.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
|
||||
(defmethod render ((sel select) backend)
|
||||
(let* ((ln (select-layout-node sel))
|
||||
(x (if ln (layout-node-x ln) 0))
|
||||
@@ -427,120 +597,3 @@ not selectable (visually distinct).
|
||||
(incf y 1)))
|
||||
(values)))
|
||||
#+END_SRC
|
||||
|
||||
** Combined tangle block
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
|
||||
(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)))
|
||||
#+END_SRC
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../src/components/select-package.lisp
|
||||
(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))
|
||||
#+END_SRC
|
||||
|
||||
Reference in New Issue
Block a user