new commands added

scheme/cd.scm

@@ -0,0 +1,194 @@
+;;cd
+;;This command can be used on all platforms because it uses the 
+;;scsh-Function "chdir"
+
+(define-record-type cd-result-object cd-result-object
+  (make-cd-result-object pos-y
+			 pos-x
+			 file-list
+			 result-text
+			 working-directory
+			 width
+			 initial-wd
+			 marked-items
+			 res-marked-items)
+  cd-result-object?
+  (pos-y cd-result-object-pos-y)
+  (pos-x cd-result-object-pos-x)
+  (file-list cd-result-object-file-list)
+  (result-text cd-result-object-result-text)
+  (working-directory cd-result-object-working-directory)
+  (width cd-result-object-width)
+  (initial-wd cd-result-object-initial-wd)
+  (marked-items cd-result-object-marked-items)
+  (res-marked-items cd-result-object-res-marked-items))
+
+;;Layout of the result of cd
+(define layout-result-cd
+  (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) printed-file-list))))))
+
+;;One File per-line
+;;In case the object is a directory "/" is added
+(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))))))))))
+
+;;selection->descend
+(define selected-cd
+  (lambda (model)
+    (let ((ln (cd-result-object-pos-y model))
+	  (wd (cd-result-object-working-directory model)))
+      (begin
+	(chdir wd)
+	(if (or (>= ln (+ (length (cd-result-object-result-text model)) 1))
+		(<= ln 1))
+	    model
+	    (let* ((text (cd-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 (cd-result-object-width model))
+			   (new-text (layout-result-cd 
+				      new-result-string new-result width))
+			   (new-model (make-cd-result-object
+				       2
+				       1
+				       new-result
+				       new-text
+				       (cwd)
+				       width
+				       (cd-result-object-initial-wd model)
+				       (cd-result-object-marked-items model)
+				       (cd-result-object-res-marked-items
+					model))))
+		      new-model))
+		  model)))))))
+
+
+(define cd-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)))
+	     
+	(begin
+	  (if (null? parameters)
+	      (begin
+		(set! result (list "forgot parameters?"))
+		(let* ((text
+			(layout-result-standard "forgot parameters?" 
+						result width))
+		       (std-obj
+			(make-cd-result-object 1 1 result text (cwd) width
+					       (cwd) '() '())))
+		  std-obj))
+	      
+	      (begin
+		(evaluate (string-append "(chdir "
+					 (exp->string (car parameters))
+					 " )"))
+		(set! result (evaluate "(directory-files)"))
+		(let* ((result-string (exp->string result))
+		       (width (next-command-message-width message))
+		       (text 
+			(layout-result-cd result-string result width))
+		       (cd-obj 
+			(make-cd-result-object 2 1 result text (cwd) width
+					       (cwd) '() '())))
+		 cd-obj))))))
+     ((print-message? message)
+      (let* ((model (print-message-object message))
+	     (pos-y (cd-result-object-pos-y model))
+	     (pos-x (cd-result-object-pos-x model))
+	     (text (cd-result-object-result-text model))
+	     (marked-pos (get-marked-positions-2
+			  (cd-result-object-file-list model)
+			  (cd-result-object-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 (cd-result-object-pos-y model)))
+	    (if (<= posy 2)
+		model
+		(let* ((new-posy (- posy 1))
+		       (new-model (make-cd-result-object 
+				   new-posy
+				   (cd-result-object-pos-x model)
+				   (cd-result-object-file-list model)
+				   (cd-result-object-result-text model)
+				   (cd-result-object-working-directory model)
+				   (cd-result-object-width model)
+				   (cd-result-object-initial-wd model)
+				   (cd-result-object-marked-items model)
+				   (cd-result-object-res-marked-items model))))
+		  new-model))))
+
+	 ((= key key-down)
+	  (let ((posy (cd-result-object-pos-y model))
+		(num-lines (length 
+			    (cd-result-object-result-text model))))
+	    (if (>= posy num-lines)
+		model
+		(let* ((new-posy (+ posy 1))
+		       (new-model (make-cd-result-object 
+				   new-posy
+				   (cd-result-object-pos-x model)
+				   (cd-result-object-file-list model)
+				   (cd-result-object-result-text model)
+				   (cd-result-object-working-directory model)
+				   (cd-result-object-width model)
+				   (cd-result-object-initial-wd model)
+				   (cd-result-object-marked-items model)
+				   (cd-result-object-res-marked-items model))))
+		  new-model))))
+
+     ((= key 10)
+	  (selected-cd model))
+     (else model))))
+
+
+     ((restore-message? message)
+      values)
+     ((selection-message? message)
+      ""))))
+
+
+(define cd-rec (make-receiver "cd" cd-receiver))
+
+(set! receivers (cons cd-rec receivers))

