207 lines
6.7 KiB
Scheme
207 lines
6.7 KiB
Scheme
(define-record-type select-list :select-list
|
|
(really-make-select-list elements view-index cursor-index num-lines)
|
|
select-list?
|
|
(elements select-list-elements)
|
|
(view-index select-list-view-index)
|
|
(cursor-index select-list-cursor-index)
|
|
(num-lines select-list-num-lines))
|
|
|
|
(define-record-discloser :select-list
|
|
(lambda (r)
|
|
`(select-list (index ,(select-list-cursor-index r))
|
|
(view-index ,(select-list-view-index r))
|
|
(num-lines ,(select-list-num-lines r)))))
|
|
|
|
(define (make-select-list elements num-lines . optional-args)
|
|
(let-optionals optional-args
|
|
((cursor-start 0))
|
|
(really-make-select-list elements 0 cursor-start num-lines)))
|
|
|
|
(define-option 'select-list 'select-list-mark-key (char->ascii #\m))
|
|
(define-option 'select-list 'select-list-unmark-key (char->ascii #\u))
|
|
(define-option 'select-list 'select-list-move-up-key key-up)
|
|
(define-option 'select-list 'select-list-move-down-key key-down)
|
|
|
|
(define select-list-key-help
|
|
'(select-list (select-list-mark-key
|
|
select-list-unmark-key
|
|
select-list-move-up-key
|
|
select-list-move-down-key)))
|
|
|
|
(define (select-list-handle-key-press select-list key)
|
|
(cond
|
|
((= key (config 'select-list 'select-list-mark-key))
|
|
(mark-current-line select-list))
|
|
((= key (config 'select-list 'select-list-unmark-key))
|
|
(unmark-current-line select-list))
|
|
((= key (config 'select-list 'select-list-move-up-key))
|
|
(move-cursor-up select-list))
|
|
((= key (config 'select-list 'select-list-move-down-key))
|
|
(move-cursor-down select-list))
|
|
(else
|
|
select-list)))
|
|
|
|
(define (select-list-navigation-key? key)
|
|
(or (= key (config 'select-list 'select-list-move-up-key))
|
|
(= key (config 'select-list 'select-list-move-down-key))))
|
|
|
|
(define (select-list-marking-key? key)
|
|
(or (= key (config 'select-list 'select-list-mark-key))
|
|
(= key (config 'select-list 'select-list-unmark-key))))
|
|
|
|
(define (select-list-key? key)
|
|
(or (select-list-navigation-key? key)
|
|
(select-list-marking-key? key)))
|
|
|
|
(define (mark/unmark-current-line-maker mark)
|
|
(lambda (select-list)
|
|
(let* ((index (select-list-cursor-index select-list))
|
|
(elements (select-list-elements select-list)))
|
|
(really-make-select-list
|
|
(fold-right
|
|
(lambda (element.i result)
|
|
(let ((el (car element.i))
|
|
(i (cadr element.i)))
|
|
(cons (make-element
|
|
(element-markable? el)
|
|
(if (and (element-markable? el)
|
|
(= index i))
|
|
mark
|
|
(element-marked? el))
|
|
(element-value el)
|
|
(element-painter el))
|
|
result)))
|
|
'() (zip elements (iota (length elements))))
|
|
(select-list-view-index select-list)
|
|
index (select-list-num-lines select-list)))))
|
|
|
|
(define unmark-current-line
|
|
(mark/unmark-current-line-maker #f))
|
|
|
|
(define mark-current-line
|
|
(mark/unmark-current-line-maker #t))
|
|
|
|
;; returns: y cursor-index view-index
|
|
(define (calculate-view index-move elements
|
|
view-index cursor-index
|
|
num-lines)
|
|
(let ((new-index (index-move cursor-index))
|
|
(max-index (- (length elements) 1)))
|
|
(cond
|
|
((< new-index 0)
|
|
(values 0 view-index))
|
|
((> new-index max-index)
|
|
(values max-index view-index))
|
|
((and (>= (- new-index view-index) num-lines)
|
|
(> new-index cursor-index))
|
|
(values new-index (+ view-index num-lines)))
|
|
((and (< new-index cursor-index)
|
|
(>= view-index cursor-index))
|
|
(values new-index (- view-index num-lines)))
|
|
(else
|
|
(values (index-move cursor-index) view-index)))))
|
|
|
|
(define (move-cursor-maker index-move)
|
|
(lambda (select-list)
|
|
(let* ((elements (select-list-elements select-list))
|
|
(old-index (select-list-cursor-index select-list))
|
|
(num-lines (select-list-num-lines select-list)))
|
|
(call-with-values
|
|
(lambda ()
|
|
(calculate-view index-move
|
|
elements
|
|
(select-list-view-index select-list)
|
|
old-index
|
|
num-lines))
|
|
(lambda (cursor-index view-index)
|
|
(really-make-select-list
|
|
elements
|
|
view-index
|
|
cursor-index
|
|
num-lines))))))
|
|
|
|
(define move-cursor-up
|
|
(move-cursor-maker (lambda (y) (- y 1))))
|
|
|
|
(define move-cursor-down
|
|
(move-cursor-maker (lambda (y) (+ y 1))))
|
|
|
|
(define (take-max lst num)
|
|
(if (>= num (length lst))
|
|
lst
|
|
(take lst num)))
|
|
|
|
(define (select-visible-elements select-list num-lines)
|
|
(take-max (drop (select-list-elements select-list)
|
|
(select-list-view-index select-list))
|
|
(+ 1 num-lines)))
|
|
|
|
(define (paint-selection-list select-list win width have-focus?)
|
|
(paint-selection-list-at select-list 0 0 win width have-focus?))
|
|
|
|
(define (paint-selection-list-at select-list x y win width
|
|
have-focus?)
|
|
(let ((num-lines (select-list-num-lines select-list))
|
|
(cursor-index (select-list-cursor-index select-list)))
|
|
(let lp ((elts
|
|
(select-visible-elements select-list num-lines))
|
|
(y y)
|
|
(i (select-list-view-index select-list)))
|
|
(cond
|
|
((null? elts)
|
|
(values))
|
|
((= i cursor-index)
|
|
((element-painter (car elts)) win x y width #t (element-marked? (car elts)))
|
|
(lp (cdr elts) (+ y 1) (+ i 1)))
|
|
((element-marked? (car elts))
|
|
((element-painter (car elts)) win x y width #f #t)
|
|
(lp (cdr elts) (+ y 1) (+ i 1)))
|
|
(else
|
|
((element-painter (car elts)) win x y width #f #f)
|
|
(lp (cdr elts) (+ y 1) (+ i 1)))))))
|
|
|
|
(define (select-list-get-marked select-list)
|
|
(map element-value
|
|
(filter element-marked?
|
|
(select-list-elements select-list))))
|
|
|
|
(define (select-list-has-marks? select-list)
|
|
(let lp ((elts (select-list-elements select-list)))
|
|
(if (null? elts)
|
|
#f
|
|
(if (element-marked? (car elts))
|
|
#t
|
|
(lp (cdr elts))))))
|
|
|
|
(define (select-list-selected-entry select-list)
|
|
(element-value
|
|
(select-list-selected-element select-list)))
|
|
|
|
(define (select-list-selected-element select-list)
|
|
(list-ref (select-list-elements select-list)
|
|
(select-list-cursor-index select-list)))
|
|
|
|
(define (select-list-get-selection select-list)
|
|
(let ((marked (select-list-get-marked select-list)))
|
|
(if (null? marked)
|
|
(let ((selected (select-list-selected-element select-list)))
|
|
(if (element-markable? selected)
|
|
(list (element-value selected))
|
|
'()))
|
|
marked)))
|
|
|
|
(define (make-get-selection-as-ref-method select-list)
|
|
(lambda (self focus-object-table)
|
|
(let ((marked (select-list-get-marked select-list))
|
|
(make-reference (lambda (obj)
|
|
(make-focus-object-reference
|
|
focus-object-table obj))))
|
|
(if (null? marked)
|
|
(write-to-string
|
|
(make-reference (select-list-selected-entry select-list)))
|
|
(string-append
|
|
"(list "
|
|
(string-join (map write-to-string (map make-reference marked)))
|
|
")")))))
|
|
|