commander-s/scheme/nuit-engine.scm

;;  ,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:
;;input-buffer are used.
;;The lower window is meant to be used more flexible. Depending on
;;the active command the key-inputs are routed to the correct receiver,
;;where one can specify how to react.

;;*************************************************************************
;;State

;;The different windows
;;------------------------
(define bar1)
(define bar2)
(define bar3)
(define command-win)
(define result-win)

(define shortcuts '("F1:Exit"
		    "F2:Repaint (after change of buffer size)"
		    "Ctrl+x o:Switch Buffer"
		    "Ctrl+x s:Insert/Select"
		    "Ctrl+x u:-/Unselect"
		    "Ctrl+x p:Result-History->prev"
		    "Ctrl+x n:Result-History->next"
		    "Ctrl+x r:Redo (Active Command)"
		    "Ctrl+f:Command-History->forward"
		    "Ctrl+b:Command-History->back"
		    "Ctrl+a:First Pos of Line"
		    "Ctrl+e:End of Line"
		    "Ctrl+k:Delete Line"))
		    


;;state of the upper window (Command-Window)
;;---------------------------
;;Text
(define text-command (list "Welcome in the scsh-ncurses-ui!" ""))

;;position in the history of all commands
(define pos-command 2)

;;col
(define pos-command-col 2)

;;Line after lines have been seperated to fit in the buffer
(define pos-command-fin-ln 2)

;;y-coordinate of the cursor
(define command-buffer-pos-y 2)

;;x-coordinate of the cursor
(define command-buffer-pos-x 2)

;;number of lines in the command-buffer
(define command-lines 0)

;;number of columns in the command-buffer
(define command-cols 0)