scheme/directory-files.scm

@@ -66,8 +66,11 @@
 ;;Auswahl->absteigen
 (define selected-dirfiles
   (lambda (model)
-    (let ((ln (dirfiles-result-object-pos-y model)))
+    (let ((ln (dirfiles-result-object-pos-y model))
-      (if (or (>= ln (+ (length (dirfiles-result-object-result-text model)) 1))
+	  (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)
@@ -78,7 +81,8 @@
 				  (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-result-string 
+					     new-result width))
 				  (new-model (make-dirfiles-result-object
 					      2
 					      1
@@ -121,7 +125,7 @@
 						(dirfiles-result-object-res-marked-items
 						 model))))
 			       new-model))
-		    model)))))))
+			   model))))))))
 
 
 ;;Receiver für directory-files
@@ -131,7 +135,7 @@
 
      ((next-command-message? message)
       (let* ((command (next-command-string message))
-	     (result (evaluate command))
+	     (result (evaluate "(directory-files)"))
 	     (result-string (exp->string result))
 	     (width (next-command-message-width message))
 	     (text (layout-result-dirfiles result-string result width))
@@ -144,7 +148,7 @@
 	     (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 
+	     (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)))
@@ -211,8 +215,12 @@
 		 (all-items (dirfiles-result-object-file-list model)))
 	    (if (<= actual-pos 2)
 		model
-		(let* ((actual-item (list-ref all-items (- actual-pos 3)))
+		(let ((actual-item (list-ref all-items (- actual-pos 3)))
-		       (actual-res-item (string-append (cwd) "/" actual-item)))
+		      (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
@@ -234,7 +242,7 @@
 					    model)
 					   new-marked-items
 					   new-res-marked-items)))
-			new-model))))))
+			  new-model)))))))
 	 
 	 ;;Ctrl+u -> aus Auswahl rausnehmen
 	 ((= key 21)
@@ -304,8 +312,13 @@
      (else   values))))
 
 
-(define dir-files-rec
+(define dir-files-rec1
-  (make-receiver "(directory-files)"  dir-files-receiver))
+  (make-receiver "directory-files"  dir-files-receiver))
 	   
-(define receivers (cons dir-files-rec '()))
+(set! receivers (cons dir-files-rec1 receivers))
+
+(define dir-files-rec2
+  (make-receiver "ls" dir-files-receiver))
+
+(set! receivers (cons dir-files-rec2 receivers))
 

scheme/find.scm

@@ -0,0 +1,185 @@
+;;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))

scheme/handle-fatal-error.scm

