;; -*- Mode: LISP; Syntax: Common-Lisp; Package: XIT; Base: 10; -*-
;;;_________________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: SPECIAL-DISPELS
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Hohl, Hubertus
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/special-dispels.lisp
;;; File Creation Date: 8/23/90 10:46:39
;;; Last Modification Time: 10/08/92 10:27:57
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;; 07/28/1992 (Matthias) new slot whitespace-separators for multi-line-text-dispel
;;;                    display-position now makes something useful
;;;
;;; 07/31/1992 (Hubertus) fixed bug in 
;;;                       (method cursor-to-end multi-line-text-dispel)
;;; 08/04/1992 (Matthias) New: editable multi-line-text-dispel plus color
;;;
;;; 10/08/1992 (Juergen)  #\Return and #\Linefeed have been switched for
;;;                       multi-line-text-dispel, i.e. #\Linefeed creates
;;;                       an new line character and #\Return accepts the 
;;;                       text.  This is more consistent with single-line
;;;                       text-dispels.
;;;________________________________________________________________________________ 


(in-package :xit)


;;;_____________________
;;;
;;; Minimax for Dispels
;;;_____________________
;;;
;;; Make MINIMAX work for non-self-adjusting dispels that specify a MIN-WIDTH
;;; limit and a display-position other than :xxx-left (same for height).

(defclass minimax-dispel-mixin (minimax-mixin)
     ())

(defmethod initialize-instance :after ((self minimax-dispel-mixin) &rest initargs)
  (declare (ignore initargs))
  (with-slots (x y width height border-width parent) self
    (multiple-value-bind (success-p approved-x approved-y approved-width approved-height
			  approved-border-width)
	(manage-geometry parent self x y width height border-width)
      (declare (ignore success-p approved-x approved-y approved-border-width))
      (setf width approved-width
	    height approved-height))))

(defmethod display-x-offset :around ((self minimax-dispel-mixin))
  (without-adjusting-size self
    (call-next-method)))

(defmethod display-y-offset :around ((self minimax-dispel-mixin))
  (without-adjusting-size self
    (call-next-method)))

;;;__________________________
;;;
;;; Abbreviating Text Dispel
;;;__________________________
;;;
;;; The abbreviating-text-dispel abbreviates text that exceeds a certain maximum 
;;; limit by appending an ellipsis. The maximum width is specified by MAX-WIDTH 
;;; (see MINIMAX-MIXIN) or - if the dispel is not self-adjusting - by the minimum
;;; of MAX-WIDTH (if any) and contact width. If the dispel specifies no MAX-WIDTH
;;; and is self-adjusting, the text is not abbreviated.

