;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: XIT; Base: 10; -*-
;;;_________________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: VIRTUALS
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Hohl, Hubertus
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/virtual-dispels.lisp
;;; File Creation Date: 6/06/90 16:41:33
;;; Last Modification Time: 07/16/92 08:47:17
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;________________________________________________________________________________ 


(in-package :xit)


(defmacro do-points (((x-var y-var) points &optional (origin-x 0) (origin-y 0)
		      end-x end-y end-p-var)
		     &body body)
  (let ((ignored-var (gensym)))
    `(block nil
       (do-points-internal ,points ,origin-x ,origin-y ,end-x ,end-y
			   #'(lambda (,x-var ,y-var ,(or end-p-var ignored-var))
			       ,@(unless end-p-var `((declare (ignore ,ignored-var))))
			       .,body)))))

(defun do-points-internal (points origin-x origin-y end-x end-y continuation)
  (let (point)
    (loop (setq point (pop points))
	  (when (null point)
	    (when (and end-x end-y)
	      (funcall continuation (+ end-x origin-x) (+ end-y origin-y) T))
	    (return nil))
	  (funcall continuation
		   (+ (point-x point) origin-x)
		   (+ (point-y point) origin-y)
		   (and (null points) (not (and end-x end-y)))))))
  

;;;___________________________________________________________________
;;;
;;;                        Virtual Dispels
;;;___________________________________________________________________
 
(defcontact virtual-dispel (foreground-color-mixin virtual-window basic-dispel)
  ())

(defmethod (setf foreground) :around (color (self virtual-dispel))
  (updating-virtual self
    (call-next-method)))