@@ -43,7 +43,8 @@
       ((call-with-current-continuation
          (lambda (k)
 	   (with-handler (lambda (condition more)
-			   (if (error? condition)
+			   (if (or (error? condition)
+				   (warning? condition))
 			       (call-with-current-continuation
 				 (lambda (decline)
 				   (k (lambda () (handler condition decline))))))

scheme/nuit-engine.scm

@@ -1,3 +1,6 @@
+;;  ,load /home/demattia/studium/studienarbeit/scsh-nuit/scheme/nuit-engine.scm
+
+
 ;;This is the "heart" of NUIT.
 ;;In a central loop the program waits for input (with wgetch).
 ;;In the upper buffer simply the functionalities of scsh-ncurses:
@@ -18,11 +21,14 @@
 (define result-win)
 
 (define shortcuts '("F1:Exit"
+		    "F2:Repaint (after change of buffer size)"
 		    "Ctrl+d:Switch Buffer"
 		    "Ctrl+s:Insert/Select"
 		    "Ctrl+u:-/Unselect"
-		    "Ctrl+p:History->prev"
+		    "Ctrl+p:Result-History->prev"
-		    "Ctrl+n:History->next"
+		    "Ctrl+n:Result-History->next"
+		    "Ctrl+f:Command-History->forward"
+		    "Ctrl+b:Command-History->back"
 		    "Ctrl+a:First Pos"
 		    "Ctrl+e:End"))
 		    
@@ -67,7 +73,7 @@
 ;;state of the lower window (Result-Window)
 ;;----------------------------
 ;;Text
-(define text-result (list "Start entering commands."))
+(define text-result (list "Type 'shortcuts' for help"))
 
 ;;line of the result-window
 (define pos-result 0)
@@ -111,18 +117,26 @@
 ;;data-type for history.entries
 (define-record-type history-entry history-entry
   (make-history-entry command
+		      parameters
 		      result-object)
   history-entry?
   (command history-entry-command)
+  (parameters history-entry-parameters)
   (result-object history-entry-result-object))
 
 ;;active command
 (define active-command "")
 
+;;sctive parameters
+(define active-parameters "")
+
 ;;active result-object
 (define current-result-object)
 
-
+;;active keyboard-interrupt:
+;;after each input this is set to #f.
+;;If a keyboard-interrupt occurs this can be checked by looking-up this box
+(define active-keyboard-interrupt #f)
 
 ;;Message-Types
 ;;---------------------
@@ -152,10 +166,12 @@
 ;;print
 (define-record-type print-message print-message
   (make-print-message command-string
-		      object)
+		      object
+		      width)
   print-message?
   (command-string print-message-command-string)
-  (object print-message-object))
+  (object print-message-object)
+  (width print-message-width))
 
 ;;->this sort of data-type is returned by a print-message 
 (define-record-type print-object print-object
@@ -195,9 +211,17 @@
   (command receiver-command)
   (rec receiver-rec))
 
+;;This list contains all the receivers that have been registered.
+(define receivers '())
+
 ;;*************************************************************************
 ;;Actions
       
+;;start the whole thing
+(define nuit
+  (lambda ()
+    (run)))
+
 ;;handle input
 (define run
   (lambda ()
@@ -211,6 +235,12 @@
       (set! command-win (newwin 0 0 0 0))
       (set! result-win (newwin 0 0 0 0))
 
+      ;;Handling Keyboard-interrupts
+      ;;If a keyboard-interrupt occurs it is stored in "active-keyboard-interrupt"
+      (set-interrupt-handler interrupt/keyboard 
+			     (lambda a 
+			       (set! active-keyboard-interrupt a)))
+      
       ;;Loop
       (let loop ((ch (paint)))
 	(cond
@@ -223,8 +253,14 @@
 	    (let ((restore-message (make-restore-message 
 				    active-command
 				    current-result-object)))
-	      (switch restore-message))
+	      (switch restore-message)
-	    (endwin)))
+	      (restore-state))
+	    (endwin)
+	    (display "")))
+
+	 ((= ch key-f2)
+	  (endwin)
+	  (run))
 
 	  ;;Ctrl+f -> switch buffer
 	 ((= ch 4)
@@ -253,7 +289,9 @@
 		(begin
 		  (execute-command)
 		  (set! command-history-pos (- (length text-command) 1))
-		  (loop (paint))))
+		  ;(loop (paint))))
+		  (endwin)
+		  (run)))
 
 
        
