commander-s/scheme/select-list.scm

(define-record-type element :element
  (make-element marked? value text)
  element?
  (marked? element-marked? set-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 value text)
  (make-element #f value text))

(define-record-type select-list :select-list
  (really-make-select-list elements view-index cursor-index cursor-y)
  select-list?
  (elements select-list-elements)
  (view-index select-list-view-index)
  (cursor-index select-list-cursor-index)
  (cursor-y select-list-cursor-y))

(define-record-discloser :select-list
  (lambda (r)
    `(select-list (index ,(select-list-cursor-index r))
		  (view-index ,(select-list-view-index r))
		  (y ,(select-list-cursor-y r)))))

(define (make-select-list value/text-tuples)
  (really-make-select-list 
   (map (lambda (value/text)
	  (apply make-unmarked-element value/text))
	value/text-tuples)
   0 0 1))

(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 result-buffer))
     ((= key key-down)
     (move-cursor-down select-list result-buffer))
     (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 (= 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-cursor-y 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 cursor-move 
 			elements view-index cursor-index
 			num-lines y)
  (let ((new-index (index-move cursor-index))
 	(max-index (- (length elements) 1)))
    (cond
     ((< new-index 0) 
      (values 0 0 view-index))
     ((> new-index max-index)
      (values y max-index view-index))
     ((and (>= (- new-index view-index) num-lines)
 	   (> new-index cursor-index))
      (values 1 new-index (+ view-index num-lines)))
     ((and (< new-index cursor-index)
	   (>= view-index cursor-index))
      (values num-lines new-index (- view-index num-lines)))
     (else
      (values (cursor-move y) (index-move cursor-index) view-index)))))

(define (copy-element-list elements)
  (fold-right
   (lambda (el result)
     (cons 
      (make-element (element-marked? el)
		    (element-value el)
		    (element-text el))
      result))
   '() elements))

(define (move-cursor-maker index-move cursor-move)
  (lambda (select-list result-buffer)
    (let* ((elements (select-list-elements select-list))
	   (old-index (select-list-cursor-index select-list)))
      (call-with-values
	  (lambda ()
	    (calculate-view index-move cursor-move
			    elements
			    (select-list-view-index select-list)
			    old-index
			    (result-buffer-num-lines result-buffer)
			    (select-list-cursor-y select-list)))
      (lambda (y cursor-index view-index)
	(really-make-select-list
	 (copy-element-list elements)
	 view-index
	 cursor-index 
	 y))))))

(define move-cursor-up
  (let ((sub-one (lambda (y) (- y 1))))
    (move-cursor-maker sub-one sub-one)))

(define move-cursor-down
  (let ((add-one (lambda (y) (+ y 1))))
    (move-cursor-maker add-one add-one)))

(define (take-max lst num)
  (if (>= num (length lst))
      lst
      (take lst num)))

(define (select-visible-elements select-list result-buffer)
  (let ((num-lines (result-buffer-num-lines result-buffer)))
    (take-max (drop (select-list-elements select-list) 
		    (select-list-view-index select-list))
	      (+ 1 num-lines)))) ;;; wtf? why this

(define (paint-selection-list select-list)
  (lambda (win result-buffer have-focus?)
    (let lp ((elts 
	      (select-visible-elements select-list result-buffer))
	     (y 0) 
	     (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 0 (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 0 (element-text (car elts)))
	(wattrset win (A-NORMAL))
	(lp (cdr elts) (+ y 1) (+ i 1)))
       (else
	(mvwaddstr win y 0 (element-text (car elts)))
	(lp (cdr elts) (+ y 1) (+ i 1)))))))