commander-s/scheme/find.scm

;;find
;;This extension uses the unix-tool "find". You can only use this command in
;;if "find" is present in your environment.

;;Datatype for the representation of a find-object
(define-record-type find-result-object find-result-object
  (make-find-result-object pos-y
			   pos-x
			   file-list
			   result-text
			   parameters
			   width
			   marked-items
			   res-marked-items)
  find-result-object?
  (pos-y find-res-obj-pos-y)
  (pos-x find-res-obj-pos-x)
  (file-list find-res-obj-file-list)
  (result-text find-res-obj-result-text)
  (parameters find-res-obj-parameters)
  (width find-res-obj-width)
  (marked-items find-res-obj-marked-items)
  (res-marked-items find-res-obj-res-marked-items))
  

;;Layout for Command "find"
(define layout-result-find
  (lambda (result-str result width parameters)
    (begin
      (let ((heading ""))
	(begin
	  (set! result-str (map (lambda (s) (string-append " " s)) result-str))
	  (if (<= (string-length parameters) (- width 10))
	      (set! heading (string-append "find " 
					   parameters  " :"))
	      (let ((dir-string (substring parameters
					   (- (string-length parameters) 
					      (- width 10))
					   (string-length parameters))))
	      (set! heading (string-append "find"  dir-string "..."))))
	  (append (list heading) result-str))))))





(define find-receiver
  (lambda (message)
    (cond 
     ((next-command-message? message)
      (let* ((command (next-command-string message))
	     (parameter (next-command-message-parameters message))
	     (parameters (get-param-as-str parameter))
	     (result (evaluate 
		      (string-append "(run/sexps (find" parameters "))")))
	     (result-string (map exp->string result))
	     (width (next-command-message-width message)))
	(let* ((text 
		(layout-result-find result-string result width parameters))
	       (find-obj 
		(make-find-result-object 2 1 result text parameter width
					 '() '())))
	  find-obj)))

     ((print-message? message)
      (let* ((model (print-message-object message))
	     (pos-y (find-res-obj-pos-y model))
	     (pos-x (find-res-obj-pos-x model))
	     (text (find-res-obj-result-text model))
	     (marked-pos (get-marked-positions-2 
			  (find-res-obj-file-list model)
			  (find-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)))
	(cond
	 
	 ((= key key-up)
	  (let ((posy (find-res-obj-pos-y model)))
	    (if (<= posy 2)
		model
		(let* ((new-posy (- posy 1))
		       (new-model (make-find-result-object 
				   new-posy
				   (find-res-obj-pos-x model)
				   (find-res-obj-file-list model)
				   (find-res-obj-result-text model)
				   (find-res-obj-parameters model)
				   (find-res-obj-width model)
				   (find-res-obj-marked-items model)
				   (find-res-obj-res-marked-items model))))
		  new-model))))

	 ((= key key-down)
	  (let ((posy (find-res-obj-pos-y model))
		(num-lines (length 
			    (find-res-obj-result-text model))))
	    (if (>= posy num-lines)
		model
		(let* ((new-posy (+ posy 1))
		       (new-model (make-find-result-object 
				   new-posy
				   (find-res-obj-pos-x model)
				   (find-res-obj-file-list model)
				   (find-res-obj-result-text model)
				   (find-res-obj-parameters model)
				   (find-res-obj-width model)
				   (find-res-obj-marked-items model)
				   (find-res-obj-res-marked-items model))))
		   new-model))))

     	 ;;Ctrl+s -> select
	 ((= key 19)
	  (let* ((marked-items (find-res-obj-marked-items model))
		 (res-marked-items (find-res-obj-res-marked-items
				    model))
		 (actual-pos (find-res-obj-pos-y model))
		 (all-items (find-res-obj-file-list model)))
	    (if (<= actual-pos 1)
		model
		(let ((actual-item (list-ref all-items (- actual-pos 2)))
		      (actual-res-item #f))
		  (begin
		    (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-find-result-object
					   (find-res-obj-pos-y model)
					   (find-res-obj-pos-x model)
					   (find-res-obj-file-list model)
					   (find-res-obj-result-text model)
					   (find-res-obj-parameters model)
					   (find-res-obj-width model)
					   new-marked-items
					   new-res-marked-items)))
			  new-model)))))))
	 
	 ;;Ctrl+u -> unselect
	 ((= key 21)
	  (let* ((marked-items (find-res-obj-marked-items model))
		 (actual-pos (find-res-obj-pos-y model))
		 (all-items (find-res-obj-file-list model)))
	    (if (<= actual-pos 1)
		model
		(let* ((actual-item (list-ref all-items (- actual-pos 2)))
		       (rest (member actual-item marked-items)))
		  (if (not 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)))
			     (new-model (make-find-result-object
					   (find-res-obj-pos-y model)
					   (find-res-obj-pos-x model)
					   (find-res-obj-file-list model)
					   (find-res-obj-result-text model)
					   (find-res-obj-parameters model)
					   (find-res-obj-width model)
					   new-marked-items
					   '())))
			new-model))))))
	 (else model))))

     ((restore-message? message)
      values)
     ((selection-message? message)
      (let* ((model (selection-message-object message))
	     (marked-items (find-res-obj-marked-items model)))
	(string-append "'" (exp->string 
			    (map exp->string marked-items))))))))

(define find-rec (make-receiver "find" find-receiver))

(set! receivers (cons find-rec receivers))