@@ -320,47 +358,49 @@
   (lambda ()
   (begin
     (init-screen)
-    (cbreak)
+    ;(cbreak)
-    (let* ((bar1-y 0)
+    (let* ((bar1-y 1)
-	   (bar1-x 0)
+	   (bar1-x 1)
-	   (bar1-h 3)
+	   (bar1-h 2)
-	   (bar1-w (COLS))
+	   (bar1-w (- (COLS) 2))
-	   (bar2-y (round (/ (LINES) 3)))
+	   (bar2-y (+ (round (/ (LINES) 3)) 2))
-	   (bar2-x 0)
+	   (bar2-x 1)
 	   (bar2-h 3)
-	   (bar2-w (COLS))
+	   (bar2-w (- (COLS) 2))
-	   (comwin-y 3)
+	   (comwin-y 2)
-	   (comwin-x 0)
+	   (comwin-x 1)
-	   (comwin-h (- bar2-y 3))
+	   (comwin-h (- bar2-y 2))
-	   (comwin-w (COLS))
+	   (comwin-w (- (COLS) 2))
 	   (reswin-y (+ bar2-y 3))
-	   (reswin-x 0)
+	   (reswin-x 1)
-	   (reswin-h (- (- (- (LINES) 6) comwin-h) 4))
+	   (reswin-h (- (- (LINES) 6) comwin-h))
-	   (reswin-w (COLS))
+	   (reswin-w (- (COLS) 2)))
-	   (bar3-y (+ reswin-y reswin-h))
+	   ; (bar3-y (+ reswin-y reswin-h))
-	   (bar3-x 0)
+; 	   (bar3-x 0)
-	   (bar3-h 4)
+; 	   (bar3-h 4)
-	   (bar3-w (COLS)))
+; 	   (bar3-w (COLS)))
 
       (wclear bar1) 
       (wclear bar2)
       (wclear command-win)
       (wclear result-win)
-      (wclear bar3)
+;     (wclear bar3)
       (clear)
 
       (set! bar1 (newwin bar1-h bar1-w bar1-y bar1-x))
       (set! bar2 (newwin bar2-h bar2-w bar2-y bar2-x))
       (set! command-win (newwin  comwin-h comwin-w comwin-y comwin-x))
       (set! result-win (newwin reswin-h reswin-w reswin-y reswin-x))
-      (set! bar3 (newwin bar3-h bar3-w bar3-y bar3-x))
+      ;(set! bar3 (newwin bar3-h bar3-w bar3-y bar3-x))
       
-      (box bar1 (ascii->char 0) (ascii->char 0))
+      (box standard-screen (ascii->char 0) (ascii->char 0))
-      (mvwaddstr bar1  1 1 "Command")
+      (refresh)
+      ;(box bar1 (ascii->char 0) (ascii->char 0))
+      (mvwaddstr bar1  0 1 "SCSH-NUIT")
       (wrefresh bar1)
-      (box bar2 (ascii->char 0) (ascii->char 0))
+
-      (mvwaddstr bar2  1 1 "Result")
+      ;(mvwaddstr bar2  1 1 active-command)
-      (wrefresh bar2)
+      ;(wrefresh bar2)
       (box command-win (ascii->char 0) (ascii->char 0))
       (set! command-lines (- comwin-h 2))
       (set! command-cols (- comwin-w 3))
@@ -384,11 +424,14 @@
       (set! result-cols (- reswin-w 3))
       (print-result-buffer result-win)
       (wrefresh result-win)
-      (box bar3 (ascii->char 0) (ascii->char 0))
+      ;(box bar3 (ascii->char 0) (ascii->char 0))
-      (wattron bar3 (A-REVERSE))
+      ;(wattron bar3 (A-REVERSE))
-      (print-bar3 (- reswin-w 3))
+      ;(print-bar3 (- reswin-w 3))
-      (wstandend bar3)
+      ;(wstandend bar3)
-      (wrefresh bar3)
+      ;(wrefresh bar3)
+
+      (box bar2 (ascii->char 0) (ascii->char 0))
+      (print-active-command-win bar2 bar2-w)
   
       (set! command-buffer (cur-right-pos command-win result-win comwin-h 
 					  reswin-h command-buffer))
@@ -415,8 +458,11 @@
 	  (set! can-write-command can-write)
 	  (set! command-history-pos history-pos)))
 
+
+
       (noecho)
       (keypad bar1 #t)
+      (set! active-keyboard-interrupt #f)
       (let ((ch (wgetch bar1)))
 	(echo)
 	  ch
@@ -427,15 +473,22 @@
 ;;which has to be executed.
 (define execute-command
   (lambda ()
-    (let* ((command (list-ref text-command (- (length text-command) 1)))
+    (let* ((com (list-ref text-command (- (length text-command) 1)))
+	   (com-par (extract-com-and-par com))
+	   (command (car com-par))
+	   (parameters (cdr com-par))
 	   ;;todo: parameters
-	   (message (make-next-command-message command '() result-cols))
+	   (message (make-next-command-message 
+		      command parameters result-cols))
 	   (model (switch message)))
       (begin
 	(if (not (= history-pos 0))
 	    (let ((hist-entry (make-history-entry active-command 
+						  active-parameters
 						  current-result-object))
-		  (active (make-history-entry command model)))
+		  (active (make-history-entry command 
+					      (get-param-as-str parameters)
+					      model)))
 	      (begin
 		(if (< history-pos (length history))
 		    (set! history (append history (list hist-entry)))
@@ -444,16 +497,54 @@
 					    (- (length history) 1)) 
 				   (list hist-entry) (list active))))
 		(set! history-pos (length history))))
-	    (let ((hist-entry (make-history-entry command model)))
+	    (let ((hist-entry (make-history-entry 
+			       command 
+			       (get-param-as-str parameters) model)))
 	      (begin
 		(set! history (list hist-entry))
 		(set! history-pos 1))))
 
 	(set! text-command (append text-command (list "")))
 	(set! active-command command)
+	(set! active-parameters (get-param-as-str parameters))
 	(set! current-result-object model)
 	(scroll-command-buffer)))))
 
+;;Extracts the name of the function and its parameters
+(define extract-com-and-par
+  (lambda (com)
+    (if (<= (string-length com) 0)
+	(cons "" '())
+	(if (equal? #\( (string-ref com 0))
+	    (cons com '())
+	    (let* ((fst-word (get-next-word com))
+		  (command (car fst-word))
+		  (rest (cdr fst-word)))
+	      (let loop ((param-str rest)
+			 (param-list '()))
+		(let* ((word (get-next-word param-str))
+		       (param (car word))
+		       (more (cdr word)))
+		  (if (equal? "" param)
+		      (cons command param-list)
+		      (loop more (append param-list (list param))))))))))) 
+
+;;gets the next word from a string
+(define get-next-word
+  (lambda (str)
+    (let loop ((old str)
+	       (new ""))
+      (if (= 0 (string-length old))
+	  (cons new old)
+	  (if (equal? #\space (string-ref old 0))
+	      (if (= 1 (string-length old))
+		  (cons new "")
+		  (cons new (substring old 1 (string-length old))))
+	      (loop (substring old 1 (string-length old))
+		    (string-append new (string (string-ref old 0)))))))))
+		    
+		  
+
 ;;scroll buffer after one command was entered
 (define scroll-command-buffer
   (lambda ()
@@ -554,12 +645,36 @@
 	    (sublist l 0 height)
 	    (sublist l (- pos height) height)))))
 
+;;print the active-command window:
+(define print-active-command-win
+  (lambda (win width)
+    (if (<= width 25)
+	values
+	(let ((active-command (string-append active-command 
+					     active-parameters)))
+	(if (> (string-length active-command) (- width 25))
+	    (let* ((com-txt (substring active-command 
+				       0
+				       (- width 25)))
+		   (whole-text (string-append "Active Command: "
+					      com-txt
+					      "...")))
+	      (begin
+		(mvwaddstr win 1 2 whole-text)
+		(wrefresh win)))
+	    (begin
+	      (mvwaddstr win 1 2 (string-append "Active Command: " 
+						active-command))
+	      (wrefresh win)))))))
+
+
 
 ;;print the lower window
 (define print-result-buffer
   (lambda (reswin)
     (let* ((print-message (make-print-message active-command 
-					      current-result-object))
+					      current-result-object
+					      command-cols))
 	   (model (switch print-message))
 	   (text (print-object-text model))
 	   (pos-y (print-object-pos-y model))
@@ -579,6 +694,22 @@
 	    (if (> pos result-lines)
 		values
 		(let ((line (list-ref lines (- pos 1))))
+		  (begin
+		    (if (not (standard-result-obj? current-result-object))
+			(set! line 
+			      (if (>= (string-length line) (- result-cols 2))
+				  (let ((start-line 
+					 (substring line 0
+						    (- (ceiling (/ result-cols 2))
+						       3)))
+					(end-line
+					 (substring line 
+						    (- (string-length line)
+						       (ceiling 
+							(/ result-cols 2)))
+						    (string-length line))))
+				    (string-append start-line "..." end-line))
+				  line)))
 		    (if (and (member pos highlighted-lines)
 			     (= active-buffer 2))
 			(begin
@@ -597,7 +728,7 @@
 			    (begin
 			      (mvwaddstr reswin pos 1 line)
 			      (wrefresh reswin)
-			    (loop (+ pos 1)))))))))))))
+			      (loop (+ pos 1))))))))))))))
   
 ;;visible lines
 (define get-right-result-lines
@@ -668,51 +799,51 @@
 	  (set! result-buffer-pos-x pos-result-col)))))
 
 
