;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT; -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: Window Identifier
;;;                       (Version 1.0)
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/utilities/window-identifier.lisp
;;; File Creation Date: 5/19/90 09:48:11
;;; Last Modification Time: 10/02/92 10:49:08
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 7/19/90  (Hubertus)  - bug-fixed Kalle's GraP-GraB-Grabsching Code
;;;
;;; 01/29/1991 (Juergen) identify-window-with-mouse has been fixed to also identify
;;;                      windows or subwindows of windows which do not react on 
;;;                      button-events.
;;;
;;; 02/14/1991 (Matthias) new: fancy-identifier, more hooks
;;;
;;; 10/15/1991 (Juergen) removed popup-part-connection and 
;;;                      hierarchical-mouse-feedback-mixin from superclass 
;;;                      list of identifier.
;;;
;;; 10/15/1991 (Juergen) Textual feedback when identifier is clicked on now
;;;                      appears in mouse-documentation-line instead of
;;;                      identifier itself.
;;;
;;; 03/18/1992 (Juergen) New general identifier class window-identifier.
;;;                      Class identifier now subsumes properties of class
;;;                      fancy-identifier, which should no longer be used.
;;;                      Additionally, identifiers now have an identify-mode
;;;                      which is either :cursor (default) or :line 
;;;                      (former behavior).
;;;_____________________________________________________________________________
;; Examples:
;;
;; (make-window 'identifier :variable-name 'you)
;; (make-window 'window-identifier
;;              :label "Move Window"
;;              :action #'move-window)

(in-package :xit)

(defcontact window-identifier (text-dispel)
  ((name :initform :identifier)
   (mouse-feedback :initform :border)
   (label :initform #'text
	  :accessor label
	  :initarg :label)
   (window :initform nil :accessor window :initarg :window)
   (action :initform nil :accessor action :initarg :action)
   (identify-mode :type (member :cursor :line)
		  :initform :cursor
		  :accessor identify-mode
		  :initarg :identify-mode)
   (reactivity :initform
	       '((:select
		  "Identify window with mouse"
		  (call :self bind-identified-window)
		  (call :write))
		 (:move)
		 (:read-event (call :self update-label))
		 (:write-event (call :self perform-action))
		 ))))

(defmethod busify-event-actions? ((contact window-identifier))
  nil)

(defmethod initialize-instance :after ((self window-identifier) &rest init-list)
  (declare (ignore init-list))
  (read-from-application self))

(defmethod label ((self window-identifier))
  (with-slots (label) self
    (typecase label
      (string label)
      ((or symbol function) (string (funcall label self))))))

(defmethod (setf label) :after (value (self window-identifier))
 (read-from-application self) )
 
(defmethod update-label ((self window-identifier))
  (setf (text self) (label self)))

(defmethod bind-identified-window ((self window-identifier))
  (mouse-feedback-off self) ;; mouse-leaves event is discarded by mouse grabbing
  (with-slots (parent identify-mode) self
      (let* ((toplevel (toplevel-window self)))
	(setf (window self)
	    (case identify-mode
	      (:cursor
	       (identify-window toplevel
		 :mouse-documentation "Identify window with mouse."))
	      (:line
	       (multiple-value-bind (x y)
		   (translate-coordinates self
			     (floor (contact-total-width self) 10)
			     (floor (contact-total-height self) 2)
			     toplevel)
		 ;(identify-window-with-mouse toplevel x y)
		 (identify-window toplevel
		   :feedback? nil
		   :anchor (point x y)
		   :mouse-documentation "Identify window with mouse.")
		 )))))))

(defmethod perform-action ((self window-identifier))
  (with-slots (window action) self
      (when (and window action)
	(funcall action window))))

(defmethod ut::slots-for-copy :around ((object window-identifier))
  (delete 'window
	  (call-next-method)))

(define-resources
  (* identifier x) 5
  (* identifier y) 5
  (* identifier border-width) 2
  (* identifier inside-border) 5
  (* identifier background) "white"
  (* identifier cursor) "dot"
  (* identifier text) "Identifier"
  (* identifier font) '(:face :italic))

(defcontact identifier (window-identifier)
  ((variable-name :initform 'me :accessor variable-name :initarg :variable-name)
   (label :initform 'label-bind-to-variable)
   (reactivity :initform
	       '((:select
		  "Identify window with mouse"
		  (call :self bind-identified-window)
		  (call :write))
		 (:move)
		 (:read-event (call :self update-label))
		 (:write-event
		  (call :self set-variable)
		  (call :self perform-action))
		 ))))


(defmethod (setf variable-name) :after (value (self identifier))
 (read-from-application self) )
 
(defun set-variable (identifier)
  (set (variable-name identifier) (window identifier)))

(defun label-bind-to-variable (identifier)
  (format nil "Identifier (binds to ~S)"
			    (variable-name identifier)))

;;;--------------------------------------------------------------------------
;;; Fancy Identifier
;;;--------------------------------------------------------------------------

;; to be removed
(defcontact fancy-identifier (identifier)
  ())

#|| The following is included in fancy-dispels.lisp
and should be obsolete here. Matthias (May 1992)
;;;--------------------------------------------------------------------------
;;; Identifier Mixin
;;;--------------------------------------------------------------------------

(defclass identifier-mixin ()
  ())

(defmethod busify-event-actions? ((self identifier-mixin))
  nil)

(defmethod identify-toplevel-window ((self identifier-mixin))
  (with-mouse-documentation ("Identify window with mouse.")
    (let* ((my-toplevel (toplevel-window self)))
      (multiple-value-bind (x y)
	  (translate-coordinates self
	   (floor (contact-total-width self) 10)
	   (floor (contact-total-height self) 2)
	    my-toplevel)
	(identify-window-with-mouse my-toplevel
	     x y)))))

(defclass property-identifier-mixin (identifier-mixin)
  ())

(defmethod identify-property ((self property-identifier-mixin) property-reader
			      &key test)
  (let ((window (identify-toplevel-window self)))
    (and (or (null test) (funcall test window))
	 (funcall property-reader window))))
||#


	       