;-*- Mode:LISP; Package:ZWEI; Lowercase:T; Base:8; Readtable:T -*-

;;; An editor that is not a window and displays on another specified window.
;;; And an interface to use such an editor
;;; as the rubout handler for any window with TV:STREAM-MIXIN.

;>> Minibuffers!!!!!!!!!!!!!

;>> needs a way to be notified about change of size (or other characteristics?) of WINDOW

(defflavor external-stream-displayer
	   (;; The window we do our display on.
	    ;; Any kind of window will do.
	    window
	    ;; The stream used as *QUERY-IO* and *TYPEIN-WINDOW*
	    ;; when editing in this displayer.
	    typein-stream
	    ;; The stream used as *TERMINAL-IO* and *TYPEOUT-WINDOW*.
	    typeout-stream
	    ;; The positions of the edges of the subrectangle of WINDOW we should use.
	    ;; All four are relative to the inside upper left corner of WINDOW.
	    ;; Note that it does not really work for LEFT and RIGHT to be anything but the
	    ;; full width of WINDOW.  Our redisplay can handle it,
	    ;; but the typeout and typein streams cannot.
	    left top right bottom
	    ;; The vertical position (relative to TOP) of the "top" of the display.
	    ;; This records how our display is rotated within the allotted space.
	    (starting-vpos nil)
	    ;; We don't really use these, but (:method window :redisplay) looks for them.
	    pline-marking-left-array	;Hpos of left edge of region-marking on this pline.
	    pline-marking-width-array	;width in pixels of region-marking.
	    pline-text-width-array	;width in pixels of text.
	    ;; The hpos (relative to the inside edge of WINDOW)
	    ;; to start display at for our first line only.
	    ;; (For following lines, LEFT is used.)
	    ;; This is how the rubout handler can manage to display
	    ;; starting at whatever cursorpos it is entered with.
	    first-line-left
	    ;; Height of screen used up by typeout through the TYPEOUT-STREAM.
	    ;; Normally zero when there is no typeout present.
	    typeout-used-height
	    ;; Height of screen used up by typein through the TYPEIN-STREAM.
	    ;; Normally zero when there is no typein present.
	    typein-used-height
	    ;; The width of a character in WINDOW.
	    ;; Used to translate cursor positions in WINDOW into character column numbers.
	    char-width
	    ;; The height of a line in WINDOW.
	    line-height
	    ;; The number of columns between tab stops.
	    (tab-nchars 8))
	   (displayer)
  :settable-instance-variables
  (:documentation "A flavor which does zwei-style displaying for another window."))

(defmethod (external-stream-displayer :print-self) (stream &rest ignore)
  (si:printing-random-object (self stream :type :no-pointer)
    (format stream "~O for ~A" (%pointer self) window)))

;;; TYPE-IN appears after the end of the editor display.
;;; If it gets big enough vertically, it can end up
;;; overwriting the beginning of the editor display.
;;; If this happens, the beginning of the display
;;; (represented by STARTING-VPOS) is advanced
;;; so that the area used for TYPE-IN is not part of the display area.
;;; This also involves decrementing N-PLINES.

;;; TYPE-OUT starts at the START of the editor display
;;; (where STARTING-VPOS points).
;;; It overwrites the editor display.
;;; At the end of the command, the editor display
;;; is output again, starting after where the type-out finished.

;>> yes, we really DO need to do the :set-window :before and :after :init !!
;>> (trust me --- I tried removal)
;>> I suppose there is a modularity problem here, but it doesn't really hurt, so wtf.
(defmethod (external-stream-displayer :before :init) (init-plist)
  (send self :set-window window)
  (let ((*standard-input* window)
	(*terminal-io* typeout-stream)
	(*standard-output* si:syn-terminal-io)
	(*query-io* syn-typein-window-io)
	(*mode-line-list* nil)
	(*comtab* (get init-plist :comtab)))
    (setq editor-closure
	  (make-editor-closure (or (get init-plist :editor-closure-variables)
				   top-level-editor-closure-variables)
			       nil))))

(defmethod (external-stream-displayer :after :init) (ignore)
  (let ((max-n-plines (send self :max-n-plines)))
    (setq pline-line-array (make-array max-n-plines))
    (setq pline-from-index-array (make-array max-n-plines))
    (setq pline-to-index-array (make-array max-n-plines))
    (setq pline-tick-array (make-array max-n-plines))
    (setq pline-marking-left-array (make-array max-n-plines))
    (setq pline-marking-width-array (make-array max-n-plines))
    (setq pline-text-width-array (make-array max-n-plines)))
  (send self :set-window window))

