commander-s/scheme/nuit-engine.scm

589 lines
16 KiB
Scheme
Raw Blame History

;; ,load /home/demattia/studium/studienarbeit/scsh-nuit/scheme/nuit-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)
;;*************************************************************************
;;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)))
(command-port (open-input-string command))
(tmp-env (scheme-report-environment 5))
(handler (lambda (condition more)
(cons 'Error: condition)))
(result (with-fatal-error-handler
handler
(eval (read command-port) tmp-env)))
(result-port (open-output-string)))
(begin
(write result result-port)
(let ((result-string (get-output-string result-port)))
(begin
(layout-result command result-string 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 result width)
;;standard (else -> keine spezielle Darstellung vorgesehen)
(layout-result-standard result width)))
; (begin
; (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)))
;;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-com
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-com first-el-old command-cols)))
(loop (+ act-pos 1) (append seperated-fst-el-old new))))))))
;;Ein Statement wird in St<53>cke zerlegt, so dass dann jedes St<53>ck in eine
;;Zeile passt.
(define seperate-line-com
(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))))))
;;> 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))))))
;;*************************************************************************
;;Die folgenden Funktionen sollten sp<73>ter in eine eigene Datei kommen.
;;Sie sind abh<62>ngig vom jeweiligen Befehl.
;;Im Standardfall wird einfach als Ergebnis die R<>ckgabe der scsh ausgegeben.
(define layout-result-standard
(lambda (result width)
(set! text-result (reverse (seperate-line result width)))))
;;n<>tzliche Hilfsfunktionen:
;;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 '())
'("")
new)
;new
(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))))))
(define (with-fatal-error-handler* handler thunk)
(call-with-current-continuation
(lambda (accept)
((call-with-current-continuation
(lambda (k)
(with-handler (lambda (condition more)
(if (error? condition)
(call-with-current-continuation
(lambda (decline)
(k (lambda () (handler condition decline))))))
(more)) ; Keep looking for a handler.
(lambda () (call-with-values thunk accept)))))))))
(define-syntax with-fatal-error-handler
(syntax-rules ()
((with-fatal-error-handler handler body ...)
(with-fatal-error-handler* handler
(lambda () body ...)))))
(run)