819 lines
22 KiB
Scheme
819 lines
22 KiB
Scheme
;; ,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."))
|
|
|
|
;;gibt an, in welcher Zeile des Result-Buffers man sich befindet
|
|
(define pos-result 1)
|
|
;;in welcher Spalte
|
|
(define pos-result-col 25)
|
|
|
|
;;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 '())
|
|
|
|
;;Position in der History
|
|
(define history-pos 0)
|
|
|
|
;;aktiver Befehl
|
|
(define active-command "")
|
|
|
|
|
|
;;Record für Angaben zu Erweiterungen
|
|
(define-record-type command-addition command-addition
|
|
(make-command-addition command-string
|
|
layout-procedure
|
|
selected-procedure
|
|
restore-procedure)
|
|
command-addition?
|
|
(command-string command-add-command-string)
|
|
(layout-procedure command-add-layout-proc)
|
|
(selected-procedure command-add-selected-proc)
|
|
(restore-procedure command-add-restore-proc))
|
|
|
|
|
|
;;Diese Liste beinhaltet die Informationen dazu, was bei bestimmten
|
|
;;Benutzereingaben zu tun ist:
|
|
(define command-additions '() )
|
|
|
|
;;*************************************************************************
|
|
;;Verhalten
|
|
|
|
;;Eingabe verarbeiten
|
|
(define run
|
|
(lambda ()
|
|
(let loop ((ch (paint)))
|
|
(cond
|
|
|
|
;;Beenden
|
|
((= ch key-f1)
|
|
(begin
|
|
(addition-function command-add-restore-proc)
|
|
#t))
|
|
|
|
;;Enter
|
|
((= ch 10)
|
|
(if (= active-buffer 1)
|
|
(begin
|
|
;;Es wird die restore-Prozedur aufgerufen
|
|
((addition-function command-add-restore-proc))
|
|
(execute-command)
|
|
(loop (paint)))
|
|
;; es wird die passende Prozedur aufgerufen
|
|
(let ((sel-proc (addition-function command-add-selected-proc)))
|
|
(begin
|
|
(sel-proc pos-result result-cols)
|
|
(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+p -> History zurück
|
|
((= ch 16)
|
|
(if (= active-buffer 1)
|
|
(begin
|
|
(history-back)
|
|
(loop (paint)))
|
|
(loop(paint))))
|
|
|
|
;;Ctrl+n -> History vor
|
|
((= ch 14)
|
|
(if (= active-buffer 1)
|
|
(begin
|
|
(history-forward)
|
|
(loop (paint)))
|
|
(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ätigt -> Kommando ausfuehren
|
|
(define execute-command
|
|
(lambda ()
|
|
(let* ((command (list-ref text-command (- (length text-command) 1)))
|
|
(result (evaluate command))
|
|
(result-string (exp->string result)))
|
|
(begin
|
|
(set! active-command command)
|
|
(layout-result command result-string result result-cols)
|
|
(set! history (append history
|
|
(list (cons command
|
|
(cons result result-string)))))
|
|
(set! history-pos (length history))
|
|
(set! text-command (append text-command (list "")))
|
|
(scroll-command-buffer)))))
|
|
|
|
;;Auswerten eines Ausdrucks in Form eines 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)))
|
|
|
|
;;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-str result width)
|
|
(let ((fun (addition-function command-add-layout-proc)))
|
|
(fun result-str result width))))
|
|
; (let loop ((pos 0))
|
|
; (if (> pos (- (length command-additions) 1))
|
|
; ;;standard (else -> keine spezielle Darstellung vorgesehen)
|
|
; (layout-result-standard result-str width)
|
|
; (let* ((el (list-ref command-additions pos))
|
|
; (el-str (command-add-command-string el))
|
|
; (el-layout-proc (command-add-layout-proc el)))
|
|
; (if (equal? el-str command)
|
|
; (el-layout-proc result-str result width)
|
|
; (loop (+ pos 1))))))))
|
|
|
|
|
|
|
|
|
|
;;Ein Character zur letzten Zeile des Command-Buffers hinzufü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 ü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ücke zerlegt, so dass dann jedes Stü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ü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ählt:
|
|
(define prepare-lines
|
|
(lambda (l height pos)
|
|
(if (< (length l) height)
|
|
;; Liste zu kurz -> ""s hinzufü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)))))
|
|
|
|
;; Ein Schritt zurück in der History. Im unteren Buffer wird jeweils das
|
|
;; Ergebnis angezeigt
|
|
(define history-back
|
|
(lambda ()
|
|
(if (<= history-pos 0)
|
|
values
|
|
(let* ((hist-entry (list-ref history (- history-pos 1)))
|
|
(entry-com (car hist-entry))
|
|
(entry-res (cdr hist-entry))
|
|
(res (car entry-res))
|
|
(res-str (cdr entry-res)))
|
|
(begin
|
|
(set! text-command (append
|
|
(sublist text-command 0
|
|
(- (length text-command) 1))
|
|
(list entry-com)))
|
|
(set! active-command entry-com)
|
|
(layout-result entry-com res-str res result-cols)
|
|
(set! history-pos (- history-pos 1)))))))
|
|
|
|
;;Ein Schritt nach vorne in der History. Analog zu history-back
|
|
(define history-forward
|
|
(lambda ()
|
|
(if (= history-pos (- (length history) 1))
|
|
(set! text-command (append
|
|
(sublist text-command 0
|
|
(- (length text-command) 1))
|
|
(list "")))
|
|
(if (> history-pos (- (length history) 1))
|
|
values
|
|
(let* ((hist-entry (list-ref history (+ history-pos 1)))
|
|
(entry-com (car hist-entry))
|
|
(entry-res (cdr hist-entry))
|
|
(res (car entry-res))
|
|
(res-str (cdr entry-res)))
|
|
(begin
|
|
(set! text-command (append
|
|
(sublist text-command 0
|
|
(- (length text-command) 1))
|
|
(list entry-com)))
|
|
(set! active-command entry-com)
|
|
(layout-result entry-com res-str res result-cols)
|
|
(set! history-pos (+ history-pos 1))))))))
|
|
|
|
|
|
;;Es wird die richtige Funktion ausgewählt:
|
|
(define addition-function
|
|
(lambda (type)
|
|
(let loop ((pos 0))
|
|
(if (> pos (- (length command-additions) 1))
|
|
(type standard-command)
|
|
(let* ((el (list-ref command-additions pos))
|
|
(el-str (command-add-command-string el))
|
|
(el-proc (type el)))
|
|
(if (equal? el-str active-command)
|
|
el-proc
|
|
(loop (+ pos 1))))))))
|
|
|
|
|
|
|
|
;;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äter in eine eigene Datei kommen.
|
|
;;Sie sind abhängig vom jeweiligen Befehl.
|
|
|
|
;;Im Standardfall wird einfach als Ergebnis die Rückgabe der scsh ausgegeben.
|
|
(define layout-result-standard
|
|
(lambda (result-str result width)
|
|
(set! text-result
|
|
(reverse (seperate-line result-str width)))))
|
|
|
|
(define standard-command
|
|
(make-command-addition
|
|
"standard"
|
|
layout-result-standard
|
|
values
|
|
values))
|
|
|
|
|
|
;;directory-files
|
|
|
|
;;speichert das working-directory zur Zeit des Aufrufs
|
|
(define initial-working-directory (cwd))
|
|
|
|
;;speichert die aktuelle Anzeige
|
|
(define printed-files '())
|
|
|
|
;;Darstellung, falls die Eingabe ist: "(directory-files)"
|
|
(define layout-result-dirfiles
|
|
(lambda (result-str result width)
|
|
(begin
|
|
;(set! initial-working-directory (cwd))
|
|
(let ((printed-file-list (print-file-list result)))
|
|
(begin
|
|
(set! printed-files printed-file-list)
|
|
(set! text-result
|
|
(append
|
|
(reverse (seperate-line
|
|
(string-append "Directory-Content of "
|
|
(cwd) " :") width))
|
|
(list "<-")
|
|
printed-file-list))
|
|
(set! pos-result 2))))))
|
|
|
|
;;Eine Datei pro Zeile
|
|
;;Falls es sich um ein Verzeichnis handelt wird "/" hinzugefügt
|
|
(define print-file-list
|
|
(lambda (file-list)
|
|
(let loop ((old file-list)
|
|
(new '()))
|
|
(if (equal? '() old)
|
|
new
|
|
(let ((hd (list-ref old 0))
|
|
(tl (cdr old)))
|
|
(if (file-directory? hd)
|
|
(let ((new-str (string-append hd "/")))
|
|
(loop tl (append new (list new-str))))
|
|
(loop tl (append new (list hd)))))))))
|
|
|
|
;;Auswahl->absteigen
|
|
(define selected-dirfiles
|
|
(lambda (ln width)
|
|
(if (or (>= ln (+ (length printed-files) 3))
|
|
(<= ln 1))
|
|
values
|
|
(if (= ln 2)
|
|
(if (not (equal? "/" (cwd)))
|
|
(begin
|
|
(chdir "..")
|
|
(let ((new-result (evaluate "(directory-files)")))
|
|
(layout-result-dirfiles (exp->string new-result)
|
|
new-result width)))
|
|
values)
|
|
(let* ((ent (list-ref printed-files (- ln 3)))
|
|
(len (string-length ent))
|
|
(last-char (substring ent (- len 1) len))
|
|
(rest (substring ent 0 (- len 1))))
|
|
(if (equal? last-char "/")
|
|
(begin
|
|
(chdir rest)
|
|
(let ((new-result (evaluate "(directory-files)")))
|
|
(layout-result-dirfiles (exp->string new-result)
|
|
new-result width))
|
|
values)))))))
|
|
|
|
;;Zurücksetzen, wenn das nächste Kommando kommt.
|
|
(define restore-dirfiles
|
|
(lambda ()
|
|
(begin
|
|
(chdir initial-working-directory)
|
|
(set! printed-files '())
|
|
;(set! printed-files '())
|
|
)))
|
|
|
|
|
|
|
|
(define new-com-add (make-command-addition
|
|
"(directory-files)"
|
|
layout-result-dirfiles
|
|
selected-dirfiles
|
|
restore-dirfiles))
|
|
(set! command-additions (cons new-com-add command-additions))
|
|
|
|
|
|
;;nützliche Hilfsfunktionen:
|
|
|
|
;;Ein Ausdruck als String
|
|
(define exp->string
|
|
(lambda (exp)
|
|
(let ((exp-port (open-output-string)))
|
|
(begin
|
|
(write exp exp-port)
|
|
(get-output-string exp-port)))))
|
|
|
|
|
|
|
|
|
|
;;Ein Statement wird in Stücke zerlegt, so dass dann jedes Stü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)
|
|
|