scsh-ncurses/scheme/input-buffer.scm

;;This is an application of the "scsh-ncurses" lib.
;;It consists of a buffer with input. 
;;
;;At the beginning we only have an empty buffer for example.
;;You pass this buffer an char after char to the input-function,
;;which modifies the content of the buffer. In the standard-case 
;;you get the characters from "wgetch".
;;
;;One brief example:
; ;
; ;
; ; (begin
; ;   (define my-buffer (make-buffer-welcome 20 20 "test"))
; ;   (init-screen)
; ;   (define win (newwin 20 20 5 5))
; ;   (box win (ascii->char 0) (ascii->char 0))
; ;   (noecho)
; ;   (keypad win #t)
; ;   (set! my-buffer (print-command-buffer win my-buffer))
; ;   (let loop ((ch (wgetch win)))
; ;     (begin
; ;       (wclear win)
; ;       (box win (ascii->char 0) (ascii->char 0))
; ;       (set! my-buffer (input my-buffer ch))
; ;       (set! my-buffer (print-command-buffer win my-buffer))
; ;       (if (= ch key-f1)
; ; 	  (begin
; ; 	    (echo)
; ; 	    (endwin))
; ; 	  (begin
; ; 	    (set! my-buffer (cursor-right-pos win my-buffer))
; ; 	    (loop (wgetch win)))))))

;;It is very esential, that you set keypad to true und call noecho!!!


;;record-type buffer
(define-record-type buffer buffer
  (make-buffer text
	       pos-line
	       pos-col
	       pos-fin-ln
	       pos-y
	       pos-x
	       num-lines
	       num-cols
	       can-write
	       history-pos)
  (text buffer-text set-buffer-text!)
  (pos-line buffer-pos-line set-buffer-pos-line!)
  (pos-col buffer-pos-col set-buffer-pos-col!)
  (pos-fin-ln buffer-pos-fin-ln set-buffer-pos-fin-ln!)
  (pos-y buffer-pos-y set-buffer-pos-y!)
  (pos-x buffer-pos-x set-buffer-pos-x!)
  (num-lines buffer-num-lines set-buffer-num-lines!)
  (num-cols buffer-num-cols set-buffer-num-cols!)
  (can-write buffer-can-write set-buffer-can-write!)
  (history-pos buffer-history-pos set-buffer-history-pos!))

;;handle input
(define input
  (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
       ((= ch 10)
	(begin
	  (set! text (append text (list "")))
	  (set! pos-line (+ pos-line 1))
	  (set! history-pos (- (length text) 1))
	  (set! pos-col 2)))

       ;;Backspace
       ((= ch key-backspace)
	(if can-write
	    (if (< pos-col 3)
		values
		(begin
		  (set! text (remove-from-command-buffer text pos-col))
		  (set! pos-col (- pos-col 1))))
	    values))

       ;; move cursor to previous line Ctrl-p, keycode 16
       ((= ch 16)
 	(if (< pos-fin-ln 2)
 	    values
 	    (let ((length-prev-line
 		   (string-length
 		    (list-ref text (- pos-line 2)))))
	      (set! can-write #f)
	      (set! pos-line (- pos-line 1))
	      (set! pos-col (+ length-prev-line 2)))))

       ;; move cursor to next line Ctrl-n, keycode 141
        ((= ch 141)
 	(let ((last-pos (length text)))
 	  (if (>= pos-line last-pos)
 	      values
 	      (let ((length-next-line 
 		     (string-length 
 		      (list-ref text pos-line))))
 		(begin
 		  (set! pos-col (+ length-next-line 2))
 		  (set! pos-line (+ pos-line 1))
 		  (if (= pos-line last-pos)
 		      (set! can-write #t)))))))

       ((= ch key-left)
	(if (<= pos-col 2)
	    values
	    (begin
	      (set! pos-col (- pos-col 1)))))

       ((= ch key-right)
	(let ((line-length (string-length 
			    (list-ref text
				      (- pos-line 1)))))
	  (if (>= pos-col (+ line-length 2))
	      values
	      (begin
		(set! pos-col (+ pos-col 1))))))

       
       ;;Ctrl+a -> Pos 1
       ((= ch 1)
	(begin
	  (set! pos-col 2)))

       ;;Ctrl-e -> End
       ((= ch 5)
	(let ((line-length (string-length 
			    (list-ref text (- pos-line 1)))))
	  (begin
	    (set! pos-col (+ line-length 2)))))

       ;;Ctrl+k -> Zeile l<>schen
       ((= ch 11)
	(if can-write
	    (let ((text-front (sublist text 0 (- (length text) 1))))
	      (begin
		(set! text (append text-front '("")))
		(set! pos-col 2)))))

       ;; forward in command history -- CursorDown
       ((= ch key-down)
	(if can-write
	    (begin
	      (if (< history-pos (- (length text) 1))
		  (set! history-pos (+ history-pos 1)))
	      (let ((rest (sublist text 0 (- (length text) 1)))
		    (hist (if (= history-pos (- (length text) 1))
			      ""
			      (list-ref text history-pos))))
		 (set! text (append rest (list hist))))
	      (let ((line-length (string-length 
				  (list-ref text (- (length text) 1)))))
		    (set! pos-col (+ line-length 2))))))

       ;; back in command history -- CursorUp
       ((= ch key-up)
	(if can-write
	    (begin
	      (if (> history-pos 0)
		  (set! history-pos (- history-pos 1)))
	      (let ((rest (sublist text 0 (- (length text) 1)))
		    (hist (list-ref text history-pos)))
		(set! text (append rest (list hist))))
	      (let ((line-length (string-length 
				  (list-ref text (- (length text) 1)))))
		(set! pos-col (+ line-length 2))))))
		    
		  
       
       (else 
	(if (<= ch 255)
	    (if can-write
		(begin
		  (begin
		    (set! text (add-to-command-buffer ch text pos-col))
		    (set! pos-col (+ pos-col 1)))
		values))
	    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
  (lambda (win buffer)
    (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)))
      (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))
	  (let loop ((pos 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
  (lambda (text pos-fin-ln num-lines pos-line num-cols)
    (let* ((res (all-commands-seperated text pos-line num-cols
					pos-fin-ln ))
	   (all-lines-seperated (car res))
	   (num-all-lines (length all-lines-seperated)))
      (begin
	(set! pos-fin-ln (cdr res))
	(if (>= pos-fin-ln num-lines)
	    ;;aktive Zeile ist die unterste
	    (cons (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 
				     num-lines (- pos-fin-ln 1))
		      pos-fin-ln)
		;;scrollen auf der ersten Seite
		(cons (sublist all-lines-seperated 0 num-lines)
		      pos-fin-ln)))))))


;;seperate all statements
(define all-commands-seperated
  (lambda (commands pos-line num-cols pos-fin-ln)
    (let loop ((act-pos 1)
	       (new '()))
      (begin
	(if (= act-pos pos-line)
	    (let* ((length-new (length new))
		   (first-el-old (list-ref commands (- act-pos 1)))
		   (seperated-act (seperate-line-com
				   first-el-old num-cols))
		   (length-act (length seperated-act)))
	      (set! pos-fin-ln (+ length-new length-act))))
	
	(if (> act-pos (length commands))
	    (cons (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))))))))


;;seperate one statement
(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))))))


;;add ">"
(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))))))


;;Find the lines to print
(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)))))



;;Cursor
;;Put Cursor to the right position
(define cursor-right-pos
  (lambda (win buffer)
    (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
      ;;zuerst mal y 
      (let* ((line (list-ref text (- pos-line 1)))
	     (offset (lines-from-fin-line num-cols pos-col line)))
	(if (>= pos-fin-ln num-lines)
	    ;;unterste Zeile
	    (set! pos-y (- num-lines offset))
	    ;;sonst
	    (set! pos-y (- pos-fin-ln offset))))
      (let ((posx (modulo pos-col num-cols)))
	(if (<= posx 1)
	    (set! pos-x (+ num-cols posx))
	    (if (and (= posx 2)
		     (> pos-col num-cols))
		(set! pos-x (+ num-cols 1))
		(set! pos-x posx)))
	(wmove win pos-y pos-x)
	(wrefresh win)
	(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
  (lambda (num-cols pos-col line)
    (let* ((lines (ceiling (/ (string-length line) num-cols)))
	   (end-pos (* lines num-cols)))
      (if (= (string-length line) 0)
	  0
	  (let loop ((offset 0)
		     (end end-pos))
	    (if (<= (+ end 2) pos-col)
		(- offset 1)
		(loop (+ offset 1) (- end num-cols))))))))
		 

	       


;;Add one character to the buffer
(define add-to-command-buffer
  (lambda (ch text pos-col)
    (let* ((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 
				 (max 0 (- pos-col 2))))
	   (after-ch (substring old-last-el 
				(max 0 (- pos-col 2))
				(string-length old-last-el)))
	   (new-last-el (string-append  before-ch
					(string (ascii->char ch))
					after-ch)))
      (append old-rest (list new-last-el)))))


;;Remove one character from the line (backspace)
(define remove-from-command-buffer
  (lambda (text pos-col)
    (let* ((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 
				 (max 0 (- pos-col 3))))
	   (after-ch (if (= pos-col 
			    (+ (string-length old-last-el) 2))
			 ""
			 (substring old-last-el 
				(max 0 (- pos-col 2))
				(string-length old-last-el))))
	   (new-last-el (if (= pos-col 
			       (+ (string-length old-last-el) 2))
			    before-ch
			    (string-append  before-ch after-ch))))
      (append old-rest (list new-last-el)))))

(define sublist
  (lambda (l pos k)
    (let ((tmp (list-tail l pos)))
      (reverse (list-tail (reverse tmp) 
			  (- (length tmp) k))))))

;;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
  (lambda (height width 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) )))