(defmethod (external-stream-displayer :set-window)
	   (new-window
	    &optional
	    (new-left 0)
	    (new-top 0)
	    (new-right (tv:sheet-inside-width new-window))
	    (new-bottom (tv:sheet-inside-height new-window)))
  (setq window new-window)
  (multiple-value-setq (typeout-stream typein-stream)
    (make-external-stream-displayer-typeout-stream self window))
  (setq line-height (send window :line-height))
  (setq char-width (send window :char-width))
  (send window :send-if-handles :set-tab-nchars tab-nchars)
  (setq left new-left
	top new-top
	right new-right
	bottom new-bottom)
  (when (variable-boundp editor-closure)
    (funcall editor-closure #'initialize-top-level-editor self)
    (let ()
      (sys:%using-binding-instances (closure-bindings editor-closure))
      (setq *debug-io* tv:cold-load-stream	;>> for debugging
	    *error-output* tv:cold-load-stream
	    *trace-output* tv:cold-load-stream)
      (setq *terminal-io* typeout-stream *query-io* typein-stream
	    *typeout-window* typeout-stream *typein-window* typein-stream))))

;;; Initialize the contents and starting position of the displayer.
;;; ARRAY becomes the text being edited, with point positioned after INDEX characters.
;;; HPOS and VPOS are the cursorpos in WINDOW for the beginning of the display.
(defmethod (external-stream-displayer :initialize-contents)
	   (array index vpos &optional (starting-hpos left) &aux string)
  ;; Make sure TOP and BOTTOM are set so as to make sure
  ;; we have an integral number of lines, always at same vertical positions.
  (setq top (\ vpos line-height))
  (setq bottom (* line-height
		  (floor (- (send window :inside-height) top) line-height)))
  (setq starting-vpos (- vpos top))
  (setq first-line-left starting-hpos)
  (setq typeout-used-height 0)
  (setq string (make-string (array-active-length array)))
  (copy-array-portion array 0 (array-active-length array)
		      string 0 (array-active-length array))
  (send self :set-interval (create-interval string nil t))
  (setq redisplay-degree dis-text)
  (let ((*interval* interval))
    (move-bp point (forward-char point index t)))
  (setq typein-used-height 0 typeout-used-height 0)
  (send typeout-stream :initialize-no-typeout)
  (setq n-plines 1)
  (unless (variable-boundp pline-tick-array)
    (let ((max-n-plines (floor (- bottom top) line-height)))
      (setq pline-tick-array (make-array max-n-plines)
	    pline-line-array (make-array max-n-plines)
	    pline-from-index-array (make-array max-n-plines)
	    pline-to-index-array (make-array max-n-plines)))))

;Returns a list (hpos vpos) of the cursorpos
;at which our display on WINDOW begins.
(defmethod (external-stream-displayer :starting-cursorpos) ()
  (list first-line-left (+ top starting-vpos)))

;Returns a list (hpos vpos) of the cursorpos
;of the beginning of the first line of WINDOW that follows
;the editor display.
;This is used to tell where to start printing "type-in".
(defmethod (external-stream-displayer :cursorpos-after-display) ()
  (list left (+ top (\ (+ (* n-plines line-height) starting-vpos) (- bottom top)))))

;Returns a list (hpos vpos) of the cursorpos
;of the beginning of the first line of WINDOW that follows
;all type-in.  This is used for erasing "type-in".
(defmethod (external-stream-displayer :cursorpos-after-typein) ()
  (list (if (zerop typein-used-height) first-line-left left)
	(+ top (\ (+ typein-used-height starting-vpos) (- bottom top)))))

;;; Trivial stubs for certain operations that ZWEI always wants to use.

(defmethod (external-stream-displayer :max-n-plines) ()
  (max 1 (1- (truncate (send window :inside-height) line-height))))

(defmethod (external-stream-displayer :new-plines) (pline)
  ;; We are about to overwrite this!  So forget it was there.
  (when (send *typein-window* :exposed-p)
    (send *typein-window* :clear-screen))
  (setq n-plines (1+ pline)))

;(defmethod (external-stream-displayer :after :redisplay) ()
;  ;; If we are using the entire window,
;  ;; and there is a lot of blank space at the end of it,
;  ;; and we have text not displayed above the top,
;  ;; rotate our starting vpos to display that text
;  ;; above the first text now displayed.
;  (LET ((MAX-N-PLINES (MAX 1 (1- (TRUNCATE (SEND WINDOW :INSIDE-HEIGHT) LINE-HEIGHT)))))
;    (WHEN (AND (= N-PLINES MAX-N-PLINES)
;	       (< (+ 4 LAST-PLINE) N-PLINES)
;	       (NOT (BP-= START-BP (INTERVAL-FIRST-BP INTERVAL))))
;      (LET ((ADDED-LINES (- MAX-N-PLINES LAST-PLINE 1)))
;	(CONDITION-CASE ()
;	    (RECENTER-WINDOW-RELATIVE SELF (- ADDED-LINES))
;	  (BARF)
;	  (:NO-ERROR
;	   (setq STARTING-VPOS (nth-value 1 (FLOOR (- STARTING-VPOS
;						      (* ADDED-LINES LINE-HEIGHT))
;						   (- BOTTOM TOP))))
;	   (DO ((P (1- MAX-N-PLINES) (1- P)))
;	       ((< P ADDED-LINES))
;	     (SETF (AREF PLINE-LINE-ARRAY P)
;		   (AREF PLINE-LINE-ARRAY (- P ADDED-LINES)))
;	     (SETF (AREF PLINE-TICK-ARRAY P)
;		   (AREF PLINE-TICK-ARRAY (- P ADDED-LINES)))
;	     (SETF (AREF PLINE-FROM-INDEX-ARRAY P)
;		   (AREF PLINE-FROM-INDEX-ARRAY (- P ADDED-LINES)))
;	     (SETF (AREF PLINE-TO-INDEX-ARRAY P)
;		   (AREF PLINE-TO-INDEX-ARRAY (- P ADDED-LINES))))
;	   (SETQ FIRST-LINE-LEFT LEFT)
;	   (SETQ LAST-POINT-PLINE
;		 (MIN (1- N-PLINES)
;		      (+ LAST-POINT-PLINE ADDED-LINES)))
;;	   (WHEN POINT-PLINE (INCF POINT-PLINE))
;	   (MUST-REDISPLAY SELF DIS-TEXT)
;	   (SEND SELF :REDISPLAY :NONE NIL NIL NIL)))))))

;This is how the ZWEI asks what to use for *TYPEOUT-WINDOW* and *TYPEIN-WINDOW*
(defmethod (external-stream-displayer :typeout-window) () typeout-stream)
(defmethod (external-stream-displayer :typein-window) () typein-stream)

;List of all windows that need to be redisplayed for this displayer.
(defmethod (external-stream-displayer :editor-windows) () (list self))

; Sent by some aspect of redisplay.
(defmethod (external-stream-displayer :finish-delayed-select) ()
  nil)
(defmethod (external-stream-displayer :top-of-editor-hierarchy) ()
  (ferror nil "Should not get here."))

;This is sent by RECENTER-WINDOW.
(defmethod (external-stream-displayer :new-scroll-position) ()
  nil)

;This is sent by (:method displayer :redisplay)
(defmethod (external-stream-displayer :update-region-marking) () nil)
(defmethod (external-stream-displayer :redisplay-blt) () nil)
(defmethod (external-stream-displayer :set-blinker-size) (ignore ignore x y)
  (send window :set-cursorpos x (external-stream-displayer-pline-vpos (// y line-height))))

;These return nil to turn off certain activities inside (:method displayer :redisplay)
(defmethod (external-stream-displayer :font-map) () nil)
(defmethod (external-stream-displayer :special-blinker-list) () nil)

;; This returns a dummy blinker that (:method displayer :redisplay) can send to harmlessly.
(defmethod (external-stream-displayer :point-blinker) () 'ignore)

(defmethod (external-stream-displayer :inside-width) ()
  (send window :inside-width))

(defmethod (external-stream-displayer :clear-screen) ()
  (send window :clear-screen))

(defmethod (external-stream-displayer :screen-line-out) (string &optional (start 0) (stop nil) xpos ypos dwidth)
  (send window :screen-line-out string start stop xpos
	(external-stream-displayer-pline-vpos (// ypos line-height))
	dwidth))

(defmethod (external-stream-displayer :set-cursorpos) (x y)
  (send window :set-cursorpos x (external-stream-displayer-pline-vpos (// y line-height))))

(defmethod (external-stream-displayer :clear-eof) ()
  (do ((pline (// (mod (- (nth-value 1 (send window :read-cursorpos)) top starting-vpos)
		       (* (truncate (- bottom top) line-height) line-height))
		  line-height)
	      (1+ pline)))
      ((>= pline n-plines))
    (send window :clear-between-cursorposes
	  left
	  (external-stream-displayer-pline-vpos pline)
	  right
	  (external-stream-displayer-pline-vpos pline))
    (setf (pline-line self pline) nil)
    (setf (pline-tick self pline) *tick*)))

(defmethod (external-stream-displayer :refresh-margins) ()
  (send window :set-cursorpos left top)
  (send self :reprompt))

;;; Methods for computing how output will look.

(defmethod (external-stream-displayer :character-width) () char-width)

(defmethod (external-stream-displayer :string-length)
	   (&rest args)
  ;; At first, cheat and work only on windows
  (lexpr-send window :string-length args))

(defmethod (external-stream-displayer :compute-motion)
	   (&rest args)
  ;; At first, cheat and work only on windows
  (lexpr-send window :compute-motion args))

(defmethod (external-stream-displayer :editor-string-length)
	   (string start end continuation &optional stop-x)
  (if continuation
      (multiple-value-bind (end-x nil end-index)
	  (send self :compute-motion string start end
		0 0 nil
		(or stop-x 0) (and stop-x 0)	;STOP-X, STOP-Y
		nil nil nil
		line-height
		(* (or *tab-width* tab-nchars)
		   char-width))
	(values end-x end-index))
    (send self :string-length string start end
	  stop-x nil 0
	  (* (or *tab-width* tab-nchars)
	     char-width))))

(defmethod (external-stream-displayer :editor-tab-width) ()
  (* (or *tab-width* tab-nchars)
     char-width))

(defmethod (external-stream-displayer :put-point-at-pline)
	   (point-line point-index point-pline first-bp last-bp
	    &aux
	    (lh line-height))
  (cond (( point-pline 0)
	 ;; Algorithm: first find LINE, which will be the new TOP-LINE,
	 ;; by scanning backwards.  Then knock off plines from the front
	 ;; of it until POINT ends up at POINT-PLINE.
	 ;; P is the number of plines between POINT and the beginning
	 ;; of the current LINE.
	 (do ((line point-line)
	      ;; P is the point-pline if we start at the beginning of LINE.
	      (p (floor (nth-value 1 
			    ;; Compute which continuation line of POINT-LINE point is on.
			    (zid-ed-compute-motion point-line point-index first-bp last-bp
						   (- right left)))
			lh))
	      (stop-line (bp-line first-bp)))
	     (( p point-pline)
	      ;; We have found the new TOP-LINE.  Now find TOP-INDEX.
	      (values
		 line
		 (let ((difference (- p point-pline)))
		   (cond ((zerop difference) 0)
			 (t ;; Compute motion to move Y down DIFFERENCE plines.
			  (multiple-value-bind (nil nil nc)
			      (send self :compute-motion
				    line
				    (if (eq line stop-line)
					(bp-index first-bp) 0)
				    nil
				    0 0 nil
				    0 (* difference lh) most-positive-fixnum (- right left))
			    (if (eq line stop-line)
				(max nc (bp-index first-bp))
			      nc)))))
		 point-pline))
	   (when (or (eq line stop-line)
		     (null (line-previous line)))  ;observed to happen in dired RG.
	     (return (values line 0 p)))
	   (setq line (line-previous line))
	   (incf p (multiple-value-bind (nil fy)
		       ;; Compute downward motion of this line, with fake RETURN.
		       (send self :compute-motion
			     	  line
				  (if (eq line stop-line) (bp-index first-bp) 0)
				  nil
				  0 0 t
				  0 most-positive-fixnum most-positive-fixnum  (- right left))
		     (floor fy lh)))))
	(t
	 ;; POINT-PLINE is negative, do the same thing in reverse.
	 (do* ((line point-line (line-next line))
	       (line-start-index point-index 0)
	       (this-line-height)
	       ;; P is the point-pline if we display from beg of (LINE-NEXT LINE).
	       ;; This line is the one if P is too far.
	       (p 0)
	       (stop-line (bp-line last-bp)))
	      (())
	   (setq this-line-height
		 (zid-ed-compute-line-motion line line-start-index last-bp (- right left)))
	   (decf p this-line-height)
	   (if (< p point-pline)
	       ;; We have found the new TOP-LINE.  Now find TOP-INDEX.
	       (return
		 (values
		   line
		   (let ((difference (- p point-pline)))
		     (cond ((zerop (+ this-line-height difference))
			    0)
			   (t (multiple-value-bind (nil nil nc)
				  (send self :compute-motion
					line line-start-index nil
					0 0 t
					0
					(* (+ this-line-height
					      difference)
					   lh)
					most-positive-fixnum
					(- right left))
				(if (eq line stop-line)
				    (min nc (bp-index last-bp))
				  nc)))))
		   point-pline)))
	   (when (eq line stop-line)
	     (return (values line 0 p)))))))
 
;;; Compute the downwarnd motion of an entire line, including following RETURN if any.
;;; The value is in units of lines, not pixels.
(defun zid-ed-compute-line-motion (line start-index last-bp &optional width
				   &aux (stop-line (bp-line last-bp)))
  (declare (:self-flavor external-stream-displayer))
  (floor (nth-value 1 (send self :compute-motion line start-index
			         (and (eq line stop-line)
				      (min (1+ (bp-index last-bp))
					   (line-length stop-line)))
				 0 0 (neq line stop-line)
				 0 most-positive-fixnum most-positive-fixnum width))
	 line-height))

;;; Do a SHEET-COMPUTE-MOTION, but take into account that if the cursor
;;; reaches the right margin in the middle of the line, it moves to the
;;; beginning of the next line "before" the next character if that char is not a Newline.
;;; WIDTH is the width of window to use in computation -- NIL means use its actual width.
(defun zid-ed-compute-motion (line index first-bp last-bp &optional width)
  (declare (:self-flavor external-stream-displayer))
  (multiple-value-bind (final-x final-y final-index max-x)
      (send self :compute-motion line
		 (if (eq line (bp-line first-bp)) (bp-index first-bp) 0)
		 index
		 0 0 nil
		 0 most-positive-fixnum most-positive-fixnum width)
    (if (and ( index (line-length line))
	     (not (and (eq line (bp-line last-bp))
		       (= index (bp-index last-bp))))
	     (> (+ final-x
		   ;; There must be room for the next character and the "!".
		   (* 2 char-width))
		(- right left)))
	(setq final-x 0
	      final-y (+ final-y line-height)))
    (values final-x final-y final-index max-x)))

;;;; Implement the type-in and type-out streams.

;;; Create type-out and type-in streams for displayer *displayer*.

;(defflavor external-stream-displayer-typeout-stream
;	   (output-stream
;	    displayer
;	    (incomplete-p nil)
;	    (typeout-active-p nil)
;	    (ouput-stream-which-operations nil)
;	    (saved-which-operations nil))
;	   (output-character-stream)
;  (:default-handler external-stream-displayer-typeout-stream-pass-on)
;  :inittable-instance-variables)

;(defun external-stream-displayer-typout-stream-pass-on (op &rest args)
;  (declare (:self-flavor external-stream-dislayer-typeout-stream))
;  (lexpr-send output-stream op args))

(defun make-external-stream-displayer-typeout-stream (*displayer* *output-window*)
  "Return type-out and type-in streams for displayer *DISPLAYER*.
These are returned as two values.  
*OUTPUT-WINDOW* is the *DISPLAYER* outputs to."
  (declare (special *output-window* *displayer* *xpos* *ypos*)
	   (values type-out type-in))
  (let (*typeout-active-p*
	*typeout-stream*)
    (declare (special *typeout-active-p* *typeout-stream*)) 
    (values
      (setq *typeout-stream*
	    (let ((*incomplete-p*)
		  (*which-operations*
		    (si:union-eq '(:make-complete :make-incomplete :incomplete-p :expose)
				 (send *output-window* :which-operations))))
	      (declare (special *incomplete-p* *which-operations*))
	      (closure '(*output-window* *incomplete-p* *displayer*
				  *typeout-active-p* *which-operations*)
		       'external-stream-displayer-typeout-stream)))
      (let (*xpos* *ypos*
	    *typein-active-p*
	    (*which-operations*
	      (si:union-eq '(:command-loop-redisplay :typeout-stays :remake-incomplete
						     :make-complete :incomplete-p)
			   (send *output-window* :which-operations))))
	(declare (special *xpos* *ypos* *typein-active-p* *which-operations*))
	(closure '(*output-window* *displayer* *typein-active-p* *typeout-active-p* *typeout-stream*
			    *which-operations* *xpos* *ypos*)
		 'external-stream-displayer-typein-stream)))))

;;; The type-out stream handles these special operations:
;;; :DO-SOMETHING-ABOUT-TYPEOUT
;;;  tells the stream to erase its typeout in a suitable way.
;;;  This sends :CLEAR-TYPEOUT back to the displayer
;;;  to make it redisplay.
;;; :INITIALIZE-NO-TYPEOUT
;;;  tells the stream to set its variables to record that
;;;  there is no typeout on the output window at the moment.
;;; Output operations send :TYPEOUT-HAPPENED to the displayer
;;;  so it can record how far typeout has got
;;;  and update TYPEOUT-USED-SIZE.

;;; Variables of the typeout stream:
;;;  *DISPLAYER* - the instance of EXTERNAL-STREAM-DISPLAYER we were made for.
;;;  *OUTPUT-WINDOW* - the window to output on.  Same one the displayer does.
;;;  *INCOMPLETE-P* - same as for typeout windows.
;;;  *TYPEOUT-ACTIVE-P* - T if there is typeout on the screen.
;;;  *WHICH-OPERATIONS* - our list of operations,
;;;  for implementing :WHICH-OPERATIONS, :SEND-IF-HANDLES and :OPERATION-HANDLED-P.
(defun external-stream-displayer-typeout-stream (op &rest args)
  (declare (special *output-window* *incomplete-p* *displayer*
		    *typeout-active-p* *which-operations*))
  (case op
    (:which-operations *which-operations*)
    (:operation-handled-p
     (memq (car args) *which-operations*))
    (:send-if-handles
     (if (memq (car args) *which-operations*)
	 (apply #'external-stream-displayer-typeout-stream args)))
    (:make-complete
     (setq *incomplete-p* nil))
    (:make-incomplete
     (setq *incomplete-p* t))
    (:incomplete-p *incomplete-p*)
    (:deexpose (setq *typeout-active-p* nil))
    (:expose)
    (:top-of-editor-hierarchy #'ignore)
    (:initialize-no-typeout
     (setq *typeout-active-p* nil
	   *incomplete-p* nil))
    (:do-something-about-typeout
     (setq *typeout-active-p* nil)
     (send *displayer* :clear-typeout))
    ((:tyi :untyi :tyi-no-hang :any-tyi :any-tyi-no-hang
	   :read-char :Readh-char-no-hang :any-read-char :any-read-char-no-hang
	   :rubout-handler :beep)
     (lexpr-send *output-window* op args))
    (t
     ;; If output is done, make sure displayer knows to redisplay itself
     ;; beneath the output.
     (unless *typeout-active-p*
       (lexpr-send *output-window* :set-cursorpos
		   (send *displayer* :starting-cursorpos))
       (send *output-window* :clear-rest-of-line))
     (setq *incomplete-p* t)
     (setq *typeout-active-p* t)
     (unwind-protect
       (lexpr-send *output-window* op args)
       (send *displayer* :typeout-happened)))))

;;; Special operations of the type-in stream:
;;; :COMMAND-LOOP-REDISPLAY
;;;  Sent by command loop after each command.
;;;  Get rid of typein, if there is any and it should go away.
;;; :TYPEOUT-STAYS
;;;  Says this batch of type-in should not go away
;;;  after the next command is typed.

;;; Variables (aside from those documented above the typeout stream)
;;; *TYPEOUT-STREAM* - the typeout stream for this displayer.
;;;   Type-in appears as type-out if type-out is active.

;;; *TYPEIN-ACTIVE-P* - non-NIL if there is type-in.
;;;  Values include:
;;;    :IN-USE - this command made type-in.
;;;    :IN-USE-STAYS - this command made it, and it shouldn't be erased.
;;;    :USED - previous command made type in, erase it after this command.
;;;    :USED-STAYS - previous command made it, but don't erase it.
;;;    NIL - no type-in present now.
;;;  The stream is "incomplete" if the value of this variable
;;;  is :IN-USE or :IN-USE-STAYS.
;;;  It is "exposed" if the variable is non-NIL.

;;; *XPOS* and *YPOS* - last cursorposition on WINDOW reached by type-in.
;;;  This is so that type-in can come out consecutively
;;;  even if editor redisplay intervenes.

;;; Output operations report their progress to the displayer
;;; using the :TYPEIN-HAPPENED operation.
(defun external-stream-displayer-typein-stream (op &rest args)
  (declare (special *output-window* *displayer* *which-operations*
		    *typein-active-p* *typeout-active-p* *typeout-stream*
		    *xpos* *ypos*))
  (case op
    (:which-operations *which-operations*)
    (:operation-handled-p
     (memq (car args) *which-operations*))
    (:send-if-handles
     (if (memq (car args) *which-operations*)
	 (apply #'external-stream-displayer-typein-stream args)))
    ((:clear-window :clear-screen :deexpose)
     (let ((after-display
	     (send *displayer* :cursorpos-after-display))
	   (after-typein
	     (send *displayer* :cursorpos-after-typein)))
       (send *output-window* :clear-between-cursorposes
	     (first after-display) (second after-display)
	     (first after-typein) (second after-typein)))
     (send *displayer* :set-typein-used-height 0)
     (setq *typein-active-p* nil))
    (:exposed-p *typein-active-p*)
    (:command-loop-redisplay
     (case *typein-active-p*
       (:in-use
	(setq *typein-active-p* :used))
       (:in-use-stays
	(setq *typein-active-p* :used-stays))
       (:used
	(external-stream-displayer-typein-stream :clear-screen))))
    (:typeout-stays
     (if (eq *typein-active-p* :in-use)
	 (setq *typein-active-p* :in-use-stays)))
    (:remake-incomplete
     (setq *typein-active-p*
	   (case *typein-active-p*
	     (:used :in-use)
	     (:used-stays :in-use-stays)
	     (t *typein-active-p*))))
    (:make-complete
     (if (eq *typein-active-p* :in-use)
	 (setq *typein-active-p* :used)))
    (:incomplete-p
     (memq *typein-active-p* '(:in-use :in-use-stays)))
    (:top-of-editor-hierarchy #'ignore)
    (:output-hold-exception (send *output-window* :output-hold-exception))
    (:beep (beep nil *output-window*))
    (t
     (if *typeout-active-p*
	 (lexpr-send *typeout-stream* op args)
       (if *typein-active-p*
	   (send *output-window* :set-cursorpos *xpos* *ypos*)
	 (lexpr-send *output-window* :set-cursorpos
		     (send *displayer* :cursorpos-after-display)))
       (setq *typein-active-p* :in-use)
       (let ((tv:more-processing-global-enable nil))
	 (unwind-protect
	     (lexpr-send *output-window* op args)
	   (multiple-value-setq (*xpos* *ypos*)
	     (send *output-window* :read-cursorpos))
	   (send *displayer* :typein-happened)))))))

;;; Sent whenever type-in stream output has happened.
;;; Look at WINDOW's cursor to see how far it got.
(defmethod (external-stream-displayer :typein-happened) ()
  (let* ((vpos (+ line-height (nth-value 1 (send window :read-cursorpos))))
	       ;;(- (+ line-height (tv:sheet-cursor-y window)) (tv:sheet-inside-top window))
	 (rel-vpos (if ( vpos starting-vpos)
		       (- vpos starting-vpos)
		     (+ (- vpos starting-vpos) (- bottom top)))))
    ;; If typein has wrapped around and clobbered top of display,
    ;; it chops off the beginning of the display area.
    (when (< rel-vpos (* n-plines line-height))
      (send window :set-cursorpos left (\ (+ starting-vpos rel-vpos) (- bottom top)))
      (send self :reprompt :null)
      (let ((lost-lines (ceiling rel-vpos line-height)))
	(condition-case ()
	    (recenter-window-relative self lost-lines)
	  (barf nil)
	  (:no-error
	   (copy-array-portion pline-line-array lost-lines n-plines
			       pline-line-array 0 (- n-plines lost-lines))
	   (copy-array-portion pline-tick-array lost-lines n-plines
			       pline-tick-array 0 (- n-plines lost-lines))
	   (copy-array-portion pline-from-index-array lost-lines n-plines
			       pline-from-index-array 0 (- n-plines lost-lines))
	   (copy-array-portion pline-to-index-array lost-lines n-plines
			       pline-to-index-array 0 (- n-plines lost-lines))
	   (decf last-point-pline lost-lines)
	   (if (minusp last-point-pline) (setq last-point-pline 0))))
	(setq n-plines (max 1 (- n-plines lost-lines)))
	(must-redisplay self dis-text)
	(setq rel-vpos (- bottom top))))
    (setq typein-used-height (max typein-used-height rel-vpos))))

;;; Sent whenever type-out stream output has happened.
;;; Look at WINDOW's cursor to see how far it has got.
(defmethod (external-stream-displayer :typeout-happened) ()
  (let* ((vpos (- (tv:sheet-cursor-y window) (tv:sheet-inside-top window)))
	 (rel-vpos (if ( vpos starting-vpos)
		       (- vpos starting-vpos)
		     (+ (- vpos starting-vpos) (- bottom top)))))
    (setq typeout-used-height (max typeout-used-height (+ rel-vpos line-height)))))

;;; Redisplay after typeout has happened.
;;; In fact, we do not erase the typeout;
;;; we instead reposition the display to start where the typeout finished.
(defmethod (external-stream-displayer :clear-typeout) ()
  (terpri window)
  (terpri window)
  (send self :reprompt)
  (must-redisplay self dis-text)
  (dotimes (p n-plines)
    (setf (pline-tick self p) -1))
  (setq typeout-used-height 0))

(defmethod (external-stream-displayer :mode-line-window) ()
  (let ((*window* self))
    (closure '(*window*)
	     'external-stream-displayer-mode-line)))

;This is the "mode line window" for the external-stream-displayer.
;It doesn't display anything; it just ignores operations so that no errors occur.
;It also allows callers to get their hands on the typein window.
(defun external-stream-displayer-mode-line (op &rest args)
  (declare (ignore args))
  (case op
    (:typein-window (send *window* :typein-stream))
    (:top-of-editor-hierarchy #'ignore)
    ((:mini-buffer-window :search-mini-buffer-window)
     #'(lambda (&rest ignore)
	 (ferror nil "Mini buffers of EXTERNAL-STREAM-DISPLAYERs not implemented.")))))

;;;; Command loop

;;; This is the function that does the actual work
(defmethod (external-stream-displayer :edit) (&optional ignore
					   (*comtab* *comtab*)
					   (*mode-line-list* *mode-line-list*)
					   (top-level-p (send self :top-level-p)))
  (let ((prompt-array (make-prompt-array))
	(tv:kbd-intercepted-characters editor-intercepted-characters)
	ch)
    (catch 'return-from-command-loop
      (catch (if (eq top-level-p t) 'exit-top-level 'exit-control-r)
	(do-forever
	  (catch-error-restart ((sys:abort error)
				(if top-level-p
				    "Return to top level editor command loop."
				  "Return to editor command loop."))
	    (catch 'zwei-command-loop
	      (catch (if (eq top-level-p t) 'top-level 'dummy-tag)
		(tagbody
		    (setq *last-command-type* *current-command-type*
			  *current-command-type* nil
			  *numeric-arg* 1
			  *numeric-arg-p* nil
			  *numeric-arg-n-digits* 0
			  *mark-stays* nil
			  *mini-buffer-command* nil)
		    (clear-prompts)
		    (unless (zerop typeout-used-height)
		      (send typeout-stream :do-something-about-typeout))
		    (send *typein-window* :command-loop-redisplay)
		    (setq *centering-fraction* *center-fraction*)
		 unreal-command			;arguments loop back here
		    (redisplay-all-windows)
		    (without-io-buffer-output-function 
		      (setq ch (input-with-prompts *standard-input* :any-tyi)))
		    (cond ((null ch)		;If EOF, return
			   (return nil))
			  ((consp ch)
			   (lexpr-send self :process-special-command ch))
			  ((numberp ch)		;Keyboard or mouse character
			   (when (eq :argument (send self :process-command-char ch))
			     (incf *numeric-arg-n-digits*)
			     (go unreal-command))))))))
	  ;; If we abort from BREAK or an error, and after every command,
	  ;; say it is ok to flush the typeout window.
	  (send *typeout-window* :make-complete)
	  (when *mini-buffer-command*
	    (mini-buffer-ring-push *mini-buffer-command*)))))))

(defmethod (external-stream-displayer :process-special-command) (&rest ignore)
  nil)
(defmethod (external-stream-displayer :process-command-char) (ch)
  (process-command-char ch))


(defun external-stream-displayer-pline-vpos (pline)
  "Return the actual vertical cursorpos of editor line PLINE."
  (declare (:self-flavor external-stream-displayer))
  (+ top
     (\ (+ starting-vpos (* pline line-height))
	(* (truncate (- bottom top) line-height) line-height))))

;This operation looks at the current cursorpos of WINDOW
;and makes editor display start from there.
;In rubout handling editors it also reprints the prompt
;that was specified by the caller of the rubout handler (eg, PROMPT-AND-READ).
(defmethod (external-stream-displayer :reprompt) (&optional ignore)
  (multiple-value-setq (first-line-left starting-vpos)
    (send window :read-cursorpos)))

(compile-flavor-methods external-stream-displayer)