;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;___________________________________________________________________________
;;;
;;;                       System: XAM
;;;                       Module: definitions
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/xam/definitions.lisp
;;; File Creation Date: 11/12/91 17:10:34
;;; Last Modification Time: 10/02/92 11:19:54
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;___________________________________________________________________________

(in-package :xit)

;___________________________________________________________________________
;
;                                macros
;___________________________________________________________________________

(defmacro my-delete (element symbol)
  `(set ',symbol (delete ,element ,symbol)))

(defmacro destroy-and-make-unbound (symbol)
  `(progn (when (and (boundp ',symbol) ,symbol)
	    (destroy ,symbol))
	  (makunbound ',symbol)))

;___________________________________________________________________________
;
;                     meta system event and action
;___________________________________________________________________________


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

(define-event-key :metasystem
  (:mouse-documentation-prefix "Mouse-M-2:"
   :default-mouse-documentation "Select metasystem")
  (:double-middle-button :default-actions select-meta-system))

(define-event-key :copy-property
  (:mouse-documentation-prefix "Mouse-R-2:"
   :default-mouse-documentation "Identify with mouse")
  (:double-right-button))

(define-event-key :meta-inspect
  (:mouse-documentation-prefix "Mouse-L-2:"
   :default-mouse-documentation "Invoke Object Browser")
  (:double-left-button))
	
;___________________________________________________________________________
;
;                    transformation function
;___________________________________________________________________________

(defun convert-nil-to-empty-string (value)
  (if value
      (convert-to-readable-string value)
    ""))

(defun convert-from-boolean (value)
  (case value
    ((nil) :no)
    (t :yes)))

(defun convert-to-boolean (value)
  (case value
    (:no nil)
    (:yes t)))

(defun convert-nil-to-none (value)
  (or value :none))

(defun convert-none-to-nil (value)
  (case value
    (:none nil)
    (t value)))

(defun convert-from-string-to-list (value)
  (unless (string-equal value "nil")
    (convert-from-string (concatenate 'string "(" value ")")))) ; efficient?

(defun convert-to-readable-string-from-list (value)
  (let ((full-string (convert-to-readable-string value)))
    (if value
	(subseq full-string 1 (1- (length full-string)))
      full-string)))

;___________________________________________________________________________
;
;                       utility functions
;___________________________________________________________________________

(defun genstring (&optional name)
  (if name
      (princ-to-string (gensym name))
    (princ-to-string (gensym))))

(defun find-child  (m type)
  (with-slots (children) m
    (find-if #'(lambda (x) (typep x type)) children)))

(defmethod meta-toplevel-window ((self basic-contact))
  (meta-toplevel-window (contact-parent self)))

(defmethod meta-toplevel-window ((self toplevel-window))
  self)
  
(defmethod show-popup-part ((self popup-part-connection))
  (with-slots (popup-part popup-part-connection) self
    (set-popup-part-if-needed self)
    (when popup-part
      (setf (view-of popup-part)
	(case popup-part-connection
	  (:self  self)
	  (:contact  self)
	  (:parent (contact-parent self))
	  (:view-of (view-of self))
	  (t        popup-part-connection)))
      (do-popup popup-part))))

(defmethod destroy-popup-part ((self popup-part-connection))
  (with-slots (popup-part popup-part-connection) self
    (when popup-part
      (destroy popup-part)
      (setf popup-part nil))))

(defmethod identify-popup-part-with-mouse ((self popup-part-connection))
  (let ((window
	 (identify-window (toplevel-window self)
			  :mouse-documentation
			  "Identify window to be used as popup part"))
	(popup nil))
    (when window
      (if (typep window 'popup-window)
	  (progn
	    (setq popup window)
	    (bury-window popup))
	(progn
	  (setq popup
	      (create-new-part 'shadow-borders-popup-container
			       (meta-toplevel-window self)
			       '(:adjust-size? t
				 :state :managed
				 :client-window :none)))
	  (setf (contact-parent window) popup)))
      (setf (popup-part self) popup))))

(defmethod identify-popup-part-with-mouse :after ((self popup-part-container))
  (let ((client (client-window self)))
    (when (and client (not (reactivity-entry client :menu)))
	(change-reactivity client :menu "Menu"
			   '(call :part-of select-from-popup-part)))))
      
(defmethod add-popup-part ((self contact))
  (with-slots (x y parent display) self
    (let ((container (create-new-part
		      'window-icon-popup-part-container
		      parent
		      `(:x ,x :y ,y :layouted? t
			:window-icon nil))))
      (setf (contact-parent self) container)
      ;(unless (reactivity-entry self :menu)
	;(change-reactivity self :menu "Menu" '(call :part-of select-from-popup-part)))
      (identify-popup-part-with-mouse container)
      )))

(defmethod add-popup-part ((self popup-part-connection))
  ;(identify-popup-part-with-mouse self)
  )

(defmethod identify-window-icon-with-mouse ((self window-icon-mixin))
  (with-slots (window-icon) self
    (let ((window
	   (identify-window (toplevel-window self)
			    :mouse-documentation
			    "Identify window to be used as window icon")))
      (when window
	(when (typep window-icon 'contact)
	  (destroy window-icon))
	(setf (window-icon self) window)
	(init-icon self window)))))

(defmethod add-window-icon ((self contact))
  (with-slots (x y parent display) self
    (let ((container (create-new-part
		      'window-icon-popup-part-container parent
		      `(:x ,x :y ,y :layouted? t))))
      (setf (contact-parent self) container)
      ;(identify-window-icon-with-mouse container)
      )))

(defmethod add-window-icon ((self window-icon-mixin))
  ;(identify-window-icon-with-mouse self)
  )
  
(defmethod setup-layouter ((self pane-layouter))
  (with-slots (window configuration configurations) self
    (unless (constraints-parsed-p self)
      (when (null configurations)
        (setf configurations (get-default-configurations self))) 
      (parse-constraints self)
      (setf (configuration self)
          (or configuration (caar configurations))))))

(defmethod update-part-of-property-sheet ((self property-sheet) name)
  (let ((part (part self name)))
    (if part (read-value part))))

(defmethod reparent-window-with-mouse ((self basic-contact))
  (let ((new-parent
	 (identify-window (toplevel-window self)
			  :mouse-documentation
			  "Identify parent window with mouse"
			  :test #'(lambda (window)
				    (typep window 'composite)))))
    (when new-parent 
      (setf (contact-parent self) new-parent))
    (unless (and (layouted-p self)
		 (typep new-parent 'layouted-window)
		 (layouter new-parent))
      (move-window self))))

(defmethod copy-and-reparent-window ((self basic-contact))
  (let ((new-parent
	 (identify-window (toplevel-window self)
			  :mouse-documentation
			  "Identify parent window with mouse"
			  :test #'(lambda (window)
				      (typep window 'composite)))))
    (when new-parent 
      (copy-window-to-parent self new-parent))))
	  
(defmethod copy-property ((self interaction-window) property
			  &key writer write-function property-test
			  mouse-documentation window-type window-test)
  (let* ((test (cond (window-test)
		     (window-type (convert-to-function
				    `(lambda (win) (typep win ',window-type))))))
	 (value
	  (apply #'identify-window-property self property
		 (append
		  (when test `(:window-test ,test))
		  (when property-test `(:property-test ,property-test))
		  (when mouse-documentation
		    `(:mouse-documentation ,mouse-documentation)))))
	 (prop-writer (or writer property))
	 (write-foo (or write-function
			(convert-to-function
			 `(lambda (obj value) (setf (,prop-writer obj) value))))))
    (when value
      (funcall write-foo (view-of self) value)
      (read-from-application (part-of self)))))

;___________________________________________________________________________
;
;            access controller (cf. property-sheet-entry)
;___________________________________________________________________________

(defclass access-controller (view)
  ((read-function :initform nil
		  :accessor read-function :initarg :read-function)
   (write-function :initform nil
		   :accessor write-function :initarg :write-function)))

(defmethod application-value ((self access-controller))
  (with-accessors ((read-function read-function) (view-of view-of)) self
     (when read-function
       (if view-of
	   (funcall read-function view-of) 
	 (funcall read-function)))))

(defmethod (setf application-value) (new-value (self access-controller))
  (with-accessors ((write-function write-function)
		   (read-function read-function)
		   (view-of view-of)) self
    (if write-function
	(if view-of
	    (funcall write-function view-of new-value)
	  (funcall write-function new-value))
      (when view-of
	(eval `(setf (,read-function ',view-of) ',new-value))))))

;___________________________________________________________________________
;
;                    non-active text dispel
;___________________________________________________________________________

(defcontact non-active-text-dispel (text-dispel)
  ((name :initform :non-active-text))
  (:documentation "A text-dispel representing an non-editable text"))

(defmethod identification ((self non-active-text-dispel))
  (text self))

(defmethod (setf identification) (value (self non-active-text-dispel))
  (setf (text self) value))

;___________________________________________________________________________
;
;                    window-viewing text-dispel
;___________________________________________________________________________

(defcontact window-viewing-text-dispel (text-dispel)
  ())

(defmethod initialize-instance :after ((self window-viewing-text-dispel)
				       &rest init-list)
  (declare (ignore init-list))
  (setf (text self) (convert-to-string (contact-name (view-of self)))))

;___________________________________________________________________________
;
;                          popup sheets
;___________________________________________________________________________
   
(defcontact shadow-popup-text-menu (shadow-borders-mixin popup-text-menu)
  ())
               
(defcontact shadow-popup-bitmap-menu (shadow-borders-mixin popup-bitmap-menu)
  ())

(defcontact shadow-popup-margined-window (window-pool-mixin
					  shadow-borders-mixin
					  focus-mixin
					  popup-window margined-window)
  ((popup-for-window :accessor popup-for-window
                     :initarg :popup-for-window
                     :initform nil)
   (adjust-size? :initform t)
   (destroy-after? :initform t)
   (reactivity
    :initform
    `((:select)
      (:move)
      (:double-left-button "Pin up" (call :self hide-unable))
       ;;(:map-notify "update contents"
       ;;(call :read)
       ;;(call :self broadcast #'read-from-application))
      )))
  (:resources
   (save-under :initform :off))
  )

(defmethod title ((self shadow-popup-margined-window))
  (text (part self :label)))

(defmethod (setf title) (new-value (self shadow-popup-margined-window))
  (setf (text (part self :label)) new-value))

(defmethod do-popup :before ((self shadow-popup-margined-window))
  (read-from-application self)
  (read-from-application (client-window self)))

(defmethod hide-enable ((self shadow-popup-margined-window))
  (setf (hide-on-mouse-exit? self) t)
  (setf (hide-on-part-event? self) t)
  (change-reactivity self :double-left-button "Pin up"
		     '(call :self hide-unable))
  (let ((label (part self :label)))
    (when label (setf (inverse? label) nil)))
  (hide self))

(defmethod hide-unable ((self shadow-popup-margined-window))
  (setf (hide-on-mouse-exit? self) nil)
  (setf (hide-on-part-event? self) nil)
  (change-reactivity self :double-left-button "Hide"
		     '(call :self hide-enable))
  (let ((label (part self :label)))
    (when label (setf (inverse? label) t)))
  (show-mouse-documentation self))

(defmethod do-hide ((self shadow-popup-margined-window))
  (if (hide-on-mouse-exit? self)
      (hide self)
    (hide-enable self)))

(defmethod hide-on-demand ((self popup-window))
  (when (or (hide-on-mouse-exit? self)
	    (hide-on-part-event? self))
      (hide self)))

(defmethod popup-parent ((self basic-contact))
  (popup-parent (contact-parent self)))

(defmethod popup-parent ((self popup-window))
  self)

(defmethod hide-popup-parent ((self basic-contact))
  (hide-on-demand (popup-parent self))
  (process-all-events (contact-display self)))

(defmethod do-hide-popup-parent ((self basic-contact))
  (hide (popup-parent self))
  (process-all-events (contact-display self)))

(defmethod create-meta-property-sheet (self 
				       &key title name parts
				       (view-of nil view-of-p)
				       reactivity-entries
				       property-sheet-reactivity)
  (while-busy nil
   (make-window 
    'shadow-popup-margined-window
    :name name
    :view-of (if view-of-p view-of self)
    :popup-for-window self
    :reactivity-entries reactivity-entries
    :margins 
    `((standard-margins
       :label-options
       (:name :label
	      :inside-border 3
	      :text ,title)
       :quad-space-options
       (:name :space
	      :thickness 1)))
    :client-window 
    `(property-sheet
      :name :meta-property-sheet
      :adjust-size? t
      :border-width 1
      :layouter (distance-layouter :distance 0)
      :reactivity-entries
      ,(cons '(:shift-left-button "Read attribute values" (call :read))
	     property-sheet-reactivity)
      :parts ,parts))))

;___________________________________________________________________________
;
;                                  Reset
;___________________________________________________________________________

(defun reset-xam ()
  (mapc #'destroy-all-windows
	(list *meta-pool*
	      *meta-sheet-pool*
	      *meta-property-sheet-pool*
	      *meta-operation-sheet-pool*
	      *meta-layout-sheet-pool*
	      *meta-add-part-sheet-pool*
	      ))
  (destroy-meta-window-pallete)
  (destroy-meta-layouter-menu)
  (destroy-pane-meta-menu)
  (destroy-meta-pane-layout-menu)
  (destroy-meta-bitmap-menu)
  (destroy-meta-event-key-menu)
  (destroy-meta-action-menu))
 
	      