;; turn off debugging for the moment
(define debug-message
  (lambda args #f))

(define-record-type terminal-buffer :terminal-buffer
  (really-make-terminal-buffer width height view-index
			       x y buffer repaint?
			       esc-code)
  terminal-buffer?
  (width terminal-buffer-width)
  (height terminal-buffer-height)
  (view-index terminal-buffer-view-index
	      set-terminal-buffer-view-index!)
  (x terminal-buffer-x set-terminal-buffer-x!)
  (y terminal-buffer-y set-terminal-buffer-y!)
  (buffer terminal-buffer-buffer set-terminal-buffer-buffer!)
  (repaint? terminal-buffer-repaint? set-terminal-buffer-repaint?!)
  (esc-code terminal-buffer-esc-code set-terminal-buffer-esc-code!))

(define-record-discloser :terminal-buffer
  (lambda (tb)
    `(terminal-buffer 
      (width ,(terminal-buffer-width tb))
      (height ,(terminal-buffer-height tb))
      (x ,(terminal-buffer-x tb))
      (y ,(terminal-buffer-y tb))
      (repaint? ,(terminal-buffer-repaint? tb))
      (esc-code ,(map char->ascii (string->list (terminal-buffer-esc-code tb)))))))

(define (make-terminal-buffer width height)
  (let ((buffer (map
		 (lambda (ignore)
		   (make-empty-line width))
		 (iota height))))
    (really-make-terminal-buffer width height buffer
				 0 0 buffer #f "")))

(define (line-at-cursor-position termbuf)
  (list-ref (terminal-buffer-view-index termbuf)
	    (terminal-buffer-y termbuf)))

(define (make-empty-line width)
  (make-string width #\space))

(define (cursor-at-end-of-line? termbuf)
  (= (terminal-buffer-x termbuf) 
     (- (terminal-buffer-width termbuf) 1)))

(define (cursor-on-last-line? termbuf)
  (= (terminal-buffer-y termbuf) 
     (- (terminal-buffer-height termbuf) 1)))

(define (append-empty-line termbuf)
  (debug-message "append-empty-line")
  (append! (terminal-buffer-buffer termbuf) 
	   (list (make-empty-line (terminal-buffer-width termbuf)))))

(define (goto-next-line termbuf)
  (debug-message "goto-next-line")
  (set-terminal-buffer-y!
   termbuf (+ (terminal-buffer-y termbuf) 1))
  (maybe-scroll-terminal-buffer termbuf))

(define (move-cursor termbuf x-offset y-offset)
  (debug-message "move-cursor " termbuf " " x-offset " " y-offset)
  (let ((new-x (+ (terminal-buffer-x termbuf) x-offset))
	(new-y (+ (terminal-buffer-y termbuf) y-offset)))
    
    (cond
     ((< new-x 0)
      (set-terminal-buffer-x! termbuf 0))
     ((>= new-x (terminal-buffer-width termbuf))
      (set-terminal-buffer-x! 
       termbuf (- (terminal-buffer-width termbuf) 1)))
     (else
      (set-terminal-buffer-x! termbuf new-x)))

    (cond
     ((< new-y 0)
      (set-terminal-buffer-y! termbuf 0))
     ((>= new-y (terminal-buffer-width termbuf))
      (set-terminal-buffer-y!
       (termbuf (- (terminal-buffer-width termbuf) 1))))
     (else 
      (set-terminal-buffer-y! termbuf new-y)))))

(define (scroll-view-index-down termbuf)
  (set-terminal-buffer-view-index!
   termbuf (cdr (terminal-buffer-view-index termbuf)))
  (set-terminal-buffer-repaint?! termbuf #t))

(define (maybe-scroll-terminal-buffer termbuf)
  (debug-message "maybe-scroll-terminal-buffer")
  (and (>= (terminal-buffer-y termbuf)
	   (terminal-buffer-height termbuf))
       (begin
	 (scroll-view-index-down termbuf)
	 (set-terminal-buffer-y!
	  termbuf
	  (- (terminal-buffer-y termbuf) 1)))))

(define (goto-beginning-of-line termbuf)
  (debug-message "goto-beginning-of-line")
  (set-terminal-buffer-x! termbuf 0))

(define (terminal-buffer-add-char termbuf char)
  (debug-message "add-char " termbuf " '" char "' " 
		 (char->ascii char))
  (cond
   ((not (string=? "" (terminal-buffer-esc-code termbuf)))
    (read-escape-code termbuf char))
   ((char=? char (ascii->char 27))
    (set-terminal-buffer-esc-code! termbuf (string char)))
   ((char=? char (ascii->char 13))
    (goto-beginning-of-line termbuf))
   ((char=? char #\newline)
    (if (cursor-on-last-line? termbuf)
	(append-empty-line termbuf))
    (goto-next-line termbuf))
   ((char-set-contains? char-set:printing char)
    (add-normal-char termbuf char))))

(define (add-normal-char termbuf char)
  (cond
   ((cursor-at-end-of-line? termbuf)
    (append-empty-line termbuf)
    (goto-next-line termbuf)
    (goto-beginning-of-line termbuf)
    (insert-char termbuf char))
   (else
    (insert-char termbuf char)
    (goto-next-char termbuf)))
  (debug-message "add-normal-char "
		 (string-length (line-at-cursor-position termbuf))
		 "'" (line-at-cursor-position termbuf) "'"))

(define (curses-paint-terminal-buffer termbuf win)
  (if (terminal-buffer-repaint? termbuf)
      (clear/repaint-buffer termbuf win)
      (paint-single-line termbuf win)))

(define (clear/repaint-buffer termbuf win)
  (debug-message "clear/repaint-buffer")
  (wclear win)
  (let lp ((i (terminal-buffer-height termbuf))
	   (lines (terminal-buffer-view-index termbuf))
	   (y 0))
    (if (zero? i)
	'blorf
	(begin
	  (debug-message y ": '" (car lines) "'")
	  (mvwaddstr win y 0 (car lines))
	  (lp (- i 1) (cdr lines) (+ y 1)))))
  (position-cursor termbuf win))

(define curses-paint-terminal-buffer/complete 
  clear/repaint-buffer)

(define (paint-single-line termbuf win)
  (debug-message "paint-single-line " termbuf)
  (wclrtoeol win)
  (mvwaddstr win 
	     (terminal-buffer-y termbuf) 0 
	     (line-at-cursor-position termbuf))
  (position-cursor termbuf win))

(define (position-cursor termbuf win)
  (wmove win 
	 (terminal-buffer-y termbuf)
	 (terminal-buffer-x termbuf)))

(define (insert-char termbuf char)
  (string-set! (line-at-cursor-position termbuf)
	       (terminal-buffer-x termbuf)
	       char))

(define (goto-next-char termbuf)
  (set-terminal-buffer-x! 
   termbuf (+ 1 (terminal-buffer-x termbuf))))

(define (read-escape-code termbuf char)
  (debug-message "read-escape-code " (char->ascii char) " " termbuf)
  (let ((code (string-append
	       (terminal-buffer-esc-code termbuf)
	       (string char))))
    (cond
     ;; very ugly hack
     ((> (string-length code) 5)
      (set-terminal-buffer-esc-code! termbuf ""))
     ((recognize-simple-cursor-movement code)
      => (lambda (lst)
	   (apply move-cursor (cons termbuf lst))
	   (set-terminal-buffer-esc-code! termbuf "")))
     ((recognize-cursor-movement code)
       => (lambda (lst)
	    (apply move-cursor (cons termbuf lst))
	    (set-terminal-buffer-esc-code! termbuf "")))
     (else 
      (set-terminal-buffer-esc-code! termbuf code)))))

(define (recognize-cursor-movement partial-code)
  (debug-message "recognize-cursor-movement " partial-code)
  (if-match
   (regexp-search (rx (: ,(ascii->char 27) 
			 #\[ (submatch digit) (submatch ("ABCD"))
			 eos))
		  partial-code)
   (whole-code count direction)
   (cond
     ((string=? direction "A")
      (list 0 (- (string->number count))))
     ((string=? direction "B")
      (list 0 (string->number count)))
     ((string=? direction "C")
      (list (string->number count) 0))
     ((string=? direction "D")
      (list (- (string->number count)) 0))
     (else (error 'gnarf direction)))
   #f))

(define (recognize-simple-cursor-movement partial-code)
  (debug-message "recognize-simple-cursor-movement ")
  (if-match
   (regexp-search (rx (: ,(ascii->char 27) (? #\[) (? #\O) (submatch ("ABCD")) eos))
		  partial-code)
   (whole-code direction)
   (cond
     ((string=? direction "A") '( 0 -1))
     ((string=? direction "B") '( 0  1))
     ((string=? direction "C") '( 1  0))
     ((string=? direction "D") '(-1  0))
     (else (error 'gnarf2 (string? direction) (char? direction) )))
   (begin (debug-message "does not match ") #f)))