commander-s/scheme/browse-directory-list.scm

;;This addition provides a directory-tree-browsing-functionality.
;;This means:
;;When using it you hand over a list of strings, that shall be
;;interpreted as paths and a string that represents the path, relative to
;;which the path-list is given.
;;In the result-window of the NUIT a file-browsing screen is shown
;;which you can browse in using arrow-keys and enter. You can also
;;select some items and paste them into the upper window.

;;If there are paths to files handed over that do not exist, they will not be 
;;displayed in the browser!

;;If the given path does not exist you will not be able to navigate!

(define key-m 109)
(define key-u 117)

(define-record-type browse-dir-list-res-obj browse-dir-list-res-obj
  (make-browse-dir-list-res-obj pos-y
				pos-x
				file-list
				result-text
				working-directory
				width
				initial-wd
				marked-items
				res-marked-items
				c-x-pressed)
  browse-dir-list-res-obj?
  (pos-y browse-dir-list-res-obj-pos-y)
  (pos-x browse-dir-list-res-obj-pos-x)
  (file-list browse-dir-list-res-obj-file-list)
  (result-text browse-dir-list-res-obj-result-text)
  (working-directory browse-dir-list-res-obj-working-directory)
  (width browse-dir-list-res-obj-width)
  (initial-wd browse-dir-list-res-obj-initial-wd)
  (marked-items browse-dir-list-res-obj-marked-items)
  (res-marked-items browse-dir-list-res-obj-res-marked-items)
  (c-x-pressed browse-dir-list-res-obj-c-x-pressed))


;;Layout of the directory-tree-browser
(define layout-result-browse-dir-list
  (lambda (result-str result width directory)
    (begin
      (let ((printed-file-list (print-file-list-1 result directory))
	    (heading ""))
	(begin
	  (if (<= (string-length directory) (- width 25))
	      (set! heading (string-append "Paths relative to " 
					   directory  " :"))
	      (let ((dir-string (substring directory 
					   (- (string-length directory) 
					      (- width 25))
					   (string-length directory))))
		(set! heading (string-append "Paths relative to ..."
					     dir-string))))
	  (append (list heading) (list " <-") printed-file-list))))))


