;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Interaction-Window
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/interaction-window.lisp
;;; File Creation Date: 6/23/89 10:31:37
;;; Last Modification Time: 12/11/92 16:20:36
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;; 5/8/90 (Juergen)   Slots mouse-documentation and compute-mouse-documentation?
;;;                    added to interaction-window
;;; 
;;; 5/8/90 (Juergen)   reactivity entries optionally have a mouse documentation
;;;                    string; the new form for reactivity entires is:
;;;                    (<event-spec> {mouse-docu-string} <action1> <action2> ...)
;;; 5/14/90 (Juergen)  mouse-reactivity is additionaly set if 
;;;                    compute-mouse-documentation? is not :never or
;;;                    mouse-documentation is not nil
;;; 7/27/90 (Hubertus) changed initarg for interaction-window's selected? slot
;;;                    form selected? to :selected?
;;;
;;; 9/17/90 (Juergen)  new keyword :part-of introduced for "call"-actions to
;;;                    perform actions on the part-of (i.e. the parent) of an
;;;                    interaction-window (cf. new function send-part-of).
;;;                    :part-of is to be used instead of :parent, which may be
;;;                    removed in future versions.
;;;
;;; 9/24/90 (Juergen)  Initarg :reactivity for class interaction-window has been
;;;                    changed to specify incremental reactivity, i.e. it extents
;;;                    (not substitutes) the default reactivity given by the initform
;;;                    in the class definition.
;;;                    Entries in the initarg overwrite entries with same event 
;;;                    specification in the initform.
;;;                    Entries of the initform may be removed by specifying the action 
;;;                    :none.
;;;
;;; 11/5/90 (Juergen)  Bug in button-event-handling removed;
;;;                    method change-reactivity has been changed.
;;;
;;; 11/6/90 (Juergen)  update for graphical-feedback-windows specialized;
;;;                    clear-area has been removed, since it is automatically
;;;                    sent after display
;;;
;;; 11/12/90 (Matthias) redone last change by Juergen
;;;
;;; 11/14/1990 (Juergen) subst-and-eval-callback changed to
;;;   subst-and-perform-callback
;;;
;;; 11/27/1990 (Juergen) Instead of perform-callback new method
;;;   send-callback is used which does not "eval" the actions but creates a
;;;   lambda from the actions and funcalls it.  Thus, the local bindings for 
;;;   *contact*, *part*, and *part-value* can be used within the acions, which
;;;   so far has been implemented using global variable bindings.
;;;   Assure that the first element of each actions is always a function name!
;;;   Thus *part-value* is no valid action, whereas (funcall *part-value*) or
;;;   (eval *part-value*) are.  
;;;   Actions like (eval ...) make global bindings accessible.
;;;
;;; 11/27/1990 (Juergen) Old callbacks are now removed when the
;;;   reactivity for an event type changes.  This has been a bug.
;;;   
;;; 11/27/1990 (Juergen) There are two new types of (XIT-)Events
;;;    which should be used to assure that the state of the interaction object
;;;    and the state of the application are consistent:
;;;    :write-event  specifies the characteristic action(s) of the
;;;                  interaction object for the application,
;;;                  i.e. how the application should change when the interaction
;;;                  object changes
;;;    :read-event   specifie show the appearance of the interaction
;;;                  object depends on the application,
;;;                  i.e. how the interaction object should change when 
;;;                  the application changes
;;;    The corresponding actions are performed by the methods
;;;    write-to-application or read-from-application.
;;;    The new slot read-back? of class interaction-window specifies whether a 
;;;    read-from-application automatically follows each write-to-application.
;;;    write- and read-events should be used for interaction objects which
;;;    represent an internal state, e.g. single- or multiple-choice-menus,
;;;    switches, forms, property sheets etc., usually in combination with
;;;    part-events.
;;;    The state of of an interaction object can be requested via the 
;;;    method identification, it can be set by the corresponding setf-method.
;;;
;;; 11/27/1990 (Juergen)  There are new types of predefined action
;;;   descriptions of the form (call <keyword> ...args...) with the following
;;;   keywords:
;;;     :write               performs a write-to-application
;;;     :read                performs a read-from-application
;;;     :part-event          sends a part-event specified by the args
;;;     :pass-part-event     passes a part event upwards in the part-of hierarchy
;;;     :process-part-event  initiated by a :part-event performs a 
;;;                          write-to-application for the corresponding part
;;;     :popup-part          performs a select-from-popup-part
;;;     :move                performs a move-window
;;;     :totop               performs a totop-window
;;;
;;; 12/04/1990 (Juergen)     change-reactivity has been changed to
;;;   add new events to the end of the reactivity list.  This fixes problems
;;;   with obligatory order of button events (single-button events have to
;;;   be specified before double-button events).
;;;
;;; 01/29/1991 (Juergen) single-button events no longer have to be specified
;;;                      before double-button events.  This is a CLUE problem
;;;                      which has been fixed for XIT.
;;; 
;;;
;;; 01/29/1991 (Juergen) New event-specifications for button clicks with
;;;                      shift key pressed:
;;;                      :shift-left-button, :shift-middle-button, 
;;;                      :shift-right-button
;;;
;;; 01/30/1991 (Juergen) Changing the slots sensitive and selected? does not
;;;                      directly trigger the change of the shaded? and 
;;;                      inverse? slots.  Instead a method is called which
;;;                      triggers the change.  This method may be redefined
;;;                      by subclasses.
;;;
;;; 01/31/1991 (Juergen) Before an interaction-window is unmapped the 
;;;                      mouse-feedback is turned of.  This has to be done
;;;                      when the mouse-feedback draws into subwindows
;;;                      specifying backing-store.
;;;
;;; 02/07/1991 (Juergen) Init option :reactivity changed to :reactivity-entries
;;;                      since it incrementally specifies reactivity entries.
;;;                      :reactivity is a valid initarg again, which overrides
;;;                      the initform.
;;;                      In most cases, however, :reactivity-entries is used.
;;;
;;; 10/02/1991 (Hubertus) Added macro facility DEFINE-CALL-ACTION for defining 
;;;                       new call types and actions.
;;;                       Optimized callback facility.
;;;
;;; 10/07/1991 (Hubertus) Added macro facility DEFINE-EVENT-KEY for defining
;;;                       new mappings from XIT event-keys onto CLUE event 
;;;                       specifications.
;;;
;;; 12/03/1991 (Juergen)  New method (setf reactivity-documentation-for)
;;;
;;; 12/03/1991 (Juergen)  define-event-key has got a new key argument
;;;                       :default-mouse-documentation.
;;;
;;; 04/02/1992 (Juergen)  callbacks are now removed whenever change-reactivity
;;;                       is called.  Formerly, this has been performed
;;;                       by transform-actions, which is only invoked for
;;;                       "call" actions and, for example, not if :none
;;;                       is specified.
;;;
;;; 04/09/1992 (Juergen)  New optional argument for method part-of which has
;;;                       to be a non-negative integer.  It specifies how many
;;;                       steps to move up in the part-of hierarchy.  Default
;;;                       is 1.
;;;
;;; 04/16/1992 (Juergen)  New action (call :synchronize-event <value>), which
;;;                       calls send-synchronize-event.
;;;
;;; 05/22/1992 (Juergen)  New logical event keys :select, :move, :menu
;;;                       with default actions totop-window, move-window,
;;;                       select-from-popup-part.  They should be used 
;;;                       instead of physical event keys.
;;; 06/12/1992 (Hubertus) New logical event key :edit with default action edit-text.
;;;
;;; 06/17/1992 (Hubertus) moved macro definitions DEFINE-CALL-ACTION and 
;;;                       DEFINE-EVENT-KEY to macros.lisp.
;;;
;;; 07/16/1992 (Juergen)  (call :self ...) and *self* should be used instead
;;;                       (call :contact ...) and *contact* respectively.
;;;                       The old notation is kept for backward compatibility
;;;                       reasons, but may be removed in future releases.
;;;
;;; 07/24/1992 (Juergen)  interaction-window now mixes in class application-mixin
;;;                       which in addition to class view also provides
;;;                       an interface for connecting interaction and
;;;                       application objects via read and write functions and
;;;                       transformations formerly only provided by
;;;                       property-sheet entries.  For more details see
;;;                       comments in file application-connection.
;;;
;;;                       In general, this is an extension to the previous
;;;                       interface.  However, there is a slight incompatibility
;;;                       to previous releases.  Instead of calling
;;;                       identification and (setf identification) to access
;;;                       the characteristic value of an interaction object, 
;;;                       the functions value or (setf value) are to be used, 
;;;                       which apply a transformation to the identification.
;;;                       This is obligatory for property-sheet-entries, where
;;;                       the transformation formerly was included in the 
;;;                       identification.  This makes the whole thing cleaner.
;;;_____________________________________________________________________________