(defmethod (setf foreground) (color (self virtual-dispel))
  (let ((new-color nil))
    (assert (setf new-color (convert self color 'pixel))
	(color) "~s is no color name." color)
    (with-slots (foreground) self
      (setf foreground new-color))
    color))

(defmethod background ((self virtual-dispel))
  (with-slots (parent foreground) self
    (let ((bg (background parent)))
      (cond ((or (eq bg :none)
		 (pixmap-p bg))
	     (let ((white (convert self "white" 'pixel)))
	       (if (eq foreground white)
		   (convert self "black" 'pixel)
		   white)))
	    (t bg)))))

(defmethod (setf background) (color (self virtual-dispel))
  color)					; a noop

(defmethod clear :before ((self virtual-dispel) &key (x 0) (y 0) width height exposures-p)
  (declare (ignore x y width height exposures-p))
  (when (realized-p self)
    ;; turning mouse-feedback off before clearing a virtual's area ensures
    ;; that no pixels generated by mouse-feedback are left on the screen
    ;; (these pixels may be outside of virtual's enclosing region!).
    (with-slots (mouse-feedback-on?) self
      (when mouse-feedback-on?
	(show-mouse-feedback self)))))

(defmethod before-display ((self virtual-dispel) &optional x y w h)
  nil)

(defmethod after-display ((self virtual-dispel) &optional clip-mask)
  (declare (special *shading-mask*))
  (with-slots (x y inverse? shaded? width height foreground) self
    (when shaded?
      (using-gcontext (gc :drawable self
			  :clip-x x
			  :clip-y y
			  :clip-mask clip-mask
			  :foreground (background self)
			  :fill-style :stippled
			  :stipple *shading-mask*
			  ) 
	(draw-rectangle-inside self gc x y width height t)))
    (when inverse?
      (let ((mask  (logxor foreground (background self))))
	(using-gcontext (gc :drawable self
			    :clip-x x
			    :clip-y y
			    :clip-mask clip-mask
			    :function BOOLE-XOR
			    :foreground mask)
	  (draw-rectangle-inside self gc x y width height t))))))

(defmethod (setf inverse?) :before (value (self virtual-dispel))
   (declare (ignore value))
   (clear self))				; update is performed by an :after method

(defmethod (setf shaded?) :before (value (self virtual-dispel))
   (declare (ignore value))
   (clear self))				; update is performed by an :after method

(defmethod move ((self virtual-dispel) x y)
  (updating-virtual self
    (call-next-method)))

(defmethod resize ((self virtual-dispel) w h b)
  (updating-virtual self
    (call-next-method)))

(defmethod show-mouse-feedback ((self virtual-dispel) &optional clip-mask)
  (with-slots (x y width height foreground mouse-feedback-border-width) self
    (let ((mask (logxor foreground (background self))))
      (using-gcontext (gc :drawable self
			  :clip-x x
			  :clip-y y
			  :clip-mask clip-mask
			  :line-width  mouse-feedback-border-width
			  :function BOOLE-XOR
			  :foreground mask) 
	(case (mouse-feedback self)
	  (:border (draw-rectangle-inside self gc x y width height))
	  (:inverse (draw-rectangle-inside self gc x y width height t)))))))


;;;______________________
;;; 
;;; Virtual Text-Dispels
;;;______________________

(defcontact virtual-text-dispel (font-mixin virtual-dispel)
  ((name :initform :text)
   (text :type stringable :accessor text :initarg :text)
   (edit-value? :type boolean :initform nil :accessor edit-value?)
   (saved-text :type stringable :initform nil :accessor saved-text)
   )
  (:resources
   (text :initform ""))
  )


(defmethod (setf text) :around (string (self virtual-text-dispel))
  (updating-virtual self
     (prog1 (call-next-method)
       (adjust-window-size self))))

(defmethod (setf font) :around (font-spec (self virtual-text-dispel))
  (updating-virtual self
      (prog1 (call-next-method)
	(adjust-window-size self))))

(defmethod display-text ((self virtual-text-dispel) &rest gc-options
			 &key (foreground nil foreground-p)
			 (background nil background-p)
			 function fill-style stipple clip-mask)
  (with-slots (x y (own-foreground foreground) text font) self
      (using-gcontext (gc :drawable self
			  :font font
			  :foreground (if foreground-p foreground own-foreground)
			  :background (if background-p background (background self))
			  :function function
			  :fill-style fill-style
			  :stipple stipple
			  :clip-x x
			  :clip-y y
			  :clip-mask clip-mask
			  )
	(draw-glyphs self gc
		     (+ x (display-x-offset self))
		     (+ y (display-y-offset self) (max-char-ascent font))
		     text))))

(defmethod display ((self virtual-text-dispel) &optional x y w h &key)
  ;; take care to *always* clip output to dispel's boundaries
  (with-clip-mask (clip-mask self (or x 0) (or y 0) w h)
    (display-text self :clip-mask clip-mask)))

(defmethod after-display ((self virtual-text-dispel) &optional clip-mask)
  (declare (special *shading-mask*))
   (with-slots (x y inverse? shaded? foreground width height) self
     (when shaded?
       (display-text self
		     :clip-mask clip-mask
		     :foreground (background self)
		     :background nil
		     :fill-style :stippled
		     :stipple *shading-mask*))
     (when inverse?
       (let ((mask  (logxor foreground (background self))))
	 (using-gcontext (gc :drawable self
			     :clip-x x
			     :clip-y y
			     :clip-mask clip-mask
			     :function BOOLE-XOR
			     :foreground mask)
	   (draw-rectangle-inside self gc x y width height t)))))) 

;;; Note: if we had a basic-text-dispel 
;;;       that supplied all methods except
;;;       DISPLAY, (SETF FONT) and (SETF TEXT)
;;;       we could remove the methods below!

(defmethod display-width ((self virtual-text-dispel))
  (with-slots (text font) self
    (if (and text font)
      (+ (text-width font text) (x-margins self))
      (call-next-method))))

(defmethod display-height ((self virtual-text-dispel))
  (with-slots (font) self
    (if font
      (+ (text-height font) (y-margins self))
      (call-next-method))))

(defmethod edit-text ((self virtual-text-dispel))
  (with-accessors ((edit-value? edit-value?)) self
    (unless edit-value?
      (setf edit-value? t)
      (save-text self)
      (change-reactivity self :keyboard "Edit text"))))

(defmethod key-press ((self virtual-text-dispel) char)
  (when
    (characterp char)
    (case char
	(#\Rubout (delete-character self))
	((;#\Clear                         ;Symbolics only
	  #\Control-\k) (clear-text self))
	((;#\Abort                         ;Symbolics only
	  #\Control-\g) (reject-text self))
	((;#\Help                          ;Symbolics only
	  #\Control-\h)  (help self))
	((;\End                            ;Symbolics only
	  #\Return #\Linefeed) (accept-text self))
	(t (if (graphic-char-p char)
	       (add-character self char)
	       (reject-character self char))))))

(defmethod add-character ((self virtual-text-dispel) char &optional position)
  (declare (ignore position))
  (with-accessors ((text text)) self
	(setf text (concatenate 'string text (string char)))))

(defmethod delete-character ((self virtual-text-dispel) &optional position)
  (declare (ignore position))
  (with-accessors ((text text)) self
	(setf text (coerce (butlast (coerce text 'list)) 'string))))

(defmethod reject-character ((self virtual-text-dispel) char)
  (declare (ignore char))
  (flash-window self)
  )

(defmethod save-text ((self virtual-text-dispel))
  (setf (saved-text self) (text self)))

(defmethod clear-text ((self virtual-text-dispel))
  (setf (text self) ""))

(defmethod accept-text ((self virtual-text-dispel))
  (with-slots (edit-value?) self
    (when edit-value?
      (setf edit-value? nil)
      (change-reactivity self :keyboard :none)
      (send-part-event self))))

(defmethod reject-text ((self virtual-text-dispel))
  (with-accessors ((saved-text saved-text)) self
    (when saved-text
      (setf (text self) (saved-text self)))))

(defmethod help ((self virtual-text-dispel))
  )


;;;________________
;;; 
;;; Line Dispels
;;;________________
;;;
;;; A dispel that consists of one or more connected line segments (polyline). 
;;; Use SET-LINE-POINTS/SET-LINE-POINT-COORDINATES to specify 
;;; start- and end points and LINE-POINTS/LINE-POINT-COORDINATES 
;;; to get start- and end-points. 
;;; Use SET-LINE-INNER-POINTS to set inner points and LINE-INNER-POINTS
;;; to get the inner points.
;;; Inner- and end-points may be specified either relative to the 
;;; line's start-point (RELATIVE-P T) or relative to the parent's 
;;; window-origin (RELATIVE-P NIL). The start-point is always parent-relative.
;;;

(defcontact line-dispel (virtual-dispel)
  ((line-state :initform 0)	      ; used internally to represent the start-point location
   (line-width :initform 1
	       :initarg :line-width
	       :accessor line-width)
   (dashes :initform nil
	   :type (or null sequence card8 (member T))
	   :initarg :line-dashes
	   :accessor line-dashes
	   :documentation
	   "NIL: specifies line-style :solid,
            T: specifies line-style :on-off-dash,
            SEQUENCE or CARD8: dito, but also set the :dashes gcontext attribute.")
   (inner-points :initform nil                  ; inner points relative to the start point
		 :initarg :inner-points)
   (enclosing-region :type (or null region)	; a cache for lines enclosing region
		     :initform nil))
  (:documentation "a dispel that consists of one or more connected line segments.")
  )

(defmethod initialize-instance :after ((self line-dispel) &rest initargs
				       &key start end inner-points relative-p)
  (without-adjusting-size self
    (set-line-points self start end relative-p)
    (set-line-inner-points self inner-points relative-p))
  (validate-enclosing-region self))

(defmethod do-adjust-window-size ((self line-dispel))
  ;; adjusting size is done by point-manipulating methods below
  self)

(defmethod (setf line-width) :around (new-value (self line-dispel))
  (updating-virtual self
    (call-next-method (max 1 new-value) self)
    (adjust-window-size self)))			; enclosing-region may have changed!

(defmethod (setf line-dashes) :around (new-value (self line-dispel))
  (declare (ignore new-value))
  (updating-virtual self
    (call-next-method)))						

(defmethod line-points ((self line-dispel) &optional relative-p)
  (declare (values start-point end-point))
  (multiple-value-bind (s-x s-y e-x e-y)
      (line-point-coordinates self relative-p)
    (values (point s-x s-y)
	    (point e-x e-y))))

(defmethod set-line-points ((self line-dispel) &optional start end relative-p)
  (set-line-point-coordinates self
			      (and start (point-x start))
			      (and start (point-y start))
			      (and end (point-x end))
			      (and end (point-y end))
			      relative-p))

(defmethod line-point-coordinates ((self line-dispel) &optional relative-p)
  (declare (values start-x start-y end-x end-y))
  (with-slots (x y width height line-state) self
    (case line-state
      (0 (values x y				; start-point :upper-left
		 (if relative-p (1- width) (+ x width -1))
		 (if relative-p (1- height) (+ y height -1))))
      (1 (values (+ x width -1) y		; start-point :upper-right
		 (if relative-p (- 1 width) x)
		 (if relative-p (1- height) (+ y height -1))))
      (2 (values x (+ y height -1)		; start-point :lower-left
		 (if relative-p (1- width) (+ x width -1))
		 (if relative-p (- 1 height) y)))
      (3 (values (+ x width -1) (+ y height -1)	; start-point :lower-right
		 (if relative-p (- 1 width) x)
		 (if relative-p (- 1 height) y))))))

(defmethod set-line-point-coordinates ((self line-dispel)
				       &optional start-x start-y end-x end-y relative-p)
  (with-slots (x y width height line-state) self
    (multiple-value-bind (new-x new-y new-width new-height new-line-state)
	(multiple-value-bind (s-x s-y e-x e-y) (line-point-coordinates self)
	  (let* ((new-line-state 0)
		 (new-s-x (or start-x s-x))
		 (new-e-x (if end-x
			      (if relative-p
				  (+ new-s-x end-x)
				  end-x)
			      e-x))
		 (new-s-y (or start-y s-y))
		 (new-e-y (if end-y
			      (if relative-p
				  (+ new-s-y end-y)
				  end-y)
			      e-y))
		 (upper-x (if (> new-s-x new-e-x)
			      (progn (setf (ldb (byte 1 0) new-line-state) 1)
				     new-e-x)
			      (progn (setf (ldb (byte 1 0) new-line-state) 0)
				     new-s-x)))
		 (upper-y (if (> new-s-y new-e-y)
			      (progn (setf (ldb (byte 1 1) new-line-state) 1)
				     new-e-y)
			      (progn (setf (ldb (byte 1 1) new-line-state) 0)
				     new-s-y))))
	    (values upper-x upper-y
		    (- (max new-s-x new-e-x) upper-x -1)
		    (- (max new-s-y new-e-y) upper-y -1)
		    new-line-state)))
      (unless (and (= x new-x)
		   (= y new-y)
		   (= width new-width)
		   (= height new-height)
		   (= line-state new-line-state))
	(updating-virtual self
	  (setf line-state new-line-state)
	  (change-geometry self :x new-x :y new-y :width new-width :height new-height)
	  (adjust-window-size self))))))

;;; Note that INNER-POINTS should *not* be used any longer, because
;;; they may be modified destructively!
;;; 
(defmethod set-line-inner-points ((self line-dispel) &optional inner-points relative-p)
  (with-slots ((old-inner-points inner-points)) self
    (unless relative-p
      (multiple-value-bind (s-x s-y) (line-point-coordinates self)
	(dolist (pt inner-points)
	  (point-decr-xy pt s-x s-y))))
    (unless (equalp inner-points old-inner-points)
      (updating-virtual self
	(setf old-inner-points inner-points)
	;; trigger change-layout for parent (lines' enclosing-region changed)
	(adjust-window-size self)))
    ))

(defmethod line-inner-points ((self line-dispel) &optional relative-p (copy-p T))
  (with-slots (inner-points) self
    (if (and relative-p
	     (not copy-p))
	inner-points
	(multiple-value-bind (s-x s-y) (line-point-coordinates self)
	  (let ((points nil))
	    (do-points ((x y) inner-points
			(if relative-p 0 s-x)
			(if relative-p 0 s-y))
	      (push (point x y) points))
	    (nreverse points)))
	)))


;;;
;;; display methods
;;;

(defmethod display ((self line-dispel) &optional x y w h &key)
  (with-clip-mask (clip-mask self x y w h)
    (display-line self :clip-mask clip-mask)))

(defmethod after-display ((self line-dispel) &optional clip-mask)
  (declare (special *shading-mask*))
   (with-slots (inverse? shaded?) self
     (when shaded?
       (display-line self
		     :clip-mask clip-mask
		     :fill-style :stippled
		     :foreground (background self)
		     :background nil
		     :stipple *shading-mask*))
     (when inverse?
       (display-line self :clip-mask clip-mask :function BOOLE-XOR :extra-width 2))))

(defmethod show-mouse-feedback ((self line-dispel) &optional clip-mask)
  (with-slots (mouse-feedback-border-width foreground) self
    (case (mouse-feedback self)
      (:inverse
	(display-line self
		      :clip-mask clip-mask
		      :function BOOLE-XOR
		      :foreground (logxor foreground (background self))
		      :extra-width (+ mouse-feedback-border-width
				      mouse-feedback-border-width)))
      (:border
	(display-outline self :clip-mask clip-mask
			 :function BOOLE-XOR)))))

(defmethod display-line ((self line-dispel) &rest gc-options &key
			 (extra-width 0) (foreground nil foreground-p)
			 (background nil background-p)
			 function fill-style stipple clip-mask)
  (with-slots (x y inner-points line-width dashes (own-foreground foreground)) self
    (multiple-value-bind (start-x start-y end-x end-y) (line-point-coordinates self T)
      (using-gcontext (gc :drawable self
			  :clip-x x
			  :clip-y y
			  :clip-mask clip-mask
			  :function function
			  :line-width (+ line-width extra-width)
			  :foreground (if foreground-p foreground own-foreground) 
			  :background (if background-p background (background self))
			  :line-style (if dashes :dash :solid)
			  :dashes (if (eq dashes T) nil dashes)
			  :fill-style fill-style
			  :stipple stipple)
	(do-points ((x y) inner-points start-x start-y end-x end-y)
	  (draw-line self gc start-x start-y x y)
	  (setq start-x x
		start-y y))))))

(defmethod display-outline ((self line-dispel) &rest gc-options &key function clip-mask)
  (with-slots (x y inner-points line-width mouse-feedback-border-width foreground) self
    (let ((width (ceiling (+ line-width
			     mouse-feedback-border-width
			     mouse-feedback-border-width)
			  2)))
      (multiple-value-bind (start-x start-y end-x end-y) (line-point-coordinates self T)
	(using-gcontext (gc :drawable self
			    :clip-x x
			    :clip-y y
			    :clip-mask clip-mask
			    :function function
			    :line-width mouse-feedback-border-width
			    :foreground (logxor foreground (background self))
			    :background (background self))
	  (do-points ((x y) inner-points start-x start-y end-x end-y)
	    (draw-outline self gc start-x start-y x y width)
	    (setq start-x x
		  start-y y)))))))

(defmethod draw-outline ((self line-dispel) gcontext start-x start-y end-x end-y width)
  (let* ((dx (- end-x start-x))
	 (dy (- end-y start-y))
	 (angle (if (= 0 dx dy) #.(/ pi 4) (atan dy dx)))
	 (x-offset (round (* (sin angle) width)))
	 (y-offset (round (* (cos angle) width)))
	 first-x first-y)
    (using-point-vector (point-vector 10)
      (point-push (setq first-x (- start-x x-offset))
		  (setq first-y (+ start-y y-offset)))
      (point-push (+ start-x x-offset) (- start-y y-offset))
      (point-push (+ end-x x-offset) (- end-y y-offset))
      (point-push (- end-x x-offset) (+ end-y y-offset))
      (point-push first-x first-y)
      (draw-lines self gcontext point-vector))))


;;;
;;; Algorithm for point - line intersection
;;;

(defmacro square (value)
  (if (atom value)
      `(* ,value ,value)
      (let ((val (gensym)))
	`(let ((,val ,value))
	   (* ,val ,val)))))

(defun line-parameters (x1 y1 x2 y2)
  "Return the parameters of a line (ax+by+c=0)."
  (let ((a (- y2 y1))
	(b (- x1 x2)))
    (values a b (- (+ (* x1 a) (* y1 b))))))

(defun line-distance-from-origin-squared (x1 y1 x2 y2)
  "Compute the squared distance between origin [0,0] and line ([x1,y1] [x2,y2]).
   Returns NIL, if the normal line through origin doesn't intersect with line."
  (multiple-value-bind (a b c)			; ax + by + c = 0
      (line-parameters x1 y1 x2 y2)
    (cond ((zerop a)				; horizontal line
	   (when (<= (min x1 x2) 0 (max x1 x2))
	     (square y1)))
	  ((zerop b)				; vertical line
	   (when (<= (min y1 y2) 0 (max y1 y2))
	     (square x1)))
	  (t (let ((x (/ (- (* a c))	        ; normal-line bx - ay = 0
			 (+ (square a) (square b)))))
	       (when (<= (min x1 x2) x (max x1 x2))
		 (+ (square x)
		    (square (/ (* b x) a)))))))))

(defmethod inside-contact-p ((self line-dispel) x y)
  (with-slots ((v-x x) (v-y y) line-width inner-points) self
    (let ((aperture (square (/ (+ line-width 2) 2)))
	  distance)
      (multiple-value-bind (start-x start-y end-x end-y) (line-point-coordinates self T)
	(decf start-x v-x) (decf start-y v-y)
	(do-points ((line-x line-y) inner-points start-x start-y end-x end-y)
	  (setq distance
		(line-distance-from-origin-squared (- start-x x) (- start-y y)
						   (- line-x x) (- line-y y)))
	  (when (and distance (<= distance aperture))
	    (return-from inside-contact-p T))
	  (setq start-x line-x
		start-y line-y))
	nil))))

(defmethod enclosing-region ((self line-dispel) &optional parent-relative-p return-coords)
  (with-slots (x y enclosing-region) self
    (unless enclosing-region
      (validate-enclosing-region self))
    (let ((region enclosing-region))
      (if parent-relative-p
	  (funcall (if return-coords #'values #'region)
		   (+ x (region-x region)) (+ y (region-y region))
		   (region-w region) (region-h region))
	  (if return-coords
	      (values (region-x region) (region-y region)
		      (region-w region) (region-h region))
	      region)))))

;;; Computes the enclosing region for lines-dispels and
;;; fills the cache (x/y are relative to virtual's origin).
;;;
(defmethod validate-enclosing-region ((self line-dispel))
  (with-slots ((v-x x) (v-y y) enclosing-region inner-points) self
    (multiple-value-bind (s-x s-y e-x e-y) (line-point-coordinates self T)
      (decf s-x v-x) (decf s-y v-y)
      (let ((min-x s-x) (min-y s-y)
	    (max-x s-x) (max-y s-y)
	    (offset (enclosing-region-offset self)))
	(do-points ((x y) inner-points s-x s-y e-x e-y)
	  (setq min-x (min min-x x)
		min-y (min min-y y)
		max-x (max max-x x)
		max-y (max max-y y)))
	(setf enclosing-region
	      (region (- min-x offset)
		      (- min-y offset)
		      (+ (- max-x min-x) 1 offset offset)
		      (+ (- max-y min-y) 1 offset offset)))
	))))

(defmethod invalidate-enclosing-region ((self line-dispel))
  (with-slots (enclosing-region) self
    (setf enclosing-region nil)))

(defmethod do-adjust-window-size :before ((self line-dispel))
  (invalidate-enclosing-region self))

(defgeneric enclosing-region-offset (self)
  (:method-combination MAX)
  (:documentation
    "used to compute the maximum enclosing-region for SELF 
     based on SELF's X/Y coordinates."))

(defmethod enclosing-region-offset MAX ((self line-dispel))
  (with-slots (line-width) self
    (ceiling line-width 2)))

;;; ToDo: implement an IN-REGION-P method for lines that performs a 
;;;       more accurate test for line - region intersection than the default.

;;;
;;; Manipulating inner points interactively:
;;; 
;;; Use the functions 
;;;    MOVE-LINE-INNER-POINT-WITH-MOUSE
;;;    REMOVE-LINE-INNER-POINT-WITH-MOUSE
;;;    INSERT-LINE-INNER-POINT-WITH-MOUSE
;;; as actions in event translations.

(defmethod move-line-inner-point-with-mouse ((self line-dispel))
  ;; This method should be called as an action
  ;; which is part of an event translation.
  (with-event (x y)
    (multiple-value-bind (point before-point after-point)
	(find-line-inner-point self x y)
      (when point
	(let ((new (drag-inner-point-with-mouse self point before-point after-point)))
	  (when new
	    ;; destructively modify and update the inner point
	    (updating-virtual self		       
	      (setf (point-x point) (point-x new)
		    (point-y point) (point-y new))
	      (adjust-window-size self))))))))

(defmethod remove-line-inner-point-with-mouse ((self line-dispel))
  ;; This method should be called as an action
  ;; which is part of an event translation.
  (with-slots (inner-points) self
    (with-event (x y)
      (multiple-value-bind (point)
	  (find-line-inner-point self x y)
	(when point
	  ;; destructively modify and update the inner points list
	  (updating-virtual self		       
	    (setf inner-points (delete point inner-points))
	    (adjust-window-size self)))))))

(defmethod insert-line-inner-point-with-mouse ((self line-dispel))
  ;; This method should be called as an action
  ;; which is part of an event translation.
  (with-slots ((v-x x) (v-y y) inner-points) self
    (with-event (x y)
      (multiple-value-bind (point before-point after-point after?)
	  (find-line-inner-point self x y)
	(multiple-value-bind (start-x start-y end-x end-y)
	    (line-point-coordinates self t)
	  (multiple-value-setq (before-point after-point)
	    (if point
		(if after?
		    (values point after-point)
		    (values before-point point))
		(values (point 0 0) (point end-x end-y))))
	  (let ((new (drag-inner-point-with-mouse
		       self
		       (point (- x (- start-x v-x))
			      (- y (- start-y v-y)))
		       before-point
		       after-point))
		inner-rest)
	    (when new
	      ;; insert new point after before-point in the inner-points list
	      (setq inner-rest (member before-point inner-points))
	      (updating-virtual self		       
		(if (not inner-rest)	       
		    (push new inner-points)
		    (setf (cdr inner-rest)
			  (cons new (cdr inner-rest))))
		(adjust-window-size self)))))))))

(defmethod find-line-inner-point ((self line-dispel) x y)
  ;; returns an inner-point [px,py] that is near [x,y] (in contact coordinates)
  ;; together with its neighbor points [bx,by] and [ax,ay]
  ;; and a boolean that is T if the line segment that contains [x,y]
  ;; runs from [px,py] to [ax,ay] and NIL if the segment runs from
  ;; [bx,by] to [px,py].
  ;; The method returns NIL if no inner point could be found.
  ;; Note that [px,py], [bx,by] and [ax,ay] are specified relative
  ;; to lines' start-point.
  
  (with-slots ((v-x x) (v-y y) line-width inner-points) self
      (let* ((aperture (square (/ (+ line-width 2) 2)))
	     (before-rest (list* nil nil inner-points))
	     distance start-x start-y)
	(multiple-value-bind (start end) (line-points self T)
	  (point-decr-xy start v-x v-y)
	  (setq start-x (point-x start)
		start-y (point-y start))
	  (do-points ((line-x line-y) inner-points start-x start-y
		      (point-x end) (point-y end))
	    (setq distance
		  (line-distance-from-origin-squared
		    (- start-x x) (- start-y y)
		    (- line-x x) (- line-y y)))
	    (when (and distance (<= distance aperture))
	      ;; found a line segment that contains [x,y] 
	      (return-from find-line-inner-point
		(cond ((null (second before-rest))        ; on first line segment
		       (values (third before-rest)
			       (point 0 0)
			       (or (fourth before-rest) end)
			       nil))
		      ((null (third before-rest))	  ; on last line segment
		       (values (second before-rest)
			       (or (first before-rest) (point 0 0))
			       end
			       T))
		      ((< (+ (square (- x start-x))
			     (square (- y start-y)))
			  (+ (square (- x line-x))
			     (square (- y line-y))))
		       (values (second before-rest)
			       (or (first before-rest) (point 0 0))
			       (third before-rest)
			       T))
		      (t 
		       (values (third before-rest)
			       (second before-rest)
			       (or (fourth before-rest) end)
			       nil)))))
	    (pop before-rest)
	    (setq start-x line-x
		  start-y line-y))
	  nil))))

(defmethod drag-inner-point-with-mouse ((self line-dispel) point before-point after-point)
  ;; Returns new-point (relative to start point!) or NIL if not successfull.
  ;; point, before-point and after-point must be specified relative to lines'
  ;; start-point.
  (with-slots (display foreground parent) self
    (using-gcontext (gc :drawable self
			:function BOOLE-XOR
			:foreground (logxor foreground (background self))
			:line-width 1)
      (multiple-value-bind (start-x start-y) (line-point-coordinates self)
	(let* ((bx (+ (point-x before-point) start-x))
	       (by (+ (point-y before-point) start-y))
	       (ax (+ (point-x after-point) start-x))
	       (ay (+ (point-y after-point) start-y))
	       (px (+ (point-x point) start-x))
	       (py (+ (point-y point) start-y)))
	  (warp-pointer parent px py)
	  (cond ((eq :success
		     (grab-pointer self
				   '(:button-press :pointer-motion) 
				   :owner-p t
				   :confine-to self
				   :sync-pointer-p t
				   :cursor (convert self "tcross" 'cursor)
				   :time nil))
		 (draw-line self gc bx by px py)
		 (draw-line self gc ax ay px py)
		 (with-mouse-documentation
		     ("Press any button to specify new point.  ~
                       Press any key to abort.")
		   (catch 'abort
		     (unwind-protect
			 (progn
			   (allow-events display :async-pointer)
			   (event-case (display :discard-p t :force-output-p t)
			     (motion-notify (x y event-window)
					    (draw-line self gc bx by px py)
					    (draw-line self gc ax ay px py)
					    (multiple-value-setq (px py)
					      (contact-translate event-window x y parent))
					    (draw-line self gc bx by px py)
					    (draw-line self gc ax ay px py)
					    nil)
			     (key-press ()
					(draw-line self gc bx by px py)
					(draw-line self gc ax ay px py)
					(throw 'abort nil))
			     (button-press ()
					   (draw-line self gc bx by px py)
					   (draw-line self gc ax ay px py)
					   t)))
		       (ungrab-pointer display))
		     (values (point (- px start-x) (- py start-y))))))
		(t
		 (ungrab-pointer display)
		 nil)))))))


;;;________________
;;; 
;;;  Arrow Dispels
;;;________________

(defcontact arrow-dispel (line-dispel)
  ((arrow-position :type (member :start :end :both)
		   :initform :end
		   :initarg :arrow-position
		   :accessor arrow-position)
   (arrow-head-length :type integer
		      :initform 6
		      :allocation :class
		      :documentation
		      "Length of the arrowhead for an arrow shaft thickness of 1.
                       The actual arrow head length is a function of the thickness of the
                       arrow shaft, specified by ARROW-SIZES."
		      )
   (arrow-base-width :type integer
		     :initform 6
		     :allocation :class
		     :documentation
		     "Width of the arrowbase for an arrow shaft thickness of 1.
                      The actual arrow base length is a function of the thickness of the
                      arrow shaft, specified by ARROW-SIZES."
		     ))
  (:documentation "a line-dispel with arrowheads at its starting or ending points."))

(defmethod (setf arrow-position) :around (new-pos (self arrow-dispel))
  (declare (ignore new-pos))
  (updating-virtual self
    (call-next-method)))

(defmethod enclosing-region-offset MAX ((self arrow-dispel))
  ;; formerly:  (ceiling (* 2 (arrow-sizes self)))
  (ceiling (arrow-sizes self)))

;;; displaying arrows
;;;
(defmethod display-line ((self arrow-dispel) &rest gc-options &key 
			 (extra-width 0) (foreground nil foreground-p)
			 (background nil background-p)
			 function fill-style stipple clip-mask)
  (with-slots ((cx x) (cy y) inner-points arrow-position dashes line-width
	       (own-foreground foreground)) self
    (multiple-value-bind (start-x start-y end-x end-y) (line-point-coordinates self T)
      (let ((first? T))
	(using-gcontext (gc :drawable self
			    :clip-x cx
			    :clip-y cy
			    :clip-mask clip-mask
			    :function function
			    :line-width (+ line-width extra-width)
			    :foreground (if foreground-p foreground own-foreground)
			    :background (if background-p background (background self))
			    :line-style (if dashes :dash :solid)
			    :dashes (if (eq dashes T) nil dashes)
			    :fill-style fill-style
			    :stipple stipple)
	  (do-points ((x y) inner-points start-x start-y end-x end-y last?)
	    (if first?
		(if last?			; no inner points
		    (draw-arrow self gc start-x start-y x y extra-width arrow-position)
		    (progn
		      (if (eq arrow-position :end)
			  (draw-line self gc start-x start-y x y)
			  (draw-arrow self gc start-x start-y x y extra-width :start))
		      (setq first? nil)))
		(if last?
		    (if (eq arrow-position :start)
			(draw-line self gc start-x start-y x y)
			(draw-arrow self gc start-x start-y x y extra-width :end))
		    (draw-line self gc start-x start-y x y)))
	    (setq start-x x
		  start-y y)))))))

(defmethod display-outline ((self arrow-dispel) &rest gc-options &key function clip-mask)
  (with-slots ((cx x) (cy y) inner-points arrow-position dashes line-width mouse-feedback-border-width
	       foreground) self
    (let ((first? T)
	  (width (ceiling (+ line-width
			     mouse-feedback-border-width
			     mouse-feedback-border-width)
			  2)))
      (multiple-value-bind (start-x start-y end-x end-y) (line-point-coordinates self T)
	(using-gcontext (gc :drawable self
			    :clip-x cx
			    :clip-y cy
			    :clip-mask clip-mask
			    :function function
			    :line-width mouse-feedback-border-width
			    :foreground (logxor foreground (background self))
			    :background (background self))
	  (do-points ((x y) inner-points start-x start-y end-x end-y last?)
	    (if first?
		(if last?			; no inner points
		    (draw-arrow-outline self gc start-x start-y x y width arrow-position)
		    (progn
		      (if (eq arrow-position :end)
			  (draw-outline self gc start-x start-y x y width)
			  (draw-arrow-outline self gc start-x start-y x y width :start))
		      (setq first? nil)))
		(if last?
		    (if (eq arrow-position :start)
			(draw-outline self gc start-x start-y x y width)
			(draw-arrow-outline self gc start-x start-y x y width :end))
		    (draw-outline self gc start-x start-y x y width)))
	    (setq start-x x
		  start-y y)))))))


;;; Computing arrow's geometry:
;;; The arrow head length is proportional to the thickness of the 
;;; arrow shaft according to the following formula:
;;;  arrow-head-length(thickness) = arrow-head-length(1) + 2*(thickness-1)
;;; The arrow base width is proportional to the thickness of the 
;;; arrow shaft according to the following formula:
;;;  arrow-base-width(thickness) = arrow-base-width(1) + 2*(thickness-1).
;;;
(defmethod arrow-sizes ((self arrow-dispel) &optional (extra-width 0))
  (declare (values actual-arrow-base-half-width actual-arrow-head-length))
  (with-slots (line-width arrow-base-width arrow-head-length) self
    (values (+ (/ (+ arrow-base-width (* 2 (1- line-width))) 2) extra-width)
	    (+ arrow-head-length (* 2 (1- line-width))))))

;;; drawing arrows
;;;
(defmethod draw-arrow ((self arrow-dispel) gcontext
		       start-x start-y end-x end-y extra-width arrow-position)
  (let ((dx (- end-x start-x))
	(dy (- end-y start-y)))
    (unless (= 0 dx dy)			       ; dont draw anything for a single point
      (multiple-value-bind (base head) (arrow-sizes self extra-width)
	(let* ((angle (atan dy dx))
	       (cos (cos angle))
	       (sin (sin angle))
	       (max-head (sqrt (+ (* dx dx) (* dy dy))))
	       bsin bcos hsin hcos 
	       (new-start-x start-x)
	       (new-end-x end-x)
	       (new-start-y start-y)
	       (new-end-y end-y))
	  ;; restrict head and base of arrows to line-length
	  (when (> head max-head)
	    (setf base (* base (/ max-head head))
		  head max-head))
	  (setf hsin (round (* head sin))
		hcos (round (* head cos))
		bsin (round (* base sin))
		bcos (round (* base cos)))
	  ;; draw starting arrow
	  (unless (eq arrow-position :end)
	    (incf new-start-x hcos)
	    (incf new-start-y hsin)
	    (using-point-vector (v 8)
	      (point-push start-x start-y)
	      (point-push (- new-start-x bsin) (+ new-start-y bcos))
	      (point-push (+ new-start-x bsin) (- new-start-y bcos))
	      (point-push start-x start-y)
	      (draw-lines self gcontext v :fill-p t :shape :convex)))
	  ;; draw ending arrow
	  (unless (eq arrow-position :start)
	    (decf new-end-x hcos)
	    (decf new-end-y hsin)
	    (using-point-vector (v 8)
	      (point-push end-x end-y)
	      (point-push (- new-end-x bsin) (+ new-end-y bcos))
	      (point-push (+ new-end-x bsin) (- new-end-y bcos))
	      (point-push end-x end-y)
	      (draw-lines self gcontext v :fill-p t :shape :convex)))
	  ;; draw line inbetween
	  (draw-line self gcontext new-start-x new-start-y new-end-x new-end-y))))))

(defmethod draw-arrow-outline ((self arrow-dispel) gcontext
			       start-x start-y end-x end-y width arrow-position)
  (multiple-value-bind (base head) (arrow-sizes self)
    (let* ((dx (- end-x start-x))
	   (dy (- end-y start-y))
	   (angle (if (= 0 dx dy) #.(/ pi 4) (atan dy dx)))
	   (cos (cos angle))
	   (sin (sin angle))
	   (max-head (sqrt (+ (* dx dx) (* dy dy))))
	   bsin bcos hsin hcos
	   (x-offset (round (* sin width)))
	   (y-offset (round (* cos width)))
	   first-x first-y
	   (new-start-x start-x)
	   (new-end-x end-x)
	   (new-start-y start-y)
	   (new-end-y end-y))
      ;; restrict head and base of arrows to line-length
      (when (> head max-head)
	(setf base (* base (/ max-head head))
	      head max-head))
      (setf hsin (round (* head sin))
	    hcos (round (* head cos))
	    bsin (round (* base sin))
	    bcos (round (* base cos)))
      (using-point-vector (v)
	;; outline arrows and line
	(unless (eq arrow-position :end)
	  (incf new-start-x hcos)
	  (incf new-start-y hsin))
	(point-push (setq first-x (- new-start-x x-offset))
		    (setq first-y (+ new-start-y y-offset)))
	(unless (eq arrow-position :end)
	  (point-push (- new-start-x bsin) (+ new-start-y bcos))
	  (point-push start-x start-y)
	  (point-push (+ new-start-x bsin) (- new-start-y bcos)))
	(point-push (+ new-start-x x-offset) (- new-start-y y-offset))
	(unless (eq arrow-position :start)
	  (decf new-end-x hcos)
	  (decf new-end-y hsin))
	(point-push (+ new-end-x x-offset) (- new-end-y y-offset))
	(unless (eq arrow-position :start)
	  (point-push (- new-end-x bsin) (+ new-end-y bcos))
	  (point-push end-x end-y)
	  (point-push (+ new-end-x bsin) (- new-end-y bcos)))
	(point-push (- new-end-x x-offset) (+ new-end-y y-offset))
	(point-push first-x first-y)
	(draw-lines self gcontext v)))))


#||
(defmethod draw-wire ((self arrow-dispel) gc parent region mask dx dy)
  (with-slots ((cx x) (cy y) inner-points arrow-position dashes line-width mouse-feedback-border-width
	       foreground) self
    (let ((first? T)
	  (width (ceiling (+ line-width
			     mouse-feedback-border-width
			     mouse-feedback-border-width)
			  2)))
      (multiple-value-bind (start-x start-y end-x end-y) (line-point-coordinates self T)
	(do-points ((x y) inner-points start-x start-y end-x end-y last?)
	    (if first?
		(if last?			; no inner points
		    (draw-arrow-outline self gc (+ dx start-x)
					(+ dy start-y) (+ dx x)(+ dy  y) width arrow-position)
		    (progn
		      (if (eq arrow-position :end)
			  (draw-outline self gc (+ dx start-x)
					(+ dy start-y) (+ dx x)(+ dy  y) width)
			  (draw-arrow-outline self gc (+ dx start-x)
					(+ dy start-y) (+ dx x)(+ dy  y) width :start))
		      (setq first? nil)))
		(if last?
		    (if (eq arrow-position :start)
			(draw-outline self gc (+ dx start-x)
					(+ dy start-y) (+ dx x)(+ dy  y) width)
			(draw-arrow-outline self gc (+ dx start-x)
					(+ dy start-y) (+ dx x)(+ dy  y)  width :end))
		    (draw-outline self gc (+ dx start-x)
					(+ dy start-y) (+ dx x)(+ dy  y) width)))
	    (setq start-x x
		  start-y y))))))
||#


;;;________________________
;;; 
;;; Labelled-Line Dispels
;;;________________________

(defcontact labelled-line-dispel (line-dispel virtual-text-dispel)
  ((font-defaults :allocation :class :initform '(:size :tiny)))
  (:documentation "a line-dispel with a text-label"))

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

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

(defmethod enclosing-region-offset MAX ((self labelled-line-dispel))
  (with-slots (x y width height) self
    (let ((x-off (display-x-offset self))
	  (y-off (display-y-offset self)))
      (max (abs (min 0 x-off))
	   (max 0 (- (+ x-off (display-width self)) width))
	   (abs (min 0 y-off))
	   (max 0 (- (+ y-off (display-height self)) height))))))

(defmethod display-line :after ((self labelled-line-dispel) &rest gc-options &key
				(extra-width 0 ew-supplied-p)
				(foreground nil foreground-p)
				(background nil background-p)
				function fill-style stipple
				clip-mask)
  (with-slots (x y text font (own-foreground foreground)) self
    (using-gcontext (gc :drawable self
			:clip-x x
			:clip-y y
			:clip-mask clip-mask
			:font font
			:foreground (if foreground-p foreground own-foreground)
			:background (if background-p background (background self))
			:function function
			:fill-style fill-style
			:stipple stipple)
      (if ew-supplied-p				; :inverse mouse-feedback
	  (draw-rectangle-inside self gc
				 (+ x (display-x-offset self))
				 (+ y (display-y-offset self))
				 (display-width self)
				 (display-height self)
				 T)
	  (funcall (if stipple #'draw-glyphs #'draw-image-glyphs)
		   self gc
		   (+ x (display-x-offset self))
		   (+ y (display-y-offset self) (max-char-ascent font))
		   text)))))

(defmethod display-outline :after ((self labelled-line-dispel) &rest gc-options &key function clip-mask)
  (with-slots (x y mouse-feedback-border-width foreground) self
    (using-gcontext (gc :drawable self
			:clip-x x
			:clip-y y
			:clip-mask clip-mask
			:line-width mouse-feedback-border-width
			:foreground (logxor foreground (background self))
			:background (background self)
			:function function)
      (draw-rectangle-inside self gc
			     (+ x (display-x-offset self))
			     (+ y (display-y-offset self))
			     (display-width self)
			     (display-height self)))))

(defmethod inside-contact-p ((self labelled-line-dispel) x y)
  (let ((x-off (display-x-offset self))
	(y-off (display-y-offset self)))
    (or (and (<= x-off x)
	     (< x (+ x-off (display-width self)))
	     (<= y-off y)
	     (< y (+ y-off (display-height self))))
	(call-next-method))))


;;;________________________
;;; 
;;; Labelled-Arrow Dispels
;;;________________________

(defcontact labelled-arrow-dispel (arrow-dispel labelled-line-dispel)
  ()
  (:documentation "an arrow-dispel with a text-label"))

