commander-s/scheme/directory-files.scm

;;directory-files
;;---------------


(define initial-working-directory (cwd))

;;Result-Object f<>r "directory-files"
(define-record-type dirfiles-result-object dirfiles-result-object
  (make-dirfiles-result-object pos-y
			       pos-x
			       file-list
			       result-text
			       working-directory
			       width
			       initial-wd
			       marked-items
			       res-marked-items)
  dirfiles-result-object?
  (pos-y dirfiles-result-object-pos-y)
  (pos-x dirfiles-result-object-pos-x)
  (file-list dirfiles-result-object-file-list)
  (result-text dirfiles-result-object-result-text)
  (working-directory dirfiles-result-object-working-directory)
  (width dirfiles-result-object-width)
  (initial-wd dirfiles-result-object-initial-wd)
  (marked-items dirfiles-result-object-marked-items)
  (res-marked-items dirfiles-result-object-res-marked-items))

;;Darstellung, falls die Eingabe ist: "(directory-files)"
(define layout-result-dirfiles
  (lambda (result-str result width)
    (begin
      (let ((printed-file-list (print-file-list result))
	    (directory (cwd))
	    (heading ""))
	(begin
	  (if (<= (string-length directory) (- width 27))
	      (set! heading (string-append "Directory-Content of " 
					   directory  " :"))
	      (let ((dir-string (substring directory 
					   (- (string-length directory) 
					      (- width 27))
					   (string-length directory))))
	      (set! heading (string-append "Directory-Content of ..."
					   dir-string))))
	  (append (list heading) (list " <-")
		  printed-file-list))))))


