commander-s/scheme/browse-list.scm

;;This addition provides the capability of displaying a list.
;;There is only one list-item per line - if the item is too long for one
;;single line it's symbolic representation is seperated into more
;;than one lines.
;;The user can scroll up and down in the list and he can select the items
;;and later paste this newly-created list into the upper buffer.


;;Result-Object-Data-Type
(define-record-type browse-list-res-obj browse-list-res-obj
  (make-browse-list-res-obj pos-y
			    pos-x
			    line
			    col-in-line
			    list
			    result-text
			    width
			    marked-items
			    marked-pos
			    c-x-pressed)
  browse-list-res-obj?
  (pos-y browse-list-res-obj-pos-y)
  (pos-x browse-list-res-obj-pos-x)
  (line browse-list-res-obj-line)
  (col-in-line browse-list-res-obj-col-in-line)
  (list browse-list-res-obj-file-list)
  (result-text browse-list-res-obj-result-text)
  (width browse-list-res-obj-width)
  (marked-items browse-list-res-obj-marked-items)
  (marked-pos browse-list-res-obj-marked-pos)
  (c-x-pressed browse-list-res-obj-c-x-pressed))


;;The layout-function
;;All lines are seperated
(define layout-result-browse-list
  (lambda (lst width)
    (let loop ((pos-list 0)
	       (buffer '()))
      (if (= pos-list (length lst))
	  buffer
	  (loop (+ pos-list 1)
		(append buffer 
			(seperated-line (list-ref lst pos-list) width)))))))

;;seperate one line -> return a list of the single lines
(define seperated-line
  (lambda (el width)
    (let loop ((old el)
	       (new '()))
      (if (<= (string-length old) 0)
	  new
	  (if (>= (string-length old) width)
	      (let* ((old-cut (substring old width (string-length old)))
		     (new-app (string-append " " (substring old 0 width))))
		(loop old-cut (append new (list new-app))))
	      (append new (list (string-append " " old))))))))

;;compute where the Cursor has to be put.
;;The cursor is always located in the last line of one item of the list
(define compute-pos-y
  (lambda (pos lst width)
    (let* ((before-pos (sublist lst 0 pos))
	   (seperated-before (layout-result-browse-list before-pos width))
	   (pos-before (length seperated-before)))
      pos-before)))
	  
;;Find out which lines of the buffer are to highlight.
;;Only those lines are highlighted, which contain the active item.
(define get-highlighted-browse-list
  (lambda (line lst pos-y width)
    (let* ((act-line (list-ref lst (- line 1)))
	   (seperated (seperated-line act-line width))
	   (length-seperated (length seperated))
	   (first-pos (- pos-y length-seperated)))
      (let loop ((count 1)
		 (res '()))
	(if (> count length-seperated)
	    res
	    (loop (+ count 1)
		  (append res (list (+ count first-pos)))))))))

;;find out which lines are to be marked. Lines are marked if they have 
;;recently been selected
(define get-marked-pos-browse
  (lambda (marked lst width)
    (let loop ((m marked)
	       (new '()))
      (if (null? m)
	  new
	  (let* ((pos (car m)))
	    (loop (cdr m) 
		  (append (get-marked-browse-list pos lst width)
			new )))))))

(define get-marked-browse-list
  (lambda (pos lst width)
    (let* ((act-line (list-ref lst (- pos 1)))
	   (seperated (seperated-line act-line width))
	   (length-seperated (length seperated))
	   (before-pos (sublist lst 0 pos))
	   (seperated-before (layout-result-browse-list before-pos width))
	   (length-before (- (length seperated-before) length-seperated)))
      (let loop ((res '())
		 (count 1))
	(if (> count length-seperated)
	    res
	    (loop (cons (+ length-before count) res)
		  (+ count 1)))))))


;;Receiving-Function, that answers to incomming messages and changes state 
;;of the passed "browse-list-res-obj"
(define browse-list-receiver
  (lambda (message)
    (cond 
     ((next-command-message? message)
      (let* ((command (next-command-string message))
	     (parameters (next-command-message-parameters message))
	     (result #f)
	     (width (next-command-message-width message)))
	(if (< (length parameters) 1)
	    (begin
	      (set! result (list "forgot parameter?"))
	      (let* ((text
		      (layout-result-standard "forgot parameters?" 
					      result width))
		     (browse-obj
		      (make-browse-list-res-obj 1 1 1 1 result text  
						    width '() '() #f)))
		browse-obj))

	    (let ((lst (list-ref parameters 0)))
	      (if (not (null? lst))
		  (let*
		      ((result-string (map exp->string lst))
		       (text 
			(layout-result-browse-list result-string
						   (- width 1)))
		       (sep-line-1 (seperated-line 
				    (exp->string (list-ref lst 0)) width))
		       (pos-y (length sep-line-1))
		       (browse-obj 
			(make-browse-list-res-obj pos-y 1 1 1 lst text width
						  '() '() #f)))
		    browse-obj)
		  (let 
		      ((browse-obj 
			(make-browse-list-res-obj 1 1 1 1 '("") '("") width
						  '() '() #f)))
		    browse-obj))))))

     ((print-message? message)
      (let* ((model (message-result-object message))
	     (pos-y (browse-list-res-obj-pos-y model))
	     (pos-x (browse-list-res-obj-pos-x model))
	     (text (browse-list-res-obj-result-text model))
	     (line (browse-list-res-obj-line model))
	     (lst (map exp->string (browse-list-res-obj-file-list model)))
	     (width (browse-list-res-obj-width model))
	     (marked (browse-list-res-obj-marked-items model))
	     (marked-pos (browse-list-res-obj-marked-pos model))
	     (real-marked-pos (get-marked-pos-browse
			       marked-pos 
			       lst
			       width))
	     (highlighted (get-highlighted-browse-list line lst pos-y width)))
	(make-print-object pos-y pos-x text highlighted real-marked-pos)))

     ((key-pressed-message? message)
      (let* ((model (message-result-object message))
	     (key (key-pressed-message-key message))
	     (c-x-pressed (browse-list-res-obj-c-x-pressed model)))


	(if c-x-pressed
	    
	    (cond
	     ;;Ctrl+x s ->selection
	     ((= key 115)
	      (let* ((marked-items (browse-list-res-obj-marked-items model))
		     (actual-pos (browse-list-res-obj-line model))
		     (all-items (browse-list-res-obj-file-list model)))
		(if (< actual-pos 1)
		    model
		    (let* ((actual-item (list-ref all-items (- actual-pos 1))))
		      (begin
			(if (member actual-item marked-items)
			    model
			    (let* 
				((new-marked-items (append marked-items
							   (list actual-item)))
				 (new-marked-pos (append
						  (list actual-pos)
						  (browse-list-res-obj-marked-pos
						   model)))
				 (new-model (make-browse-list-res-obj
					     (browse-list-res-obj-pos-y model)
					     (browse-list-res-obj-pos-x model)
					     (browse-list-res-obj-line model)
					     (browse-list-res-obj-col-in-line
					      model)
					     (browse-list-res-obj-file-list 
					      model)
					     (browse-list-res-obj-result-text 
					      model)
					     (browse-list-res-obj-width model)
					     new-marked-items
					     new-marked-pos
					     #f)))
			      new-model)))))))
	     
	     
	     ;;Ctrl+x u -> unselect
	     ((= key 117)
	      (let* ((marked-items (browse-list-res-obj-marked-items model))
		     (marked-pos (browse-list-res-obj-marked-pos model))
		     (actual-pos (browse-list-res-obj-line model))
		     (all-items (browse-list-res-obj-file-list model)))
		(if (< actual-pos 1)
		    model
		    (let* ((actual-item (list-ref all-items (- actual-pos 1)))
			   (rest (member actual-item marked-items))
			   (rest-pos (member actual-pos marked-pos)))
		      (if (not rest)
			  model
			  (let* ((after-item (length rest))
				 (after-marked (length rest-pos))
				 (all-items (length marked-items))
				 (all-marked (length marked-pos))
				 (before-item (sublist marked-items
						       0 
						       (- all-items
							  after-item )))
				 (before-marked (sublist marked-pos
							 0 
							 (- all-marked
							    after-marked)))
				 (new-marked-items (append before-item
							   (list-tail rest 1)))
				 (new-marked-pos (append before-marked
							 (list-tail rest-pos 1)))
				 (new-model (make-browse-list-res-obj
					     (browse-list-res-obj-pos-y model)
					     (browse-list-res-obj-pos-x model)
					     (browse-list-res-obj-line model)
					     (browse-list-res-obj-col-in-line
					      model)
					     (browse-list-res-obj-file-list 
					      model)
					     (browse-list-res-obj-result-text 
					      model)
					     (browse-list-res-obj-width model)
					     new-marked-items
					     new-marked-pos
					     #f)))
			    new-model))))))
	     
	     (else
	      (make-browse-list-res-obj
	       (browse-list-res-obj-pos-y model)
	       (browse-list-res-obj-pos-x model)
	       (browse-list-res-obj-line model)
	       (browse-list-res-obj-col-in-line
		model)
	       (browse-list-res-obj-file-list 
		model)
	       (browse-list-res-obj-result-text 
		model)
	       (browse-list-res-obj-width model)
	       (browse-list-res-obj-marked-items model)
	       (browse-list-res-obj-marked-pos model)
	       #f)))
    
	    (cond

	     ;;ctrl+x
	     ((= key 24)
	      (make-browse-list-res-obj
	       (browse-list-res-obj-pos-y model)
	       (browse-list-res-obj-pos-x model)
	       (browse-list-res-obj-line model)
	       (browse-list-res-obj-col-in-line
		model)
	       (browse-list-res-obj-file-list 
		model)
	       (browse-list-res-obj-result-text 
		model)
	       (browse-list-res-obj-width model)
	       (browse-list-res-obj-marked-items model)
	       (browse-list-res-obj-marked-pos model)
	       #t))

	     
	     ((= key key-up)
	      (let ((line (browse-list-res-obj-line model))
		    (lst (map exp->string (browse-list-res-obj-file-list model)))
		    (width (browse-list-res-obj-width model)))
		(if (<= line 1)
		    model
		    (let* ((new-line (- line 1))
			   (pos-y (compute-pos-y new-line lst width)))
		      (make-browse-list-res-obj 
		       pos-y 1 new-line 1
		       (browse-list-res-obj-file-list model)
		       (browse-list-res-obj-result-text model)
		       (browse-list-res-obj-width model)
		       (browse-list-res-obj-marked-items model)
		       (browse-list-res-obj-marked-pos model)
		       #f)))))
	     
	     ((= key key-down)
	      (let ((line (browse-list-res-obj-line model))
		    (lst (map exp->string (browse-list-res-obj-file-list model)))
		    (width (browse-list-res-obj-width model)))
		(if (>= line (length lst))
		    model
		    (let* ((new-line (+ line 1))
			   (pos-y (compute-pos-y new-line lst width)))
		      (make-browse-list-res-obj 
		       pos-y 1 new-line 1
		       (browse-list-res-obj-file-list model)
		       (browse-list-res-obj-result-text model)
		       (browse-list-res-obj-width model)
		       (browse-list-res-obj-marked-items model)
		       (browse-list-res-obj-marked-pos model)
		       #f)))))
	     
	     (else model)))))
	    
	    
     ((selection-message? message)
      (let* ((model (message-result-object message))
	     (marked-items (browse-list-res-obj-marked-items model)))
	(string-append "'" (exp->string marked-items))))

)))

(register-plugin! (make-plugin "browse-list" browse-list-receiver))