1338 lines
38 KiB
Scheme
1338 lines
38 KiB
Scheme
;; ,load /home/demattia/studium/studienarbeit/scsh-nuit/scheme/nuit-engine.scm
|
||
|
||
|
||
;;*************************************************************************
|
||
;;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)
|
||
;;---------------------------
|
||
|
||
;;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 0)
|
||
;;in welcher Spalte
|
||
(define pos-result-col 0)
|
||
|
||
;;gibt an, in welcher Zeile des Buffers man sich befindet
|
||
(define result-buffer-pos-y 0)
|
||
;;gibt an, an welcher Position des Buffers man sich befindet.
|
||
(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
|
||
;;-------------------
|
||
|
||
;;entweder 1...oben oder 2...unten
|
||
(define active-buffer 1)
|
||
|
||
;;History
|
||
(define history '())
|
||
|
||
;;Position in der History
|
||
(define history-pos 0)
|
||
|
||
;;Datentyp f<>r History-Eintr<74>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 "")
|
||
|
||
;;actives Result-Objekt
|
||
(define current-result-object)
|
||
|
||
|
||
|
||
;;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<64>ckt
|
||
;;->Es wird das Objekt und die Taste an den "User-Code" weitergegeben
|
||
;; und dann kommt das ver<65>nderte Objekt zur<75>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<75>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
|
||
|
||
;;Eingabe verarbeiten
|
||
(define run
|
||
(lambda ()
|
||
(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
|
||
|
||
;;Das Resultat dieser TAstendr<64>cke ist unabh<62>ngig vom activen Buffer
|
||
;;Beenden
|
||
((= ch key-f1)
|
||
(begin
|
||
(let ((restore-message (make-restore-message
|
||
active-command
|
||
current-result-object)))
|
||
(switch restore-message))
|
||
(endwin)))
|
||
|
||
;;Ctrl+b -> Buffer wechseln
|
||
((= ch 2)
|
||
(begin
|
||
(if (= active-buffer 1)
|
||
(set! active-buffer 2)
|
||
(set! active-buffer 1))
|
||
(loop (paint))))
|
||
|
||
|
||
;;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! current-result-object (switch key-message))
|
||
(loop (paint))))
|
||
|
||
(cond
|
||
|
||
;;Enter
|
||
((= ch 10)
|
||
(begin
|
||
;;Es wird die restore-Prozedur aufgerufen
|
||
; (let ((restore-message (make-restore-message
|
||
; active-command
|
||
; current-result-object)))
|
||
; (switch restore-message))
|
||
|
||
(execute-command)
|
||
(loop (paint))))
|
||
|
||
;;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
|
||
(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<75>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
|
||
(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) 4))
|
||
(reswin-w (COLS))
|
||
(bar3-y (+ reswin-y reswin-h))
|
||
(bar3-x 0)
|
||
(bar3-h 4)
|
||
(bar3-w (COLS)))
|
||
|
||
(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<73>tigt -> Kommando ausfuehren
|
||
(define execute-command
|
||
(lambda ()
|
||
(let* ((command (list-ref text-command (- (length text-command) 1)))
|
||
;;Hier sollte noch die Behandlung von Parametern eingef<65>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
|
||
(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)))
|
||
|
||
|
||
|
||
;;Nachrichten-Vermittlung
|
||
;;Der Switch sorgt daf<61>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<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)))))
|
||
|
||
;;Einen ganzen String hinzuf<75>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 ()
|
||
(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)))))))))
|
||
|
||
|
||
;;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))))))
|
||
|
||
;;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))))))
|
||
|
||
|
||
;;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)))))
|
||
|
||
|
||
;;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)
|
||
(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)))))
|
||
|
||
|
||
;;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<75>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 (history-entry-command hist-entry))
|
||
(entry-res-obj (history-entry-result-object hist-entry)))
|
||
(begin
|
||
(set! active-command entry-com)
|
||
(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) )
|
||
(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))
|
||
(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)
|
||
(set! current-result-object entry-res-obj)
|
||
(set! history-pos (+ history-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<73>ter in eine eigene Datei kommen.
|
||
;;Sie sind abh<62>ngig vom jeweiligen Befehl.
|
||
|
||
|
||
;;Standardfall
|
||
;;------------
|
||
|
||
;;Datentyp, der das Resultat einer "Standard-Auswertung" repr<70>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)
|
||
(reverse (seperate-line result-str width))))
|
||
|
||
|
||
;;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<65>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 '()))
|
||
|
||
|
||
|
||
|
||
|
||
;;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)
|
||
(let ((exp-port (open-output-string)))
|
||
(begin
|
||
(write exp exp-port)
|
||
(get-output-string exp-port)))))
|
||
|
||
|
||
|
||
|
||
;;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)
|
||
|