;;Eine Datei pro Zeile
;;Falls es sich um ein Verzeichnis handelt wird "/" hinzugef<65>gt
(define print-file-list
  (lambda (file-list)
    (let loop ((old file-list)
	       (new '()))
      (if (equal? '() old)
	  new
	  (let ((hd (list-ref old 0))
		(tl (cdr old)))
	    (if (file-directory? hd)
		(let ((new-str (string-append " " hd "/")))
		  (loop tl (append new (list new-str))))
		(loop tl (append new (list (string-append " " hd))))))))))

;;Auswahl->absteigen
(define selected-dirfiles
  (lambda (model)
    (let ((ln (dirfiles-result-object-pos-y model))
	  (wd (dirfiles-result-object-working-directory model)))
      (begin (chdir wd)
	     (if (or (>= ln (+ (length 
				(dirfiles-result-object-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 (dirfiles-result-object-width model))
				  (new-text (layout-result-dirfiles 
					     new-result-string 
					     new-result width))
				  (new-model (make-dirfiles-result-object
					      2
					      1
					      new-result
					      new-text
					      (cwd)
					      width
					      (dirfiles-result-object-initial-wd 
					       model)
					      (dirfiles-result-object-marked-items
					       model)
					      (dirfiles-result-object-res-marked-items
					       model))))
			     new-model))
			 model)
		     (let* ((text (dirfiles-result-object-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 rest)
			     (let* ((new-result (evaluate "(directory-files)"))
				    (new-result-string (exp->string new-result))
				    (width (dirfiles-result-object-width model))
				    (new-text (layout-result-dirfiles 
					       new-result-string new-result width))
				    (new-model (make-dirfiles-result-object
						2
						1
						new-result
						new-text
						(cwd)
						width
						(dirfiles-result-object-initial-wd
						 model)
						(dirfiles-result-object-marked-items
						 model)
						(dirfiles-result-object-res-marked-items
						 model))))
			       new-model))
			   model))))))))


;;Receiver f<>r directory-files
(define dir-files-receiver
  (lambda (message)
    (cond

     ((next-command-message? message)
      (let* ((command (next-command-string message))
	     (result (evaluate "(directory-files)"))
	     (result-string (exp->string result))
	     (width (next-command-message-width message))
	     (text (layout-result-dirfiles result-string result width))
	     (model (make-dirfiles-result-object 2 1 result text (cwd) 
						 width (cwd) '() '())))
	model))

     ((print-message? message)
      (let* ((model (print-message-object message))
	     (posy (dirfiles-result-object-pos-y model))
	     (posx (dirfiles-result-object-pos-x model))
	     (text (dirfiles-result-object-result-text model))
	     (marked-pos (get-marked-positions-3
			  (dirfiles-result-object-file-list model)
			  (dirfiles-result-object-marked-items model))))
	(make-print-object posy posx text (list posy) marked-pos)))

     ((key-pressed-message? message)
      (let* ((model (key-pressed-message-result-model message))
	     (key (key-pressed-message-key message)))
	(cond
	 
	 ((= key key-up)
	  (let ((posy (dirfiles-result-object-pos-y model)))
	    (if (<= posy 2)
		model
		(let* ((new-posy (- posy 1))
		       (new-model (make-dirfiles-result-object 
				   new-posy
				   (dirfiles-result-object-pos-x model)
				   (dirfiles-result-object-file-list model)
				   (dirfiles-result-object-result-text 
				    model)
				   (dirfiles-result-object-working-directory
				    model)
				   (dirfiles-result-object-width model)
				   (dirfiles-result-object-initial-wd model)
				   (dirfiles-result-object-marked-items 
				    model)
				   (dirfiles-result-object-res-marked-items
				      model))))
		  new-model))))

	 ((= key key-down)
	  (let ((posy (dirfiles-result-object-pos-y model))
		(num-lines (length 
			    (dirfiles-result-object-result-text model))))
	    (if (>= posy num-lines)
		model
		(let* ((new-posy (+ posy 1))
		       (new-model (make-dirfiles-result-object 
				   new-posy
				   (dirfiles-result-object-pos-x model)
				   (dirfiles-result-object-file-list model)
				   (dirfiles-result-object-result-text 
				    model)
				   (dirfiles-result-object-working-directory
				    model)
				   (dirfiles-result-object-width model)
				   (dirfiles-result-object-initial-wd
				    model)
				   (dirfiles-result-object-marked-items
				    model)
				   (dirfiles-result-object-res-marked-items
				      model))))
		  new-model))))

	 ((= key 10)
	  (selected-dirfiles model))

	 ;;Ctrl+s -> Auswahl
	 ((= key 19)
	  (let* ((marked-items (dirfiles-result-object-marked-items model))
		 (res-marked-items (dirfiles-result-object-res-marked-items
				    model))
		 (actual-pos (dirfiles-result-object-pos-y model))
		 (all-items (dirfiles-result-object-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 (equal? (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-dirfiles-result-object
					   (dirfiles-result-object-pos-y model)
					   (dirfiles-result-object-pos-x model)
					   (dirfiles-result-object-file-list 
					    model)
					   (dirfiles-result-object-result-text 
					    model)
					   (dirfiles-result-object-working-directory
					    model)
					   (dirfiles-result-object-width model)
					   (dirfiles-result-object-initial-wd
					    model)
					   new-marked-items
					   new-res-marked-items)))
			  new-model)))))))
	 
	 ;;Ctrl+u -> aus Auswahl rausnehmen
	 ((= key 21)
	  (let* ((marked-items (dirfiles-result-object-marked-items model))
		 (res-marked-items (dirfiles-result-object-res-marked-items
				    model))
		 (actual-pos (dirfiles-result-object-pos-y model))
		 (all-items (dirfiles-result-object-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-dirfiles-result-object
					 (dirfiles-result-object-pos-y model)
					 (dirfiles-result-object-pos-x model)
					 (dirfiles-result-object-file-list 
					  model)
					 (dirfiles-result-object-result-text 
					  model)
					 (dirfiles-result-object-working-directory
					  model)
					 (dirfiles-result-object-width model)
					 (dirfiles-result-object-initial-wd
					  model)
					 new-marked-items
					 new-res-marked-items)))
			new-model))))))
			
		      


	 (else model))))
     
     ((restore-message? message)
      ;(let ((model (restore-message-object message)))
	;(chdir (dirfiles-result-object-initial-wd model))))
      (chdir initial-working-directory))

     ((selection-message? message)
      (let* ((model (selection-message-object message))
	     (marked-items (dirfiles-result-object-res-marked-items model)))
	(string-append "'" (exp->string marked-items))))
		  
				   
      
     (else   values))))


(define dir-files-rec1
  (make-receiver "directory-files"  dir-files-receiver))
	   
(set! receivers (cons dir-files-rec1 receivers))

(define dir-files-rec2
  (make-receiver "ls" dir-files-receiver))

(set! receivers (cons dir-files-rec2 receivers))