(defcontact abbreviating-text-dispel (minimax-dispel-mixin text-dispel)
   ((ellipsis :allocation :class
	      :type stringable
	      :initform "..."))
   (:documentation "A text dispel that abbreviates text by appending an ellipsis
                    whenever a maximum-width is exceeded."))

(defmethod display ((self abbreviating-text-dispel) &optional x y width height &key)
  (with-clip-mask (clip-mask self x y width height)
    (with-slots (text font ellipsis foreground) self
      (let ((x-pos (display-x-offset self))
	    (y-pos (+ (display-y-offset self) (max-char-ascent font))))
	(multiple-value-bind (abbrev-index abbrev-width ellipsis-width)
	    (abbreviated-text self)
	  (using-gcontext (gc :drawable self
			      :clip-mask clip-mask
			      :font font
			      :foreground foreground)
	    (draw-glyphs self gc x-pos y-pos text :end abbrev-index)
	    (unless (zerop ellipsis-width)
	      (draw-glyphs self gc (+ x-pos abbrev-width) y-pos ellipsis))
	    ))))))

(defmethod display-width ((self abbreviating-text-dispel))
  (with-slots (text font) self
    (if (and text font)
      (multiple-value-bind (abbrev-index abbrev-width ellipsis-width)
	  (abbreviated-text self)
	(declare (ignore abbrev-index))
	(+ abbrev-width ellipsis-width
	   (x-margins self)))
      (call-next-method))))

(defmethod abbreviated-text ((self abbreviating-text-dispel))
  (with-slots (text font ellipsis adjust-size? width) self
    (let* ((text-width (text-width font text))
	   (max-w (max-width self))
	   (end (length text))
	   (max-width (if (not adjust-size?)
			  (max 0
			       (- (if max-w (min max-w width) width)
				  (x-margins self)))
			  (if max-w
			      (max 0 (- max-w (x-margins self)))
			      text-width))))
      (if (> text-width max-width)
	  (do* ((e-width (text-width font ellipsis))
		(fill-width (max 0 (- max-width e-width)))
		(i 0 (1+ i))
		(width 0)
		(cw 0))
	       ((or (>= i end)
		    (> width fill-width))
		(values (max 0 (1- i))
			(- width cw)
			e-width))
	    (incf width (setq cw (char-width font (char->card8 (char text i))))))
	  (values end text-width 0)))))


;;;________________________
;;;
;;; Multi Line Text Dispel
;;;________________________
;;;
;;; A MULTI-LINE-TEXT-DISPEL displays a text string with control-characters, 
;;; whose output may extent across multiple lines. There are two operational 
;;; modes for multi-line-text-dispels:
;;;
;;;  - if the dispel is not self-adjusting (adjust-size? = NIL) then character 
;;;    output can be filled, i.e. line breaks are made at separator characters.
;;;    The fill-column slot-value (if non-NIL) specifies the maximum length 
;;;    for filled lines:
;;;      :MAX              - fill to width of text-dispel (minus x-margins)
;;;      (<n> :pixel)      - fill to width specified by <n>
;;;      (<n> :character)  - fill to <n> * maximum-character-width(font)
;;;      :NONE or NIL      - don't fill, break lines at terminators (see below).
;;;      :WRAP             - always fill to width of text-dispel (minus x-margins),
;;;                          i.e. separators are ignored and line terminators taken 
;;;                          into account.
;;; 
;;;  - if the dispel is self-adjusting, character output is done as specified
;;;    by the text string, i.e. lines are broken at the usual line terminating 
;;;    characters #\Return and #\Linefeed.
;;;
;;; Besides the standard characters and line terminators, the text string 
;;; specified by (SETF TEXT) may contain additional control-sequences 
;;; which are identified by starting with a #\Page character. 
;;; Control-sequences have the form #\Page<dispatch-char>... 
;;; (they are extensible through the PARSE-TEXT-CONTROL-SEQUENCE eql-method).
;;;  
;;; Up to now the only valid control-sequence is of the form #\Page|<font-spec>|.
;;; This is used to specify a new font for subsequent characters in the string.
;;; 
;;; The WITH-OUTPUT-TO-TEXT-DISPEL macro provides a convenient way of doing
;;; output on a stream (by use of the Common-Lisp stream output functions), which
;;; is connected to a (multi-line) text-dispel. This macro allows font changes
;;; on the dispel-stream by using the WITH-FONT macro.
;;;

(defcontact multi-line-text-dispel (text-dispel)
  ((max-lines :type (or null (integer 1 *))	; specifies maximum number of output lines
	      :initform nil
	      :initarg :max-lines
	      :accessor text-max-lines)
   (separators :initform '(#\Space #\- #\. #\= #\_ #\, #\;)	;specifies the characters
	       :initarg :separators		                ; at which to break lines
	       :accessor text-separators)
   (whitespace-separators :initform '(#\Space)
		     :initarg :whitespace-separators
		     :accessor text-whitespace-separators)			; specifies the separators that are
		     ; skipped around a line break
   (interline-spacing :type (or fixnum float)	   ; ratio of line-height to text-height
		      :initform 1.2		   ; for float, otherwise constant spacing
		      :initarg :interline-spacing  ; in pixels
		      :accessor text-interline-spacing)
   (fill-column :type (or null (member :none :max :wrap) list)
		:initform :max		
		:initarg :fill-column	
		:accessor text-fill-column)
   (display-position :initform :upper-left)
   (cursor-line :initform nil :accessor cursor-line)
   (cursor-position :initform 0)
   ;; internal cache
   (text-lines :initform nil)
   )
  (:documentation "A text dispel for multiple line texts with multiple fonts.")
  (:resources
    (max-lines :initform nil)
    (fill-column :initform :max)
    (separators :initform '(#\Space #\- #\. #\= #\_ #\, #\;))
    (whitespace-separators :initform '(#\Space))
    (interline-spacing :initform 1.2))
  )

;;; Note: multi-line-text-dispel shouldn't have fixed-size-mixin mixed in
;;;
(defmethod adjusted-total-width ((self multi-line-text-dispel))
  (multiple-value-bind (w h)
      (adjusted-window-size self)
      (declare (ignore h))
    (+ (* 2 (contact-border-width self)) w)))

(defmethod adjusted-total-height ((self multi-line-text-dispel))
  (multiple-value-bind (w h)
      (adjusted-window-size self)
      (declare (ignore w))
    (+ (* 2 (contact-border-width self)) h)))

(defmethod display-width ((self multi-line-text-dispel))
  (multiple-value-bind (text-width text-height) (text-size self)
    (declare (ignore text-height))
    (+ text-width (x-margins self))))

(defmethod display-height ((self multi-line-text-dispel))
  (multiple-value-bind (text-width text-height) (text-size self)
    (declare (ignore text-width))
    (+ text-height (y-margins self))))

;;; Triggers that invalidate the text-lines cache
;;;
(defmethod (setf text) :before (new-text (self multi-line-text-dispel))
  (with-slots (text-lines) self
    (setf text-lines nil)))

(defmethod (setf font) :before (new-font (self multi-line-text-dispel))
  (with-slots (text-lines) self
    (setf text-lines nil)))

(defmethod (setf text-max-lines) :before (new-value (self multi-line-text-dispel))
  (with-slots (text-lines) self
    (setf text-lines nil)))

(defmethod (setf text-max-lines) :after (new-value (self multi-line-text-dispel))
  (adjust-window-size self)
  (update self))

(defmethod (setf text-separators) :before (new-value (self multi-line-text-dispel))
  (with-slots (text-lines) self
    (setf text-lines nil)))

(defmethod (setf text-separators) :after (new-value (self multi-line-text-dispel))
  (adjust-window-size self)
  (update self))

(defmethod (setf text-whitespace-separators) :before (new-value (self multi-line-text-dispel))
  (with-slots (text-lines) self
    (setf text-lines nil)))

(defmethod (setf text-whitespace-separators) :after (new-value (self multi-line-text-dispel))
  (adjust-window-size self)
  (update self))

(defmethod (setf text-interline-spacing) :before (new-value (self multi-line-text-dispel))
  (with-slots (text-lines) self
    (setf text-lines nil)))

(defmethod (setf text-interline-spacing) :after (new-value (self multi-line-text-dispel))
  (adjust-window-size self)
  (update self))

(defmethod (setf text-fill-column) :before (new-value (self multi-line-text-dispel))
  (with-slots (text-lines) self
    (setf text-lines nil)))

(defmethod (setf text-fill-column) :after (new-value (self multi-line-text-dispel))
  (adjust-window-size self)
  (update self))

(defmethod update-text-lines ((self multi-line-text-dispel))
  (with-slots (text-lines) self
    (setf text-lines (parse-text-lines self))))

(defmethod text-size ((self multi-line-text-dispel))
  (declare (values text-width text-height))
  (with-slots (text-lines) self
    (cond ((not (null text-lines))
	(values (text-lines-width text-lines) 
		(text-lines-height text-lines)))
	(t (update-text-lines self)
	   (values (text-lines-width text-lines)
		   (text-lines-height text-lines))))))

;;; 
;;; Parsing Text Lines
;;;

(defun make-text-line-string (initial-size)
  (make-array (or initial-size 10)
	      :element-type #+(and allegro-version>=
				   (version>= 4 1)) 'base-char
			    #+allegro-v4.0 'cltl1:string-char
			    #-allegro 'string-char
	      :fill-pointer 0
	      :adjustable t))

(defstruct text-lines
  lines
  width
  height)

(defstruct text-line
  (string (make-text-line-string 10))
  (start 0)
  (length 0)
  text-pointer
  (descrs nil)	   ; a sorted alist of (<indexinto-string>.<descr>) entries
					; <descr> = <color-pixel> or <font>
  (width 0)
  (height 0))

(defun text-line-fonts (line)
  (remove-if-not #'(lambda (item) (font-p (cdr item))) (text-line-descrs line)))

(defun text-line-colors (line)
  (remove-if-not #'(lambda (item) (typep (cdr item) 'pixel)) (text-line-descrs line)))

(defun line-fonts-max-property (current-font line function &rest args)
  (let* ((fonts (text-line-fonts line))
	 (max (if (and fonts
		       (zerop (caar fonts)))
		  0 
		  (apply function current-font args))))
    (dolist (font fonts)
      (setq max (max max (apply function (cdr font) args))))
    max))

(defmethod fill-width ((self multi-line-text-dispel))
  (with-slots (font fill-column width) self
    (typecase fill-column
	     (null nil)
	     ((member :none) nil)
	     ((member :max :wrap) (max 0 (- width (x-margins self))))
	     (list
	       (case (second fill-column)
		 (:pixel (max 0 (first fill-column)))
		 (:character (max 0 (* (first fill-column)
				       (max-char-width font)))))))))

(defmethod parse-text-lines ((self multi-line-text-dispel))
  (with-slots (text font foreground interline-spacing
	       max-lines fill-column width) self
    (do ((start 0)
	 (current-font font)
	 (current-color foreground)
	 (fill-width
	   (fill-width self))
	 (max-width 0)
	 (height 0)
	 (line-count 0)
	 line
	 (lines nil))
	(nil)
      (multiple-value-setq (start line current-font current-color)
	(parse-text-line self text start current-font current-color fill-width))
      (setq max-width (max max-width (text-line-width line)))
      (push line lines)
      (incf line-count)
      (when (or (null start)
		(and max-lines
		     (= max-lines line-count)))
	(incf height (text-line-height line))
	(return (make-text-lines :lines (nreverse lines)
				 :width max-width
				 :height height)))
      (incf height
	    (line-spacing self line))
      )))

(defmethod fill? ((self multi-line-text-dispel))
  (with-slots (adjust-size? separators fill-column font) self
      (and (not adjust-size?)
	   (fill-width self)
	   (not (eq fill-column :wrap)))))
	
(defmethod parse-text-line ((self multi-line-text-dispel) text start current-font
							  current-color fill-width)
  (macrolet ((line-terminator-p (char)
	       `(member ,char '(#\Linefeed #\Return #\Newline) :test #'char=))
	     (escape-char-p (char)
	       `(char= ,char #\Page)))
    (with-slots (adjust-size? separators fill-column font foreground) self
      (let* ((line (make-text-line :descrs (list (cons 0 (or current-color
							     foreground))
						 (cons 0 (or current-font
							    font)))
				   :text-pointer start))
	     (end (length text))
	     (break-lines? (and (not adjust-size?) fill-width))
	     (wrap-around? (and break-lines? (eq fill-column :wrap)))
	     (fill? (fill? self))
	     (separators (if wrap-around? nil separators)))
	(flet ((separator-p (char)
		 (member char separators :test #'char=))
	       (whitespace-separator-p (char)
		 (and separators
		      (member char (text-whitespace-separators self)
			      :test #'char=))))
	  (do ((i start)
	       (cw)
	       (break) (break-without-whitespace nil)
	       (last-sep nil)
	       (in-line nil)
	       (return nil)
	       (char))
	      ((or return
		   (>= i end))
	       (when (>= i end)
		 (setf (text-line-length line)
		     (- (fill-pointer (text-line-string line))
			(text-line-start line))))
	       (multiple-value-prog1
		   (values return
			   line
			   (or (cdar (text-line-fonts line))
			       current-font)
			   (or (cdar (text-line-colors line))
			       current-color))
		 (setf (text-line-descrs line)
		     (nreverse (text-line-descrs line))
		     (text-line-height line)
		     (line-fonts-max-property current-font line #'text-height))))
	    (cond ((escape-char-p (setq char (char text i)))
		   (if (>= (+ i 2) end)
		       (setq i end)
		     (setq i (parse-text-control-sequence
			      self (char text (1+ i)) text (+ i 2) line))))
		  ((line-terminator-p char)
		   (cond  ((and break-lines? (not wrap-around?))
			   (incf i))	; skip them
			  (t (setf (text-line-length line)
				 (- (fill-pointer
					 (text-line-string line))
					(text-line-start line)))
			     (setq return (1+ i))))) ; break at terminators
		  ((graphic-char-p char)
		   (setq cw (or (char-width 
				 (or (cdar (text-line-fonts line)) current-font)
				 (char->card8 char))
				0))
		   (cond ((and fill?
			       (not in-line)
			       (whitespace-separator-p char))
			  ;; ignore white-space separators at the beginning of line
			  ;;(format t "Ignoring white-space at front~%")
			  (vector-push-extend char (text-line-string line))
			  (incf i))
			 (t
			  (when (separator-p char)
			    (setq last-sep i))
			  (unless in-line
			    (setq in-line t)
			    (setf (text-line-start line) (fill-pointer
							  (text-line-string line))))
			  (cond ((and break-lines?
				      (> i start) ; consume at least one char always!
				      (> (+ (text-line-width line) cw) fill-width))
				 (when (separator-p char)
				   (incf (text-line-width line) cw)
				   (vector-push-extend char (text-line-string line))
				   (incf i))
				 (cond (last-sep ;; last separator position on this line or nil when :wrap
					(setq break
					    (position-if
					     #'separator-p (text-line-string line)
					     :from-end t))
					(when break
					  (setq break-without-whitespace
					      (position-if
					       #'(lambda (x)
						   (not (member
							 x
							 (text-whitespace-separators self))))
					       (text-line-string line)
					       :from-end t
					       :end break)))
					(cond (break-without-whitespace  
					       (setf (text-line-width line)
						   (- (text-line-width line)
						      (do ((skip-w 0)
							   (index
							    (1- (fill-pointer (text-line-string line)))
							    (1- index))
							   (font-item nil))
							  ((<= index break-without-whitespace) skip-w)
							(when (or (null font-item)
								  (< index (car font-item)))
							  (setq font-item
							      (or (assoc index
									 (text-line-fonts line)
									 :test #'>=)
								  (cons 0 current-font))))
							(incf skip-w
							      (char-width
							       (cdr font-item)
							       (char->card8
								(char (text-line-string line) index)))))))
					       (setf (text-line-length line)
						   (1+ (-  break-without-whitespace (text-line-start line))))
					       (setf (fill-pointer (text-line-string line))
						   (1+ break))
					       (setq return (1+ last-sep)))
					      (t ;; only beginning of line contains separators
					;(format t "Strip whitespace from start~%")
					       (setf (text-line-width line) 0)
					       (setf in-line nil)
					       ;; try again
					       (setq i (1+ last-sep)))))
				       (t
					(setf (text-line-length line)
					    (- i (text-line-start line)))
					(setq return i))))
				(t
				 (incf (text-line-width line) cw)
				 (vector-push-extend char (text-line-string line))
				 (incf i))))))
		  (t
		   ;; skip all other semi-standard chars (e.g. #\Tab or #\Backspace)
		   (incf i))))
	  )))))


;;; Control sequences have the form #\Page<dispatch-char>.
;;; The PARSE-TEXT-CONTROL-SEQUENCE methods get start-index into the text-string 
;;; (after first <dispatch-char>) and return the index for the next non-consumed
;;; char. As a side effect the line structure may be modified. 
;;;

;;; Default method
;;;
(defmethod parse-text-control-sequence ((self multi-line-text-dispel) (char character)
					text start line)
  (values (text-control-sequence-end self char text start)))	    ; skip #\Page
  
;;; #\Page|<font-spec>|  
;;;  
(defmethod parse-text-control-sequence ((self multi-line-text-dispel) (char (eql #\|))
					text start line)
  (let ((end (text-control-sequence-end self char text start))
	(text-end (length text))
	(fp (fill-pointer (text-line-string line))))
    (cond (end
	   ;; overwrite font entries with same fp
	   (setf (text-line-descrs line)
		 (acons fp
			(convert self (read-from-string (subseq text start end))
				 'font)
			(delete fp (text-line-descrs line)
				:test #'(lambda (new item)
					  (and (font-p (cdr item))
					       (= new (car item))))
				:end 2)))
	   (1+ end))
	  (t text-end))))

(defmethod parse-text-control-sequence ((self multi-line-text-dispel) (char (eql #\<))
								      text start line)
  (let ((end (text-control-sequence-end self char text start))
	(text-end (length text))
	(fp (fill-pointer (text-line-string line))))
    (cond (end
	   ;; overwrite font entries with same fp
	   (setf (text-line-descrs line)
		 (acons fp
			(convert self (subseq text start end)
				 'pixel)
			(delete fp (text-line-descrs line)
				:test #'(lambda (new item)
					  (and (typep (cdr item) 'pixel)
					       (= new (car item)))))))
	   (1+ end))
	  (t text-end))))
  

(defmethod text-control-sequence-end ((self multi-line-text-dispel) (char character)
					  text start)
  (1- start))


(defmethod text-control-sequence-end ((self multi-line-text-dispel) (char (eql #\|))
					  text start)
  (position char text :start start))

(defmethod text-control-sequence-end ((self multi-line-text-dispel) (char (eql #\<))
					  text start)
  (position #\> text :start start))

;;; Set cursor

(defmethod set-cursor-position-with-mouse ((self multi-line-text-dispel))
  "Sets the cursor according to a prevailing mouse button event."
  (with-event (x y window)
    (multiple-value-bind (nx ny)
	(contact-translate window x y self)
      (set-line-cursor-pixel-position self nx ny))))

(defmethod convert-pointer-to-cursor ((self multi-line-text-dispel) x y)
  (let ((line (convert-cursor-offset-to-cursor-line self y)))
    (values line (convert-cursor-offset-to-cursor-position self line x))))
  
(defmethod set-line-cursor-pixel-position ((self multi-line-text-dispel) x y)
  (multiple-value-bind (line position)
      (convert-pointer-to-cursor self x y)
    (setf (cursor-position self)
	position)
    (setf (cursor-line self) line))
  (update self))

(defmethod convert-cursor-offset-to-cursor-position ((self multi-line-text-dispel) line x-offset)
  (with-slots (text font ) self
    (let ((cursor-offset (max 0 (- x-offset (display-line-offset self line))))
	  (characters-in-line (length (text-line-string line)))
	  (start (if (fill? self)
		     (text-line-start line)
		   0)))
      (cond ((< cursor-offset 0) 0)
	    ((> cursor-offset (text-line-width line)) characters-in-line)
	    (t
	     (- (search-cursor-position-in-line line cursor-offset
					     start 0)
		start))))))

(defmethod search-cursor-position-in-line (line cursor-offset left-index partial-length)
  "Searches for the cursor-position  in line"
  (let ((new-partial-length
		  (+ partial-length
		     (character-width-in-line left-index line))))
	     (cond ((< cursor-offset new-partial-length)
		    (if (> (/ (- cursor-offset partial-length)
			      (- new-partial-length partial-length))
			   *cursor-position-threshold*)
			(1+ left-index) left-index))
		   (t (search-cursor-position-in-line line cursor-offset
						      (1+ left-index)
						      new-partial-length)))))

(defmethod subline-width (line start end)
  (let ((result 0)
	(index start))
    (dotimes (i (- end start) result)
      (incf result (character-width-in-line index line))
      (incf index))))

(defmethod character-width-in-line (index line)
  (let* ((font (cdr (find index (text-line-fonts line)
			  :from-end t :test #'>= :key #'car))))
    (when font
      (char-width
	font (char->card8 (char (text-line-string line) index))))))

(defmethod convert-cursor-offset-to-cursor-line ((self multi-line-text-dispel) y-offset)
  (with-slots (text-lines font) self
    (unless text-lines (update-text-lines self))
    (let*
	((lines (text-lines-lines text-lines))
	 (cursor-offset 
	  (- y-offset (+ (display-y-offset self)
			 0)))
	  (y 0)
	  )
	 (cond ((< cursor-offset 0) (car lines))
	       ((> cursor-offset (text-lines-height text-lines))
		(car (last lines)))
	       (t (dolist (line lines)
		    (incf y (line-spacing self line))
		    (when (< cursor-offset  y)
		      (return line))))))))

(defmethod convert-cursor-to-text-pointer ((self multi-line-text-dispel))
  (with-slots (cursor-line cursor-position) self
    (when (and cursor-line cursor-position)
      (convert-line-and-position-to-text-pointer self cursor-line cursor-position))))
      
(defmethod convert-line-and-position-to-text-pointer
    ((self multi-line-text-dispel) cursor-line cursor-position)
  (with-slots (text) self
    (let ((offset (1- (text-line-text-pointer cursor-line)))
	  (text-length (length text)))
      (dotimes (i (+ (1+ cursor-position)
		     (if (fill? self)
			 (text-line-start cursor-line)
		       0))
		 offset)
	(incf offset)
	(when (> offset (1- text-length)) (return text-length))
	(loop
	  (unless (< offset text-length) (return))
	  (cond ((char= (char text offset) #\Page)
	      (setf offset (1+ (text-control-sequence-end self
							  (char text (1+ offset))
							  text
							  (+ 2 offset)))))
	      ((member  (char text offset) '(#\Return #\Newline)
			  :test #'char=)
		 (if (fill? self)
		     (incf offset)
		   (return)))
	      (t (return))))))))
		

(defmethod convert-text-pointer-to-cursor ((self multi-line-text-dispel) text-index)
  (with-slots (text-lines text) self
    (unless text-lines (update-text-lines self))
    (let ((line (find text-index (text-lines-lines text-lines)
		      :key #'text-line-text-pointer :from-end t
		      :test #'>=)))
      (when line
	(if (> text-index (length text))
	    (values line (text-line-length line))
	(let* ((offset (text-line-text-pointer line))
	       (cursor-position 0))
	  (do ()
	      ((>= offset text-index)
	       (values line
		       (- cursor-position
			  (if (fill? self)
			      (text-line-start line)
			    0))))
	    (case (char text offset)
	      (#\Page
		   (setf offset (1+ (text-control-sequence-end self
						    (char text (1+ offset))
						    text
						    (+ 2 offset)))))
	      ((#\Return #\Newline)
			(incf offset)
			(if (not (fill? self))
			    (incf cursor-position))) 
	      (t (incf offset) (incf cursor-position))))))))))

(defmethod make-editable ((self multi-line-text-dispel)
			  &optional cursor-line-and-position)
 (with-slots (cursor-line) self
   (if cursor-line-and-position
       (setf cursor-line (car cursor-line-and-position))
     (setf cursor-line (last-line self)))
   (when cursor-line
     (call-next-method self
		       (if cursor-line-and-position
			   (cadr cursor-line-and-position)
			 (end-of-line self))))))

(defmethod edit-text-with-mouse ((self multi-line-text-dispel))
  (with-event (x y window)
    (multiple-value-bind (nx ny)
	(contact-translate window x y self)
      (make-editable self
		(multiple-value-list
		   (convert-pointer-to-cursor self nx ny)))))
  (show-mouse-documentation self))
  
     
(defmethod cursor-to-end-of-line ((self multi-line-text-dispel))
  (with-slots (cursor-line) self
    (when cursor-line
      (change-cursor-position self
			      (end-of-line self)))))

(defmethod end-of-line ((self multi-line-text-dispel))
  (with-slots (cursor-line) self
    (when cursor-line
      (if (fill? self)
	  (text-line-length cursor-line)
	(length (text-line-string cursor-line))))))

(defmethod cursor-to-end ((self multi-line-text-dispel))
  (with-slots (cursor-line) self
    (let ((last-line (last-line self)))
      (when last-line
	(setf cursor-line last-line)
	(cursor-to-end-of-line self)))))

(defmethod last-line ((self multi-line-text-dispel))
  (with-slots (text-lines cursor-line) self
    (unless text-lines (update-text-lines self))
    (car (last (text-lines-lines text-lines)))))

(defmethod forward-cursor ((self multi-line-text-dispel))
  (with-slots (text cursor-position cursor-line text-lines) self
    (let ((text-length (if (fill? self)
			   (text-line-length cursor-line)
			 (length (text-line-string cursor-line)))))
      (if (< cursor-position text-length)
	(incf cursor-position)
	(let ((next-line (cadr (member cursor-line (text-lines-lines text-lines)))))
	  (when next-line
	    (setf cursor-position 0)
	    (setf cursor-line next-line)))))
    (update self)))

(defmethod backward-cursor ((self multi-line-text-dispel))
  (with-slots (text cursor-position cursor-line text-lines) self
    (if (> cursor-position 0)
	(call-next-method)
      (let ((prev-line (cadr (member cursor-line
				     (reverse (text-lines-lines text-lines))))))
	(when prev-line
	  (setf cursor-position (text-line-length prev-line))
	  (setf cursor-line prev-line)))))
  (update self))

(defmethod next-line ((self multi-line-text-dispel))
  (with-slots (text cursor-position cursor-line text-lines) self
    (let ((next-line (cadr (member cursor-line (text-lines-lines text-lines)))))
      (when next-line
	(let* ((text-length (if (fill? self)
			       (text-line-length next-line)
			     (length (text-line-string next-line))))
	       (next-line-end-offset
		(character-offset-in-line self next-line text-length))
	       (cursor-offset (character-offset-in-line self cursor-line
							       cursor-position)))
	  (if (>= cursor-offset next-line-end-offset)
	      (setf cursor-position text-length)
	    (if (< cursor-offset 0)
		(setf cursor-position 0)
	      (setf cursor-position
		  (convert-cursor-offset-to-cursor-position self next-line
				     cursor-offset)))))
	(setf cursor-line next-line)))
      (update self)))

(defmethod previous-line ((self multi-line-text-dispel))
  (with-slots (text cursor-position cursor-line text-lines) self
    (let ((previous-line (cadr (member cursor-line (reverse (text-lines-lines text-lines))))))
      (when previous-line
	(let* ((text-length (if (fill? self)
			       (text-line-length previous-line)
			     (length (text-line-string previous-line))))
	       (previous-line-end-offset
		(character-offset-in-line self previous-line text-length))
	       (cursor-offset (character-offset-in-line self cursor-line
							       cursor-position)))
	  (if (>= cursor-offset previous-line-end-offset)
	      (setf cursor-position text-length)
	    (if (< cursor-offset 0)
		(setf cursor-position 0)
	      (setf cursor-position
		  (convert-cursor-offset-to-cursor-position self previous-line
				     cursor-offset )))))
	(setf cursor-line previous-line))))
  (update self))

;;; 
;;; Displaying Text Lines
;;;

(defmethod display ((self multi-line-text-dispel) &optional x y width height &key)
  (declare (ignore x y width height))
  (text-size self) 				; ensure text-lines cache is valid!
  (with-clip-mask (clip-mask self x y width height)
    (display-text-lines self clip-mask)
    ))

(defmethod character-offset-in-line ((self  multi-line-text-dispel) line position)
  (let ((text-width (if (fill? self)
			(text-line-length line)
		      (length (text-line-string line))))
	(text-line-start (if (fill? self)
			     (text-line-start line) 0)))
    (+ (subline-width line
		      text-line-start
		      (+ (min text-width position)
			 text-line-start))
       (display-line-offset self line))))

(defmethod draw-cursor-in-line ((self multi-line-text-dispel) line y font clip-mask)
   (with-slots (text-lines cursor-position foreground) self
     (let* ((cursor-x (character-offset-in-line self line cursor-position))
	    (cursor-y (- y (max-char-ascent font)))
	    (cursor-width 1)
	    (cursor-height (text-height font))
	    (cursor-color (cdr (find cursor-position (text-line-colors line) 
			       :test #'>= :key #'car
			       :from-end t))))
       (using-gcontext (gc :drawable self :function BOOLE-XOR
			  :clip-mask clip-mask
			  :foreground (logxor (or cursor-color
						  foreground) (background self))
			  :background 0) 
	(draw-rectangle-inside self gc cursor-x cursor-y
			       cursor-width cursor-height t)))))

(defmethod display-line-offset ((self multi-line-text-dispel) line)
  (with-slots (display-position) self
    (let* ((x-margin (x-margin self))
	   (fill-width (fill-width self)))
      (flet ((center (line)
	       (+ x-margin (floor (- fill-width
				     (text-line-width line))
			      2)))
	     (flushright (line)
	       (+ x-margin (- fill-width
			      (text-line-width line)))))
	(case display-position
	  ((:left-center :upper-left :lower-left) x-margin)
	  ((:upper-center :center :lower-center) (center line))
	  ((:upper-right :right-center :lower-right)
	   (flushright line)))))))

(defmethod display-text-lines ((self multi-line-text-dispel) &optional clip-mask)
  (with-slots (font text-lines edit-value? foreground
	       cursor-line) self
   (using-gcontext (gc :drawable self
		       :clip-mask clip-mask
		       :font font
		       :foreground foreground)
     (let* ((lines (text-lines-lines text-lines))
	    (x-margin (x-margin self))
	    (y (+ (display-y-offset self)
		  (line-fonts-max-property font (first lines) #'max-char-ascent)))
	    (current-font font)
	    (current-color foreground))
       (do* ((rest-lines lines (cdr rest-lines))
	     (line (car rest-lines) (car rest-lines))
	     (current-x nil)
	     (start nil)
	     (start-descr nil)
	     (start-font nil)
	     (start-color nil))
	   ((null rest-lines))
	 (setq start (if (fill? self)
			 (text-line-start line) 0))
	 (setq start-descr (find start (text-line-descrs line) 
			       :test #'>= :key #'car
			       :from-end t))
	 (setq start-font (find start (text-line-fonts line) 
			       :test #'>= :key #'car
			       :from-end t))
	 (setq start-color (find start (text-line-colors line) 
			       :test #'>= :key #'car
			       :from-end t))
	 (setq current-x
	       (display-line-offset self line))
	 (when start-font
	   (setq current-font (cdr start-font))
	   (setf (gcontext-font gc) current-font))
	 (when start-color
	   (setq current-color (cdr start-color))
	   (setf (gcontext-foreground gc) current-color))
	 (do ((string (text-line-string line))
	      (descrs-rest (if start-descr
			      (cdr (member start-descr (text-line-descrs line)))
			    (text-line-descrs line)))
	      (i start  new-i)
	      (end-i
	       (if (fill? self)
		   (+ (text-line-start line) (text-line-length line))
		 (length (text-line-string line))))
	      new-i ignored-index
	      (string-width))
	     ((= i end-i)
	      (when (and edit-value?
			 (eq cursor-line line))
		;; draw cursor
		(draw-cursor-in-line self line y current-font clip-mask))
		  
	      (incf y
		    (line-spacing self line)))
	   (loop
	     (when (not (and descrs-rest
			     (= i (caar descrs-rest))))
	       (return))
	     ;; change gcontext's font
	     (typecase (cdar descrs-rest)
	       (number
		(setq current-color (cdr (pop descrs-rest)))
		(setf (gcontext-foreground gc) current-color))
	       (font
		(setq current-font (cdr (pop descrs-rest)))
		(setf (gcontext-font gc) current-font))
	       (t (error "Unknown type of descr: ~a" (car descrs-rest)))))
	   (multiple-value-setq (ignored-index string-width)
	     (draw-glyphs self gc current-x y string
			  :start i
			  :end (setq new-i
				   (or (and descrs-rest (caar descrs-rest))
				       end-i))))
	   (when new-i
	     (incf current-x (or string-width
				 (text-width (gcontext-font gc) string
					     :start i
					     :end new-i)))
	     ))
	 )))))

(defmethod line-spacing ((self multi-line-text-dispel) line)
  (with-slots (interline-spacing) self
    (typecase interline-spacing
			(fixnum interline-spacing)
			(float (ceiling (* interline-spacing (text-line-height line)))))))

;;;
;;; Minor support for Text Editing
;;;

(defmethod add-character ((self multi-line-text-dispel) char &optional position)
  ; currently no cursor position supported
  (declare (ignore position))
  (with-accessors ((text text)) self
    (let ((text-pointer (convert-cursor-to-text-pointer self)))
      (setf text
	  (concatenate 'string
	    (subseq text 0 text-pointer)
	    (string char)
	    (subseq text text-pointer)))
      (adjust-window-size self)
      (if (and (fill? self)
	       (or (member (char text text-pointer)
		      '(#\Return #\Newline))
		   (member (char text text-pointer)
			   (text-whitespace-separators self))))
	  (change-text-pointer self (1+ text-pointer))
	(change-text-pointer self (1+ text-pointer))))))

(defmethod add-string ((self multi-line-text-dispel) string &optional position)
  ; currently no cursor position supported
  (declare (ignore position))
  (with-accessors ((text text)) self
    (let ((text-pointer (convert-cursor-to-text-pointer self)))
      (setf text
	  (concatenate 'string
	    (subseq text 0 text-pointer)
	    string
	    (subseq text text-pointer)))
      (adjust-window-size self)
      (change-text-pointer self (+ (length string) text-pointer)))))

(defmethod delete-to-end ((self multi-line-text-dispel) &optional position)
  (with-slots (display text cursor-line cursor-position) self
    (let ((end (if (fill? self)
		   (+ (text-line-start cursor-line)
		      (text-line-length cursor-line))
		 (length (text-line-string cursor-line)))))
      
      (when (< cursor-position end)
	(let* ((tail (subseq (text-line-string cursor-line)
			     (if (fill? self)
				 (+ (text-line-start cursor-line) cursor-position)
			       cursor-position)
			     (if (fill? self)
				 (text-line-length cursor-line)
				 (length (text-line-string cursor-line)))))
	       (text-pointer (convert-cursor-to-text-pointer self)))
	  (setf (cut-buffer display) tail)
	  (setf (text self)
	      (concatenate 'string
		(subseq text 0 text-pointer)
		(subseq text (convert-line-and-position-to-text-pointer
			      self cursor-line end))))
	  (adjust-window-size self)
	  (change-text-pointer self text-pointer) 
	  (update self))))))


(defmethod delete-character-backward ((self multi-line-text-dispel) &optional position)
  (with-slots (text-lines text) self
    (let ((text-pointer (convert-cursor-to-text-pointer self)))
      (multiple-value-bind (text new-pointer)
	  (delete-character-backward-in-text self (text self)
							text-pointer)
	(setf (text self) text)
	(adjust-window-size self)
	(change-text-pointer self new-pointer)))))

(defmethod delete-character-forward ((self multi-line-text-dispel) &optional position)
  (with-slots (text-lines text) self
    (let ((text-pointer (convert-cursor-to-text-pointer self)))
      (multiple-value-bind (text new-pointer)
	  (delete-character-forward-in-text self (text self)
					    text-pointer)
	(setf (text self) text)
	(adjust-window-size self)
	(change-text-pointer self new-pointer)))))

(defmethod change-text-pointer ((self multi-line-text-dispel) text-pointer)
  (with-slots (cursor-line) self
    (multiple-value-bind (line line-position)
	(convert-text-pointer-to-cursor self text-pointer)
      (setf cursor-line line)
      (change-cursor-position self line-position))))

(defmethod delete-character-backward-in-text ((self multi-line-text-dispel)
					      text pointer)
   (let* ((last-control-sequence-start (position #\Page text :from-end t
						 :end (max 0 (1- pointer))))
	   (last-control-sequence-end (when last-control-sequence-start
					(text-control-sequence-end self
					 (char text (1+ last-control-sequence-start))
					 text (+ 2 last-control-sequence-start)))))
     (cond ((and last-control-sequence-start
		  (= pointer (1+ last-control-sequence-end)))
	    ;; cursor is right after a control sequence, skip sequence backward
	     (delete-character-backward-in-text
	      self
	      text
	      last-control-sequence-start))
	    (t
	     (values
	      (concatenate 'string
	       (subseq text 0 (max 0 (1- pointer)))
	       (subseq text (max 0 pointer)))
	      (max 0 (1- pointer)))))))

(defmethod delete-character-forward-in-text ((self multi-line-text-dispel)
					      text pointer)
   (cond ((char= (char text pointer) #\Page)
	  ;; remove control sequence immediately after cursor first
	  (let ((control-sequence-end (text-control-sequence-end self
								 (char text (1+ pointer))
								 text (+ 2 pointer))))
	    (delete-character-forward-in-text
	      self
	      (concatenate 'string
		(subseq text 0 pointer)
		(subseq text (1+ control-sequence-end))
	      pointer))))
	    (t
	     (values
	      (concatenate 'string
	       (subseq text 0 (max 0 pointer))
	       (subseq text (max 0 (1+ pointer))))
	      (max 0 pointer)))))
#||	
(defmethod delete-character-backward ((self multi-line-text-dispel) &optional position)
  ; currently no cursor position supported
  (declare (ignore position))
  (with-slots (text-lines) self
    (let ((editable-text
	    (reduce #'(lambda (s1 s2)
			(concatenate 'string s1 (string #\Return) s2))
		    (mapcar #'text-line-string
			    (text-lines-lines text-lines)))))
      ;; sorry, font information is lost	
      (setf (text self)
	  (subseq editable-text 0 (max 0 (1- (length editable-text))))))))
||#

(defmethod key-press ((self multi-line-text-dispel) (char (eql #\Linefeed)))
  (add-character self #\return))

(defmethod key-press ((self multi-line-text-dispel) (char (eql #\Control-\u)))
  (clear-text self))

(defmethod key-press ((self multi-line-text-dispel) (char (eql #\Control-\n)))
  (next-line self))

(defmethod key-press ((self multi-line-text-dispel) (char (eql #\Control-\p)))
  (previous-line self))

(defmethod key-press ((self multi-line-text-dispel) (char (eql #\Control-\e)))
  (cursor-to-end-of-line self))

(defmethod key-press ((self multi-line-text-dispel) (char (eql #\Meta-\c)))
  (set-text-input-color self))

(defmethod set-text-input-color ((self multi-line-text-dispel))
  (with-slots (text cursor-position) self
    (let* ((color-name (prompt "Color: " :default
			       (get-pixel-name self (foreground self))))
	   (text-color (convert self color-name 'pixel))
	   (text-pointer (convert-cursor-to-text-pointer self)))
      (when text-color
	(setf text
	    (concatenate 'string
	      (subseq text 0 text-pointer)
	      (format nil "~|<~a>" color-name)
	      (subseq text text-pointer)))))
    (update-text-lines self)
    (update self)))
    
    
;;;
;;; Providing Stream Oriented Output to Text Dispels
;;;

(defmacro with-output-to-text-dispel ((stream text-dispel &key (mode :clear)) &body body)
  "Perform output to the text-dispel by using the specified stream.
   MODE may be :clear (clear text-dispel before doing output) or :append
   (append output to dispel's current output).
   Inside the dynamic scope of BODY the WITH-FONT macro may be used to
   temporarily change the font."
  `(with-output-to-text-dispel-internal ,text-dispel ,mode #'(lambda (,stream) .,body)))

(defun with-output-to-text-dispel-internal (text-dispel mode continuation)
  (let* ((saved-font (font text-dispel))
	 (string (make-text-line-string 100)))
    (multiple-value-prog1
      (with-output-to-string (stream string)
	(funcall continuation stream))
      (setf (slot-value text-dispel 'font) saved-font)
      (setf (text text-dispel)
	    (ecase mode
	      (:clear string)
	      (:append (concatenate 'string (text text-dispel) string)))))))

(defmacro with-font ((font text-dispel stream) &body body)
  `(with-font-internal ,font ,text-dispel ,stream #'(lambda () .,body)))

(defun with-font-internal (font dispel stream continuation)
  (let ((current-font (font dispel))
	(multi-font-dispel-p (typep dispel 'multi-line-text-dispel)))
    (unwind-protect
	(progn
	  (setf (slot-value dispel 'font)
		(setq font (if (font-p font)
			       font
			       (convert dispel font 'font))))
	  (when multi-font-dispel-p
	    (format stream "~||~A|" (font-name font)))
	  (funcall continuation))
      (when multi-font-dispel-p
	(format stream "~||~A|" (font-name current-font)))
      (setf (slot-value dispel 'font) current-font))))

(defmacro with-color ((color text-dispel stream) &body body)
  `(with-color-internal ,color ,text-dispel ,stream #'(lambda () .,body)))

(defun with-color-internal (color dispel stream continuation)
  (let ((current-color (foreground dispel))
	(window (if (realized-p dispel) dispel
		  (contact-root dispel))))
    (unwind-protect
	(progn
	  (setf (slot-value dispel 'foreground)
		(setq color (if (typep color 'pixel)
			       color
			       (convert dispel color 'pixel))))
	  (format stream "~|<~A>" (get-pixel-name window color))
	  (funcall continuation))
      (format stream "~|<~A>"  (get-pixel-name window current-color))
      (setf (slot-value dispel 'foreground) current-color))))


#|| For testin:
(defmacro current-char (multi-line-text-dispel)
 `(char (text ,multi-line-text-dispel)
	(convert-cursor-to-text-pointer ,multi-line-text-dispel)))

||#