revamp code for positioning the cursor, code cleanup

scheme/input-buffer.scm

@@ -34,13 +34,15 @@
 ;;It is very esential, that you set keypad to true und call noecho!!!
 
 
+(define first-column 2)
+
 ;;record-type buffer
 (define-record-type buffer :buffer
   (make-buffer text
-	       pos-line
+	       pos-line			;; Cursor-Position auf text bezogen 
 	       pos-col
-	       pos-fin-ln
+	       pos-fin-ln		;; ???
-	       pos-y
+	       pos-y			;; Cursor relativ zum Fenster
 	       pos-x
 	       num-lines
 	       num-cols
@@ -67,204 +69,181 @@
 		      (pos-y . ,buffer-pos-y)
 		      (pos-x . ,buffer-pos-x))))))
 
+(define (buffer-text-current-line buffer)
+  (list-ref (buffer-text buffer)
+	    (- (buffer-pos-line buffer) 1)))
+
 ;;handle input
-(define input
+(define (input buffer ch)
-  (lambda (buffer ch)
-    (let ((text (buffer-text buffer))
-	  (pos-line (buffer-pos-line buffer))
-	  (pos-col (buffer-pos-col buffer))
-	  (pos-fin-ln (buffer-pos-fin-ln buffer))
-	  (pos-y (buffer-pos-y buffer))
-	  (pos-x (buffer-pos-x buffer))
-	  (num-lines (buffer-num-lines buffer))
-	  (num-cols (buffer-num-cols buffer))
-	  (can-write (buffer-can-write buffer))
-	  (history-pos (buffer-history-pos buffer)))
-    (begin
   (cond
        
-       ;;Enter
+   ;; enter key
    ((= ch 10)
-	(begin
+    (set-buffer-text! buffer 
-	  (set! text (append text (list "")))
+		      (append (buffer-text buffer (list ""))))
-	  (set! pos-line (+ pos-line 1))
+    (set-buffer-pos-line! buffer 
-	  (set! history-pos (- (length text) 1))
+			  (+ (buffer-pos-line buffer) 1))
-	  (set! pos-col 2)))
+    (set-buffer-pos-col! buffer first-column)
-
+    (set-buffer-history-pos! buffer
-       ;;Backspace
+			     (+ (length (buffer-text buffer)) 1)))
-       ((= ch key-backspace)
+   ;; backspace
-	(if can-write
+   ((and (= ch key-backspace)
-	    (if (< pos-col 3)
+	 (buffer-can-write buffer)
-		(values)
+	 (not (< (buffer-pos-col buffer) 3)))
-		(begin
+    (set-buffer-text! buffer
-		  (set! text (remove-from-command-buffer text pos-col))
+		      (remove-from-command-buffer
-		  (set! pos-col (- pos-col 1))))
+		       (buffer-text buffer)
-	    (values)))
+		       (buffer-pos-col buffer)))
+    (regress-buffer-cursor-column! buffer))
 
    ;; FIXME
    ;; move cursor to previous line Ctrl-p, keycode 16
-       ((= ch 16)
+;       ((= ch 16)
-	(if (< pos-fin-ln 2)
+;        (if (< pos-fin-ln 2)
- 	    (values)
+; 	   (values)
- 	    (let ((length-prev-line
+; 	   (let ((length-prev-line
- 		   (string-length
+; 		  (string-length
- 		    (list-ref text (- pos-line 2)))))
+; 		   (list-ref text (- pos-line 2)))))
-	      (set! can-write #f)
+; 	     (set! can-write #f)
-	      (set! pos-line (- pos-line 1))
+; 	     (set! pos-line (- pos-line 1))
-	      (set! pos-col (+ length-prev-line 2)))))
+; 	     (set! pos-col (+ length-prev-line 2)))))
 
    ;; FIXME
    ;; move cursor to next line Ctrl-n, keycode 141
-        ((= ch 141)
+;       ((= ch 141)
- 	(let ((last-pos (length text)))
+;        (let ((last-pos (length text)))
- 	  (if (>= pos-line last-pos)
+; 	 (if (>= pos-line last-pos)
- 	      (values)
+; 	     (values)
- 	      (let ((length-next-line 
+; 	     (let ((length-next-line 
- 		     (string-length 
+; 		    (string-length 
- 		      (list-ref text pos-line))))
+; 		     (list-ref text pos-line))))
- 		(begin
+; 	       (begin
- 		  (set! pos-col (+ length-next-line 2))
+; 		 (set! pos-col (+ length-next-line 2))
- 		  (set! pos-line (+ pos-line 1))
+; 		 (set! pos-line (+ pos-line 1))
- 		  (if (= pos-line last-pos)
+; 		 (if (= pos-line last-pos)
- 		      (set! can-write #t)))))))
+; 		     (set! can-write #t)))))))
 
-       ((= ch key-left)
+   ;; CursorLeft
-	(if (<= pos-col 2)
+   ((and (= ch key-left)
-	    (values)
+	 (> (buffer-pos-col buffer) first-column))
-	    (begin
+    (regress-buffer-cursor-column! buffer))
-	      (set! pos-col (- pos-col 1)))))
      
+   ;; CursorRight
    ((= ch key-right)
     (let ((line-length (string-length 
-			    (list-ref text
+			(buffer-text-current-line buffer))))
-				      (- pos-line 1)))))
+      (if (< (buffer-pos-col buffer) (+ line-length first-column))
-	  (if (>= pos-col (+ line-length 2))
+	  (advance-buffer-cursor-column! buffer))))
-	      (values)
-	      (begin
-		(set! pos-col (+ pos-col 1))))))
-
        
    ;;Ctrl+a -> Pos 1
    ((= ch 1)
-	(begin
+    (set-buffer-pos-col! buffer first-column))
-	  (set! pos-col 2)))
 
    ;;Ctrl-e -> End
    ((= ch 5)
     (let ((line-length (string-length 
-			    (list-ref text (- pos-line 1)))))
+			(buffer-text-current-line buffer))))
-	  (begin
+      (set-buffer-pos-col! buffer
-	    (set! pos-col (+ line-length 2)))))
+			   (+ line-length first-column))))
 
-       ;;Ctrl+k -> Zeile löschen
+   ;; Ctrl+k -> Zeile löschen
-       ((= ch 11)
+   ((and (= ch 11)
-	(if can-write
+	 (buffer-can-write buffer))
-	    (let ((text-front (sublist text 0 (- (length text) 1))))
+    (let ((text-front (sublist (buffer-text buffer) 
-	      (begin
+			       0 (- (length (buffer-text buffer)) 1))))
-		(set! text (append text-front '("")))
+      (set-buffer-text! buffer (append text-front '("")))
-		(set! pos-col 2)))))
+      (set-buffer-pos-col! buffer first-column)))
 
    ;; forward in command history -- CursorDown
-       ((= ch key-down)
+   ((and (= ch key-down)
-	(if can-write
+	 (buffer-can-write buffer))
-	    (begin
+    (if (< (buffer-history-pos buffer) 
-	      (if (< history-pos (- (length text) 1))
+	   (- (length (buffer-text buffer)) 1))
-		  (set! history-pos (+ history-pos 1)))
+	(set-buffer-history-pos! buffer
-	      (let ((rest (sublist text 0 (- (length text) 1)))
+				 (+ (buffer-history-pos buffer) 1)))
-		    (hist (if (= history-pos (- (length text) 1))
+    (let ((rest (sublist (buffer-text buffer) 0 
+			 (- (length (buffer-text buffer)) 1)))
+	  (hist (if (= (buffer-history-pos buffer) 
+		       (- (length (buffer-text buffer)) 1))
 		    ""
-			      (list-ref text history-pos))))
+		    (list-ref (buffer-text buffer) 
-		 (set! text (append rest (list hist))))
+			      (buffer-history-pos buffer)))))
-	      (let ((line-length (string-length 
+      (set-buffer-text! buffer (append rest (list hist)))
-				  (list-ref text (- (length text) 1)))))
+      (let ((line-length 
-		    (set! pos-col (+ line-length 2))))))
+	     (string-length 
+	      (list-ref (buffer-text buffer) 
+			(- (length (buffer-text buffer)) 1)))))
+	(set-buffer-pos-col! buffer (+ line-length first-column)))))
 
    ;; back in command history -- CursorUp
-       ((= ch key-up)
+   ((and (= ch key-up)
-	(if can-write
+	 (buffer-can-write buffer))
-	    (begin
+    (if (> (buffer-history-pos buffer) 0)
-	      (if (> history-pos 0)
+	(set-buffer-history-pos! (- (buffer-history-pos 1))))
-		  (set! history-pos (- history-pos 1)))
+    (let ((rest (sublist (buffer-text buffer) 0 
-	      (let ((rest (sublist text 0 (- (length text) 1)))
+			 (- (length (buffer-text buffer)) 1)))
-		    (hist (list-ref text history-pos)))
+	  (hist (list-ref (buffer-text buffer) 
-		(set! text (append rest (list hist))))
+			  (buffer-history-pos buffer))))
+      (set-buffer-text! buffer
+			(append rest (list hist))))
     (let ((line-length (string-length 
-				  (list-ref text (- (length text) 1)))))
+			(list-ref (buffer-text buffer) 
-		(set! pos-col (+ line-length 2))))))
+				  (- (length (buffer-text buffer)) 1)))))
+      (set-buffer-pos-col! buffer (+ line-length first-column))))
 
-       ((and can-write (<= ch 255))
+   ((and (buffer-can-write buffer) (<= ch 255))
-	(set! text (add-to-command-buffer ch text pos-col))
+    (append-char-to-buffer! ch buffer)
-	(set! pos-col (+ pos-col 1)))
+    (advance-buffer-cursor-column! buffer))
 
-       (else 
   (values)))
 
-      (make-buffer text pos-line  pos-col pos-fin-ln pos-y pos-x
-		   num-lines num-cols can-write history-pos)))))
-
-
-
 ;;print content of the buffer into the specified window
-(define print-command-buffer
+(define (print-command-buffer win buffer)
-  (lambda (win buffer)
+  (call-with-values
-    (let ((text (buffer-text buffer))
+      (lambda ()
-	  (pos-line (buffer-pos-line buffer))
+	(get-right-command-lines buffer))
-	  (pos-col (buffer-pos-col buffer))
+    (lambda (lines new-pos-fin-ln)
-	  (pos-fin-ln (buffer-pos-fin-ln buffer))
+      (set-buffer-pos-fin-ln! buffer new-pos-fin-ln)
-	  (pos-y (buffer-pos-y buffer))
+      (let lp ((lines lines) (line-count 0))
-	  (pos-x (buffer-pos-x buffer))
+	(if (or (null? lines)
-	  (num-lines (buffer-num-lines buffer))
+		(> line-count (buffer-num-lines buffer)))
-	  (num-cols (buffer-num-cols buffer))
+	    (values)
-	  (can-write (buffer-can-write buffer))
-	  (history-pos (buffer-history-pos buffer)))
-      (let* ((l (get-right-command-lines text pos-fin-ln num-lines
-					    pos-line num-cols))
-	     (lines (car l)))
 	    (begin
-	  (set! pos-fin-ln (cdr l))
+	      (mvwaddstr win line-count 1 (car lines))
-	  (let loop ((pos 1))
+	      (lp (cdr lines) (+ line-count 1))))))))
-	    (if (> pos num-lines)
-		(make-buffer text pos-line pos-col pos-fin-ln pos-y
-			     pos-x num-lines num-cols can-write history-pos)
-		(let ((line (list-ref lines (- pos 1))))
-		  (begin
-		    (mvwaddstr win pos 1 line)
-		    ;(wrefresh win)
-		    (loop (+ pos 1)))))))))))
-
 
 ;;compute the visible lines
-(define get-right-command-lines
+(define (get-right-command-lines buffer)
-  (lambda (text pos-fin-ln num-lines pos-line num-cols)
+  (call-with-values 
-    (let* ((res (all-commands-seperated text pos-line num-cols
+      (lambda ()
-					pos-fin-ln ))
+	(all-commands-seperated buffer))
-	   (all-lines-seperated (car res))
+    (lambda (all-lines-seperated new-pos-fin-ln)
-	   (num-all-lines (length all-lines-seperated)))
+      (let ((num-all-lines (length all-lines-seperated))
-      (begin
+	    (num-lines (buffer-num-lines buffer))
-	(set! pos-fin-ln (cdr res))
+	    (pos-fin-ln (buffer-pos-fin-ln buffer)))
+	(set! pos-fin-ln new-pos-fin-ln)
 	(if (>= pos-fin-ln num-lines)
 	    ;;aktive Zeile ist die unterste
-	    (cons (sublist all-lines-seperated 
+	    (values (sublist all-lines-seperated 
 			     (- pos-fin-ln num-lines) 
 			     num-lines)
 		    pos-fin-ln)
 	    (if (<= num-all-lines num-lines)
 		;;noch keine ganze Seite im Buffer
-		(cons (prepare-lines all-lines-seperated 
+		(values (prepare-lines all-lines-seperated 
 				       num-lines (- pos-fin-ln 1))
 			pos-fin-ln)
 		;;scrollen auf der ersten Seite
-		(cons (sublist all-lines-seperated 0 num-lines)
+		(values (sublist all-lines-seperated 0 num-lines)
 			pos-fin-ln)))))))
 
-
 ;;seperate all statements
-(define all-commands-seperated
+(define (all-commands-seperated buffer)
-  (lambda (commands pos-line num-cols pos-fin-ln)
+  (let ((num-cols (buffer-num-cols buffer))
-    (let loop ((act-pos 1)
+	(pos-fin-ln (buffer-pos-fin-ln buffer))
-	       (new '()))
+	(commands (buffer-text buffer)))
-      (begin
+    (let loop ((act-pos 1) (new '()))
-	(if (= act-pos pos-line)
+      (if (= act-pos (buffer-pos-line buffer))
 	  (let* ((length-new (length new))
 		 (first-el-old (list-ref commands (- act-pos 1)))
 		 (seperated-act (seperate-line-com
@@ -273,16 +252,14 @@
 	    (set! pos-fin-ln (+ length-new length-act))))
 
       (if (> act-pos (length commands))
-	    (cons (reverse new) pos-fin-ln)
+	  (values (reverse new) pos-fin-ln)
 	  (let* ((first-el-old (list-ref commands (- act-pos 1)))
 		 (seperated-fst-el-old 
 		  (seperate-line-com first-el-old num-cols)))
-	      (loop (+ act-pos 1) (append seperated-fst-el-old new))))))))
+	    (loop (+ act-pos 1) (append seperated-fst-el-old new)))))))
-
 
 ;;seperate one statement
-(define seperate-line-com
+(define (seperate-line-com line width)
-  (lambda (line width)
   (let loop ((new '())
 	     (old line))
     (if (> width (string-length old))
@@ -295,12 +272,10 @@
 					;(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))))))
+	  (loop (cons next-line new) rest-old)))))
-
 
 ;;add ">"
-(define add-prompts
+(define (add-prompts l)
-  (lambda (l)
   (let* ((lr (reverse l))
 	 (old-first-el (list-ref lr 0))
 	 (new-first-el (string-append ">" old-first-el))
@@ -311,12 +286,10 @@
 	  (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))))))
+	  (reverse new)))))
-
 
 ;;Find the lines to print
-(define prepare-lines
+(define (prepare-lines l height pos)
-  (lambda (l height pos)
   (if (< (length l) height)
       ;; Liste zu kurz -> ""s hinzufügen
       (let loop ((tmp-list l))
@@ -328,58 +301,63 @@
 	  ;;pos nicht ganz unten
 	  (sublist l 0 height)
 	  ;;standard-Fall 
-	    (sublist l (- pos height) height)))))
+	  (sublist l (- pos height) height))))
-
-
 
 ;;Cursor
 ;;Put Cursor to the right position
 (define (cursor-right-pos win buffer)
-  (let ((text (buffer-text buffer))
+  (let ((pos-col (buffer-pos-col buffer))
-	(pos-line (buffer-pos-line buffer))
-	(pos-col (buffer-pos-col buffer))
 	(pos-fin-ln (buffer-pos-fin-ln buffer))
-	(pos-y (buffer-pos-y buffer))
 	(pos-x (buffer-pos-x buffer))
 	(num-lines (buffer-num-lines buffer))
-	(num-cols (buffer-num-cols buffer))
+	(num-cols (buffer-num-cols buffer)))
-	(can-write (buffer-can-write buffer))
+
-	(history-pos (buffer-history-pos buffer)))
+    ;; y position
-    (begin
+    (let* ((item-length (string-length (buffer-text-current-line buffer)))
-      ;;zuerst mal y 
+	   (no-wrapped-lines (quotient item-length num-cols))
-      (let* ((line (list-ref text (- pos-line 1)))
+	   (first-line-offset (quotient (- pos-col first-column) num-cols))
-	     (offset (lines-from-fin-line num-cols pos-col line)))
+	   (new-y (- (+ (- pos-fin-ln no-wrapped-lines)
-	(if (>= pos-fin-ln num-lines)
+			first-line-offset)
-	    ;;unterste Zeile
+		     1)))
-	    (set! pos-y (- num-lines offset))
+      (debug-message "num-cols "
-	    ;;sonst
+		     num-cols
-	    (set! pos-y (- pos-fin-ln offset))))
+		     " no-wrapped-lines "
+		     no-wrapped-lines 
+		     " first-line-offset " 
+		     first-line-offset
+		     " new-y " new-y
+		     " length "
+		     item-length
+		     " pos-fin-ln "
+		     pos-fin-ln
+		     " pos-col "
+		     pos-col)
+      (set-buffer-pos-y! buffer new-y))
+
+    ;; x position
     (let ((posx (modulo pos-col num-cols)))
       (if (<= posx 1)
-	    (set! pos-x (+ num-cols posx))
+	  (set-buffer-pos-x! buffer (+ num-cols posx))
 	  (if (and (= posx 2)
 		   (> pos-col num-cols))
-		(set! pos-x (+ num-cols 1))
+	      (set-buffer-pos-x! buffer (+ num-cols 1))
-		(set! pos-x posx)))
+	      (set-buffer-pos-x! buffer posx))))
-	(wmove win pos-y pos-x)
-	(make-buffer text pos-line  pos-col pos-fin-ln pos-y pos-x
-		     num-lines num-cols can-write history-pos)))))
 
-(define lines-from-fin-line
+    (wmove win (buffer-pos-y buffer) (buffer-pos-x buffer))))
-  (lambda (num-cols pos-col line)
+		 
-    (let* ((lines (ceiling (/ (string-length line) num-cols)))
+(define (advance-buffer-cursor-column! buffer)
-	   (end-pos (* lines num-cols)))
+  (set-buffer-pos-col! buffer
-      (if (= (string-length line) 0)
+		       (+ 1 (buffer-pos-col buffer))))
-	  0
+
-	  (let loop ((offset 0)
+(define (regress-buffer-cursor-column! buffer)
-		     (end end-pos))
+  (set-buffer-pos-col! buffer
-	    (if (<= (+ end 2) pos-col)
+		       (- (buffer-pos-col buffer) 1)))
-		(- offset 1)
-		(loop (+ offset 1) (- end num-cols))))))))
 
 ;; add one character to the buffer
-(define (add-to-command-buffer ch text pos-col)
+(define (append-char-to-buffer! ch buffer)
-  (let* ((last-pos (- (length text) 1))
+  (let* ((text (buffer-text buffer))
+	 (pos-col (buffer-pos-col buffer))
+	 (last-pos (- (length text) 1))
 	 (old-last-el (list-ref text last-pos))
 	 (old-rest (sublist text 0 last-pos))
 	 (before-ch (substring old-last-el 0 
@@ -390,7 +368,8 @@
 	 (new-last-el (string-append  before-ch
 				      (string (ascii->char ch))
 				      after-ch)))
-    (append old-rest (list new-last-el))))
+    (set-buffer-text! buffer
+		      (append old-rest (list new-last-el)))))
 
 ;;Remove one character from the line (backspace)
 (define remove-from-command-buffer
@@ -419,11 +398,10 @@
 
 ;;Create a fitting buffer for a window with box and a welcome-Message
 ;;If the message is "", the buffer starts in line one
-(define make-buffer-welcome
+(define (make-buffer-welcome height width welcome-message)
-  (lambda (height width welcome-message)
+  (if (string=? "" welcome-message)
-    (if (equal? "" welcome-message)
       (make-buffer (list "") 1 2 1 1 2 (- height 2) (- width 3) #t 1)
       (make-buffer (list welcome-message "") 2 2 2 2 2 
-		     (- height 2) (- width 3) #t 1) )))
+		   (- height 2) (- width 3) #t 1) ))
 
 

scheme/ncurses-packages.scm

@@ -368,10 +368,12 @@
 
 (define-structure ncurses ncurses-interface    
   (open scheme-with-scsh
+	srfi-1
 	external-calls
 	define-record-types
 	conditions
 	signals 
+	tty-debug
 	handle)
   (files ncurses
 	 ncurses-constants