scsh-ncurses/scheme/nui-engine.scm

;;  ,load /home/demattia/studium/studienarbeit/scsh-ncurses/scheme/nui-engine.scm


;;*************************************************************************
;;Zustand

;;Zustand des oberen Fensters (Command-Window)
;;---------------------------

;;Text
(define text-command (list "Welcome in the scsh-ncurses-ui!" ""))

;;gibt an, in welcher Zeile der gesamten Command-History man sich befindet
(define pos-command 2)
;;in welcher Spalte
(define pos-command-col 2)

;;gibt an, in welcher Zeile des Buffers nach Zeilenumbruch man sich befindet.
(define pos-command-fin-ln 2)

;;gibt an, in welcher Zeile des Buffers man sich befindet
(define command-buffer-pos-y 2)
;;gibt an, an welcher Position des Buffers man sich befindet.
(define command-buffer-pos-x 2)

;;Anzahl der Zeilen des Commando-Buffers
(define command-lines 0)

;;Anzahl der Spalten des Commando-Buffers
(define command-cols 0)

;;befindet sich der cursor am Ende der letzten Zeile des command-wins?
(define can-write-command #t)


;;Zustand des unteren Fensters (Result-Window)
;;----------------------------

;;Text
(define text-result (list "Start entering commands."
			  "Ctrl-h for help."))

;;gibt an, in welcher Zeile des Result-Buffers man sich befindet
(define pos-result 2)
;;in welcher Spalte
(define pos-result-col 17)

;;gibt an, in welcher Zeile des Buffers man sich befindet
(define result-buffer-pos-y 2)
;;gibt an, an welcher Position des Buffers man sich befindet.
(define result-buffer-pos-x 2)

;;Anzahl der Zeilen des Buffers
(define result-lines 0)
;;Anzahl der Spalten des Buffers
(define result-cols 0)

  

;;allgemeiner Zustand
;;-------------------

;;entweder 1...oben oder 2...unten
(define active-buffer 1)


;;History
(define history '())

;;*************************************************************************
;;Verhalten
      
;;Eingabe verarbeiten
(define run
  (lambda ()
    (let loop ((ch (paint)))
      (cond
       
       ;;Beenden
       ((= ch key-f1)
	#t)

       ;;Enter
       ((= ch 10)
	(if (= active-buffer 1)
	    (begin
	      (execute-command)
	      (loop (paint)))
	    (loop (paint))))

       ;;Backspace
       ((= ch key-backspace)
	(if (= active-buffer 1)
	    (if can-write-command
		(if (< pos-command-col 3)
		    (loop (paint))
		    (begin
		      (remove-from-command-buffer)
		      (set! pos-command-col (- pos-command-col 1))
		      (loop (paint))))
		(loop (paint)))
	    (loop (paint))))

       ;;Navigieren
       ((= ch key-up)
	(if (= active-buffer 1)
	    (if (< pos-command-fin-ln 2)
		(loop (paint))
		(let ((length-prev-line
		       (string-length
			(list-ref text-command (- pos-command 2)))))
		(begin
		  (set! can-write-command #f)
		  (set! pos-command (- pos-command 1))
		  (set! pos-command-col (+ length-prev-line 2))
		  (loop (paint)))))
	    (if (< pos-result 2)
		(loop (paint))
		(let ((length-prev-line
		       (string-length
			(list-ref text-result (- pos-result 2)))))
		  (begin
		    (set! pos-result (- pos-result 1))
		    (set! pos-result-col (+ length-prev-line 1))
		    (loop (paint)))))))

       ((= ch key-down)
	(if (= active-buffer 1)
	    (let ((last-pos (length text-command)))
	      (if (>= pos-command last-pos)
		  (loop (paint))
		  (let ((length-next-line 
			 (string-length 
			  (list-ref text-command pos-command))))
		  (begin
		    (set! pos-command-col (+ length-next-line 2))
		    (set! pos-command (+ pos-command 1))
		    (if (= pos-command last-pos)
			(set! can-write-command #t))
		    (loop (paint))))))
	    (let ((last-pos (length text-result)))
	      (if (>= pos-result last-pos)
		  (loop (paint))
		  (let ((length-next-line 
			 (string-length 
			  (list-ref text-result pos-result))))
		    (begin
		    (set! pos-result-col (+ length-next-line 1))
		    (set! pos-result (+ pos-result 1))
		    (loop (paint))))))))

       ((= ch key-left)
	(if (= active-buffer 1)
	    (if (<= pos-command-col 2)
		(loop (paint))
		(begin
		  (set! pos-command-col (- pos-command-col 1))
		  (loop (paint))))
	    (if (<= pos-result-col 1)
		(loop (paint))
		(begin
		  (set! pos-result-col (- pos-result-col 1))
		  (loop (paint))))))

       ((= ch key-right)
	(if (= active-buffer 1)
	    (let ((line-length (string-length 
				(list-ref text-command (- pos-command 1)))))
	      (if (>= pos-command-col (+ line-length 2))
		  (loop (paint))
		  (begin
		    (set! pos-command-col (+ pos-command-col 1))
		    (loop (paint)))))
	    (let ((line-length (string-length 
				(list-ref text-result (- pos-result 1)))))
	      (if (>= pos-result-col (+ line-length 1))
		  (loop (paint))
		  (begin
		    (set! pos-result-col (+ pos-result-col 1))
		    (loop (paint)))))))
       
       ;;Ctrl+b -> Buffer wechseln
       ((= ch 2)
	(begin
	  (if (= active-buffer 1)
	      (set! active-buffer 2)
	      (set! active-buffer 1))
	  (loop (paint))))
       

       ;;Ctrl+a -> Zeilenanfang
       ((= ch 1)
	(if (= active-buffer 1)
	    (begin
	      (set! command-buffer-pos-x 2)
	      (loop (paint)))))

       ;;Ctrl-e -> Zeilenende
       ((= ch 5)
	(if (= active-buffer 1)
	    (let ((line-length (string-length 
				(list-ref text-command (- pos-command 1)))))
	      (begin
		(set! command-buffer-pos-x (+ line-length 2))
		(loop (paint))))))
       
       (else 
	(if (= active-buffer 1)
	    (if (<= ch 255)
		(if can-write-command
		    (begin
		      (add-to-command-buffer ch)
		      (loop (paint)))
		    (loop (paint)))
		(loop (paint)))))))))
       

;;darstellen und auf Eingabe warten
(define paint
  (lambda ()
  (begin
    (init-screen)
    (cbreak)
    (let* ((bar1-y 0)
	   (bar1-x 0)
	   (bar1-h 3)
	   (bar1-w (COLS))
	   (bar2-y (round (/ (LINES) 3)))
	   (bar2-x 0)
	   (bar2-h 3)
	   (bar2-w (COLS))
	   (comwin-y 3)
	   (comwin-x 0)
	   (comwin-h (- bar2-y 3))
	   (comwin-w (COLS))
	   (reswin-y (+ bar2-y 3))
	   (reswin-x 0)
	   (reswin-h (- (- (- (LINES) 6) comwin-h) 3))
	   (reswin-w (COLS))
	   (bar3-y (+ reswin-y reswin-h))
	   (bar3-x 0)
	   (bar3-h 3)
	   (bar3-w (COLS)))
      (let ((bar1 (newwin bar1-h bar1-w bar1-y bar1-x))
	    (bar2 (newwin bar2-h bar2-w bar2-y bar2-x))
	    (command-win (newwin  comwin-h comwin-w comwin-y comwin-x))
	    (result-win (newwin reswin-h reswin-w reswin-y reswin-x))
	    (bar3 (newwin bar3-h bar3-w bar3-y bar3-x)))
	(box bar1 (ascii->char 0) (ascii->char 0))
	(mvwaddstr bar1  1 1 "Command")
	(wrefresh bar1)
	(box bar2 (ascii->char 0) (ascii->char 0))
	(mvwaddstr bar2  1 1 "Result")
	(wrefresh bar2)
	(box command-win (ascii->char 0) (ascii->char 0))
	(set! command-lines (- comwin-h 2))
	(set! command-cols (- comwin-w 3))
	(print-command-buffer command-win)
	(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)
	(box bar3 (ascii->char 0) (ascii->char 0))
	(wattron bar3 (A-REVERSE))
	(mvwaddstr bar3 1 1 "F1:Exit | Ctrl+b:Switch-Buffer")
	(wstandend bar3)
	(wrefresh bar3)
	(cursor-right-pos command-win result-win comwin-h reswin-h)
	(noecho)
	(keypad bar1 #t)
	(let ((ch (wgetch bar1)))
	  (wclear bar1) 
	  (wclear bar2)
	  (wclear command-win)
	  (wclear result-win)
	  (wclear bar3)
	  (clear)
	  (endwin)
	  (echo)
	  ch
	))))))

;;Eingabe wurde durch Benutzer best<73>tigt -> Kommando ausfuehren
(define execute-command
  (lambda ()
    (let ((command (list-ref text-command (- (length text-command) 1))))
      (layout-result command result-cols)
      (set! text-command (append text-command (list "")))
      (scroll-command-buffer))))

;;Nach einer Eingabe kann es sein, dass die aktive Buffer_Zeile verschoben 
;;werden muss.
(define scroll-command-buffer
  (lambda ()
    (begin
      (set! pos-command (+ pos-command 1))
      (set! pos-command-col 2))))


;;Der Benutzer muss sich darum k<>mmern, dass das Ergebnis sinnvoll
;;dargestellt wird.
(define layout-result
  (lambda (command width)
    ;;standard
    (begin
      (let* ((handler (lambda (c m) values))
	     (result (with-fatal-error-handler handler 
      (let ((com (if (> (string-length command) (- width 22)) 
		     (string-append (substring command 0 (- width 22)) "...")
		     command)))
	(set! text-result (cons (string-append "command unknown: " com) '()))
	(set! pos-result-col (+ 18 (string-length com)))
	(set! pos-result 1)))))


;;Ein Character zur letzten Zeile des Command-Buffers hinzuf<75>gen
(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)))))

;;Ein Character aus der letzten Zeile entfernen (backspace)
(define remove-from-command-buffer
  (lambda ()
    (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 3))))
	   (after-ch (if (= pos-command-col 
			       (+ (string-length old-last-el) 2))
			 ""
			 (substring old-last-el 
				(max 0 (- pos-command-col 2))
				(string-length old-last-el))))
	   (new-last-el (if (= pos-command-col 
			       (+ (string-length old-last-el) 2))
			    before-ch
			    (string-append  before-ch after-ch))))
      (set! text-command (append old-rest (list new-last-el))))))
	   
	   

;;Es wird der sichtbare Teil der bisherigen Eingaben in den Command-
;;Buffer angezeigt.
(define print-command-buffer
  (lambda (comwin)
    (let ((lines (get-right-command-lines)))
      (let loop ((pos 1))
	(if (> pos command-lines)
	    values
	    (let ((line (list-ref lines (- pos 1))))
	      (begin
		(mvwaddstr comwin pos 1 line)
		(wrefresh comwin)
		(loop (+ pos 1)))))))))


;;Anzeigen des sichtbaren Teils des Result-Buffers
(define print-result-buffer
  (lambda (reswin)
    (let ((lines (get-right-result-lines)))
      (let loop ((pos 1))
	(if (> pos result-lines)
	    values
	    (let ((line (list-ref lines (- pos 1))))
	      (begin
		(mvwaddstr reswin pos 1 line)
		(wrefresh reswin)
		(loop (+ pos 1)))))))))


;;Es werden die anzuzeigenden Zeilen erzeugt.
;;n<>tig, damit auch Befehle <20>ber mehrere Zeilen m<>glich sind:
(define get-right-command-lines
  (lambda ()
    (let* ((all-lines-seperated (all-commands-seperated text-command))
	   (num-all-lines (length all-lines-seperated)))
      (if (>= pos-command-fin-ln command-lines)
	  ;;aktive Zeile ist die unterste
	  (sublist all-lines-seperated 
		   (- pos-command-fin-ln command-lines) 
		   command-lines)
	  (if (<= num-all-lines command-lines)
	      ;;noch keine ganze Seite im Buffer
	      (prepare-lines all-lines-seperated 
			     command-lines (- pos-command-fin-ln 1))
	      ;;scrollen auf der ersten Seite
	      (sublist all-lines-seperated 0 command-lines))))))

;;anzuzeigende Zeilen im Result-Buffer
(define get-right-result-lines
  (lambda ()
    (prepare-lines text-result result-lines pos-result)))
	  

;;Ein Statement wird in St<53>cke zerlegt, so dass dann jedes St<53>ck in eine
;;Zeile passt.
(define seperate-line
  (lambda (line width)
    (let loop ((new '())
	       (old line))
      (if (> width (string-length old))
	  (if (= 0 (string-length old))
	      (if (equal? new '())
		  (add-prompts '(""))
		  (add-prompts  new))
	      ;new
	      (add-prompts (append (list old) 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))))))




;;alle Statements zerlegen
(define all-commands-seperated
  (lambda (commands)
    (let loop ((act-pos 1)
	       (new '()))
      (begin
	(if (= act-pos pos-command)
	    (let* ((length-new (length new))
		   (first-el-old (list-ref commands (- act-pos 1)))
		   (seperated-act (seperate-line first-el-old command-cols))
		   (length-act (length seperated-act)))
	      (set! pos-command-fin-ln (+ length-new length-act))))
	
	(if (> act-pos (length commands))
	    (reverse new)
	    (let* ((first-el-old (list-ref commands (- act-pos 1)))
		   (seperated-fst-el-old 
		    (seperate-line first-el-old command-cols)))
	      (loop (+ act-pos 1) (append seperated-fst-el-old new))))))))


;;> hinzuf<75>gen
(define add-prompts
  (lambda (l)
     (let* ((lr (reverse l))
	    (old-first-el (list-ref lr 0))
	    (new-first-el (string-append ">" old-first-el))
	    (old-rest (list-tail lr 1)))
      (let loop ((old old-rest)
		 (new (list new-first-el)))
	(if (> (length old) 0)
	    (let* ((old-first-el (list-ref old 0))
		   (new-first-el (string-append " " old-first-el)))
	      (loop (list-tail old 1) (append new (list new-first-el))))
	    (reverse new))))))



;;Cursor an die richtige Stelle bewegen:
(define cursor-right-pos
  (lambda (comwin reswin comwin-h reswin-h)
    (begin
      (compute-y-x)
      (if (= active-buffer 1)
	  (begin
	    (wmove comwin command-buffer-pos-y command-buffer-pos-x)
	    (wrefresh comwin))
	  (begin
	    (wmove reswin result-buffer-pos-y result-buffer-pos-x)
	    (wrefresh reswin))))))


;;pos-y und pos-x berechnen
(define compute-y-x
  (lambda ()
    (if (= active-buffer 1)
	(begin
	  ;;zuerst mal y 
	  (if (>= pos-command-fin-ln command-lines)
	      ;;unterste Zeile
	      (set! command-buffer-pos-y command-lines)
	      ;;sonst
	      (set! command-buffer-pos-y pos-command-fin-ln))
	  ;;jetzt x
	  (let ((posx (modulo pos-command-col command-cols)))
	    (set! command-buffer-pos-x posx)))
	(begin
	  ;;zuerst y
	  (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)))))


;;Es wird in einer Liste der zu druckende Berecih ausgew<65>hlt:
(define prepare-lines
  (lambda (l height pos)
    (if (< (length l) height)
	;; Liste zu kurz -> ""s hinzuf<75>gen
	(let loop ((tmp-list l))
	  (if (= height (length tmp-list))
	      tmp-list
	      (loop (append tmp-list (list "")))))
	;; Teilliste holen
	(if (<  pos height)
	    ;;pos nicht ganz unten
	    (sublist l 0 height)
	    ;;standard-Fall 
	    (sublist l (- pos height) height)))))

;;Teilliste
(define sublist
  (lambda (l pos k)
    (let ((tmp (list-tail l pos)))
      (reverse (list-tail (reverse tmp) 
			  (- (length tmp) k))))))


   
(run)