;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XAM
;;;                       Module: Reactivity
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/xam/reactivity-meta.lisp
;;; File Creation Date: 05/21/92 14:06:57
;;; Last Modification Time: 10/07/92 15:26:01
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_____________________________________________________________________________

(in-package :xit)

(defvar *meta-event-key-menu*)

(defmethod select-meta-event-key-menu ((self text-dispel))
  (declare (special *meta-event-key-menu*))
  (unless (and (boundp '*meta-event-key-menu*) *meta-event-key-menu*)
    (setf *meta-event-key-menu* (make-meta-event-key-menu)))
  (setf (view-of *meta-event-key-menu*) self)
  (popup *meta-event-key-menu*))

(defun destroy-meta-event-key-menu ()
  (declare (special *meta-event-key-menu*))
  (when (boundp '*meta-event-key-menu*)
    (destroy-and-make-unbound *meta-event-key-menu*)))

(defun make-meta-event-key-menu ()
  (while-busy nil
    (make-window 'shadow-popup-margined-window
       :name :meta-event-key-menu
       :adjust-size? t
       :destroy-after? nil
       :margins 
       `((standard-margins
	  :label-options
	  (:name :label
	   :inside-border 3
	   :text "Event Keys")
	  :quad-space-options
	  (:name :space
	   :thickness 1)))
       :client-window 
       `(text-menu
	 :adjust-size? t
	 :reactivity ((:part-event
		       (call :eval
			     (let ((dispel (view-of *contact*)))
			       (setf (text dispel) *part-value*)
			       (send-part-event dispel *part-value*)))
		       (call :contact hide-popup-parent)))
	 :parts ((:text "select"
		  :view-of ":select"
		  :action-docu "Select :select event key")
		 (:text "move"
		  :view-of ":move"
		  :action-docu "Select :move event key")
		 (:text "menu"
		  :view-of ":menu"
		  :action-docu "Select :menu event key")
		 (:text "edit"
		  :view-of ":edit"
		  :action-docu "Select :edit event key")
		 (:text "accept-text"
		  :view-of ":accept-text"
		  :action-docu "Select :accept-text event key")
		 (:text "part-event"
		  :view-of ":part-event"
		  :action-docu "Select :part-event event key")
		 (:text "read-event"
		  :view-of ":read-event"
		  :action-docu "Select :read-event event key")
		 (:text "write-even"
		  :view-of ":write-even"
		  :action-docu "Select :write-even event key")
		 (:text "token-event"
		  :view-of ":token-event"
		  :action-docu "Select :token-event event key")
		 (:text "metasystem"
		  :view-of ":metasystem"
		  :action-docu "Select :metasystem event key")
		 (:text "single-left-button"
		  :view-of ":single-left-button"
		  :action-docu "Select :single-left-button event key")
		 (:text "single-middle-button"
		  :view-of ":single-middle-button"
		  :action-docu "Select :single-middle-button event key")
		 (:text "single-right-button"
		  :view-of ":single-right-button"
		  :action-docu "Select :single-right-button event key")
		 (:text "double-left-button"
		  :view-of ":double-left-button"
		  :action-docu "Select :double-left-button event key")
		 (:text "double-middle-button"
		  :view-of ":double-middle-button"
		  :action-docu "Select :double-middle-button event key")
		 (:text "double-right-button"
		  :view-of ":double-right-button"
		  :action-docu "Select :double-right-button event key")
		 (:text "shift-left-button"
		  :view-of ":shift-left-button"
		  :action-docu "Select :shift-left-button event key")
		 (:text "shift-middle-button"
		  :view-of ":shift-middle-button"
		  :action-docu "Select :shift-middle-button event key")
		 (:text "shift-right-button"
		  :view-of ":shift-right-button"
		  :action-docu "Select :shift-right-button event key")
		 (:text "keyboard"
		  :view-of ":keyboard"
		  :action-docu "Select :keyboard event key")
		 (:text "mouse"
		  :view-of ":mouse"
		  :action-docu "Select :mouse event key")
		 (:text "timer"
		  :view-of ":timer"
		  :action-docu "Select :timer event key")
		 (:text "NONE"
		  :view-of ""
		  :action-docu "Remove reactivity entry"))))))

(defvar *meta-action-menu*)

(defmethod select-meta-action-menu ((self text-dispel))
  (declare (special *meta-action-menu*))
  (unless (and (boundp '*meta-action-menu*) *meta-action-menu*)
    (setf *meta-action-menu* (make-meta-action-menu)))
  (setf (view-of *meta-action-menu*) self)
  (popup *meta-action-menu*))

(defun destroy-meta-action-menu ()
  (declare (special *meta-action-menu*))
  (when (boundp '*meta-action-menu*)
    (destroy-and-make-unbound *meta-action-menu*)))

(defun make-meta-action-menu ()
  (while-busy nil
    (make-window 'shadow-popup-margined-window
       :name :meta-action-menu
       :adjust-size? t
       :destroy-after? nil
       :margins 
       `((standard-margins
	  :label-options
	  (:name :label
	   :inside-border 3
	   :text "Actions")
	  :quad-space-options
	  (:name :space
	   :thickness 1)))
       :client-window 
       `(text-menu
	 :adjust-size? t
	 :reactivity ((:part-event
		       (call :eval
			     (let ((dispel (view-of *contact*)))
			       (add-string dispel *part-value*)
			       (send-part-event dispel *part-value*)))
		       (call :contact hide-popup-parent)))
	 :parts ((:text "totop"
		  :view-of "(call :totop)"
		  :action-docu "Add action")
		 (:text "move"
		  :view-of "(call :move)"
		  :action-docu "Add action")
		 (:text "popup-part"
		  :view-of "(call :popup-part)"
		  :action-docu "Add action")
		 (:text "read"
		  :view-of "(call :read)"
		  :action-docu "Add action")
		 (:text "write"
		  :view-of "(call :write)"
		  :action-docu "Add action")
		 (:text "pass-part-event"
		  :view-of "(call :pass-part-event)"
		  :action-docu "Add action")
		 (:text "process-part-event"
		  :view-of "(call :process-part-event)"
		  :action-docu "Add action")
		 (:text "(call :self ...)"
		  :view-of "(call :self identity)"
		  :action-docu "Add action")
		 (:text "(call :part-of ...)"
		  :view-of "(call :part-of identity)"
		  :action-docu "Add action")
		 (:text "(call :view-of ...)"
		  :view-of "(call :view-of identity)"
		  :action-docu "Add action")
		 (:text "(call :eval ...)"
		  :view-of "(call :eval ())"
		  :action-docu "Add action")
		 (:text "(call :part-event ...)"
		  :view-of "(call :part-event)"
		  :action-docu "Add action")
		 (:text "(call :synchronize-event ...)"
		  :view-of "(call :synchronize-event)"
		  :action-docu "Add action")
		 )))))

(defun convert-reactivity-entry-to-string (entry)
  (if entry
      (convert-to-readable-string entry)
    ""))

(defun convert-reactivity-actions-to-string (actions)
  (if actions
      (let ((action-string (convert-to-readable-string actions)))
	(subseq action-string 1 (1- (length action-string))))
    ""))

(defun convert-cr-to-space (sequence)
  (dolist (old-item '(#\Return #\Linefeed #\Newline) sequence)
    (setq sequence (substitute #\Space old-item sequence))))

(defcontact reactivity-sheet-entry (paned-window)
  ((adjust-size? :initform nil)
   (reactivity :initform
	       '((:part-event (call :pass-part-event))
		 (:read-event (call :contact broadcast
			       'read-from-application))))
   (layouter :initform
	     '(pane-layouter
	       :configurations
	       ((configuration-1
		 ((main 1.0 :h
			(:event 180)
			(empty 3)
			(docu-and-actions :rest :v
					  (:docu :ask)
					  (empty 3)
					  (:actions :rest)))))))))
  (:resources
   (width :initform 500)
   (height :initform 80)
   (border-width :initform 0)
   (inside-border :initform 0)))

(defmethod initialize-instance :after ((self reactivity-sheet-entry)
				       &rest init-list)
  (declare (ignore init-list))
  (add-part self 
	    :class 'text-dispel
	    :name :event
	    :adjust-size? nil
	    :border-width 2
	    :font '(:face :bold)
	    :reactivity '((:edit)
			  (:menu "Menu"
			   (call :contact select-meta-event-key-menu))
			  (:read-event
			   (call :eval
			    (let ((entry (part-of *contact*)))
			      (when (mapped-p entry)
				(setf (text *contact*)
				    (convert-reactivity-entry-to-string
				     (reactivity-entry-event entry)))))))))
  (add-part self
	    :class 'text-dispel
	    :name :docu
	    :adjust-size? nil
	    :border-width 1
	    :display-position :left-center
	    :font '(:face :italic)
	    :reactivity '((:edit)
			  (:read-event
			   (call :eval
			    (let ((entry (part-of *contact*)))
			      (when (mapped-p entry)
				(setf (text *contact*)
				    (convert-reactivity-entry-to-string
				     (reactivity-entry-docu entry)))))))))
  (add-part self 
	    :class 'margined-window
	    :name :actions
	    :adjust-size? nil
	    :border-width 0
	    :reactivity '((:part-event (call :pass-part-event))
			  (:read-event
			   (call :eval (read-from-application
					(client-window *contact*)))))
	    :margins
	    `((standard-margins-with-scroll-bars-without-label
	       :scroll-bar-options (:locations (:right))))
	    :client-window
	    `(scrollable-multi-line-text-dispel
	      :font (:size :small)
	      :fill-column :wrap
	      :separators (#\Space #\- #\Return #\Newline #\Linefeed)
	      :reactivity ((:edit)
			   (:menu "Menu"
				  (call :contact select-meta-action-menu))
			   (:read-event
			    (call :eval
				  (let ((entry (part-of *contact* 2)))
				    (when (mapped-p entry)
				      (setf (text *contact*)
					  (convert-reactivity-actions-to-string
					   (reactivity-entry-actions entry))))))))
	      )))

(defmethod associated-reactivity-entry ((self reactivity-sheet-entry))
  (nth (position self (parts (part-of self))) (reactivity (view-of self))))

(defmethod reactivity-entry-event ((self reactivity-sheet-entry))
  (first (associated-reactivity-entry self)))

(defmethod reactivity-entry-docu ((self reactivity-sheet-entry))
  (let ((reactivity-entry-event (reactivity-entry-event self)))
    (when reactivity-entry-event
      (reactivity-documentation-for (view-of self) reactivity-entry-event))))

(defmethod reactivity-entry-actions ((self reactivity-sheet-entry))
  (let ((reactivity-entry-event (reactivity-entry-event self)))
    (when reactivity-entry-event
      (let ((actions 
	     (reactivity-actions-for (view-of self) reactivity-entry-event)))
	(unless (eq actions t) actions)))))

(defmethod reactivity-entry-for-write ((self reactivity-sheet-entry))
  (when (mapped-p self)
    (let ((event (convert-from-string (text (part self :event)))))
      (when event
	(let ((docu (text (part self :docu)))
	      (actions (convert-from-string
			(concatenate 'string
			  "("
			  (convert-cr-to-space
			   (text (client-window (part self :actions))))
			  ")"))))
	  (if (zerop (length docu))
	      (cons event actions)
	    (list* event docu actions)))))))

(defcontact reactivity-sheet (uniform-part-intel)
  ((part-class :initform 'reactivity-sheet-entry)
   (layouter :initform 'distance-layouter)
   (reactivity :initform '((:part-event (call :write))
			   (:read-event (call :contact read-entries))
			   (:write-event (call :contact write-entries))))
   (read-back? :initform t)))

(defmethod setup-entries ((self reactivity-sheet))
  (let* ((parts (parts self))
	 (num-parts (length parts))
	 (num-entries (1+ (length (reactivity (view-of self)))))
	 (last-pos (min (1- num-parts) (1- num-entries))))
    (dotimes (i num-parts)
      (setf (contact-state (nth i parts))
	  (if (> i last-pos) :withdrawn :mapped)))
    (dotimes (i (- num-entries num-parts))
      (add-part self))))

(defmethod read-entries ((self reactivity-sheet))
  (with-final-layout self
    (setup-entries self)
    (broadcast self 'read-from-application)))

(defmethod write-entries ((self reactivity-sheet))
   (setf (reactivity (view-of self))
       (delete nil (broadcast self #'reactivity-entry-for-write))))

(defmethod select-meta-reactivity-sheet (object)
  (declare (ignore object))
  nil)

(defmethod select-meta-reactivity-sheet ((self interaction-window))
  (declare (special *meta-pool*))
  (let ((sheet (get-pool-window *meta-pool* :meta-reactivity-sheet)))
    (setf (view-of sheet) self)
    (popup sheet)
    (hide-unable sheet))) ;; sheet is pinned up by default
  
(defmethod make-meta-sheet-named ((key (eql :meta-reactivity-sheet)))
  (while-busy nil
    (make-window 'shadow-popup-margined-window
     :name :meta-reactivity-sheet
     :margins 
     '((standard-margins
	:label-options
	(:name :label
	 :inside-border 3
	 :text "Reactivity")
	:quad-space-options
	(:name :space
	 :thickness 1)))
   :client-window 
   '(reactivity-sheet
     :reactivity-entries ((:shift-left-button "Read attribute values" (call :read)))
     :border-width 1
     :adjust-size? t))))
