commander-s/scheme/command-buffer.scm

;; History

;(define command-history-pos 0)
(define the-command-history (make-empty-history))

(define (command-history) the-command-history)

(define *current-command-history-item* #f)

(define (current-command-history-item)
  *current-command-history-item*)

(define-record-type command-history-entry :command-history-entry
  (make-command-history-entry prompt text)
  command-history-entry?
  (prompt        command-history-entry-prompt)
  (text  command-history-entry-text))

(define input-field->command-history-item
  (lambda (input-field)
    (let* ((prompt (input-field-prompt input-field))
	   (prompt+texts (map list->string 
			      (input-field-window-lines input-field)))
	   (texts (cons (substring (car prompt+texts)
				   (string-length prompt)
				   (string-length (car prompt+texts)))
			(cdr prompt+texts)))
	   (text (fold-right string-append
			     ""
			     texts)))
      (make-command-history-entry prompt text))))

(define (append-to-command-history! history-entry)
  (append-history-item! the-command-history history-entry)
  (set! *current-command-history-item* 
	(history-last-entry the-command-history)))

;;  one step back in the history
(define (command-history-back!)
  (cond
   ((and (current-command-history-item)
	 (history-prev-entry (current-command-history-item)))
    => (lambda (prev)
	 (set! *current-command-history-item* prev)))
   (else (values))))

;; one step forward
(define (command-history-forward!)
  (cond
   ((and *current-command-history-item*
	 (history-next-entry *current-command-history-item*))
    => (lambda (next)
	 (set! *current-command-history-item* next)))
   (else (values))))


(define *history-down?* #t)
					       
(define history-up
  (lambda (com-buf)
    (let ((last-entry (history-last-entry (command-history))))
      (if last-entry
	  (if *history-down?*
	      (begin
		(set! *history-down?* #f)
		(set-command-buffer-keep-in-mind! com-buf 
						  (input-field-text (command-buffer-input-field com-buf)))
		(set-command-buffer-text! com-buf 
					  (command-history-entry-text 
					   (entry-data *current-command-history-item*))))
	      (let ((current-window-text (command-history-entry-text
					   (entry-data *current-command-history-item*))))
		(command-history-back!)
		(set-command-buffer-text! com-buf 
					  (command-history-entry-text 
					   (entry-data *current-command-history-item*)))
		(if (and (not (eq? *current-command-history-item*
				   (history-first-entry (command-history))))
			 (equal? current-window-text
				 (command-history-entry-text
				  (entry-data *current-command-history-item*))))
		    (history-up com-buf)
		    (values))))
	  (values)))))


(define history-down
  (lambda (com-buf)
    (let ((last-entry (history-last-entry (command-history))))
      (if last-entry
	  (if (eq? *current-command-history-item*
		   (history-last-entry (command-history)))
	      (begin
		(if (command-buffer-keep-in-mind com-buf)
		    (set-command-buffer-text! com-buf (command-buffer-keep-in-mind com-buf)))
		(set! *history-down?* #t))
	      (let ((current-window-text (command-history-entry-text
					   (entry-data *current-command-history-item*))))
		(command-history-forward!)
		(set-command-buffer-text! com-buf
					  (command-history-entry-text
					   (entry-data *current-command-history-item*)))
		(if (equal? current-window-text
			   (command-history-entry-text 
			    (entry-data *current-command-history-item*)))
		    (history-down com-buf)
		    (values))))
	  (values)))))

;; Buffer

(define-record-type command-buffer :command-buffer
  (really-make-command-buffer win
			      prompt
			      x-loc y-loc
			      x-dim y-dim
			      history-scroll
			      input-field 
			      keep-in-mind)
  command-buffer?
  (win            command-buffer-win            set-command-buffer-win!)
  (prompt         command-buffer-prompt         set-command-buffer-prompt!)
  (x-loc          command-buffer-x-loc          set-command-buffer-x-loc!)
  (y-loc          command-buffer-y-loc          set-command-buffer-y-loc!)
  (x-dim          command-buffer-x-dim          set-command-buffer-x-dim!)
  (y-dim          command-buffer-y-dim          set-command-buffer-y-dim!)
  (history-scroll command-buffer-history-scroll set-command-buffer-history-scroll!)
  (input-field    command-buffer-input-field    set-command-buffer-input-field!)
  (keep-in-mind   command-buffer-keep-in-mind   set-command-buffer-keep-in-mind!))

(define make-command-buffer
  (lambda (win prompt x-loc y-loc x-dim y-dim)
    (really-make-command-buffer win
				prompt
				x-loc y-loc
				x-dim y-dim
				0
				(make&install-input-field win
							  x-loc y-loc ;; later y-loc and y-dim will
							  x-dim y-dim ;; be dynamically calculated
							  (if (procedure? prompt)
							      (prompt)
							      prompt)
							  ""
							  standard-behavior-pro)
				#f)))

(define make-buffer make-command-buffer)

(define buffer-pos-col
  (lambda (com-buf)
    (let ((input-field (command-buffer-input-field com-buf)))
      (- (input-field-x-edit-pos input-field)
	 (string-length (input-field-prompt input-field))))))

(define history-lines-from-history
  (lambda (com-buf n)
    (let loop ((current-entry (history-last-entry (command-history)))
	       (n n)
	       (history-lines '()))
      (if (or (< n 0)
	      (not current-entry))
	  history-lines
	  (let* ((current-item (entry-data current-entry))
		 (new-lines (split-to-string-list (string-append (command-history-entry-prompt current-item)
								 (command-history-entry-text current-item))
						  (command-buffer-x-dim com-buf)))
		 (new-n (- n (length new-lines))))
	    (loop (history-prev-entry current-entry)
		  new-n
		  (append new-lines history-lines)))))))

(define print-command-buffer
  (lambda (com-buf)           
    (print-history-lines com-buf) 
    (print-input-field com-buf)))    

(define print-history-lines
  (lambda (com-buf)
    (let* ((win (command-buffer-win com-buf))
	   (x-loc (command-buffer-x-loc com-buf))
	   (y-loc (command-buffer-y-loc com-buf))
	   (x-dim (command-buffer-x-dim com-buf))
	   (history-lines (history-lines-from-history com-buf
						      (+ (command-buffer-y-dim com-buf)
							 (command-buffer-history-scroll com-buf))))
	   (history-lines-to (take history-lines
				   (max (- (length history-lines)
					   (command-buffer-history-scroll com-buf))
					(- (command-buffer-y-dim com-buf)
					   (input-field-y-size 
					    (command-buffer-input-field com-buf))))))
	   (history-lines-to-print (drop history-lines-to
					 (max 0
					      (- (length history-lines-to)
						 (- (command-buffer-y-dim com-buf)
						    (input-field-y-size 
						     (command-buffer-input-field com-buf))))))))
      (let loop ((lines history-lines-to-print)
		 (y-ofst 0))
	(if (null? lines)
	    #t
	    (begin
	      (mvwaddstr win 
			   (+ y-loc y-ofst)
			   x-loc
			   (fill-string (car lines) #\space x-dim))
	      (loop (cdr lines)
		    (+ y-ofst 1))))))))

(define print-input-field 
  (lambda (com-buf)
    (input-field-refresh (command-buffer-input-field com-buf))))



;; Input

(define input
  (lambda (com-buf asc)
    (cond ((or (= asc 13)
	       (= asc 10))
	   (return-pressed-action com-buf))
	  ((= asc key-up)
	   (history-up com-buf))
	  ((= asc key-down)
	   (history-down com-buf))
;	  ((= asc 23) ; C-w
;	   (scroll-up-history-window-lines com-buf))
;	  ((= asc 5) ; C-e
;	   (scroll-down-history-window-lines com-buf))
	  (else 
	   (call-with-values
	       (lambda ()
		 (send-input-field (command-buffer-input-field com-buf)
				   asc))
	     (lambda (was-known has-changed)
	       (if (eq? was-known 'buffer-full)
		   (enlarge-input-field com-buf asc)
		   #t)))))))

(define return-pressed-action
  (lambda (com-buf) 
    (append-to-command-history! (input-field->command-history-item 
				 (command-buffer-input-field com-buf)))
    (set-command-buffer-keep-in-mind! com-buf #f)
    (set-command-buffer-history-scroll! com-buf 0)
    (set! *current-command-history-item* (history-last-entry (command-history)))
    (set! *history-down?* #t)
    (let ((new-input-field-y-dim (max 1 
				      (- (command-buffer-y-dim com-buf)
					 (length (history-lines-from-history
						  com-buf
						  (command-buffer-y-dim com-buf))))))
	  (old-input-field (command-buffer-input-field com-buf)))
      (set-command-buffer-input-field! com-buf
				       (make&install-input-field 
					(command-buffer-win com-buf)
					(command-buffer-x-loc com-buf)
					(+ (command-buffer-y-loc com-buf)
					   (- (command-buffer-y-dim com-buf)
					      new-input-field-y-dim))
					(command-buffer-x-dim com-buf)
					new-input-field-y-dim
					(let ((prompt (command-buffer-prompt com-buf)))
					  (if (procedure? prompt)
					      (prompt)
					      prompt))
					""
					standard-behavior-pro))
      (remove-input-field old-input-field))
    (print-command-buffer com-buf)))
		
(define scroll-up-history-window-lines
  (lambda (com-buf)
    (let ((scroll (command-buffer-history-scroll com-buf)))
      (if (< scroll (- (length (history-lines-from-history com-buf
							   (+ scroll
							      (command-buffer-y-dim com-buf))))
		       (- (command-buffer-y-dim com-buf)
			  (input-field-y-size (command-buffer-input-field com-buf)))))
	  (begin
	    (set-command-buffer-history-scroll! com-buf (+ scroll 1))
	    (print-command-buffer com-buf))))))

(define scroll-down-history-window-lines
  (lambda (com-buf)
    (let ((scroll (command-buffer-history-scroll com-buf)))
      (if (> scroll 0)
	  (begin
	    (set-command-buffer-history-scroll! com-buf (- scroll 1))
	    (print-command-buffer com-buf))))))


(define command-buffer-text
  (lambda (com-buf)
    (input-field-text (command-buffer-input-field com-buf))))

(define buffer-text command-buffer-text)

(define set-command-buffer-text!
  (lambda (com-buf text)
    (let* ((buffer-y-dim (command-buffer-y-dim com-buf))
	   (buffer-x-dim (command-buffer-x-dim com-buf))
	   (input-field (command-buffer-input-field com-buf))
	   (prompt (input-field-prompt input-field))
	   (needed-y-dim (max 1
			      (+ (quotient (+ (string-length prompt)
					      (string-length text))
					   buffer-x-dim)
				 1))))
      (set-input-field-text! input-field "")
      (if (> needed-y-dim buffer-y-dim)
	  (begin 
	    (input-field-move input-field 
			      (command-buffer-x-loc com-buf)
			      (command-buffer-y-loc com-buf))
	    (input-field-resize input-field
				buffer-x-dim
				buffer-y-dim)
	    (if (not (input-field-y-scroll input-field))
		(input-field-toggle-y-scroll input-field)))
	  (let* ((new-input-field-y-dim (max needed-y-dim
				      (- (command-buffer-y-dim com-buf)
					 (length (history-lines-from-history
						  com-buf
						  (command-buffer-y-dim com-buf))))))
		 (move-input-field (lambda ()
			      (input-field-move input-field
						(input-field-x-location input-field)
						(+ (command-buffer-y-loc com-buf)
						   (- (command-buffer-y-dim com-buf)
						      new-input-field-y-dim)))))
		 (resize-input-field (lambda ()
				(input-field-resize input-field
						    buffer-x-dim
						    new-input-field-y-dim))))
	    (if (> new-input-field-y-dim (input-field-y-size input-field))
		(begin (move-input-field) (resize-input-field))
		(begin (resize-input-field) (move-input-field)))
	    (if (input-field-y-scroll input-field)
		(input-field-toggle-y-scroll input-field))))
      (set-input-field-text! input-field text))))

(define set-buffer-text! set-command-buffer-text!)

(define change-command-buffer-prompt!
  (lambda (com-buf prompt)
    (let* ((new-input-field-y-dim (max 1 
				       (- (command-buffer-y-dim com-buf)
					  (length (history-lines-from-history
						   com-buf
						   (command-buffer-y-dim com-buf))))))
	   (old-input-field (command-buffer-input-field com-buf))
	   (text (input-field-text old-input-field)))
      (set-command-buffer-prompt! com-buf prompt)
      (set-command-buffer-input-field! com-buf
				       (make&install-input-field 
					(command-buffer-win com-buf)
					(command-buffer-x-loc com-buf)
					(+ (command-buffer-y-loc com-buf)
					   (- (command-buffer-y-dim com-buf)
					      new-input-field-y-dim))
					(command-buffer-x-dim com-buf)
					new-input-field-y-dim
					(let ((prompt (command-buffer-prompt com-buf)))
					  (if (procedure? prompt)
					      (prompt)
					      prompt))
					""
					standard-behavior-pro))
      (set-command-buffer-text! com-buf text)
      (remove-input-field old-input-field))
    (print-command-buffer com-buf)))

(define enlarge-input-field
  (lambda (com-buf asc)
    (let ((input-field (command-buffer-input-field com-buf)))
      (if (= (command-buffer-y-dim com-buf)
	     (input-field-y-size input-field))
	(begin
	  (input-field-toggle-y-scroll input-field)
	  (send-input-field input-field key-right))
	(begin 
	  (input-field-move input-field
			    (input-field-x-location input-field)
			    (- (input-field-y-location input-field)
			       1))
	  (input-field-resize input-field 
			      (input-field-x-size input-field)
			      (+ (input-field-y-size input-field)
				 1))
	  (send-input-field input-field asc)
	  (send-input-field input-field key-right)))
      (print-command-buffer com-buf))))

(define fill-string
  (lambda (str ch len)
    (let loop ((len (- len (string-length str)))
	       (missing '()))
      (if (zero? len)
	  (string-append str
			 (list->string missing))
	  (loop (- len 1)
		(cons ch missing))))))

(define split-to-string-list
  (lambda (str len)
    (let loop ((lst '())
	       (str str)
	       (str-len (string-length str)))
      (if (<= str-len len)
	  (append lst (list str))
	  (let ((new-str (substring str 
				    len str-len)))
	  (loop (append lst (list (substring str
					     0 len)))
		new-str
		(string-length new-str)))))))