(in-package :xit)

;_______________________________________________________________________________

;(defparameter *contact* nil)    ; should be removed in future?
;(defparameter *part* nil)       ; should be removed in future?
;(defparameter *part-value* nil) ; should be removed in future?

;;;
;;; CLUE Callback Modifications
;;;

;;; equal to add-callback without deleting callback functions with the same name
;;; Note: the items for the named callback are canonicalized function objects 
;;; with a lambda-list of three arguments (*self* *part* *part-value*).
;;;
(defun add-new-callback (contact name function)
  "Associate CONTACT callback NAME with the given FUNCTION."
  (with-slots (callbacks) contact
    (let ((functions (assoc name callbacks :test #'eq)))
      (if functions
	  ;; Append behind any previous functions for this callback
	  (rplacd functions (nconc (rest functions)
				   (list function)))
	  ;; Else add first callback function
	  (push (list name function) callbacks))
      name)))

;;; modified version of perform-callback, which did not work with
;;; macro actions (e.g. (setf ...)), without arguments
;;;
(defmethod send-callback ((self basic-window) name
			  &optional (part nil) (part-value nil))
  (let ((functions (callback-p self name)))
    (when functions
      (catch :abort-callback
	(do* ((functions functions         (rest functions))
	      (function  (first functions) (first functions))
	      (value))
	    ((null functions)
	     ;; Return value(s) of last callback function
	     value)
	  (setq value (funcall function self part part-value)))))))


;____________________________________________________________________________
;
;                           Graphical Feedback Window
;____________________________________________________________________________

;;; 11/22/1990 (Matthias) was: (defvar *shading-bitmap* 50%GRAY)
;;; now in general.lisp

(defcontact graphical-feedback-window (basic-window)
  ((inverse?  :type boolean
	      :initform nil
	      :accessor inverse?
	      :initarg :inverse?)
   (shaded?   :type boolean
	      :initform nil
	      :accessor shaded?
	      :initarg :shaded?))
  (:documentation "Abstract class providing the properties for
                   inverting and shading windows"))

(defmethod initialize-instance :after ((self graphical-feedback-window)
				       &rest init-list)
   (declare (ignore init-list))
   (with-slots (sensitive shaded?) self
     (when (eq sensitive :off)
       (sensitivity-changed self))))

(defmethod display :before ((self graphical-feedback-window) &optional x y w h &key)
  (before-display self x y w h))

(defmethod before-display ((self graphical-feedback-window) &optional x y w h)
  ;; 04/29/1991 (Hubertus) You can't rely on exposure-regions to be cleared
  ;; when DISPLAY is called to process exposure events. This is due to the
  ;; fact that the server may perform additional graphics operations
  ;; after  the exposure event has been sent and before  this event is
  ;; actually processed by the client. A typical example for this is the
  ;; ADJUST-WINDOW-SIZE -- UPDATE sequence performed after changing text-dispel
  ;; contents.
  (clear-area self :x (or x 0) :y (or y 0) :width w :height h))

(defmethod display :after ((self graphical-feedback-window) &optional x y w h &key)
  (with-clip-mask (clip-mask self x y w h)
    (after-display self clip-mask)))

;;; 11/22/1990 (Matthias) 
;;; shading is done by drawing a stippled pattern (background color) over the
;;; foreground color (the text etc. or the inverse of the text if inverse? = t)

(defmethod after-display ((self graphical-feedback-window) &optional clip-mask)
   (declare (special *white-pixel* *inversion-pixel* *shading-mask*))
   (with-slots (inverse? shaded? width height) self
     (when inverse?
       (using-gcontext (gc :drawable self
			   :clip-mask clip-mask
			   :function BOOLE-XOR
			   :foreground *inversion-pixel*
			   :subwindow-mode :include-inferiors) 
		       (draw-rectangle-inside self gc 0 0 width height t)))
     (when shaded?
       (using-gcontext (gc :drawable self
			   :clip-mask clip-mask			  
			   :foreground *white-pixel*
			   :subwindow-mode :include-inferiors
			   :fill-style :stippled
			   :stipple *shading-mask*
			   ) 
		       (draw-rectangle-inside self gc 0 0 width height t)))))

(defmethod (setf inverse?) :after (value (self graphical-feedback-window))
  (declare (ignore value))
  (update self))

(defmethod (setf shaded?) :after (value (self graphical-feedback-window))
   (declare (ignore value))
   (update self))

(defmethod (setf contact-sensitive) :after (value
					    (self graphical-feedback-window))
   (declare (ignore value))
   (sensitivity-changed self))


(defmethod sensitivity-changed ((self graphical-feedback-window))
   ;; may be redefined in subclasses
   (with-accessors ((sensitive contact-sensitive) (shaded? shaded?)) self
     (if (eq sensitive :on)
	 (when shaded?   (setf shaded? nil))
	 (unless shaded? (setf shaded? t)))))


;_______________________________________________________________________________
;
;                             Interaction Window
;_______________________________________________________________________________

(defcontact interaction-window (application-mixin timer-mixin
				graphical-feedback-window)
  ((reactivity :initform nil :reader reactivity :initarg :reactivity)
   (mouse-feedback :type (member :none :border :inverse)
		   :initform :none
		   :accessor mouse-feedback
		   :initarg :mouse-feedback)
   (mouse-feedback-on? :type boolean
		       :initform nil)
   (mouse-feedback-border-width :type integer
				:initform 1
				:allocation :class)
   (mouse-documentation :type (or null stringable)
			:initform nil
			:initarg :mouse-documentation)
   (compute-mouse-documentation? :type (member :never :if-needed :always)
				 :initform :if-needed
				 :accessor compute-mouse-documentation?
				 :initarg :compute-mouse-documentation?)
   (selected? :type boolean :initform nil
	      :accessor selected? :initarg :selected?)
   (read-back? :type boolean :initform nil
	       :accessor read-back? :initarg :read-back?))
  (:documentation "Abstract class providing the functionality for
                   interaction objects of having a reactivity,
                   a mouse-feedback, and a mouse documentation,
                   or being selected"))

(defmethod initialize-instance :after ((self interaction-window)
				       &rest init-list
				       &key reactivity-entries)
  (declare (ignore init-list))
  (with-slots (reactivity mouse-feedback 
	       mouse-documentation compute-mouse-documentation?
	       selected? inverse?) self
    (let ((react (append reactivity reactivity-entries)))
      (setf reactivity nil)
      (dolist (entry react)
	(apply #'change-reactivity self (if (listp entry)
					    entry
					  (list entry))))
      (unless (assoc :mouse react)
	(unless (and (eq mouse-feedback :none)
		     (eq compute-mouse-documentation? :never)
		     (null mouse-documentation))
	  (change-reactivity self :mouse))))
    (when selected? ;(setf inverse? t)
      (selection-changed self))))

(defmethod part-of ((self interaction-window) &optional (n 1))
  (with-slots (parent) self
    (cond
     ((= n 1) parent)
     ((zerop n) self)
     (t (part-of parent (1- n))))))

(defmethod (setf mouse-feedback) :before (feedback (self interaction-window))
  (with-slots (mouse-feedback mouse-documentation
	       compute-mouse-documentation?) self
    (if (eq feedback :none)
      (when (and (eq mouse-feedback :none)
		 (eq compute-mouse-documentation? :never)
		 (null mouse-documentation))
	(change-reactivity self :mouse :none))
      (change-reactivity self :mouse))))

(defmethod (setf selected?) :after (value (self interaction-window))
  (declare (ignore value))
  (selection-changed self))

(defmethod selection-changed ((self interaction-window))
  ;; may be redefined in subclasses
  (with-accessors ((selected? selected?) (inverse? inverse?)) self
     (if selected?
	 (unless inverse? (setf inverse? t))
	 (when inverse?   (setf inverse? nil)))))


;____________________________________________________________________
;
;                            Reactivity
;____________________________________________________________________
     
(defun new-event (contact event-spec actions)
  (apply #'add-event contact event-spec (if (listp actions)
					    actions
					    (list actions))))

(defmethod put-event-spec-at-end ((self interaction-window)
				  event-spec)
  ;; The event-translation entry specified by event-spec is put at the 
  ;; end of the event-translation list.
  ;; This is necessary for some kinds of event specifications 
  ;; (cf. change-reactivity).
  (with-slots (event-translations) self
    (let* ((parsed-event-spec (first (cluei::parse-event-translation
				      event-spec nil)))
	   (entry (assoc parsed-event-spec event-translations :test #'equal)))
      (when entry
	(setf event-translations
	    (nconc
	     (delete entry event-translations :test #'equal)
	     (list entry)))))))

(defun event-key-from-specification (event-spec)
  (if (listp event-spec)
      ;;(gentemp (format nil "~:@(~A~)" (car event-spec)) 'keyword)
      ;; event-key has to be a unique symbol, if callbacks are used
      (intern (format nil "~:@(~A~)" event-spec) 'keyword)
    event-spec))
      

(defmethod transform-actions ((self interaction-window) event-key actions)
  (do ((action-list actions (cdr action-list))
       (action (car actions) (cadr action-list))
       (first-callback? t)
       (transformed-actions nil))
      ((null action) transformed-actions)
    (cond ((and (consp action)
		(eq (first action) 'call))     
	   (add-new-callback self event-key
			     (apply #'make-callback-function
				    (second action)
				    (cddr action)))
	   (when first-callback?
	     (setq transformed-actions
		 (nconc transformed-actions
			(list `(send-callback ,event-key))))
	     (setq first-callback? nil)))
	  (t 
	   (setq transformed-actions
	       (nconc transformed-actions (list action)))))))
				 
(defmethod change-reactivity ((self interaction-window) event-spec
			      &rest docu-and-actions)
  (let* ((event-key (event-key-from-specification event-spec))
	 (documentation? (typep (first docu-and-actions) 'string))
	 ;first may be mouse documentation
	 (documentation (when documentation? (car docu-and-actions)))
	 (actions (if documentation? (cdr docu-and-actions) docu-and-actions)))

    ; update the reactivity slot value
    (with-slots (reactivity mouse-documentation compute-mouse-documentation?)
                self
		(let* ((entry (reactivity-entry self event-spec))
		       (react (if entry
				  (remove entry reactivity :test 'eq)
				  reactivity)))
		  (setf reactivity (if (equal actions '(:none))
				       react
				       (nconc react
					      (list
					       (cons event-spec
						     (if documentation?
							 (cons documentation
							       (copy-list actions))
						       (copy-list actions)))))
				       
				       )))
                (when (eq compute-mouse-documentation? :if-needed)
		  (setf mouse-documentation nil)))

    ; delete old callback
    (delete-callback self event-key)
    
    ; update event actions (and create new callback)
    (if (equal actions '(:none))
	(remove-event-key-actions self event-spec) 
        (add-event-key-actions self event-spec
			       (transform-actions self event-key actions)))))

(defmethod (setf reactivity) (value (self interaction-window))
  (with-slots (reactivity mouse-feedback
	       mouse-documentation compute-mouse-documentation?) self
    (dolist (entry reactivity)
      (funcall #'change-reactivity self
	       (if (listp entry) (car entry) entry) :none))
    (dolist (entry value)
      (apply #'change-reactivity self (if (listp entry) entry (list entry))))
    (unless
	(or (reactivity-entry self :mouse)
	    (and (eq mouse-feedback :none)
		 (null mouse-documentation)
		 (eq compute-mouse-documentation? :never)))
      (change-reactivity self :mouse))
    reactivity))

(defmethod reactivity-entry ((self interaction-window) event-spec)
  (with-slots (reactivity) self
    (assoc event-spec reactivity :test #'equal)))

(defmethod reactivity-actions-for ((self interaction-window) event-spec)
  (let* ((entry (reactivity-entry self event-spec))
	 (docu-and-actions (cdr entry))
	 (actions (if (stringp (car docu-and-actions))
		      (cdr docu-and-actions)
		      docu-and-actions)))
    (when entry
      (or actions t))))
  
(defmethod reactivity-documentation-for ((self interaction-window) event-spec)
  (let* ((entry (reactivity-entry self event-spec))
	 (docu-or-action (second entry)))
    (when (stringp docu-or-action) docu-or-action)))

(defmethod (setf reactivity-documentation-for)
    (documentation (self interaction-window) event-spec)
  (let* ((entry (reactivity-entry self event-spec))
	 (docu-or-action (second entry)))
    (if (stringp docu-or-action)
	(setf (second entry) documentation)
      (push documentation (cdr entry))))
  (when (eq (compute-mouse-documentation? self) :if-needed)
    (setf (mouse-documentation self) nil)))

(defmethod find-reactivity-action ((self interaction-window) event-spec action-spec)
  (let ((actions (reactivity-actions-for self event-spec))
	(test-function (if (consp action-spec)
			   #'equal
			   #'(lambda (action-spec action)
			       (or (eq action-spec action)
				   (and (consp action)
					(eq action-spec (car action))))))))
    (find action-spec actions
          :test test-function)))

;________________________
;
; Defining Call Actions
;________________________

(defmethod make-callback-function (name &rest actions)
  (error "Don't know how to handle actions ~s for unknown call type ~S."
	  actions name))


;____________________________________________________________________________
;
;                       Predefined Call Actions     
;____________________________________________________________________________

(define-call-action :write ()
  '(write-to-application *self*))

(define-call-action :read ()
  '(read-from-application *self*))

(define-call-action :part-event (&rest values)
  `(send-part-event *self* ,@values))

(define-call-action :pass-part-event ()
  '(send-part-event-from-to *part* (part-of *self*) *part-value*))

(define-call-action :process-part-event ()
  '(write-to-application *part*))

(define-call-action :synchronize-event (&rest values)
  `(send-synchronize-event ,@values))

(define-call-action :popup-part ()
  '(select-from-popup-part *self*))

(define-call-action :move ()
  '(move-window *self*))

(define-call-action :totop ()
  '(totop-window *self*))

(define-call-action :self (&rest functionname&args)
  `(,(first functionname&args) *self*
    ,@(rest functionname&args)))

;; to be remove, use :self instead
(define-call-action :contact (&rest functionname&args)
  `(,(first functionname&args) *self*
    ,@(rest functionname&args)))

(define-call-action :part-of (&rest functionname&args)
  `(,(first functionname&args) (part-of *self*)
    ,@(rest functionname&args)))

(define-call-action :parent (&rest functionname&args)
  `(,(first functionname&args) (contact-parent *self*)
    ,@(rest functionname&args)))

(define-call-action :view-of (&rest functionname&args)
  `(,(first functionname&args) (view-of *self*)
    ,@(rest functionname&args)))

(define-call-action :eval (&rest actions)
  `(progn ,@actions))


;_____________________________________________________________________
;
; Defining mappings from XIT event keys onto CLUE event specifications
;_____________________________________________________________________


(defvar *ordered-mouse-documentation-event-keys*
    ;; ToDo: sorting of event-keys or mouse-docu-prefixes should be automated 
    '(:single-left-button :select :edit :double-left-button :shift-left-button
      :single-middle-button :move :double-middle-button :shift-middle-button
      :single-right-button :menu :double-right-button :shift-right-button
      :keyboard))

(defun add-event-key-for-mouse-documentation (key)
  (or (find key *ordered-mouse-documentation-event-keys*)
      (setf *ordered-mouse-documentation-event-keys*
	  (nconc *ordered-mouse-documentation-event-keys* (list key)))))
 

;;; base methods for CLUE event specs used as keys
;;;    
(defmethod mouse-documentation-prefix-for (event-spec)
  (declare (ignore event-spec))
  nil)

(defmethod remove-event-key-actions (self event-spec)
  (delete-event self event-spec))

(defmethod add-event-key-actions (self event-spec &optional
						  transformed-actions
						  position
						  ;mouse-documentation
						  )
;  (when (and mouse-documentation
;	     (reactivity-entry self event-spec)
;	     (not (reactivity-documentation-for self event-spec)))
;    (setf (reactivity-documentation-for self event-spec) mouse-documentation))
  (new-event self event-spec transformed-actions)
  (when position
    (case position
      (:end (put-event-spec-at-end self event-spec))
      (otherwise
       (warn "Position option ~S not yet implemented." position)))))


;;;___________________________________________________________________________
;;;
;;;                  Predefined Event Keys
;;;___________________________________________________________________________

;; Physical event keys

(define-event-key :mouse (:mouse-documentation-prefix nil)		  
   (:enter-notify :default-actions mouse-enters-action)
   (:leave-notify :default-actions mouse-exits-action))

(define-event-key :single-left-button (:mouse-documentation-prefix "Mouse-L:")
   ((:button-press :button-1)
     :default-actions ((button-click-action :left :single))
     :position :end))

(define-event-key :double-left-button (:mouse-documentation-prefix "Mouse-L-2:")
   ((:button-press :button-1 :double-click)
     :default-actions ((button-click-action :left :double))))

(define-event-key :shift-left-button (:mouse-documentation-prefix "sh-Mouse-L:")
   ((:button-press :button-1 :shift)
     :default-actions ((button-click-action :left :shift-single))))

(define-event-key :single-middle-button (:mouse-documentation-prefix "Mouse-M:")
   ((:button-press :button-2)
     :default-actions ((button-click-action :middle :single))
     :position :end))

(define-event-key :double-middle-button (:mouse-documentation-prefix "Mouse-M-2:")
   ((:button-press :button-2 :double-click)
     :default-actions ((button-click-action :middle :double))))

(define-event-key :shift-middle-button (:mouse-documentation-prefix "sh-Mouse-M:")
   ((:button-press :button-2 :shift)
     :default-actions ((button-click-action :middle :shift-single))))

(define-event-key :single-right-button (:mouse-documentation-prefix "Mouse-R:")
   ((:button-press :button-3)
     :default-actions ((button-click-action :right :single))
     :position :end))

(define-event-key :double-right-button (:mouse-documentation-prefix "Mouse-R-2:")
   ((:button-press :button-3 :double-click)
     :default-actions ((button-click-action :right :double))))

(define-event-key :shift-right-button (:mouse-documentation-prefix "sh-Mouse-R:")
   ((:button-press :button-3 :shift)
     :default-actions ((button-click-action :right :shift-single))))
 
(define-event-key :keyboard (:mouse-documentation-prefix "Keyboard:")
   (:key-press :default-actions keyboard-action))

;;; 02/10/1992 (Matthias) 
(define-event-key :keyboard-focus (:mouse-documentation-prefix nil)
		  ;; = :keyboard, aber ohne Mouse-Doku ??!?
   (:key-press :default-actions keyboard-action))

;; Logical event keys

(define-event-key :select
  (:mouse-documentation-prefix "Mouse-L:"
   :default-mouse-documentation "Select")
  (:single-left-button :default-actions totop-window))

(define-event-key :move
  (:mouse-documentation-prefix "Mouse-M:"
   :default-mouse-documentation "Move window")
  (:single-middle-button :default-actions move-window))

(define-event-key :menu
  (:mouse-documentation-prefix "Mouse-R:"
   :default-mouse-documentation "Menu")
  (:single-right-button :default-actions select-from-popup-part))

(define-event-key :edit
  (:mouse-documentation-prefix "Mouse-L:"
   :default-mouse-documentation "Edit")
  (:single-left-button :default-actions edit-text))


;; Event keys for internal events

(define-event-key :read-event ())
(define-event-key :write-event ())
(define-event-key :part-event ())


#|| For example, a :metasystem event key which reacts on Mouse-L or
    keyboard char M can be defined as follows:

(define-event-key :metasystem ()
   (:single-left-button :default-mouse-documentation "Select metasystem"
			:default-actions select-meta-system)
   ((:key-press #\M) :default-actions ((call :metasystem))))

The call action could be defined as follows:

(define-call-action :metasystem ()
   '(select-meta-system *self*))
	  
||#

;___________________________________
;
;  mouse button
;___________________________________

(defmethod button-click-action ((self interaction-window) button type)
  (with-event (x y)
    (button-click self button type x y)))

(defmethod button-click ((self interaction-window) button type x y)
  (values button type x y))                     ; to be filled by subclasses

;___________________________________
;
;  keyboard events
;___________________________________

(defmethod keyboard-action ((self interaction-window))
  (with-event (character)
    (key-press self character)))

(defmethod key-press ((self interaction-window) char)
  char)                                         ; to be filled by subclasses

;__________________________________
;
;      part-event reactivity
;__________________________________

(defmethod send-part-event-from-to ((sender t)
				    (receiver t)
				    &rest part-values)
  (declare (ignore part-values))
  nil)

(defmethod send-part-event-from-to ((sender interaction-window)
				    (receiver interaction-window)
				    &rest part-values)
  (dispatch-part-event receiver sender
		       (if (cdr part-values)
			   part-values        ;; more than one part-value
			 (car part-values)))) ;; just one or no part-value

(defmethod send-part-event ((sender interaction-window) &rest part-values)
  (with-slots (parent) sender
    (apply #'send-part-event-from-to sender parent part-values)))

(defmethod dispatch-part-event ((self interaction-window) part part-value)
  (with-slots (parent) self
    (if (reactivity-entry self :part-event)
	(part-event self part part-value)
	(dispatch-part-event parent part part-value))))

(defmethod dispatch-part-event ((self basic-contact) part part-value)
  (declare (ignore part part-value))
  nil)

(defmethod part-event ((self interaction-window)
		       (part interaction-window) part-value)
  (send-callback self :part-event part part-value))

;__________________________________
;
;    read / write reactivity
;__________________________________


(defmethod read-from-application ((self interaction-window))
  (send-callback self :read-event))

(defmethod write-to-application ((self interaction-window))
  (declare (special *part* *part-value*))
  (with-slots (read-back?) self
     (send-callback self :write-event *part* *part-value*)
     (when read-back? (read-from-application self))))

;__________________________________
;
;       mouse reactivity
;__________________________________
  
(defmethod mouse-enters-action ((self interaction-window))
  (with-event (kind mode)
    ;(format t "Mouse enters ~A ~A ~A (~A)~%" kind mode self (contact-state self))
    (unless (eq mode :grab)
      (case kind
	(:inferior          (mouse-enters-from-inferior self))
	(:ancestor          (mouse-enters-from-ancestor self))
	(:virtual           (mouse-enters-virtual self))
	(:nonlinear         (mouse-enters-nonlinear self))
	(:nonlinear-virtual (mouse-enters-nonlinear-virtual self))))))

(defmethod mouse-exits-action ((self interaction-window))
  (with-event (kind mode)
    ;(format t "Mouse exits ~A ~A ~A (~A)~%" kind mode self (contact-state self))
    ;; 06/16/1992 (Matthias) Changed :grab to :ungrab (should be symmetrical)
    (unless (eq mode :ungrab)
      (case kind
	(:inferior          (mouse-exits-to-inferior self))
	(:ancestor          (mouse-exits-to-ancestor self))
	(:virtual           (mouse-exits-virtual self))
	(:nonlinear         (mouse-exits-nonlinear self))
	(:nonlinear-virtual (mouse-exits-nonlinear-virtual self))))))

(defmethod mouse-enters-from-ancestor ((self interaction-window))
  (mouse-enters self))                         ; could be changed or extended

(defmethod mouse-exits-to-ancestor ((self interaction-window))
  (mouse-exits self))                          ; could be changed or extended

(defmethod mouse-enters-from-inferior ((self interaction-window)) ; no real mouse-enters
  self)                                        ; to be filled by subclasses

(defmethod mouse-exits-to-inferior ((self interaction-window))  ; no real mouse-exits
  self)                                        ; to be filled by subclasses

(defmethod mouse-enters-virtual ((self interaction-window)) ; no real mouse-enters
  (mouse-enters self))                         ; to be filled by subclasses

(defmethod mouse-exits-virtual ((self interaction-window)) ; no real mouse-exits
  (mouse-exits self))                          ; to be filled by subclasses

(defmethod mouse-enters-nonlinear ((self interaction-window))
  (mouse-enters self))                         ; to be filled by subclasses

(defmethod mouse-exits-nonlinear ((self interaction-window))
  (mouse-exits self))                          ; to be filled by subclasses

(defmethod mouse-enters-nonlinear-virtual ((self interaction-window))
  (mouse-enters self))                         ; to be filled by subclasses

(defmethod mouse-exits-nonlinear-virtual ((self interaction-window))
  (mouse-exits self))                          ; to be filled by subclasses

(defmethod mouse-enters ((self interaction-window))
  self)                                        ; to be filled by subclasses

(defmethod mouse-exits ((self interaction-window)) 
  self)					       ; to be filled by subclasses

(defmethod mouse-enters :before ((self interaction-window))
  (with-slots (mouse-documentation) self
     (mouse-feedback-on self)
     (show-mouse-documentation self)))

(defmethod mouse-exits :after ((self interaction-window)) 
  (mouse-feedback-off self)
  (hide-mouse-documentation self))

(defmethod mouse-enters-from-inferior :before ((self interaction-window))
  (show-mouse-documentation self))

(defmethod mouse-exits-to-inferior :after ((self interaction-window))
  (hide-mouse-documentation self))

(defmethod show-mouse-feedback ((self interaction-window) &optional clip-mask)
  (declare (special *inversion-pixel*))
  (with-slots (width height mouse-feedback-border-width) self
    (using-gcontext (gc :drawable self
			:clip-mask clip-mask
			:line-width mouse-feedback-border-width
			:function BOOLE-XOR :foreground *inversion-pixel*
			:subwindow-mode :include-inferiors) 
	(case (mouse-feedback self)
	  (:border  (draw-rectangle-inside self gc 0 0 width height))
	  (:inverse (draw-rectangle-inside self gc 0 0 width height t))))))

(defmethod display :after ((self interaction-window) &optional x y w h &key)
  (with-slots (mouse-feedback-on?) self
    (when mouse-feedback-on?
      (with-clip-mask (clip-mask self x y w h)
	(show-mouse-feedback self clip-mask)))))

(defmethod (setf contact-state) :before (new-state (self interaction-window))
  (with-slots (state) self
    (when (and (eq state :mapped)
	       (not (eq new-state :mapped)))
      (mouse-feedback-off self))))

(defmethod mouse-feedback-on ((self interaction-window))
  ;; this has to be done for the case where mouse-feedback draws into
  ;; parts which specify backing-store (e.g. dispels)
  (with-slots (mouse-feedback-on?) self
    (unless mouse-feedback-on?
      (show-mouse-feedback self))
    (setf mouse-feedback-on? t)))

(defmethod mouse-feedback-off ((self interaction-window))
  (with-slots (mouse-feedback-on?) self
    (when mouse-feedback-on?
      (show-mouse-feedback self))
    (setf mouse-feedback-on? nil)))

;__________________________________
;
;     mouse documentation  
;__________________________________

(defvar *empty-mouse-documentation* "")

(defmethod mouse-documentation ((self interaction-window))
  (declare (special *empty-mouse-documentation*))
  (with-slots (mouse-documentation compute-mouse-documentation? parent) self
     (case compute-mouse-documentation?
       (:always (let ((docu (compute-mouse-documentation self)))
		  (or docu *empty-mouse-documentation*)))
       (:if-needed (let ((docu (or mouse-documentation
				   (compute-mouse-documentation self))))
		     (if docu
			 (setf mouse-documentation docu)
		         (mouse-documentation parent))))
       (:never (or mouse-documentation
		   (mouse-documentation parent))))))

(defmethod mouse-documentation ((self basic-contact))
  (declare (special *empty-mouse-documentation*))
  *empty-mouse-documentation*)
  
(defmethod (setf mouse-documentation) (value (self interaction-window))
  (with-slots (mouse-documentation compute-mouse-documentation? mouse-feedback)
	      self
     (prog1
       (setf mouse-documentation value)
       (if value
	   (change-reactivity self :mouse)
         (when (and (eq compute-mouse-documentation? :never)
		    (eq mouse-feedback :none))
	   (change-reactivity self :mouse :none))))))
         
(defmethod (setf compute-mouse-documentation?) :after
	   (value (self interaction-window))
  (with-slots (mouse-documentation mouse-feedback) self
     (if (eq value :never)
	 (when (and (null mouse-documentation) (eq mouse-feedback :none))
	   (change-reactivity self :mouse :none))
       (change-reactivity self :mouse))))

(defmethod show-mouse-documentation ((self interaction-window))
  (declare (special *mouse-documentation-window*))
  (show-documentation *mouse-documentation-window*
		      (mouse-documentation self)))

(defmethod hide-mouse-documentation ((self interaction-window))
  (declare (special *mouse-documentation-window*))
  (hide-documentation *mouse-documentation-window*))

(defmethod mouse-documentation-for ((self interaction-window) event-spec)
  (let ((documentation (reactivity-documentation-for self event-spec))
	(actions (reactivity-actions-for self event-spec)))
    (when actions
      (let ((event-string (or (mouse-documentation-prefix-for event-spec)
			      (format nil "~A" event-spec))))
	(list (format nil "~A ~A" event-string
		      (or documentation
			  (actions-to-string self actions)))))
      )))

(defmethod actions-to-string ((self interaction-window) actions)
  (format nil "~{~A~^ ~}" (if (listp actions)
			      actions
			      nil)))

(defmethod compute-mouse-documentation ((self interaction-window)
				    &optional (event-specs nil event-specs-p))
 (let ((docu (format nil "~{~A~^;  ~}."       
		     (mapcan #'(lambda (event-spec)
				 (mouse-documentation-for self event-spec))
			     (if event-specs-p
				 event-specs
			         *ordered-mouse-documentation-event-keys*))))) 
   (when (> (length docu) 1)
     docu)))
			     

;_______________________________________________________________________________
;
;                         Hierarchical Mouse Feedback Window
;_______________________________________________________________________________

(defcontact hierarchical-mouse-feedback-window (interaction-window)
  nil
  (:documentation "An interaction window that turns off mouse-feedback of parent
                   windows when entered and turns them on again when left"))

(defmethod mouse-feedback-on-notification ((self hierarchical-mouse-feedback-window))
  (mouse-feedback-on self))


(defmethod mouse-feedback-off-notification ((self hierarchical-mouse-feedback-window))
  (mouse-feedback-off self))

(defmethod mouse-feedback-on-notification ((self basic-contact))
  nil)


(defmethod mouse-feedback-off-notification ((self basic-contact))
  nil)

(defmethod mouse-feedback-on :around ((self hierarchical-mouse-feedback-window))
  (with-slots (mouse-feedback parent) self
    (if (eq mouse-feedback :none)
	(mouse-feedback-on-notification parent)
	(call-next-method))))

(defmethod mouse-feedback-off :around ((self hierarchical-mouse-feedback-window))
  (with-slots (mouse-feedback parent) self
    (mouse-feedback-off-notification parent)
    (call-next-method)))

;(defmethod mouse-feedback-off :around ((self hierarchical-mouse-feedback-window))
;  (with-slots (mouse-feedback parent) self
;    (if (eq mouse-feedback :none)
;	(mouse-feedback-off-notification parent)
;	(call-next-method))))

(defmethod mouse-enters-from-ancestor :before ((self hierarchical-mouse-feedback-window))
  (with-slots (parent) self
    (mouse-feedback-off-notification parent)))

(defmethod mouse-exits-to-ancestor :after ((self hierarchical-mouse-feedback-window))
  (with-slots (parent) self
    (mouse-feedback-on-notification parent)))

;(defmethod mouse-enters-from-inferior ((self hierarchical-mouse-feedback-window))
;  (mouse-enters self))

;(defmethod mouse-enters-virtual ((self hierarchical-mouse-feedback-window))
;  self)

;(defmethod mouse-exits-virtual ((self hierarchical-mouse-feedback-window))
;  (mouse-feedback-off self))
