cl-tty/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)
  "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)
                            (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)
  "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))))

(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)))))

(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))))

(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)))

(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))
             (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)))