175 lines
5.0 KiB
Scheme
175 lines
5.0 KiB
Scheme
(define-record-type element :element
|
|
(make-element markable? marked? value text)
|
|
element?
|
|
(markable? element-markable?)
|
|
(marked? element-marked?)
|
|
(value element-value)
|
|
(text element-text))
|
|
|
|
(define-record-discloser :element
|
|
(lambda (r)
|
|
`(element ,(element-marked? r) ,(element-text r))))
|
|
|
|
(define (make-unmarked-element markable? value text)
|
|
(make-element markable? #f value text))
|
|
|
|
(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 value/markable/text-tuples num-lines)
|
|
(really-make-select-list
|
|
(map (lambda (value/markable/text)
|
|
(apply make-unmarked-element value/markable/text))
|
|
value/markable/text-tuples)
|
|
0 0 num-lines))
|
|
|
|
(define key-m 109)
|
|
|
|
(define key-u 117)
|
|
|
|
(define (select-list-handle-key-press select-list key-message)
|
|
(let ((key (key-pressed-message-key key-message))
|
|
(result-buffer (key-pressed-message-result-buffer key-message)))
|
|
(cond
|
|
((= key key-m)
|
|
(mark-current-line select-list))
|
|
((= key key-u)
|
|
(unmark-current-line select-list))
|
|
((= key key-up)
|
|
(move-cursor-up select-list))
|
|
((= key key-down)
|
|
(move-cursor-down select-list))
|
|
(else
|
|
select-list))))
|
|
|
|
(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
|
|
(if (and (element-markable? el)
|
|
(= index i))
|
|
mark
|
|
(element-marked? el))
|
|
(element-value el)
|
|
(element-text 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 (copy-element-list elements)
|
|
(fold-right
|
|
(lambda (el result)
|
|
(cons
|
|
(make-element (element-markable? el)
|
|
(element-marked? el)
|
|
(element-value el)
|
|
(element-text el))
|
|
result))
|
|
'() elements))
|
|
|
|
(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
|
|
(copy-element-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)
|
|
(paint-selection-list-at select-list 0 0))
|
|
|
|
(define (paint-selection-list-at select-list x y)
|
|
(lambda (win result-buffer have-focus?)
|
|
(let ((num-lines (select-list-num-lines 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 (select-list-cursor-index select-list))
|
|
(wattron win (A-REVERSE))
|
|
(mvwaddstr win y x (element-text (car elts)))
|
|
(wattrset win (A-NORMAL))
|
|
(lp (cdr elts) (+ y 1) (+ i 1)))
|
|
((element-marked? (car elts))
|
|
(wattron win (A-BOLD))
|
|
(mvwaddstr win y x (element-text (car elts)))
|
|
(wattrset win (A-NORMAL))
|
|
(lp (cdr elts) (+ y 1) (+ i 1)))
|
|
(else
|
|
(mvwaddstr win y x (element-text (car elts)))
|
|
(lp (cdr elts) (+ y 1) (+ i 1))))))))
|