;;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!!!


(define first-column 2)

;;record-type buffer
(define-record-type buffer :buffer
  (make-buffer text
	       pos-line			;; Cursor-Position auf text bezogen 
	       pos-col
	       pos-fin-ln		;; ???
	       pos-y			;; Cursor relativ zum Fenster
	       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!))

(define-record-discloser :buffer
  (lambda (rec)
    `(buffer ,@(map (lambda (p)
		      (cons (car p) ((cdr p) rec)))
		    `((pos-line . ,buffer-pos-line)
		      (pos-col . ,buffer-pos-col)
		      (pos-fin-ln . ,buffer-pos-fin-ln)
		      (pos-y . ,buffer-pos-y)
		      (pos-x . ,buffer-pos-x)
		      (history-pos . ,buffer-history-pos)
		      (lines . ,(lambda (b) (length (buffer-text b)))))))))

(define (buffer-text-current-line buffer)
  (list-ref (buffer-text buffer)
	    (- (buffer-pos-line buffer) 1)))

(define (buffer-text-append-new-line! buffer)
  (set-buffer-text! buffer
		    (append (buffer-text buffer) 
			    (list ""))))

;;handle input
(define (input buffer ch)
  (cond
       
   ;; enter key
   ((= ch 10)
    (set-buffer-text! buffer 
		      (append (buffer-text buffer) (list "")))
    (set-buffer-pos-line! buffer 
			  (+ (buffer-pos-line buffer) 1))
    (set-buffer-pos-col! buffer first-column)
    (set-buffer-history-pos! buffer
			     (- (length (buffer-text buffer)) 1)))
   ;; backspace
   ((and (= ch key-backspace)
	 (buffer-can-write buffer)
	 (not (< (buffer-pos-col buffer) 3)))
    (set-buffer-text! buffer
		      (remove-from-command-buffer
		       (buffer-text buffer)
		       (buffer-pos-col buffer)))
    (regress-buffer-cursor-column! buffer))

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

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

   ;; CursorLeft
   ((and (= ch key-left)
	 (> (buffer-pos-col buffer) first-column))
    (regress-buffer-cursor-column! buffer))
     
   ;; CursorRight
   ((= ch key-right)
    (let ((line-length (string-length 
			(buffer-text-current-line buffer))))
      (if (< (buffer-pos-col buffer) (+ line-length first-column))
	  (advance-buffer-cursor-column! buffer))))
       
   ;;Ctrl+a -> Pos 1
   ((= ch 1)
    (set-buffer-pos-col! buffer first-column))

   ;;Ctrl-e -> End
   ((= ch 5)
    (let ((line-length (string-length 
			(buffer-text-current-line buffer))))
      (set-buffer-pos-col! buffer
			   (+ line-length first-column))))

   ;; Ctrl+k -> Zeile löschen
   ((and (= ch 11)
	 (buffer-can-write buffer))
    (let ((text-front (sublist (buffer-text buffer) 
			       0 (- (length (buffer-text buffer)) 1))))
      (set-buffer-text! buffer (append text-front '("")))
      (set-buffer-pos-col! buffer first-column)))

   ;; forward in command history -- CursorDown
   ((and (= ch key-down)
	 (buffer-can-write buffer))
    (if (< (buffer-history-pos buffer) 
	   (- (length (buffer-text buffer)) 1))
	(set-buffer-history-pos! buffer
				 (+ (buffer-history-pos buffer) 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 (buffer-text buffer) 
			      (buffer-history-pos buffer)))))
      (set-buffer-text! buffer (append rest (list hist)))
      (let ((line-length 
	     (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
   ((and (= ch key-up)
	 (buffer-can-write buffer))
    (if (> (buffer-history-pos buffer) 0)
	(set-buffer-history-pos! buffer
				 (- (buffer-history-pos buffer) 1)))
    (let ((rest (sublist (buffer-text buffer) 0 
			 (- (length (buffer-text buffer)) 1)))
	  (hist (list-ref (buffer-text buffer) 
			  (buffer-history-pos buffer))))
      (set-buffer-text! buffer
			(append rest (list hist))))
    (let ((line-length (string-length 
			(list-ref (buffer-text buffer) 
				  (- (length (buffer-text buffer)) 1)))))
      (set-buffer-pos-col! buffer (+ line-length first-column))))

   ((and (buffer-can-write buffer) (<= ch 255))
    (append-char-to-buffer! ch buffer)
    (advance-buffer-cursor-column! buffer))

  (values)))

;;print content of the buffer into the specified window
(define (print-command-buffer win buffer)
  (call-with-values
      (lambda ()
	(get-right-command-lines buffer))
    (lambda (lines new-pos-fin-ln)
      (set-buffer-pos-fin-ln! buffer new-pos-fin-ln)
      (let lp ((lines lines) (line-count 0))
	(if (or (null? lines)
		(> line-count (buffer-num-lines buffer)))
	    (values)
	    (begin
	      (mvwaddstr win line-count 1 (car lines))
	      (lp (cdr lines) (+ line-count 1))))))))

;;compute the visible lines
(define (get-right-command-lines buffer)
  (call-with-values 
      (lambda ()
	(all-commands-seperated buffer))
    (lambda (all-lines-seperated pos-fin-ln)
      (let ((num-all-lines (length all-lines-seperated))
	    (num-lines (buffer-num-lines buffer)))
	(if (>= pos-fin-ln num-lines)
	    ;;aktive Zeile ist die unterste
	    (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
		(values (prepare-lines all-lines-seperated 
				       num-lines (- pos-fin-ln 1))
			pos-fin-ln)
		;;scrollen auf der ersten Seite
		(values (sublist all-lines-seperated 0 num-lines)
			pos-fin-ln)))))))

;;seperate all statements
(define (all-commands-seperated buffer)
  (let ((num-cols (buffer-num-cols buffer))
	(pos-fin-ln (buffer-pos-fin-ln buffer))
	(commands (buffer-text buffer)))
    (let loop ((act-pos 1) (new '()))
      (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
				 first-el-old num-cols))
		 (length-act (length seperated-act)))
	    (set! pos-fin-ln (+ length-new length-act))))

      (if (> act-pos (length commands))
	  (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)))))))

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

;;Cursor
;;Put Cursor to the right position
(define (cursor-right-pos win buffer)
  (let ((text-index (- (buffer-pos-col buffer) first-column))
	(pos-fin-ln (buffer-pos-fin-ln buffer))
	(pos-x (buffer-pos-x buffer))
	(num-lines (buffer-num-lines buffer))
	(num-cols (buffer-num-cols buffer)))

    ;; y position
    (let* ((item-length (string-length (buffer-text-current-line buffer)))
	   (no-wrapped-lines (quotient item-length num-cols))
	   (first-line-offset (quotient text-index num-cols))
	   (new-y (- (+ (- pos-fin-ln no-wrapped-lines)
			first-line-offset)
		     1)))
;       (debug-message "num-cols "
; 		     num-cols
; 		     " 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
; 		     " text-index "
; 		     text-index
; 		     " pos-line " 
; 		     (buffer-pos-line buffer)
; 		     " num-lines "
; 		     num-lines)

;       (if (and (not (zero? text-index))
; 	       (zero? (remainder text-index num-cols))
; 	       (= text-index item-length))
; 	  (set-buffer-pos-y! buffer (+ new-y 1))
; 	  (set-buffer-pos-y! buffer new-y))


      (cond
       ((and (>= new-y num-lines)
	     (not (zero? text-index))
	     (zero? (remainder text-index num-cols))
	     (= text-index item-length))
	(set-buffer-pos-y! buffer num-lines))
       ((and (>= new-y num-lines)
	     (< text-index item-length))
	(set-buffer-pos-y! buffer 
			   (- num-lines 
			      (- (+ no-wrapped-lines 1)
				 first-line-offset))))
       ((>= new-y num-lines)
	(set-buffer-pos-y! buffer (- num-lines 1)))
       ((and (not (zero? text-index))
	     (zero? (remainder text-index num-cols))
	     (= text-index item-length))
	(set-buffer-pos-y! buffer (+ new-y 1)))
       (else
	(set-buffer-pos-y! buffer new-y)))
	  
      ;; x position
      (set-buffer-pos-x! buffer (+ first-column
				   (modulo text-index num-cols)))
      
;       (debug-message "cursor position "
; 		     (buffer-pos-x buffer)
; 		     " "
; 		     (buffer-pos-y buffer))
;      (debug-message "num-cols " num-cols
;		     " pos-col " pos-col
;		     " text '" (buffer-text-current-line buffer) "'")

      (wmove win (buffer-pos-y buffer) (buffer-pos-x buffer)))))
		 
(define (advance-buffer-cursor-column! buffer)
  (set-buffer-pos-col! buffer
		       (+ 1 (buffer-pos-col buffer))))

(define (regress-buffer-cursor-column! buffer)
  (set-buffer-pos-col! buffer
		       (- (buffer-pos-col buffer) 1)))

;; add one character to the buffer
(define (append-char-to-buffer! ch buffer)
  (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 
			       (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)))
    (set-buffer-text! buffer
		      (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 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 height width welcome-message)
  (if (string=? "" 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) ))