(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 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/text-tuples num-lines)
  (really-make-select-list 
   (map (lambda (value/text)
	  (apply make-unmarked-element value/text))
	value/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 (= 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-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))))))))