diff --git a/scheme/directory-files.scm b/scheme/directory-files.scm new file mode 100644 index 0000000..c5383f4 --- /dev/null +++ b/scheme/directory-files.scm @@ -0,0 +1,311 @@ + +;;directory-files +;;--------------- + + +(define initial-working-directory (cwd)) + +;;Result-Object für "directory-files" +(define-record-type dirfiles-result-object dirfiles-result-object + (make-dirfiles-result-object pos-y + pos-x + file-list + result-text + working-directory + width + initial-wd + marked-items + res-marked-items) + dirfiles-result-object? + (pos-y dirfiles-result-object-pos-y) + (pos-x dirfiles-result-object-pos-x) + (file-list dirfiles-result-object-file-list) + (result-text dirfiles-result-object-result-text) + (working-directory dirfiles-result-object-working-directory) + (width dirfiles-result-object-width) + (initial-wd dirfiles-result-object-initial-wd) + (marked-items dirfiles-result-object-marked-items) + (res-marked-items dirfiles-result-object-res-marked-items)) + +;;Darstellung, falls die Eingabe ist: "(directory-files)" +(define layout-result-dirfiles + (lambda (result-str result width) + (begin + (let ((printed-file-list (print-file-list result)) + (directory (cwd)) + (heading "")) + (begin + (if (<= (string-length directory) (- width 27)) + (set! heading (string-append "Directory-Content of " + directory " :")) + (let ((dir-string (substring directory + (- (string-length directory) + (- width 27)) + (string-length directory)))) + (set! heading (string-append "Directory-Content of ..." + dir-string)))) + (append (list heading) (list " <-") + printed-file-list)))))) + + +;;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 (string-append " " hd)))))))))) + +;;Auswahl->absteigen +(define selected-dirfiles + (lambda (model) + (let ((ln (dirfiles-result-object-pos-y model))) + (if (or (>= ln (+ (length (dirfiles-result-object-result-text model)) 1)) + (<= ln 1)) + model + (if (= ln 2) + (if (not (equal? "/" (cwd))) + (begin + (chdir "..") + (let* ((new-result (evaluate "(directory-files)")) + (new-result-string (exp->string new-result)) + (width (dirfiles-result-object-width model)) + (new-text (layout-result-dirfiles + new-result-string new-result width)) + (new-model (make-dirfiles-result-object + 2 + 1 + new-result + new-text + (cwd) + width + (dirfiles-result-object-initial-wd + model) + (dirfiles-result-object-marked-items + model) + (dirfiles-result-object-res-marked-items + model)))) + new-model)) + model) + (let* ((text (dirfiles-result-object-result-text model)) + (ent (list-ref text (- ln 1))) + (len (string-length ent)) + (last-char (substring ent (- len 1) len)) + (rest (substring ent 1 (- len 1)))) + (if (equal? last-char "/") + (begin + (chdir rest) + (let* ((new-result (evaluate "(directory-files)")) + (new-result-string (exp->string new-result)) + (width (dirfiles-result-object-width model)) + (new-text (layout-result-dirfiles + new-result-string new-result width)) + (new-model (make-dirfiles-result-object + 2 + 1 + new-result + new-text + (cwd) + width + (dirfiles-result-object-initial-wd + model) + (dirfiles-result-object-marked-items + model) + (dirfiles-result-object-res-marked-items + model)))) + new-model)) + model))))))) + + +;;Receiver für directory-files +(define dir-files-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)) + (text (layout-result-dirfiles result-string result width)) + (model (make-dirfiles-result-object 2 1 result text (cwd) + width (cwd) '() '()))) + model)) + + ((print-message? message) + (let* ((model (print-message-object message)) + (posy (dirfiles-result-object-pos-y model)) + (posx (dirfiles-result-object-pos-x model)) + (text (dirfiles-result-object-result-text model)) + (marked-pos (get-marked-positions + (dirfiles-result-object-file-list model) + (dirfiles-result-object-marked-items model)))) + (make-print-object posy posx text (list posy) marked-pos))) + + ((key-pressed-message? message) + (let* ((model (key-pressed-message-result-model message)) + (key (key-pressed-message-key message))) + (cond + + ((= key key-up) + (let ((posy (dirfiles-result-object-pos-y model))) + (if (<= posy 2) + model + (let* ((new-posy (- posy 1)) + (new-model (make-dirfiles-result-object + new-posy + (dirfiles-result-object-pos-x model) + (dirfiles-result-object-file-list model) + (dirfiles-result-object-result-text + model) + (dirfiles-result-object-working-directory + model) + (dirfiles-result-object-width model) + (dirfiles-result-object-initial-wd model) + (dirfiles-result-object-marked-items + model) + (dirfiles-result-object-res-marked-items + model)))) + new-model)))) + + ((= key key-down) + (let ((posy (dirfiles-result-object-pos-y model)) + (num-lines (length + (dirfiles-result-object-result-text model)))) + (if (>= posy num-lines) + model + (let* ((new-posy (+ posy 1)) + (new-model (make-dirfiles-result-object + new-posy + (dirfiles-result-object-pos-x model) + (dirfiles-result-object-file-list model) + (dirfiles-result-object-result-text + model) + (dirfiles-result-object-working-directory + model) + (dirfiles-result-object-width model) + (dirfiles-result-object-initial-wd + model) + (dirfiles-result-object-marked-items + model) + (dirfiles-result-object-res-marked-items + model)))) + new-model)))) + + ((= key 10) + (selected-dirfiles model)) + + ;;Ctrl+s -> Auswahl + ((= key 19) + (let* ((marked-items (dirfiles-result-object-marked-items model)) + (res-marked-items (dirfiles-result-object-res-marked-items + model)) + (actual-pos (dirfiles-result-object-pos-y model)) + (all-items (dirfiles-result-object-file-list model))) + (if (<= actual-pos 2) + model + (let* ((actual-item (list-ref all-items (- actual-pos 3))) + (actual-res-item (string-append (cwd) "/" actual-item))) + (if (member actual-res-item marked-items) + model + (let* ((new-res-marked-items (append res-marked-items + (list + actual-res-item))) + (new-marked-items (append marked-items + (list actual-item))) + (new-model (make-dirfiles-result-object + (dirfiles-result-object-pos-y model) + (dirfiles-result-object-pos-x model) + (dirfiles-result-object-file-list + model) + (dirfiles-result-object-result-text + model) + (dirfiles-result-object-working-directory + model) + (dirfiles-result-object-width model) + (dirfiles-result-object-initial-wd + model) + new-marked-items + new-res-marked-items))) + new-model)))))) + + ;;Ctrl+u -> aus Auswahl rausnehmen + ((= key 21) + (let* ((marked-items (dirfiles-result-object-marked-items model)) + (res-marked-items (dirfiles-result-object-res-marked-items + model)) + (actual-pos (dirfiles-result-object-pos-y model)) + (all-items (dirfiles-result-object-file-list model))) + (if (<= actual-pos 2) + model + (let* ((actual-item (list-ref all-items (- actual-pos 3))) + (actual-res-item (string-append (cwd) "/" actual-item)) + (rest (member actual-item marked-items)) + (res-rest (member actual-res-item res-marked-items))) + (if (not res-rest) + model + (let* ((after-item (length rest)) + (all-items (length marked-items)) + (before-item (sublist marked-items + 0 + (- all-items + after-item ))) + (new-marked-items (append before-item + (list-tail rest 1))) + (after-res-item (length res-rest)) + (all-res-items (length res-marked-items)) + (before-res-item (sublist res-marked-items + 0 + (- all-res-items + after-res-item))) + (new-res-marked-items (append before-res-item + (list-tail res-rest + 1))) + (new-model (make-dirfiles-result-object + (dirfiles-result-object-pos-y model) + (dirfiles-result-object-pos-x model) + (dirfiles-result-object-file-list + model) + (dirfiles-result-object-result-text + model) + (dirfiles-result-object-working-directory + model) + (dirfiles-result-object-width model) + (dirfiles-result-object-initial-wd + model) + new-marked-items + new-res-marked-items))) + new-model)))))) + + + + + (else model)))) + + ((restore-message? message) + ;(let ((model (restore-message-object message))) + ;(chdir (dirfiles-result-object-initial-wd model)))) + (chdir initial-working-directory)) + + ((selection-message? message) + (let* ((model (selection-message-object message)) + (marked-items (dirfiles-result-object-res-marked-items model))) + (string-append "'" (exp->string marked-items)))) + + + + (else values)))) + + +(define dir-files-rec + (make-receiver "(directory-files)" dir-files-receiver)) + +(define receivers (cons dir-files-rec '())) + diff --git a/scheme/nuit-engine.scm b/scheme/nuit-engine.scm index a2e7617..8a03bff 100644 --- a/scheme/nuit-engine.scm +++ b/scheme/nuit-engine.scm @@ -4,6 +4,25 @@ ;;************************************************************************* ;;Zustand +;;Die verschiedenen Fenster +;;------------------------ +(define bar1) +(define bar2) +(define bar3) +(define command-win) +(define result-win) + +(define shortcuts '("F1:Exit" + "Ctrl+b:Switch Buffer" + "Ctrl+s:Insert/Select" + "Ctrl+u:-/Unselect" + "Ctrl+p:History->prev" + "Ctrl+n:History->next" + "Ctrl+a:First Pos" + "Ctrl+e:End")) + + + ;;Zustand des oberen Fensters (Command-Window) ;;--------------------------- @@ -40,20 +59,25 @@ (define text-result (list "Start entering commands.")) ;;gibt an, in welcher Zeile des Result-Buffers man sich befindet -(define pos-result 1) +(define pos-result 0) ;;in welcher Spalte -(define pos-result-col 25) +(define pos-result-col 0) ;;gibt an, in welcher Zeile des Buffers man sich befindet -(define result-buffer-pos-y 2) +(define result-buffer-pos-y 0) ;;gibt an, an welcher Position des Buffers man sich befindet. -(define result-buffer-pos-x 2) +(define result-buffer-pos-x 0) ;;Anzahl der Zeilen des Buffers (define result-lines 0) ;;Anzahl der Spalten des Buffers (define result-cols 0) +;;welche Zeilen sollen gehighlighted werden? +(define highlighted-lines '()) + +;;welche Zeilen sollen markiert werden? +(define marked-lines '()) ;;allgemeiner Zustand @@ -68,26 +92,97 @@ ;;Position in der History (define history-pos 0) +;;Datentyp für History-Einträge +(define-record-type history-entry history-entry + (make-history-entry command + result-object) + history-entry? + (command history-entry-command) + (result-object history-entry-result-object)) + ;;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)) +;;actives Result-Objekt +(define current-result-object) -;;Diese Liste beinhaltet die Informationen dazu, was bei bestimmten -;;Benutzereingaben zu tun ist: -(define command-additions '() ) + +;;Typen für Nachrichten +;;--------------------- + +;;Ein neuer Befehl wurde eingegeben +;;-> neues "Object" erzeugen anhand der Parameter in einer Liste +(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)) + +;;Es wurde eine Taste gedrückt +;;->Es wird das Objekt und die Taste an den "User-Code" weitergegeben +;; und dann kommt das veränderte Objekt zurück. +(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)) + +;;Zeichnen +(define-record-type print-message print-message + (make-print-message command-string + object) + print-message? + (command-string print-message-command-string) + (object print-message-object)) + +;;->solch ein Datentyp kommt zurück +(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)) + +;;Wiederherstellen (bei Seiteneffekten) +(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)) + +;;Auswahl anfordern + +(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)) + + + +;;Der Benutzer muss bei Erweiterungen angeben an welche Funktion die +;;Nachrichten bei einem bestimmten Befehl auszuliefern ist + +(define-record-type receiver receiver + (make-receiver command rec) + receiver? + (command receiver-command) + (rec receiver-rec)) + ;;************************************************************************* ;;Verhalten @@ -95,171 +190,170 @@ ;;Eingabe verarbeiten (define run (lambda () - (let loop ((ch (paint))) - (cond + (begin + + ;;Initialisierung + ;;erfolgt nur am Anfang + (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)) + + ;;Loop + (let loop ((ch (paint))) + (cond - ;;Beenden - ((= ch key-f1) - (begin - (addition-function command-add-restore-proc) - #t)) + ;;Das Resultat dieser TAstendrücke ist unabhängig vom activen Buffer + ;;Beenden + ((= ch key-f1) + (begin + (let ((restore-message (make-restore-message + active-command + current-result-object))) + (switch restore-message)) + (endwin))) - ;;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))) + ;;Ctrl+b -> Buffer wechseln + ((= ch 2) + (begin + (if (= active-buffer 1) + (set! active-buffer 2) + (set! active-buffer 1)) (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))))) + + ;;Erfolgt der TAstendruck bei aktivem Ergebnis-Buffer, so wird eine + ;;entsprechende Nachricht versendet. + (else + (if (= active-buffer 2) + (let ((key-message + (make-key-pressed-message active-command + current-result-object + ch))) (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)) + (set! current-result-object (switch key-message)) (loop (paint)))) - (if (<= pos-result-col 1) - (loop (paint)) + + (cond + + ;;Enter + ((= ch 10) (begin - (set! pos-result-col (- pos-result-col 1)) - (loop (paint)))))) + ;;Es wird die restore-Prozedur aufgerufen + ; (let ((restore-message (make-restore-message +; active-command +; current-result-object))) +; (switch restore-message)) + + (execute-command) + (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) + ;;Backspace + ((= ch key-backspace) (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)))) + + ;;Navigieren + ((= ch key-up) + (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)))))) + + ((= ch key-down) + (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))))))) + + + ((= ch key-left) + (if (<= pos-command-col 2) + (loop (paint)) (begin - (add-to-command-buffer ch) - (loop (paint))) - (loop (paint))) - (loop (paint))))))))) + (set! pos-command-col (- pos-command-col 1)) + (loop (paint))))) + + + ((= ch key-right) + (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)))))) + + + ;;Ctrl+p -> History zurück + ((= ch 16) + (begin + (history-back) + (loop (paint)))) + + ;;Ctrl+n -> History vor + ((= ch 14) + (begin + (history-forward) + (loop (paint)))) + + ;;Ctrl+s -> Auswahl-holen + ((= 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))))) + + + + ;;Ctrl+a -> Zeilenanfang + ((= ch 1) + (begin + (set! pos-command-col 2) + (loop (paint)))) + + ;;Ctrl-e -> Zeilenende + ((= ch 5) + (let ((line-length (string-length + (list-ref text-command (- pos-command 1))))) + (begin + ;(set! command-buffer-pos-x (+ line-length 2)) + (set! pos-command-col (+ line-length 2)) + (loop (paint))))) + + (else + (if (<= ch 255) + (if can-write-command + (begin + (add-to-command-buffer ch) + (loop (paint))) + (loop (paint))) + (loop (paint)))))))))))) ;;darstellen und auf Eingabe warten @@ -282,69 +376,101 @@ (comwin-w (COLS)) (reswin-y (+ bar2-y 3)) (reswin-x 0) - (reswin-h (- (- (- (LINES) 6) comwin-h) 3)) + (reswin-h (- (- (- (LINES) 6) comwin-h) 4)) (reswin-w (COLS)) (bar3-y (+ reswin-y reswin-h)) (bar3-x 0) - (bar3-h 3) + (bar3-h 4) (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) + (wclear bar1) + (wclear bar2) + (wclear command-win) + (wclear result-win) + (wclear bar3) + (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)) + (set! 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)) + (print-bar3 (- reswin-w 3)) + ;(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))) + + (echo) ch - )))))) + ))))) + +;;Auswerten ;;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))))) + (let* ((command (list-ref text-command (- (length text-command) 1))) + ;;Hier sollte noch die Behandlung von Parametern eingefügt werden + (message (make-next-command-message command '() result-cols)) + (model (switch message))) + (begin + ;;Vorheriges Objekt in History sichern + (if (not (= history-pos 0)) + (let ((hist-entry (make-history-entry active-command + current-result-object)) + (active (make-history-entry command 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)))) + + ;;Dieser Fall tritt nur ganz am Anfang ein. + (let ((hist-entry (make-history-entry command model))) + (begin + (set! history (list hist-entry)) + (set! history-pos 1)))) + + (set! text-command (append text-command (list ""))) + (set! active-command command) + (set! current-result-object model) + (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)))) ;;Auswerten eines Ausdrucks in Form eines String (define evaluate @@ -360,35 +486,44 @@ (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)))))))) +;;Nachrichten-Vermittlung +;;Der Switch sorgt dafür, dass die Nachrichten richtig ankommen +(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)))))))) - - +;;Steuerung der oberen Buffers ;;Ein Character zur letzten Zeile des Command-Buffers hinzufügen (define add-to-command-buffer (lambda (ch) @@ -406,6 +541,19 @@ (set! text-command (append old-rest (list new-last-el))) (set! pos-command-col (+ pos-command-col 1))))) +;;Einen ganzen String hinzufügen +;;->mehrfacher Aufruf von add-to-command-string +(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))))))))) + + ;;Ein Character aus der letzten Zeile entfernen (backspace) (define remove-from-command-buffer (lambda () @@ -443,20 +591,6 @@ (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 @@ -475,15 +609,6 @@ ;;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) @@ -505,7 +630,6 @@ (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 @@ -524,7 +648,6 @@ (rest-old (substring old width (string-length old)))) (loop (cons next-line new) rest-old)))))) - ;;> hinzufügen (define add-prompts (lambda (l) @@ -541,7 +664,107 @@ (reverse new)))))) +;;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))))) + +;;Darstellen des unteren Buffers +;;Anzeigen des sichtbaren Teils des Result-Buffers +(define print-result-buffer + (lambda (reswin) + (let* ((print-message (make-print-message active-command + current-result-object)) + (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)))) + (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))))))))))))) + +;;anzuzeigende Zeilen im Result-Buffer +(define get-right-result-lines + (lambda () + (prepare-lines text-result result-lines pos-result))) + +;;Markierte und gehighlightete Zeilen berechnen: +(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 ;;Cursor an die richtige Stelle bewegen: (define cursor-right-pos (lambda (comwin reswin comwin-h reswin-h) @@ -578,21 +801,53 @@ (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))))) +;;Unterstes Fenster +(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))))))))) + + ;; Ein Schritt zurück in der History. Im unteren Buffer wird jeweils das ;; Ergebnis angezeigt @@ -601,57 +856,41 @@ (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))) + (entry-com (history-entry-command hist-entry)) + (entry-res-obj (history-entry-result-object hist-entry))) (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))))))) + (set! current-result-object entry-res-obj) + (set! text-command (append + (sublist text-command 0 + (- (length text-command) 1)) + (list entry-com))) + (if (> history-pos 1) + (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)) + (if (= history-pos (length history) ) (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))) + (let* ((hist-entry (list-ref history history-pos)) + (entry-com (history-entry-command hist-entry)) + (entry-res-obj (history-entry-result-object hist-entry))) (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! current-result-object entry-res-obj) (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 @@ -665,44 +904,106 @@ ;;Die folgenden Funktionen sollten später in eine eigene Datei kommen. ;;Sie sind abhängig vom jeweiligen Befehl. + +;;Standardfall +;;------------ + +;;Datentyp, der das Resultat einer "Standard-Auswertung" repräsentiert +(define-record-type standard-result-obj standard-result-obj + (make-standard-result-obj cursor-pos-y + cursor-pos-x + result-text) + 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)) + +(define init-std-res (make-standard-result-obj 1 1 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))) + 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)) + (text (standard-result-obj-result-text model))) + (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) + "")))) + ;;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)) + (reverse (seperate-line result-str width)))) ;;directory-files +;;--------------- + -;;speichert das working-directory zur Zeit des Aufrufs (define initial-working-directory (cwd)) -;;speichert die aktuelle Anzeige -(define printed-files '()) +;;Result-Object für "directory-files" +(define-record-type dirfiles-result-object dirfiles-result-object + (make-dirfiles-result-object pos-y + pos-x + file-list + result-text + working-directory + width + initial-wd + marked-items + res-marked-items) + dirfiles-result-object? + (pos-y dirfiles-result-object-pos-y) + (pos-x dirfiles-result-object-pos-x) + (file-list dirfiles-result-object-file-list) + (result-text dirfiles-result-object-result-text) + (working-directory dirfiles-result-object-working-directory) + (width dirfiles-result-object-width) + (initial-wd dirfiles-result-object-initial-wd) + (marked-items dirfiles-result-object-marked-items) + (res-marked-items dirfiles-result-object-res-marked-items)) ;;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))) + (let ((printed-file-list (print-file-list result)) + (directory (cwd)) + (heading "")) (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)))))) + (if (<= (string-length directory) (- width 27)) + (set! heading (string-append "Directory-Content of " + directory " :")) + (let ((dir-string (substring directory + (- (string-length directory) + (- width 27)) + (string-length directory)))) + (set! heading (string-append "Directory-Content of ..." + dir-string)))) + (append (list heading) (list " <-") + printed-file-list)))))) + ;;Eine Datei pro Zeile ;;Falls es sich um ein Verzeichnis handelt wird "/" hinzugefügt @@ -715,57 +1016,275 @@ (let ((hd (list-ref old 0)) (tl (cdr old))) (if (file-directory? hd) - (let ((new-str (string-append hd "/"))) + (let ((new-str (string-append " " hd "/"))) (loop tl (append new (list new-str)))) - (loop tl (append new (list hd))))))))) + (loop tl (append new (list (string-append " " 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))) + (lambda (model) + (let ((ln (dirfiles-result-object-pos-y model))) + (if (or (>= ln (+ (length (dirfiles-result-object-result-text model)) 1)) + (<= ln 1)) + model + (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))))))) + (let* ((new-result (evaluate "(directory-files)")) + (new-result-string (exp->string new-result)) + (width (dirfiles-result-object-width model)) + (new-text (layout-result-dirfiles + new-result-string new-result width)) + (new-model (make-dirfiles-result-object + 2 + 1 + new-result + new-text + (cwd) + width + (dirfiles-result-object-initial-wd + model) + (dirfiles-result-object-marked-items + model) + (dirfiles-result-object-res-marked-items + model)))) + new-model)) + model) + (let* ((text (dirfiles-result-object-result-text model)) + (ent (list-ref text (- ln 1))) + (len (string-length ent)) + (last-char (substring ent (- len 1) len)) + (rest (substring ent 1 (- len 1)))) + (if (equal? last-char "/") + (begin + (chdir rest) + (let* ((new-result (evaluate "(directory-files)")) + (new-result-string (exp->string new-result)) + (width (dirfiles-result-object-width model)) + (new-text (layout-result-dirfiles + new-result-string new-result width)) + (new-model (make-dirfiles-result-object + 2 + 1 + new-result + new-text + (cwd) + width + (dirfiles-result-object-initial-wd + model) + (dirfiles-result-object-marked-items + model) + (dirfiles-result-object-res-marked-items + model)))) + new-model)) + model))))))) + + +;;Receiver für directory-files +(define dir-files-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)) + (text (layout-result-dirfiles result-string result width)) + (model (make-dirfiles-result-object 2 1 result text (cwd) + width (cwd) '() '()))) + model)) + + ((print-message? message) + (let* ((model (print-message-object message)) + (posy (dirfiles-result-object-pos-y model)) + (posx (dirfiles-result-object-pos-x model)) + (text (dirfiles-result-object-result-text model)) + (marked-pos (get-marked-positions + (dirfiles-result-object-file-list model) + (dirfiles-result-object-marked-items model)))) + (make-print-object posy posx text (list posy) marked-pos))) + + ((key-pressed-message? message) + (let* ((model (key-pressed-message-result-model message)) + (key (key-pressed-message-key message))) + (cond + + ((= key key-up) + (let ((posy (dirfiles-result-object-pos-y model))) + (if (<= posy 2) + model + (let* ((new-posy (- posy 1)) + (new-model (make-dirfiles-result-object + new-posy + (dirfiles-result-object-pos-x model) + (dirfiles-result-object-file-list model) + (dirfiles-result-object-result-text + model) + (dirfiles-result-object-working-directory + model) + (dirfiles-result-object-width model) + (dirfiles-result-object-initial-wd model) + (dirfiles-result-object-marked-items + model) + (dirfiles-result-object-res-marked-items + model)))) + new-model)))) + + ((= key key-down) + (let ((posy (dirfiles-result-object-pos-y model)) + (num-lines (length + (dirfiles-result-object-result-text model)))) + (if (>= posy num-lines) + model + (let* ((new-posy (+ posy 1)) + (new-model (make-dirfiles-result-object + new-posy + (dirfiles-result-object-pos-x model) + (dirfiles-result-object-file-list model) + (dirfiles-result-object-result-text + model) + (dirfiles-result-object-working-directory + model) + (dirfiles-result-object-width model) + (dirfiles-result-object-initial-wd + model) + (dirfiles-result-object-marked-items + model) + (dirfiles-result-object-res-marked-items + model)))) + new-model)))) + + ((= key 10) + (selected-dirfiles model)) + + ;;Ctrl+s -> Auswahl + ((= key 19) + (let* ((marked-items (dirfiles-result-object-marked-items model)) + (res-marked-items (dirfiles-result-object-res-marked-items + model)) + (actual-pos (dirfiles-result-object-pos-y model)) + (all-items (dirfiles-result-object-file-list model))) + (if (<= actual-pos 2) + model + (let* ((actual-item (list-ref all-items (- actual-pos 3))) + (actual-res-item (string-append (cwd) "/" actual-item))) + (if (member actual-res-item marked-items) + model + (let* ((new-res-marked-items (append res-marked-items + (list + actual-res-item))) + (new-marked-items (append marked-items + (list actual-item))) + (new-model (make-dirfiles-result-object + (dirfiles-result-object-pos-y model) + (dirfiles-result-object-pos-x model) + (dirfiles-result-object-file-list + model) + (dirfiles-result-object-result-text + model) + (dirfiles-result-object-working-directory + model) + (dirfiles-result-object-width model) + (dirfiles-result-object-initial-wd + model) + new-marked-items + new-res-marked-items))) + new-model)))))) + + ;;Ctrl+u -> aus Auswahl rausnehmen + ((= key 21) + (let* ((marked-items (dirfiles-result-object-marked-items model)) + (res-marked-items (dirfiles-result-object-res-marked-items + model)) + (actual-pos (dirfiles-result-object-pos-y model)) + (all-items (dirfiles-result-object-file-list model))) + (if (<= actual-pos 2) + model + (let* ((actual-item (list-ref all-items (- actual-pos 3))) + (actual-res-item (string-append (cwd) "/" actual-item)) + (rest (member actual-item marked-items)) + (res-rest (member actual-res-item res-marked-items))) + (if (not res-rest) + model + (let* ((after-item (length rest)) + (all-items (length marked-items)) + (before-item (sublist marked-items + 0 + (- all-items + after-item ))) + (new-marked-items (append before-item + (list-tail rest 1))) + (after-res-item (length res-rest)) + (all-res-items (length res-marked-items)) + (before-res-item (sublist res-marked-items + 0 + (- all-res-items + after-res-item))) + (new-res-marked-items (append before-res-item + (list-tail res-rest + 1))) + (new-model (make-dirfiles-result-object + (dirfiles-result-object-pos-y model) + (dirfiles-result-object-pos-x model) + (dirfiles-result-object-file-list + model) + (dirfiles-result-object-result-text + model) + (dirfiles-result-object-working-directory + model) + (dirfiles-result-object-width model) + (dirfiles-result-object-initial-wd + model) + new-marked-items + new-res-marked-items))) + new-model)))))) + + + + + (else model)))) + + ((restore-message? message) + ;(let ((model (restore-message-object message))) + ;(chdir (dirfiles-result-object-initial-wd model)))) + (chdir initial-working-directory)) + + ((selection-message? message) + (let* ((model (selection-message-object message)) + (marked-items (dirfiles-result-object-res-marked-items model))) + (string-append "'" (exp->string marked-items)))) -;;Zurücksetzen, wenn das nächste Kommando kommt. -(define restore-dirfiles - (lambda () - (begin - (chdir initial-working-directory) - (set! printed-files '()) - ;(set! printed-files '()) - ))) + + + (else values)))) + + +(define dir-files-rec + (make-receiver "(directory-files)" dir-files-receiver)) + +(define receivers (cons dir-files-rec '())) -(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: +(define get-marked-positions + (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))))))) + + ;;Ein Ausdruck als String (define exp->string (lambda (exp) @@ -796,24 +1315,24 @@ (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 (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 ...))))) +; (define-syntax with-fatal-error-handler +; (syntax-rules () +; ((with-fatal-error-handler handler body ...) +; (with-fatal-error-handler* handler +; (lambda () body ...))))) -(run) +; (run) \ No newline at end of file diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index 6caa9a7..d27f22d 100644 --- a/scheme/nuit-packages.scm +++ b/scheme/nuit-packages.scm @@ -9,6 +9,8 @@ signals handle ncurses - srfi-6) + srfi-6 + rt-modules) (files nuit-engine - handle-fatal-error)) + handle-fatal-error + directory-files))