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

(define-record-type app-window :app-window
  (make-app-window x y width height curses-win)
  app-window?
  (x app-window-x)
  (y app-window-y)
  (width app-window-width)
  (height app-window-height)
  (curses-win app-window-curses-win set-app-window-curses-win!))

(define bar-1 #f)
(define bar-2 #f)
(define command-window #f)
(define result-window #f)

(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"
		    "PageUp - previous entry in result history"
		    "PageDown - next entry in result history"
		    "Ctrl+x r:Redo (Active Command)"
		    "CursorUp - previous entry in command history"
		    "CursorDown - next entry in command history"
		    "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
;;-------------------

(define *focus-buffer* 'command-buffer)

(define (focus-on-command-buffer?)
  (eq? *focus-buffer* 'command-buffer))

(define (focus-command-buffer!)
  (set! *focus-buffer* 'command-buffer))

(define (focus-on-result-buffer?)
  (eq? *focus-buffer* 'result-buffer))

(define (focus-result-buffer!)
  (set! *focus-buffer* 'result-buffer))

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

;;handle input
(define (run)

  '(set-interrupt-handler interrupt/keyboard 
			  (lambda a 
			    (set! active-keyboard-interrupt a)))
      
  ;;Loop
  (paint)
  (let loop ((ch (wait-for-input)))
    (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 (focus-on-result-buffer?)
	    (let ((key-message 
		   (make-key-pressed-message active-command
					     current-result-object
					     ch)))
	      (set! current-result-object (switch key-message))))
	(paint)
	(loop (wait-for-input))))

     ;; forward in result history
     ((= ch key-npage)
      (history-forward)
      (paint-result-window)
      (loop (wait-for-input)))
     
     ;; back in result history
     ((= ch key-ppage)
      (history-back)
      (paint-result-window)
      (loop (wait-for-input)))

     ;;if lower window is active a message is sent.
     (else
      (if c-x-pressed
	  (cond
	   
	   ;;Ctrl-x o ->switch buffer
	   ((= ch 111)
	    (begin
	      (if (focus-on-command-buffer?)
		  (let ((key-message 
			 (make-key-pressed-message active-command
						   current-result-object
						   97)))
		    (focus-result-buffer!)
		    (set! current-result-object (switch key-message))
		    (paint-result-window))
		  (begin
		    (focus-command-buffer!)
		    (paint-command-window-contents)))
	      (set! c-x-pressed #f)
	      (loop (wait-for-input))))

	   ;;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 (wait-for-input)))))
	   
	   (else
	    (begin
	      (if (focus-on-result-buffer?)
		  (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 (wait-for-input)))))
	  
	  (if (focus-on-result-buffer?)
	      (let ((key-message 
		     (make-key-pressed-message active-command
					       current-result-object
					       ch)))
		(begin
		  (set! current-result-object (switch key-message))
		  (loop (wait-for-input))))
	      
	      (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))
		    (paint-result-window)
		    (paint-bar-2)
		    (paint-command-window-contents)
		    (move-cursor command-buffer)
		    (loop (wait-for-input)))))

	       (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)))
		  (paint-command-window-contents)
		  (set! command-buffer
			(move-cursor 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)))
		    (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 (wait-for-input)))))))))))

(define (window-init-curses-win! window)
  (set-app-window-curses-win!
   window
   (newwin (app-window-height window) (app-window-width window)
	   (app-window-y window) (app-window-x window))))

(define (init-windows!)
  (init-screen)
  (set! bar-1
	(make-app-window 1 1 
			 (- (COLS) 2) 2 
			 #f))
  (set! bar-2
	(make-app-window 1 (+ (round (/ (LINES) 3)) 2)
			 (- (COLS) 2) 3
			 #f))
  (set! command-window
	(make-app-window 1 2
			 (- (COLS) 2) (- (app-window-y bar-2) 2)
			 #f))
  (set! result-window
	(make-app-window 1 (+ (app-window-y bar-2) 3)
			 (- (COLS) 2)
			 (- (- (LINES) 6) (app-window-height command-window))
			 #f))
  (window-init-curses-win! bar-1)
  (window-init-curses-win! bar-2)
  (window-init-curses-win! command-window)
  (window-init-curses-win! result-window)
  (wclear (app-window-curses-win bar-1))
  (wclear (app-window-curses-win bar-2))
  (wclear (app-window-curses-win command-window))
  (wclear (app-window-curses-win result-window))
  (clear))

(define (paint-bar-1)
  (mvwaddstr (app-window-curses-win bar-1) 0 1 "SCSH-NUIT")
  (wrefresh (app-window-curses-win bar-1)))

(define (paint-bar-2)
  (box (app-window-curses-win bar-2) (ascii->char 0) (ascii->char 0))
  (print-active-command-win (app-window-curses-win bar-2) 
			    (app-window-width bar-2)))

(define (paint-command-window)
  (box (app-window-curses-win command-window) 
       (ascii->char 0) (ascii->char 0)))

(define (paint-command-window-contents)
  (set! command-lines (- (app-window-height command-window) 2))
  (set! command-cols (- (app-window-width command-window) 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 (app-window-curses-win command-window) 
			      command-buffer))
  (wrefresh (app-window-curses-win command-window)))

(define (paint-result-window)
  (wclear (app-window-curses-win result-window))
  (box (app-window-curses-win result-window) 
       (ascii->char 0) (ascii->char 0))
  (set! result-lines (- (app-window-height result-window) 2))
  (set! result-cols (- (app-window-width result-window) 3))
  (print-result-buffer result-window)
  (wrefresh (app-window-curses-win result-window)))

(define (paint)
  (init-windows!)
  (paint-bar-1)
  (paint-bar-2)
  (paint-command-window)
  (paint-command-window-contents)
  (paint-result-window)
  
  (set! command-buffer 
	(move-cursor 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)))
    (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)))

(define (wait-for-input)
  (noecho)
  (keypad (app-window-curses-win bar-1) #t)
  (set! active-keyboard-interrupt #f)
  (let ((ch (wgetch (app-window-curses-win bar-1))))
    (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 result-window)
  (let* ((window (app-window-curses-win result-window))
	 (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)))
    (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)
			 (focus-on-result-buffer?))
		    (begin
		      (wattron window (A-REVERSE))
		      (mvwaddstr window pos 1 line)
		      (wattrset window (A-NORMAL))
		      (wrefresh window)
		      (loop (+ pos 1)))
		    (if (member pos marked-lines)
			(begin
			  (wattron window (A-BOLD))
			  (mvwaddstr window pos 1 line)
			  (wattrset window (A-NORMAL))
			  (wrefresh window)
			  (loop (+ pos 1)))
			(begin
			  (mvwaddstr window pos 1 line)
			  (wrefresh window)
			  (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 (move-cursor buffer)
  (begin
    (if (focus-on-command-buffer?)
	(cursor-right-pos (app-window-curses-win command-window) 
			  buffer)
	(begin
	  (compute-y-x)
	  (wmove (app-window-curses-win result-window) 
		 result-buffer-pos-y result-buffer-pos-x)
	  (wrefresh (app-window-curses-win result-window))
	  buffer))))

;;compue pos-x and pos-y
(define compute-y-x
  (lambda ()
    (if (focus-on-command-buffer?)
	(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! 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)))))))