;;only true if the curser is in the last line
(define can-write-command #t)

;;active entry of the "edit-history"
(define command-history-pos 1)

;;representation of the whole buffer
(define command-buffer)


;;state of the lower window (Result-Window)
;;----------------------------
;;Text
(define text-result (list "Type 'shortcuts' for help"))

;;line of the result-window
(define pos-result 0)

;;column
(define pos-result-col 0)

;;y-coordinate of the cursor in the result-buffer
(define result-buffer-pos-y 0)

;;x-coordinate of the cursor in the result-buffer
(define result-buffer-pos-x 0)

;;lines of the lower window
(define result-lines 0)

;;columns in the lower window
(define result-cols 0)

;;lines to be highlighted
(define highlighted-lines '())

;;lines to be marked
(define marked-lines '())


  

;;miscelaneous state
;;-------------------

;;1....upper;2....lower
(define active-buffer 1)

;;History
(define history '())

;;Position in the "elaborated" History
(define history-pos 0)

;;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)

;;This indicates if the last input was Ctrl-x
(define c-x-pressed #f)


;;Message-Types
;;---------------------
;;A new command was entered
;;->create a new "object"
(define-record-type next-command-message next-command-message
  (make-next-command-message command-string
			     parameters
			     width)
  next-command-message?
  (command-string next-command-string)
  (parameters next-command-message-parameters)
  (width next-command-message-width))

;;key pressed
;;The object and the key are send to the user-code, who returns the
;;changed object.
(define-record-type key-pressed-message key-pressed-message
  (make-key-pressed-message command-string
			    result-model
			    key)
  key-pressed-message?
  (command-string key-pressed-command-string)
  (result-model key-pressed-message-result-model)
  (key key-pressed-message-key))

;;print
(define-record-type print-message print-message
  (make-print-message command-string
		      object
		      width)
  print-message?
  (command-string print-message-command-string)
  (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
  (make-print-object pos-y
		     pos-x
		     text
		     highlighted-lines
		     marked-lines)
  (pos-y print-object-pos-y)
  (pos-x print-object-pos-x)
  (text print-object-text)
  (highlighted-lines print-object-highlighted-lines)
  (marked-lines print-object-marked-lines))

;;restore (when side-effects occur)
(define-record-type restore-message restore-message
  (make-restore-message command-string
			object)
  restore-message?
  (command-string restore-message-command-string)
  (object restore-message-object))

;;request the selection
(define-record-type selection-message selection-message
  (make-selection-message command-string
			  object)
  selection-message?
  (command-string selection-message-command-string)
  (object selection-message-object))

;;The "user" (who extends the functionality of NUIT) has to inform NUIT
;;about which function is meant to be the receiver, when a certain
;;command is active
(define-record-type receiver receiver
  (make-receiver command rec)
  receiver?
  (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 ()
    (begin

      ;;initialisation
      (init-screen)
      (set! bar1 (newwin 0 0 0 0))
      (set! bar2 (newwin 0 0 0 0))
      (set! bar3 (newwin 0 0 0 0))
      (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
       
	 ;;The result of pressing these keys is independent of which
	 ;;Buffer is active
	 ;;Finish
	 ((= ch key-f1)
	  (begin
	    (let ((restore-message (make-restore-message 
				    active-command
				    current-result-object)))
	      (switch restore-message)
	      (restore-state))
	    (endwin)
	    (display "")))

	 ((= ch key-f2)
	  (endwin)
	  (run))

	 ;;Ctrl-x -> wait for next input
	 ((= ch 24)
	  (begin
	    (set! c-x-pressed (not c-x-pressed))
	    (if (= active-buffer 2)
		(let ((key-message 
		       (make-key-pressed-message active-command
						 current-result-object
						 ch)))
		  (set! current-result-object (switch key-message))))
	    (loop (paint))))

       	 ;;if lower window is active a message is sent.
	 (else
	  (if c-x-pressed
	      (cond

	       ;;Ctrl-x o ->switch buffer
	       ((= ch 111)
		(begin
		  (if (= active-buffer 1)
		      (begin
			(set! active-buffer 2)
			(let ((key-message 
			       (make-key-pressed-message active-command
							 current-result-object
							 97)))
			  (set! current-result-object (switch key-message))))
		      (set! active-buffer 1))
		  (set! c-x-pressed #f)
		  (loop (paint))))

	       ;;C-x p -> result-history back
	       ((= ch 112)
		(begin
		  (history-back)
		  (set! c-x-pressed #f)
		  (loop (paint))))

	       ;;C-x n -> result-history forward
	       ((= ch 110)
	        (begin
		  (history-forward)
		  (set! c-x-pressed #f)
		  (loop (paint))))

	       ;;C-x r -> redo
	       ((= ch 114)
		(if (or (> (length text-command) 2)
			(not (equal? active-command "")))
		    (let ((command-string (string-append active-command
							 active-parameters))
			  (text (sublist text-command 0 
					 (- (length text-command) 1))))
		      (begin
			(switch restore-message)
			(set! text-command (append text 
						   (list command-string)))
			(execute-command)
			(set! command-history-pos (- (length text-command) 1))
			(set! c-x-pressed #f)
			(endwin)
			(run)))
		    (begin
		      (set! c-x-pressed #f)
		      (loop (paint)))))

	       (else
		(begin
		  (if (= active-buffer 2)
		      (let ((key-message 
			     (make-key-pressed-message active-command
						       current-result-object
						       ch)))
			(set! current-result-object (switch key-message)))
		      
		      (if (= ch 115)
			  (let* ((message 
				  (make-selection-message 
				   active-command current-result-object))
				 (marked-items (switch message)))
			    (add-string-to-command-buffer marked-items))))
		  (set! c-x-pressed #f)
		  (loop (paint)))))
	      
	      (if (= active-buffer 2)
		  (let ((key-message 
			 (make-key-pressed-message active-command
						   current-result-object
						   ch)))
		    (begin
		      (set! current-result-object (switch key-message))
		      (loop (paint))))
		  
		  (cond
		   
		   ;;Enter
		   ((= ch 10)
		    (let ((restore-message (make-restore-message 
					    active-command
					    current-result-object)))
		      (begin
			(switch restore-message)
			(execute-command)
			(set! command-history-pos (- (length text-command) 1))
					;(loop (paint))))
			(endwin)
			(run))))
		   
		   
		   
		   ;;Ctrl+p -> History back
		   ; ((= ch 16)
; 		    (begin
; 		      (history-back)
; 		      (loop (paint))))
		   
; 		   ;;Ctrl+n -> History forward
; 		   ((= ch 14)
; 		    (begin
; 		      (history-forward)
; 		      (loop (paint))))

; 		   ;;Ctrl+s -> get selection
; 		   ((= ch 19)
; 	       (let* ((message (make-selection-message active-command 
; 						       current-result-object))
; 		      (marked-items (switch message)))
; 		 (begin
; 		   (add-string-to-command-buffer marked-items)
; 		   (loop (paint)))))

		   (else 
		    (begin
		      (set! command-buffer (make-buffer text-command 
							pos-command
							pos-command-col
							pos-command-fin-ln
							command-buffer-pos-y
							command-buffer-pos-x
							command-lines
							command-cols
							can-write-command
							command-history-pos))
		      (set! command-buffer (input command-buffer ch))
		      (let ((text (buffer-text command-buffer))
			    (pos-line (buffer-pos-line command-buffer))
			    (pos-col (buffer-pos-col command-buffer))
			    (pos-fin-ln (buffer-pos-fin-ln command-buffer))
			    (pos-y (buffer-pos-y command-buffer))
			    (pos-x (buffer-pos-x command-buffer))
			    (num-lines (buffer-num-lines command-buffer))
			    (num-cols (buffer-num-cols command-buffer))
			    (can-write (buffer-can-write command-buffer))
			    (history-pos (buffer-history-pos command-buffer)))
			(begin
			  (set! text-command text)
			  (set! pos-command pos-line)
			  (set! pos-command-col pos-col)
			  (set! pos-command-fin-ln pos-fin-ln)
			  (set! command-buffer-pos-y pos-y)
			  (set! command-buffer-pos-x pos-x)
			  (set! command-lines num-lines)
			  (set! command-cols num-cols)
			  (set! can-write-command can-write)
			  (set! command-history-pos history-pos)))
		      (loop (paint)))))))))))))
       

;;print and wait for input
(define paint
  (lambda ()
  (begin
    (init-screen)
    ;(cbreak)
    (let* ((bar1-y 1)
	   (bar1-x 1)
	   (bar1-h 2)
	   (bar1-w (- (COLS) 2))
	   (bar2-y (+ (round (/ (LINES) 3)) 2))
	   (bar2-x 1)
	   (bar2-h 3)
	   (bar2-w (- (COLS) 2))
	   (comwin-y 2)
	   (comwin-x 1)
	   (comwin-h (- bar2-y 2))
	   (comwin-w (- (COLS) 2))
	   (reswin-y (+ bar2-y 3))
	   (reswin-x 1)
	   (reswin-h (- (- (LINES) 6) comwin-h))
	   (reswin-w (- (COLS) 2)))

      (wclear bar1) 
      (wclear bar2)
      (wclear command-win)
      (wclear result-win)
      (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))
      
      ;(box standard-screen (ascii->char 0) (ascii->char 0))
      ;(refresh)
      (mvwaddstr bar1  0 1 "SCSH-NUIT")
      (wrefresh bar1)

      (box bar2 (ascii->char 0) (ascii->char 0))
      (print-active-command-win bar2 bar2-w)

      (box command-win (ascii->char 0) (ascii->char 0))
      (set! command-lines (- comwin-h 2))
      (set! command-cols (- comwin-w 3))
      
      (set! command-buffer (make-buffer text-command 
					pos-command
					pos-command-col
					pos-command-fin-ln
					command-buffer-pos-y
					command-buffer-pos-x
					command-lines
					command-cols
					can-write-command
					command-history-pos))		
      
      (set! command-buffer (print-command-buffer command-win command-buffer))

      (wrefresh command-win)
      (box result-win (ascii->char 0) (ascii->char 0))
      (set! result-lines (- reswin-h 2))
      (set! result-cols (- reswin-w 3))
      (print-result-buffer result-win)
      (wrefresh result-win)
 
      (set! command-buffer (cur-right-pos command-win result-win comwin-h 
					  reswin-h command-buffer))

      (let ((text (buffer-text command-buffer))
	    (pos-line (buffer-pos-line command-buffer))
	    (pos-col (buffer-pos-col command-buffer))
	    (pos-fin-ln (buffer-pos-fin-ln command-buffer))
	    (pos-y (buffer-pos-y command-buffer))
	    (pos-x (buffer-pos-x command-buffer))
	    (num-lines (buffer-num-lines command-buffer))
	    (num-cols (buffer-num-cols command-buffer))
	    (can-write (buffer-can-write command-buffer))
	    (history-pos (buffer-history-pos command-buffer)))
	(begin
	  (set! text-command text)
	  (set! pos-command pos-line)
	  (set! pos-command-col pos-col)
	  (set! pos-command-fin-ln pos-fin-ln)
	  (set! command-buffer-pos-y pos-y)
	  (set! command-buffer-pos-x pos-x)
	  (set! command-lines num-lines)
	  (set! command-cols num-cols)
	  (set! can-write-command can-write)
	  (set! command-history-pos history-pos)))

      ;(refresh)
      ; (wrefresh command-win)
;       (wrefresh result-win)
;       (wrefresh bar1)
;       (wrefresh bar2)
      

      (noecho)
      (keypad bar1 #t)
      (set! active-keyboard-interrupt #f)
      (let ((ch (wgetch bar1)))
	(echo)
	  ch
	)))))


;;If the user presses enter the last line is interpreted as a command
;;which has to be executed.
(define execute-command
  (lambda ()
    (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 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 
					      (get-param-as-str parameters)
					      model)))
	      (begin
		(if (< history-pos (length history))
		    (set! history (append history (list hist-entry)))
		    (set! history (append 
				   (sublist history 0 
					    (- (length history) 1)) 
				   (list hist-entry) (list active))))
		(set! history-pos (length history))))
	    (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))))
	      (if (equal? #\( (string-ref old 0))
		  (let* ((nw (get-next-word-braces 
			     (substring old 1 
					(string-length old))))
			 (nw-new (car nw))
			 (nw-old (cdr nw)))
		    (loop nw-old (string-append new "(" nw-new)))
		  (loop (substring old 1 (string-length old))
		    (string-append new (string (string-ref old 0))))))))))

(define get-next-word-braces
  (lambda (str)
    (let loop ((old str)
	       (new ""))
      (if (= 0 (string-length old))
	  (cons new old)
	  (if (equal? #\( (string-ref old 0))
	      (let* ((nw (get-next-word-braces 
			  (substring old 1 
				     (string-length old))))
		     (nw-new (car nw))
		     (nw-old (cdr nw)))
		(loop nw-old (string-append new "(" nw-new)))
	      (if (equal? #\) (string-ref old 0))
		  (cons (string-append 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 ()
    (begin
      (set! pos-command (+ pos-command 1))
      (set! pos-command-col 2))))

;;evaluate an expression given as a string
(define evaluate
  (lambda (exp)
    (let* ((command-port (open-input-string exp))
	   (handler (lambda (condition more)
		      (cons 'Error: condition)))
	   (structure (reify-structure 'scheme-with-scsh))
	   (s (load-structure structure))
	   (env (rt-structure->environment structure))
	   (result (with-fatal-error-handler
		    handler
		    (eval (read command-port) env))))
      result)))



;;Message-Passing
;;switch manages that the messages are delivered in the correct way
(define switch
  (lambda (message)
    (let ((command ""))
      (begin
	(cond 
	 ((next-command-message? message)
	  (set! command (next-command-string message)))
	 ((key-pressed-message? message)
	  (set! command (key-pressed-command-string message)))
	 ((print-message? message)
	  (set! command (print-message-command-string message)))
	 ((restore-message? message)
	  (set! command (restore-message-command-string message)))
	 ((selection-message? message)
	  (set! command (selection-message-command-string message))))
	(let ((receiver (get-receiver command)))
	  (if receiver
	      (receiver message)
	      (standard-receiver message)))))))

(define get-receiver
  (lambda (command)
    (let loop ((recs receivers))
      (if (= 0 (length recs))
	  #f
	  (let* ((act-rec (car recs))
		 (act-com (receiver-command act-rec))
		 (act-rec-proc (receiver-rec act-rec)))
	    (if (equal? command act-com)
		act-rec-proc
		(loop (cdr recs))))))))


;;Management of the upper buffer
;;add a char to the buffer
(define add-to-command-buffer
  (lambda (ch)
	(let* ((last-pos (- (length text-command) 1))
	       (old-last-el (list-ref text-command last-pos))
	       (old-rest (sublist text-command 0 last-pos))
	       (before-ch (substring old-last-el 0 
				     (max 0 (- pos-command-col 2))))
	       (after-ch (substring old-last-el 
				    (max 0 (- pos-command-col 2))
				    (string-length old-last-el)))
	       (new-last-el (string-append  before-ch
					    (string (ascii->char ch))
					   after-ch)))
      (set! text-command (append old-rest (list new-last-el)))
      (set! pos-command-col (+ pos-command-col 1)))))

;;add a string to the buffer
(define add-string-to-command-buffer
  (lambda (string)
    (let loop ((str string))
      (if (equal? str "")
	  values
	  (let ((first-ch (string-ref str 0)))
	    (begin
	      (add-to-command-buffer (char->ascii first-ch))
	      (loop (substring str 1 (string-length str)))))))))
	    

;;selection of the visible area of the buffer
(define prepare-lines
  (lambda (l height pos)
    (if (< (length l) height)
	(let loop ((tmp-list l))
	  (if (= height (length tmp-list))
	      tmp-list
	      (loop (append tmp-list (list "")))))
	(if (<  pos height)
	    (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
					      command-cols))
	   (model (switch print-message))
	   (text (print-object-text model))
	   (pos-y (print-object-pos-y model))
	   (pos-x (print-object-pos-x model))
	   (highlighted-lns (print-object-highlighted-lines model))
	   (marked-lns (print-object-marked-lines model)))
      (begin
	(set! text-result text)
	(set! pos-result pos-y)
	(set! pos-result-col pos-x)
	(set! highlighted-lines highlighted-lns)
	(set! marked-lines marked-lns)
	(right-highlighted-lines)
	(right-marked-lines)
	(let ((lines (get-right-result-lines)))
	  (let loop ((pos 1))
	    (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)
				  (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
			  (wattron reswin (A-REVERSE))
			  (mvwaddstr reswin pos 1 line)
			  (wattrset reswin (A-NORMAL))
			  (wrefresh reswin)
			  (loop (+ pos 1)))
			(if (member pos marked-lines)
			    (begin
			      (wattron reswin (A-BOLD))
			      (mvwaddstr reswin pos 1 line)
			      (wattrset reswin (A-NORMAL))
			      (wrefresh reswin)
			      (loop (+ pos 1)))
			    (begin
			      (mvwaddstr reswin pos 1 line)
			      (wrefresh reswin)
			      (loop (+ pos 1))))))))))))))
  
;;visible lines
(define get-right-result-lines
  (lambda ()
    (prepare-lines text-result result-lines pos-result)))
	  
;;marked and highlighted lines
(define right-highlighted-lines
  (lambda ()
    (let loop ((old highlighted-lines)
		 (new '()))
	(if (equal? '() old)
	    (set! highlighted-lines new)
	    (let ((el (car old)))
	      (if (<= pos-result result-lines)
		  ;;auf der ersten Seite
		  (loop (cdr old)
			(append new (list el)))
		  (let* ((offset (- pos-result result-lines))
			 (new-el (- el offset )))
		    (loop (cdr old)
			  (append new (list new-el))))))))))
(define right-marked-lines
  (lambda ()
    (let loop ((old marked-lines)
	       (new '()))
      (if (equal? '() old)
	  (set! marked-lines new)
	  (let ((el (car old)))
	    (if (<= pos-result result-lines)
		;;auf der ersten Seite
		(loop (cdr old)
		      (append new (list el)))
		(let* ((offset (- pos-result result-lines))
		       (new-el (- el offset )))
		  (loop (cdr old)
			(append new (list new-el))))))))))


;;Cursor
;;move cursor to the corrct position
(define cur-right-pos
  (lambda (comwin reswin comwin-h reswin-h buffer)
    (begin
      (if (= active-buffer 1)
	  (cursor-right-pos comwin buffer)
	  (begin
	    (compute-y-x)
	    (wmove reswin result-buffer-pos-y result-buffer-pos-x)
	    (wrefresh reswin)
	    buffer)))))


;;compue pos-x and pos-y
(define compute-y-x
  (lambda ()
    (if (= active-buffer 1)
	(begin
	  (if (>= pos-command-fin-ln command-lines)
	      (set! command-buffer-pos-y command-lines)
	      (set! command-buffer-pos-y pos-command-fin-ln))
	  (let ((posx (modulo pos-command-col command-cols)))
	    (set! command-buffer-pos-x posx)))
	(begin
	  (if (>= pos-result result-lines)
	      (set! result-buffer-pos-y result-lines)
	      (set! result-buffer-pos-y pos-result))
	  (set! result-buffer-pos-x pos-result-col)))))


; ;;index of shortcuts at the bottom
; (define print-bar3
;   (lambda (width)
;     (let loop ((pos 0)
; 	       (used-width 0)
; 	       (act-line 1))
;       (if (>= pos (length shortcuts))
; 	  (begin
; 	    (let* ((num-blanks (+ (- width used-width) 1))
; 		   (last-string (make-string num-blanks #\space)))
; 	      (mvwaddstr bar3 act-line (+ used-width 1) last-string))
; 	    (wrefresh bar3))
; 	  (let* ((act-string (list-ref shortcuts pos))
; 		 (act-length (string-length act-string))
; 		 (rest-width (- width used-width)))
; 	    (if (= act-line 1)
; 		(if (<= (+ act-length 3) rest-width)
; 		    (if (= used-width 0)
; 			(begin
; 			  (mvwaddstr bar3 1 (+ used-width 1) act-string)
; 			  (loop (+ pos 1) (+ used-width act-length) 1))	    
; 			(begin
; 			  (mvwaddstr bar3 1 (+ used-width 1)
; 				     (string-append " | " act-string))
; 			  (loop (+ pos 1) (+ used-width (+ 3 act-length))
; 				1)))
; 		    (begin
; 		      (let* ((num-blanks (+ rest-width 1))
; 			     (last-string (make-string num-blanks #\space)))
; 			(mvwaddstr bar3 1 (+ used-width 1) last-string))       
; 		      (loop pos 0 2)))
; 		(if (<= (+ act-length 3) rest-width)
; 		    (if (= used-width 0)
; 			(begin
; 			  (mvwaddstr bar3 2 (+ used-width 1) act-string)
; 			  (loop (+ pos 1) (+ used-width act-length) 2))
; 			(begin
; 			  (mvwaddstr bar3 2 (+ used-width 1)
; 				     (string-append " | " act-string))
; 			  (loop (+ pos 1) (+ used-width (+ 3 act-length)) 2)))
; 		    (begin
; 		      (let* ((num-blanks (+ rest-width 1) )
; 			     (last-string (make-string num-blanks #\space)))
; 			(mvwaddstr bar3 2 (+ used-width 1) last-string))
; 		      (wrefresh bar3)))))))))
			


;; one step back in the history
(define history-back
  (lambda ()
    (if (<= history-pos 0)
	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)
	    (if (> history-pos 1)
		(set! history-pos (- history-pos 1))))))))


;;one step forward
(define history-forward
  (lambda ()
	(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! active-command entry-com)
		(set! active-parameters entry-par)
		(set! current-result-object entry-res-obj)
		(set! history-pos (+ history-pos 1)))))))
				
(define sublist
  (lambda (l pos k)
    (let ((tmp (list-tail l pos)))
      (reverse (list-tail (reverse tmp) 
			  (- (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! active-parameters "")
      (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
;;-----------------

;;Datatype representing the "standard-result-objects"
(define-record-type standard-result-obj standard-result-obj
  (make-standard-result-obj cursor-pos-y
			    cursor-pos-x
			    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 standard-result-obj-result))

(define init-std-res (make-standard-result-obj 1 1 text-result 
					       (car text-result)))

(set! current-result-object init-std-res)

		    
;;Standard-Receiver:
(define standard-receiver
  (lambda (message)
    (cond 
     ((next-command-message? message)
      (let* ((command (next-command-string message))
	     (result (evaluate command))
	     (result-string (exp->string result))
	     (width (next-command-message-width message)))
	(let* ((text 
		(layout-result-standard result-string result width))
	       (std-obj 
		(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))
	     (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))
     ((restore-message? message)
      values)
     ((selection-message? message)
      ""))))

;;the result is the "answer" of scsh
(define layout-result-standard
  (lambda (result-str result width)
	  (reverse (seperate-line result-str width))))


;useful helpers
(define get-marked-positions-1
  (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 1))))
		(loop (+ count 1) result)))))))


(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 '()))
      (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 3))))
		(loop (+ count 1) result)))))))

;;expression as string
(define exp->string
  (lambda (exp)
    (let ((exp-port (open-output-string)))
     (begin
       (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)
    (let loop ((new '())
	       (old line))
      (if (> width (string-length old))
	  (if (= 0 (string-length old))
	      (if (equal? new '())
		  '("")
		   new)
	      (append (list old) new))
	  (let ((next-line (substring old 0 width))
		(rest-old (substring old width (string-length old))))
	    (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)))))))