-;;index of shortcuts at the bottom
+; ;;index of shortcuts at the bottom
-(define print-bar3
+; (define print-bar3
-  (lambda (width)
+;   (lambda (width)
-    (let loop ((pos 0)
+;     (let loop ((pos 0)
-	       (used-width 0)
+; 	       (used-width 0)
-	       (act-line 1))
+; 	       (act-line 1))
-      (if (>= pos (length shortcuts))
+;       (if (>= pos (length shortcuts))
-	  (begin
+; 	  (begin
-	    (let* ((num-blanks (+ (- width used-width) 1))
+; 	    (let* ((num-blanks (+ (- width used-width) 1))
-		   (last-string (make-string num-blanks #\space)))
+; 		   (last-string (make-string num-blanks #\space)))
-	      (mvwaddstr bar3 act-line (+ used-width 1) last-string))
+; 	      (mvwaddstr bar3 act-line (+ used-width 1) last-string))
-	    (wrefresh bar3))
+; 	    (wrefresh bar3))
-	  (let* ((act-string (list-ref shortcuts pos))
+; 	  (let* ((act-string (list-ref shortcuts pos))
-		 (act-length (string-length act-string))
+; 		 (act-length (string-length act-string))
-		 (rest-width (- width used-width)))
+; 		 (rest-width (- width used-width)))
-	    (if (= act-line 1)
+; 	    (if (= act-line 1)
-		(if (<= (+ act-length 3) rest-width)
+; 		(if (<= (+ act-length 3) rest-width)
-		    (if (= used-width 0)
+; 		    (if (= used-width 0)
-			(begin
+; 			(begin
-			  (mvwaddstr bar3 1 (+ used-width 1) act-string)
+; 			  (mvwaddstr bar3 1 (+ used-width 1) act-string)
-			  (loop (+ pos 1) (+ used-width act-length) 1))	    
+; 			  (loop (+ pos 1) (+ used-width act-length) 1))	    
-			(begin
+; 			(begin
-			  (mvwaddstr bar3 1 (+ used-width 1)
+; 			  (mvwaddstr bar3 1 (+ used-width 1)
-				     (string-append " | " act-string))
+; 				     (string-append " | " act-string))
-			  (loop (+ pos 1) (+ used-width (+ 3 act-length))
+; 			  (loop (+ pos 1) (+ used-width (+ 3 act-length))
-				1)))
+; 				1)))
-		    (begin
+; 		    (begin
-		      (let* ((num-blanks (+ rest-width 1))
+; 		      (let* ((num-blanks (+ rest-width 1))
-			     (last-string (make-string num-blanks #\space)))
+; 			     (last-string (make-string num-blanks #\space)))
-			(mvwaddstr bar3 1 (+ used-width 1) last-string))       
+; 			(mvwaddstr bar3 1 (+ used-width 1) last-string))       
-		      (loop pos 0 2)))
+; 		      (loop pos 0 2)))
-		(if (<= (+ act-length 3) rest-width)
+; 		(if (<= (+ act-length 3) rest-width)
-		    (if (= used-width 0)
+; 		    (if (= used-width 0)
-			(begin
+; 			(begin
-			  (mvwaddstr bar3 2 (+ used-width 1) act-string)
+; 			  (mvwaddstr bar3 2 (+ used-width 1) act-string)
-			  (loop (+ pos 1) (+ used-width act-length) 2))
+; 			  (loop (+ pos 1) (+ used-width act-length) 2))
-			(begin
+; 			(begin
-			  (mvwaddstr bar3 2 (+ used-width 1)
+; 			  (mvwaddstr bar3 2 (+ used-width 1)
-				     (string-append " | " act-string))
+; 				     (string-append " | " act-string))
-			  (loop (+ pos 1) (+ used-width (+ 3 act-length)) 2)))
+; 			  (loop (+ pos 1) (+ used-width (+ 3 act-length)) 2)))
-		    (begin
+; 		    (begin
-		      (let* ((num-blanks (+ rest-width 1) )
+; 		      (let* ((num-blanks (+ rest-width 1) )
-			     (last-string (make-string num-blanks #\space)))
+; 			     (last-string (make-string num-blanks #\space)))
-			(mvwaddstr bar3 2 (+ used-width 1) last-string))
+; 			(mvwaddstr bar3 2 (+ used-width 1) last-string))
-		      (wrefresh bar3)))))))))
+; 		      (wrefresh bar3)))))))))
 			
 
 
@@ -723,14 +854,12 @@
 	values
 	(let* ((hist-entry (list-ref history (- history-pos 1)))
 	       (entry-com (history-entry-command hist-entry))
+	       (entry-par (history-entry-parameters hist-entry))
 	       (entry-res-obj (history-entry-result-object hist-entry)))
 	  (begin
 	    (set! active-command entry-com)
+	    (set! active-parameters entry-par)
 	    (set! current-result-object entry-res-obj)
-	    (set! text-command (append
-				(sublist text-command 0
-					 (- (length text-command) 1))
-				(list entry-com)))
 	    (if (> history-pos 1)
 		(set! history-pos (- history-pos 1))))))))
 
@@ -738,24 +867,17 @@
 ;;one step forward
 (define history-forward
   (lambda ()
-    (if (= history-pos  (length history) )
-	(set! text-command (append 
-				(sublist text-command 0 
-					(- (length text-command) 1))
-				(list "")))
 	(if (> history-pos (- (length history) 1))
 	    values
 	    (let* ((hist-entry (list-ref history history-pos))
 		   (entry-com (history-entry-command hist-entry))
+		   (entry-par (history-entry-parameters hist-entry))
 		   (entry-res-obj (history-entry-result-object hist-entry)))
 	      (begin
-		(set! text-command (append 
-				    (sublist text-command 0 
-					     (- (length text-command) 1))
-				    (list entry-com)))
 		(set! active-command entry-com)
+		(set! active-parameters entry-par)
 		(set! current-result-object entry-res-obj)
-		(set! history-pos (+ history-pos 1))))))))
+		(set! history-pos (+ history-pos 1)))))))
 				
 (define sublist
   (lambda (l pos k)
@@ -764,6 +886,67 @@
 			  (- (length tmp) k))))))
  
 
+;;When NUIT is closed the state has to be restored, in order to let the
+;;user start again from scratch 
+(define restore-state
+  (lambda ()
+    (begin
+      (set! text-command (list "Welcome in the scsh-ncurses-ui!" ""))
+      (set! pos-command 2)
+      (set! pos-command-col 2)
+      (set! pos-command-fin-ln 2)
+      (set! command-buffer-pos-y 2)
+      (set! command-buffer-pos-x 2)
+      (set! command-lines 0)
+      (set! command-cols 0)
+      (set! can-write-command #t)
+      (set! command-history-pos 1)
+      (set! command-buffer #f)
+      (set! text-result (list "Start entering commands."))
+      (set! pos-result 0)
+      (set! pos-result-col 0)
+      (set! result-buffer-pos-y 0)
+      (set! result-buffer-pos-x 0)
+      (set! result-lines 0)
+      (set! result-cols 0)
+      (set! highlighted-lines '())
+      (set! marked-lines '())
+      (set! active-buffer 1)
+      (set! history '())
+      (set! history-pos 0)
+      (set! active-command "")
+      (set! current-result-object init-std-res)
+      (set! active-keyboard-interrupt #f))))
+    
+;;Shortcuts-receiver:
+;;-------------------
+;;If the user enters the command "shortcuts" a list of the included
+;;shortcuts is displayed
+(define-record-type shortcut-result-obj shortcut-result-obj
+  (make-shortcut-result-obj a)
+  shortcut-result-object?
+  (a shortcut-result-object-a))
+
+(define shortcut-receiver
+  (lambda (message)
+    (cond
+     ((next-command-message? message)
+      (make-shortcut-result-obj #t))
+     ((print-message? message)
+      (make-print-object 1 1 shortcuts '() '()))
+     ((key-pressed-message? message)
+      (key-pressed-message-result-model message))
+     ((restore-message? message)
+      values)
+     ((selection-message? message)
+      ""))))
+
+(define shortcut-rec (make-receiver "shortcuts" shortcut-receiver))
+
+(set! receivers (cons shortcut-rec receivers))
+
+
+
 ;;Standard-Receiver
 ;;-----------------
 
@@ -771,13 +954,16 @@
 (define-record-type standard-result-obj standard-result-obj
   (make-standard-result-obj cursor-pos-y
 			    cursor-pos-x
-			    result-text)
+			    result-text
+			    result)
   standard-result-obj?
   (cursor-pos-y standard-result-obj-cur-pos-y)
   (cursor-pos-x standard-result-obj-cur-pos-x)
-  (result-text standard-result-obj-result-text))
+  (result-text standard-result-obj-result-text)
+  (result standard-result-obj-result))
 
-(define init-std-res (make-standard-result-obj 1 1 text-result))
+(define init-std-res (make-standard-result-obj 1 1 text-result 
+					       (car text-result)))
 
 (set! current-result-object init-std-res)
 
@@ -794,13 +980,16 @@
 	(let* ((text 
 		(layout-result-standard result-string result width))
 	       (std-obj 
-		(make-standard-result-obj 1 1 text)))
+		(make-standard-result-obj 1 1 text result)))
 	  std-obj)))
      ((print-message? message)
       (let* ((model (print-message-object message))
 	     (pos-y (standard-result-obj-cur-pos-y model))
 	     (pos-x (standard-result-obj-cur-pos-x model))
-	     (text (standard-result-obj-result-text model))) 
+	     (width (print-message-width message))
+	     (result (standard-result-obj-result model))
+	     (text (layout-result-standard (exp->string result)
+					   result width))) 
 	(make-print-object pos-y pos-x text '() '())))
      ((key-pressed-message? message)
       (key-pressed-message-result-model message))
@@ -816,7 +1005,19 @@
 
 
 ;useful helpers
-(define get-marked-positions
+(define get-marked-positions-2
+  (lambda (all-items marked-items)
+    (let loop ((count 0)
+	       (result '()))
+      (if (>= count (length all-items))
+	  result
+	  (let ((act-item (list-ref all-items count)))
+	    (if (member act-item marked-items)
+		(loop (+ count 1)
+		      (append result (list (+ count 2))))
+		(loop (+ count 1) result)))))))
+
+(define get-marked-positions-3
   (lambda (all-items marked-items)
     (let loop ((count 0)
 	       (result '()))
@@ -828,7 +1029,6 @@
 		      (append result (list (+ count 3))))
 		(loop (+ count 1) result)))))))
 
-
 ;;expression as string
 (define exp->string
   (lambda (exp)
@@ -837,9 +1037,6 @@
        (write exp exp-port)
        (get-output-string exp-port)))))
 
-
-
-
 ;;seperate a long line into pieces, each fitting into a smaller line.
 (define seperate-line
   (lambda (line width)
@@ -856,3 +1053,14 @@
 	    (loop (cons next-line new) rest-old))))))
 
 
+(define get-param-as-str
+  (lambda (param-lst)
+    (let loop ((lst param-lst)
+	       (str ""))
+      (if (null? lst)
+	  str
+	  (loop (cdr lst)
+		(string-append str " " (car lst)))))))
+
+
+

scheme/nuit-packages.scm

@@ -1,5 +1,5 @@
 (define-interface nuit-interface
-  (export run))
+  (export nuit))
 
 (define-structure nuit nuit-interface    
   (open scheme-with-scsh
@@ -13,4 +13,6 @@
 	rt-modules)
   (files nuit-engine
 	 handle-fatal-error
-	 directory-files))
+	 directory-files
+	 find
+	 cd))