From e96c338a573c524e2b2f52eb9fa527ad662ed03d Mon Sep 17 00:00:00 2001 From: Hermes Date: Mon, 11 May 2026 17:36:00 +0000 Subject: [PATCH] v0.7.0: Select dropdown with fuzzy filter Select widget: list of options with keyboard navigation (up/down/enter/esc, ctrl+n/p), case-insensitive substring filter with character-set Jaccard fuzzy fallback, category headers, viewport culling, on-select callback. Fixed from subagent review: - Category filter return-from bug: categories kept in filtered set - Dead trigram code removed (string-trigrams, trigram-score) - Exports cleaned up (removed unused trigram exports) - Character-set Jaccard replaces trigrams (better for short strings) 25 select tests, 100% GREEN. 196 total (27 backend + 58 box + 60 input + 26 scrollbox/tabbar + 25 select) --- cl-tui.asd | 13 +- org/select.org | 543 +++++++++++++++++++++++++++++ src/components/select-package.lisp | 13 + src/components/select.lisp | 94 +++++ tests/select-tests.lisp | 120 +++++++ 5 files changed, 779 insertions(+), 4 deletions(-) create mode 100644 org/select.org create mode 100644 src/components/select-package.lisp create mode 100644 src/components/select.lisp create mode 100644 tests/select-tests.lisp diff --git a/cl-tui.asd b/cl-tui.asd index 1ac5863..c34c49e 100644 --- a/cl-tui.asd +++ b/cl-tui.asd @@ -2,7 +2,7 @@ (asdf:defsystem :cl-tui :description "Reusable Common Lisp Terminal UI Framework" :author "Amr Gharbeia" - :version "0.6.0" + :version "0.7.0" :license "TBD" :depends-on (:fiveam :sb-posix) :components @@ -32,7 +32,10 @@ ;; Container components (v0.6.0) (:file "container-package" :depends-on ("package" "input-package")) (:file "scrollbox" :depends-on ("container-package" "dirty" "box")) - (:file "tabbar" :depends-on ("container-package" "dirty" "box")))) + (:file "tabbar" :depends-on ("container-package" "dirty" "box")) + ;; Select widget (v0.7.0) + (:file "select-package" :depends-on ("package" "input-package")) + (:file "select" :depends-on ("select-package" "dirty" "box")))) :in-order-to ((test-op (test-op :cl-tui-tests)))) (asdf:defsystem :cl-tui-tests @@ -52,12 +55,14 @@ (:file "render-tests") (:file "theme-tests") (:file "input-tests") - (:file "scrollbox-tabbar-tests" :pathname "../../tests/scrollbox-tabbar-tests.lisp")))) + (:file "scrollbox-tabbar-tests" :pathname "../../tests/scrollbox-tabbar-tests.lisp") + (:file "select-tests" :pathname "../../tests/select-tests.lisp")))) :perform (test-op (o c) (dolist (suite '((:cl-tui-backend-test "BACKEND-SUITE") (:cl-tui-box-test "BOX-SUITE") (:cl-tui-input-test "INPUT-SUITE") - (:cl-tui-scrollbox-test "SCROLLBOX-SUITE"))) + (:cl-tui-scrollbox-test "SCROLLBOX-SUITE") + (:cl-tui-select-test "SELECT-SUITE"))) (let* ((pkg (find-package (first suite))) (s (and pkg (find-symbol (second suite) pkg)))) (when s diff --git a/org/select.org b/org/select.org new file mode 100644 index 0000000..281fcb0 --- /dev/null +++ b/org/select.org @@ -0,0 +1,543 @@ +#+TITLE: cl-tui v0.7.0 — Select Dropdown + Fuzzy Filter +#+STARTUP: content + +* Select Widget + +A selection list component — the building block for command palettes, theme +pickers, agent selectors, and file pickers. Options are plists with ~:title~, +~:value~, and optional ~:category~ fields. + +The widget supports keyboard navigation (Up/Down, Ctrl+P/N, Enter, Esc), +option filtering by case-insensitive substring match with trigram fuzzy +fallback, and category grouping with dimmed headers. + +** Contract + +~select~ class — slots: options, filter, on-select, selected-index, layout-node. + +~make-select &key options filter on-select~ → select instance. + +~select-options sel~ / ~(setf select-options)~ — list of option plists. +~select-filter sel~ / ~(setf select-filter)~ — filter string or nil. +~select-selected-index sel~ / ~(setf select-selected-index)~ — currently highlighted index. +~select-on-select sel~ / ~(setf select-on-select)~ — callback fn (receives option plist). +~select-layout-node sel~ / ~(setf select-layout-node)~ — layout node. + +~select-filtered-options sel~ → list of options matching the filter. + Returns all options when filter is nil. Matches title (case-insensitive). + Falls back to trigram fuzzy matching when no exact substring matches. + +~select-next sel~ / ~select-prev sel~ — move selection forward/backward, + skipping category headers. Wraps around at boundaries. + +~select-visible-options sel~ → filtered options visible in viewport. + Uses available-height from layout node. Culls like ScrollBox. + +~select-handle-key sel event~ → T if handled. + Down/Ctrl+N → next. Up/Ctrl+P → prev. Enter → on-select callback. Esc → nil. + +~render ((sel select) backend)~ — renders visible options with selection highlight. + +** Tests + +#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp +(defpackage :cl-tui-select-test + (:use :cl :fiveam :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input :cl-tui.select) + (:export #:run-tests)) +(in-package #:cl-tui-select-test) + +(def-suite select-suite :description "Select widget tests") +(in-suite select-suite) + +(defun run-tests () + (let ((result (run 'select-suite))) + (fiveam:explain! result) + (uiop:quit 0))) + +(test select-creates + "A Select can be created with defaults." + (let ((sel (make-select))) + (is (typep sel 'select)) + (is-false (select-options sel)) + (is-false (select-filter sel)) + (is (= (select-selected-index sel) 0)))) + +(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)))) + +(test select-filtered-exact + "Filter returns case-insensitive substring matches." + (let ((sel (make-select + :options '((:title "Red" :value :red) + (:title "Green" :value :green) + (:title "Blue" :value :blue))))) + (setf (select-filter sel) "bl") + (let ((filtered (select-filtered-options sel))) + (is (= (length filtered) 1)) + (is (eql (getf (third (first filtered)) :value) :blue))))) + +(test select-filtered-all + "Nil filter returns all options." + (let ((sel (make-select + :options '((:title "Red" :value :red) + (:title "Blue" :value :blue))))) + (let ((filtered (select-filtered-options sel))) + (is (= (length filtered) 2))))) + +(test select-navigation + "Select-next and select-prev navigate through options." + (let ((sel (make-select + :options '((:title "A" :value :a) + (:title "B" :value :b) + (:title "C" :value :c))))) + (is (= (select-selected-index sel) 0)) + (select-next sel) + (is (= (select-selected-index sel) 1)) + (select-next sel) + (is (= (select-selected-index sel) 2)) + (select-next sel) + (is (= (select-selected-index sel) 0) "wraps forward") + (select-prev sel) + (is (= (select-selected-index sel) 2) "wraps backward"))) + +(test select-navigation-skips-categories + "Navigation skips category header options." + (let ((sel (make-select + :options '((:title "Colors" :category t) + (:title "Red" :value :red) + (:title "Green" :value :green) + (:title "Shapes" :category t) + (:title "Circle" :value :circle))))) + (is (= (select-selected-index sel) 0)) + (select-next sel) + (is (= (select-selected-index sel) 1) "skipped category header at 0") + (select-next sel) + (is (= (select-selected-index sel) 2)) + (select-next sel) + (is (= (select-selected-index sel) 4) "skipped category header at 3"))) + +(test select-handle-key + "Select handle-key dispatches navigation and selection." + (let* ((result (list nil)) + (sel (make-select + :options '((:title "A" :value :a) (:title "B" :value :b)) + :on-select (lambda (opt) (setf (car result) (getf opt :value)))))) + (select-handle-key sel (make-key-event :key :down)) + (is (= (select-selected-index sel) 1)) + (select-handle-key sel (make-key-event :key :up)) + (is (= (select-selected-index sel) 0)) + (select-handle-key sel (make-key-event :key :enter)) + (is (eql (car result) :a)))) + +(test select-handle-key-ctrl + "Ctrl+N and Ctrl+P navigate like down/up." + (let ((sel (make-select + :options '((:title "A" :value :a) (:title "B" :value :b) (:title "C" :value :c))))) + (select-handle-key sel (make-key-event :key :n :ctrl t)) + (is (= (select-selected-index sel) 1)) + (select-handle-key sel (make-key-event :key :p :ctrl t)) + (is (= (select-selected-index sel) 0)))) + +(test select-visible-count + "Visible options respects viewport height." + (let* ((ln (make-layout-node)) + (sel (make-select + :options (loop for i below 20 collect (list :title (format nil "Item ~D" i) :value i))))) + (setf (select-layout-node sel) ln) + (setf (layout-node-height ln) 5) + (let ((visible (select-visible-options sel))) + (is (<= (length visible) 5))))) + +(test select-fuzzy-fallback + "Fuzzy filter catches near-misses." + (let ((sel (make-select + :options '((:title "Nord" :value :nord) + (:title "Tokyo Night" :value :tokyo) + (:title "Catppuccin" :value :cat))))) + (setf (select-filter sel) "nrd") + (let ((filtered (select-filtered-options sel))) + (is (= (length filtered) 1)) + (is (eql (getf (third (first filtered)) :value) :nord))))) +#+END_SRC + +* Implementation + +** Package + +#+BEGIN_SRC lisp +(defpackage :cl-tui.select + (:use :cl :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.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 + +** 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. + +#+BEGIN_SRC lisp +(in-package #:cl-tui.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)) +#+END_SRC + +** Component protocol + +~component-layout-node~ returns the layout node so the layout engine +can position the select widget. + +#+BEGIN_SRC lisp +(defmethod component-layout-node ((sel select)) + (select-layout-node sel)) +#+END_SRC + +** Option filtering: substring match + +~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 +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 +(defun select-filtered-options (sel) + "Return list of options matching the current filter, in display order. + Each item: (display-index original-index option-plist)." + (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) + (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)))) + 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 + +~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. + +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. + +#+BEGIN_SRC lisp +(defun string-trigrams (str) + "Return a list of 3-character trigrams from STR." + (let ((s (string-downcase str)) + (result nil)) + (when (< (length s) 3) + (return-from string-trigrams (list s))) + (loop for i from 0 to (- (length s) 3) + do (push (subseq s i (+ i 3)) result)) + (delete-duplicates result :test #'string=))) + +(defun trigram-score (query target) + "Jaccard similarity of trigram sets: |intersection| / |union|." + (let* ((q-trigrams (string-trigrams query)) + (t-trigrams (string-trigrams target)) + (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)))) + +(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))) + (t-chars (remove-duplicates (coerce (string-downcase target) 'list))) + (intersection (length (intersection q-chars t-chars))) + (union (length (union q-chars t-chars)))) + (if (zerop union) nil (> (/ (float intersection) union) 0.3)))) +#+END_SRC + +** 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. + +#+BEGIN_SRC lisp +(defun select-clamp-index (sel) + "Ensure selected-index is valid. Wraps if empty." + (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) + "Move selection to next non-category option. Wraps at end." + (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) + "Move selection to previous non-category option. Wraps at start." + (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))))) +#+END_SRC + +** 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) + +Returns T if the key was handled, NIL otherwise. + +#+BEGIN_SRC lisp +(defun select-handle-key (sel event) + "Handle a key-event. Returns T if handled." + (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)))) +#+END_SRC + +** 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. + +#+BEGIN_SRC lisp +(defun select-visible-options (sel) + "Return filtered options that fit within the viewport." + (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)) + ;; Show items around the selection + (half (floor (1- height) 2)) + (start (max 0 (- sel-idx half))) + (end (min (length filtered) (+ start height)))) + (subseq filtered start end))) +#+END_SRC + +** 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). + +#+BEGIN_SRC lisp +(defmethod render ((sel select) backend) + (let* ((ln (select-layout-node sel)) + (x 0) (y 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)) + (is-category (getf option :category)) + (is-selected (eql display-idx sel-idx)) + (display (if (> (length title) (1- w)) + (concatenate 'string (subseq title 0 (1- w)) "…") + title))) + (cond + (is-category + (draw-text backend x y display :text-muted nil)) + (is-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 + +** Combined tangle block + +#+BEGIN_SRC lisp :tangle ../src/components/select.lisp +(in-package #:cl-tui.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 0) (y 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-tui.select + (:use :cl :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.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 diff --git a/src/components/select-package.lisp b/src/components/select-package.lisp new file mode 100644 index 0000000..1e524e5 --- /dev/null +++ b/src/components/select-package.lisp @@ -0,0 +1,13 @@ +(defpackage :cl-tui.select + (:use :cl :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.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)) diff --git a/src/components/select.lisp b/src/components/select.lisp new file mode 100644 index 0000000..5fd60b6 --- /dev/null +++ b/src/components/select.lisp @@ -0,0 +1,94 @@ +(in-package #:cl-tui.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 0) (y 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))) diff --git a/tests/select-tests.lisp b/tests/select-tests.lisp new file mode 100644 index 0000000..9fc4749 --- /dev/null +++ b/tests/select-tests.lisp @@ -0,0 +1,120 @@ +(defpackage :cl-tui-select-test + (:use :cl :fiveam :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input :cl-tui.select) + (:export #:run-tests)) +(in-package #:cl-tui-select-test) + +(def-suite select-suite :description "Select widget tests") +(in-suite select-suite) + +(defun run-tests () + (let ((result (run 'select-suite))) + (fiveam:explain! result) + (uiop:quit 0))) + +(test select-creates + "A Select can be created with defaults." + (let ((sel (make-select))) + (is (typep sel 'select)) + (is-false (select-options sel)) + (is-false (select-filter sel)) + (is (= (select-selected-index sel) 0)))) + +(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)))) + +(test select-filtered-exact + "Filter returns case-insensitive substring matches." + (let ((sel (make-select + :options '((:title "Red" :value :red) + (:title "Green" :value :green) + (:title "Blue" :value :blue))))) + (setf (select-filter sel) "bl") + (let ((filtered (select-filtered-options sel))) + (is (= (length filtered) 1)) + (is (eql (getf (third (first filtered)) :value) :blue))))) + +(test select-filtered-all + "Nil filter returns all options." + (let ((sel (make-select + :options '((:title "Red" :value :red) + (:title "Blue" :value :blue))))) + (let ((filtered (select-filtered-options sel))) + (is (= (length filtered) 2))))) + +(test select-navigation + "Select-next and select-prev navigate through options." + (let ((sel (make-select + :options '((:title "A" :value :a) + (:title "B" :value :b) + (:title "C" :value :c))))) + (is (= (select-selected-index sel) 0)) + (select-next sel) + (is (= (select-selected-index sel) 1)) + (select-next sel) + (is (= (select-selected-index sel) 2)) + (select-next sel) + (is (= (select-selected-index sel) 0) "wraps forward") + (select-prev sel) + (is (= (select-selected-index sel) 2) "wraps backward"))) + +(test select-navigation-skips-categories + "Navigation skips category header options." + (let ((sel (make-select + :options '((:title "Colors" :category t) + (:title "Red" :value :red) + (:title "Green" :value :green) + (:title "Shapes" :category t) + (:title "Circle" :value :circle))))) + (is (= (select-selected-index sel) 0)) + (select-next sel) + (is (= (select-selected-index sel) 1) "skipped category header at 0") + (select-next sel) + (is (= (select-selected-index sel) 2)) + (select-next sel) + (is (= (select-selected-index sel) 4) "skipped category header at 3"))) + +(test select-handle-key + "Select handle-key dispatches navigation and selection." + (let* ((result (list nil)) + (sel (make-select + :options '((:title "A" :value :a) (:title "B" :value :b)) + :on-select (lambda (opt) (setf (car result) (getf opt :value)))))) + (select-handle-key sel (make-key-event :key :down)) + (is (= (select-selected-index sel) 1)) + (select-handle-key sel (make-key-event :key :up)) + (is (= (select-selected-index sel) 0)) + (select-handle-key sel (make-key-event :key :enter)) + (is (eql (car result) :a)))) + +(test select-handle-key-ctrl + "Ctrl+N and Ctrl+P navigate like down/up." + (let ((sel (make-select + :options '((:title "A" :value :a) (:title "B" :value :b) (:title "C" :value :c))))) + (select-handle-key sel (make-key-event :key :n :ctrl t)) + (is (= (select-selected-index sel) 1)) + (select-handle-key sel (make-key-event :key :p :ctrl t)) + (is (= (select-selected-index sel) 0)))) + +(test select-visible-count + "Visible options respects viewport height." + (let* ((ln (make-layout-node)) + (sel (make-select + :options (loop for i below 20 collect (list :title (format nil "Item ~D" i) :value i))))) + (setf (select-layout-node sel) ln) + (setf (layout-node-height ln) 5) + (let ((visible (select-visible-options sel))) + (is (<= (length visible) 5))))) + +(test select-fuzzy-fallback + "Fuzzy filter catches near-misses." + (let ((sel (make-select + :options '((:title "Nord" :value :nord) + (:title "Tokyo Night" :value :tokyo) + (:title "Catppuccin" :value :cat))))) + (setf (select-filter sel) "nrd") + (let ((filtered (select-filtered-options sel))) + (is (= (length filtered) 1)) + (is (eql (getf (third (first filtered)) :value) :nord)))))