;;  ,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)