;;One File per-line
;;In case the object is a directory "/" is added
(define print-file-list-1
  (lambda (file-list dir)
    (let loop ((old file-list)
	       (new '()))
      (if (equal? '() old)
	  new
	  (let* ((hd (list-ref old 0))
		 (hd-path (string-append dir "/" hd))
		 (tl (cdr old)))
	    (if (file-exists? hd-path)
		(if (file-directory? hd-path)
		    (let ((new-str (string-append " " hd "/")))
		      (loop tl (append new (list new-str))))
		    (loop tl (append new (list (string-append " " hd)))))
		(loop tl new)))))))

;;selection->descend
(define selected-browse-dir-list
  (lambda (model)
    (let ((ln (browse-dir-list-res-obj-pos-y model))
	  (wd (browse-dir-list-res-obj-working-directory model)))
      (if (not (file-exists? wd))
	  model
	  (begin (chdir wd)
		 (if (or (>= ln (+ (length 
				    (browse-dir-list-res-obj-result-text model)) 1))
			 (<= ln 1))
		     model
		     (if (= ln 2)
			 (if (not (equal? "/" (cwd)))
			     (begin
			       (chdir "..")
			       (let* ((new-result (evaluate "(directory-files)"))
				      (new-result-string (exp->string new-result))
				      (width (browse-dir-list-res-obj-width model))
				      (new-text (layout-result-browse-dir-list 
						 new-result-string 
						 new-result width (cwd)))
				      (new-model (make-browse-dir-list-res-obj
						  2
						  1
						  new-result
						  new-text
						  (cwd)
						  width
						  (browse-dir-list-res-obj-initial-wd 
						   model)
						  (browse-dir-list-res-obj-marked-items
						   model)
						  (browse-dir-list-res-obj-res-marked-items
						   model)
						  (browse-dir-list-res-obj-c-x-pressed
						   model))))
				 new-model))
			     model)
			 (let* ((text (browse-dir-list-res-obj-result-text model))
				(ent (list-ref text (- ln 1)))
				(len (string-length ent))
				(last-char (substring ent (- len 1) len))
				(rest (substring ent 1 (- len 1))))
			   (if (equal? last-char "/")
			       (begin
				 (chdir wd)
				 (chdir rest)
				 (let* ((new-result (evaluate "(directory-files)"))
					(new-result-string (exp->string new-result))
					(width (browse-dir-list-res-obj-width model))
					(new-text (layout-result-browse-dir-list 
						   new-result-string new-result width 
						   (cwd)))
					(new-model (make-browse-dir-list-res-obj
						    2
						    1
						    new-result
						    new-text
						    (cwd)
						    width
						    (browse-dir-list-res-obj-initial-wd
						     model)
						    (browse-dir-list-res-obj-marked-items
						     model)
						    (browse-dir-list-res-obj-res-marked-items
						     model)
						    (browse-dir-list-res-obj-c-x-pressed						   model))))
				   new-model))
			   model)))))))))

(define browse-dir-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) 2)
	    (begin
	      (set! result (list "forgot parameters?"))
	      (let* ((text
		      (layout-result-standard "forgot parameters?" 
					      result width))
		     (browse-obj
		      (make-browse-dir-list-res-obj 1 1 result text (cwd) 
						    width (cwd) '() '() #f)))
		browse-obj))
	    
	    (let* ((file-list 
		    (evaluate (list-ref parameters 0)))
		   (dir (evaluate (list-ref parameters 1)))
		   (result-string (exp->string file-list))
		   (width (next-command-message-width message))
		   (text 
		    (layout-result-browse-dir-list result-string
						   file-list width dir))
		   (browse-obj 
		    (make-browse-dir-list-res-obj 2 1 file-list text dir width
						  (cwd) '() '() #f)))
	      browse-obj))))

     ((print-message? message)
      (let* ((model (print-message-object message))
	     (pos-y (browse-dir-list-res-obj-pos-y model))
	     (pos-x (browse-dir-list-res-obj-pos-x model))
	     (text (browse-dir-list-res-obj-result-text model))
	     (marked-pos (get-marked-positions-3
			  (browse-dir-list-res-obj-file-list model)
			  (browse-dir-list-res-obj-marked-items model))))
	(make-print-object pos-y pos-x text (list pos-y) marked-pos))) 

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

	 ;; user pressed 'm' --- mark current entry
	 ((= key key-m)
	  (let* ((marked-items (browse-dir-list-res-obj-marked-items model))
		 (res-marked-items (browse-dir-list-res-obj-res-marked-items
				    model))
		 (actual-pos (browse-dir-list-res-obj-pos-y model))
		 (all-items (browse-dir-list-res-obj-file-list model)))
	    (if (<= actual-pos 2)
		model
		(let ((actual-item (list-ref all-items (- actual-pos 3)))
		      (actual-res-item #f))
		  (begin
		    (if (not (string=? (cwd) "/"))
			(set! actual-res-item (string-append (cwd) "/" actual-item))
			(set! actual-res-item (string-append "/" actual-item)))
		    (if (member actual-res-item marked-items)
			model
			(let* ((new-res-marked-items (append res-marked-items
							     (list 
							      actual-res-item)))
			       (new-marked-items (append marked-items
							 (list actual-item)))
			       (new-model (make-browse-dir-list-res-obj
					   (browse-dir-list-res-obj-pos-y model)
					   (browse-dir-list-res-obj-pos-x model)
					   (browse-dir-list-res-obj-file-list 
					    model)
					   (browse-dir-list-res-obj-result-text 
					    model)
					   (browse-dir-list-res-obj-working-directory
					    model)
					   (browse-dir-list-res-obj-width model)
					   (browse-dir-list-res-obj-initial-wd
					    model)
					   new-marked-items
					   new-res-marked-items
					   #f)))
			  new-model)))))))
	 
	 ;; user pressed 'u' --- unmark current entry
	 ((= key key-u)
	  (let* ((marked-items (browse-dir-list-res-obj-marked-items model))
		 (res-marked-items (browse-dir-list-res-obj-res-marked-items
				    model))
		 (actual-pos (browse-dir-list-res-obj-pos-y model))
		 (all-items (browse-dir-list-res-obj-file-list model)))
	    (if (<= actual-pos 2)
		model
		(let* ((actual-item (list-ref all-items (- actual-pos 3)))
		       (actual-res-item (string-append (cwd) "/" actual-item))
		       (rest (member actual-item marked-items))
		       (res-rest (member actual-res-item res-marked-items)))
		  (if (not res-rest)
		      model
		      (let* ((after-item (length rest))
			     (all-items (length marked-items))
			     (before-item (sublist marked-items
						   0 
						   (- all-items
						      after-item )))
			     (new-marked-items (append before-item
						       (list-tail rest 1)))
			     (after-res-item (length res-rest))
			     (all-res-items (length res-marked-items))
			     (before-res-item (sublist res-marked-items
						       0
						       (- all-res-items 
							  after-res-item)))
			     (new-res-marked-items (append before-res-item
							   (list-tail res-rest
								      1)))
			     (new-model (make-browse-dir-list-res-obj
					 (browse-dir-list-res-obj-pos-y model)
					 (browse-dir-list-res-obj-pos-x model)
					 (browse-dir-list-res-obj-file-list 
					  model)
					 (browse-dir-list-res-obj-result-text 
					  model)
					 (browse-dir-list-res-obj-working-directory
					  model)
					 (browse-dir-list-res-obj-width model)
					 (browse-dir-list-res-obj-initial-wd
					  model)
					 new-marked-items
					 new-res-marked-items
					 #f)))
			new-model))))))

	 ((= key key-up)
	  (let ((posy (browse-dir-list-res-obj-pos-y model)))
	    (if (<= posy 2)
		model
		(let* ((new-posy (- posy 1))
		       (new-model (make-browse-dir-list-res-obj 
				   new-posy
				   (browse-dir-list-res-obj-pos-x model)
				   (browse-dir-list-res-obj-file-list model)
				   (browse-dir-list-res-obj-result-text model)
				   (browse-dir-list-res-obj-working-directory 
				    model)
				   (browse-dir-list-res-obj-width model)
				   (browse-dir-list-res-obj-initial-wd model)
				   (browse-dir-list-res-obj-marked-items model)
				   (browse-dir-list-res-obj-res-marked-items 
				    model)
				   #f)))
		  new-model))))

	 ((= key key-down)
	  (let ((posy (browse-dir-list-res-obj-pos-y model))
		(num-lines (length 
			    (browse-dir-list-res-obj-result-text model))))
	    (if (>= posy num-lines)
		model
		(let* ((new-posy (+ posy 1))
		       (new-model (make-browse-dir-list-res-obj 
				   new-posy
				   (browse-dir-list-res-obj-pos-x model)
				   (browse-dir-list-res-obj-file-list model)
				   (browse-dir-list-res-obj-result-text model)
				   (browse-dir-list-res-obj-working-directory 
				    model)
				   (browse-dir-list-res-obj-width model)
				   (browse-dir-list-res-obj-initial-wd model)
				   (browse-dir-list-res-obj-marked-items model)
				   (browse-dir-list-res-obj-res-marked-items 
				    model)
				   #f)))
		  new-model))))
	 
	 ((= key 10)
	  (selected-browse-dir-list model))
	 
	 ;; user pressed C-x
	 ((= key 24)
	  (make-browse-dir-list-res-obj
 	   (browse-dir-list-res-obj-pos-y model)
 	   (browse-dir-list-res-obj-pos-x model)
 	   (browse-dir-list-res-obj-file-list model)
 	   (browse-dir-list-res-obj-result-text model)
 	   (browse-dir-list-res-obj-working-directory 
 	    model)
 	   (browse-dir-list-res-obj-width model)
 	   (browse-dir-list-res-obj-initial-wd model)
 	   (browse-dir-list-res-obj-marked-items model)
 	   (browse-dir-list-res-obj-res-marked-items 
 	    model)
 	   (not c-x-pressed)))
	 
	 (else model))))


     ((restore-message? message)
      (let* ((model (restore-message-object message))
	     (initial-wd (browse-dir-list-res-obj-initial-wd model)))
	(chdir initial-wd)))
     
     ((selection-message? message)
      (let* ((model (selection-message-object message))
	     (marked-items (browse-dir-list-res-obj-res-marked-items model)))
	(string-append "'" (exp->string marked-items)))))))

(define browse-dir-list-rec (make-receiver "browse-dir-list" 
					   browse-dir-list-receiver))

(set! receivers (cons browse-dir-list-rec receivers))