commander-s/scheme/select-list.scm

(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)
  (really-make-select-list elements 0 0 num-lines))

(define key-m 109)

(define key-u 117)

(define (select-list-handle-key-press select-list key)
  (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 (select-list-navigation-key? key)
  (or (= key key-up) (= key key-down)))

(define (select-list-marking-key? key)
  (or (= key key-m) (= key key-u)))

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