;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XAM
;;;                       Module: XBrowse Interface
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/xam/meta-browse.lisp
;;; File Creation Date: 07/10/92 15:20:18
;;; Last Modification Time: 10/09/92 11:20:01
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_____________________________________________________________________________

(in-package :xit)

;;;___________________________________________________________________________
;;;
;;;                            Metasystem Extensions
;;;___________________________________________________________________________

(defmethod meta-operation-sheet-entries :around ((self basic-contact))
  (append
   (call-next-method)
   '((:view-of meta-browse-gio
     :text "Browse"
     :action-docu "Invoke Interaction Object Browser")
    (:view-of meta-browse-object
     :text "Inspect"
     :action-docu "Invoke Object Browser"))))
	    
(defmethod class-property-sheet-entry ((self basic-contact))
  `(:label "class" 
    :read-function (lambda (view-of) (class-name (class-of view-of)))
    :read-transformation (lambda (value) 
			   (string-downcase (write-to-string value)))
    :value-part 
    (:class non-active-text-dispel
     :mouse-feedback :border
     :reactivity-entries ((:meta-inspect "Invoke class browser"
			   (call :contact hide-popup-parent)
			   (call :eval (meta-browse-class
					(class-of (view-of *self*)))))))))

(defmethod view-of-property-sheet-entry ((self view))
  `(:class text-property-field
    :label "view-of"
    :read-function view-of
    :read-transformation write-to-string
    :write-transformation (lambda (value) (eval (convert-from-string value)))
    :value-part 
    (:font (:size :small)
     :reactivity-entries ((:copy-property
			   (call :contact copy-property 'identity
				 :writer 'view-of
				 :mouse-documentation
				 "Identify window for view-of"))
			  (:meta-inspect
			   (call :contact hide-popup-parent)
			   (call :eval (meta-browse-object
					(view-of (view-of *self*)))))))))

(defmethod layout-property-sheet-entry ((self layouted-window))
  `(:label "layout"
    :read-function (lambda (view-of)
			(let ((layouter (layouter view-of)))
			  (when layouter 
			    (class-name (class-of layouter)))))
    :read-transformation convert-to-string
    :value-part 
    (:class non-active-text-dispel
     :mouse-feedback :border
     :reactivity-entries
     ((:menu "Change layout"
	 (call :contact hide-popup-parent)
	 (call :view-of select-layout-meta-sheet-for))
      (:meta-inspect "Invoke class browser"
       (call :contact hide-popup-parent)
       (call :eval (meta-browse-class
		    (class-of (layouter (view-of *self*))))))))))
		  
(defmethod layouter-class-property-sheet-entry ((self layouter))
  `(:label "class" 
    :read-function (lambda (layouter) (class-name (class-of layouter)))
    :read-transformation (lambda (value) 
			   (string-downcase (write-to-string value)))
    :value-part 
    (:class non-active-text-dispel
     :mouse-feedback :border
     :reactivity-entries ((:menu "Change layouter class"
			   (call :contact do-hide-popup-parent)
			   (call :eval
				 (select-meta-layouter-menu
				  (window (view-of *contact*)))))
			  (:meta-inspect "Invoke class browser"
			   (call :contact hide-popup-parent)
			   (call :eval (meta-browse-class
					(class-of (view-of *self*)))))))))

;;;___________________________________________________________________________
;;;
;;;                                  generator function
;;;___________________________________________________________________________

(defmethod part-dependents (object)
  (declare (ignore object))
  nil)

(defmethod part-dependents ((self composite))
  (composite-children self))

(defmethod part-of-dependents (object)
  (declare (ignore object))
  nil)

(defmethod part-of-dependents ((self basic-contact))
  (contact-parent self))

(defmethod view-of-dependents (object)
  (declare (ignore object))
  nil)

(defmethod view-of-dependents ((self interaction-window))
  (with-slots (view-of) self
    (when view-of (list view-of))))

(defmethod layouter-dependents (object)
  (declare (ignore object))
  nil)

(defmethod layouter-dependents ((self layouted-window))
  (layouter self))

(defmethod window-icon-dependents (object)
  (declare (ignore object))
  nil)

(defmethod window-icon-dependents ((self window-icon-mixin))
  (window-icon self))

(defmethod popup-part-dependents (object)
  (declare (ignore object))
  nil)

(defmethod popup-part-dependents ((self popup-part-connection))
  (popup-part self))

;;___________________________________________________________________________
;;
;;                          io options for nodes
;;___________________________________________________________________________

(defmethod select-metasystem-for-object-node ((self graph:representation-mixin))
  (select-meta-system (graph:representative self)))

(defmethod meta-inspect-object-node ((self graph:representation-mixin))
  (meta-browse-object (graph:representative self)))

(defclass gio-node-window-mixin ()
  ((reactivity :initform '((:select "Select this object"
				     (call :eval
					   (meta-browse-gio
					    (get-object *contact*))))
			    ;(:select "Select this object"
				     ;(call :eval
					   ;(setf (selected-object
						  ;(root-object-manager
						   ;*contact*))
					       ;(get-object *contact*))))
			    (:meta-inspect
			     (call :view-of meta-inspect-object-node))
			    (:metasystem "Select metasystem"
			     (call :view-of select-metasystem-for-object-node))
			    (:single-middle-button "Browser Menu"
			     (call :view-of select-from-popup-part))	
			    (:single-right-button "Presentation Menu"
			     (call :contact select-from-popup-part))))))

(defmethod select-node ((self gio-node-window-mixin))
  ;(center-node-in-viewport (graph-io-of self) self)
  ;(expand-node self)
  ;(highlight-node self :on)
  ;(graph:generate (graph:graph-generator (graph:part-of (view-of self))))
  )

(defmethod deselect-node ((self gio-node-window-mixin))
  ;(let ((node (view-of self)))
    ;(unless (member node (xgraph:fisheye-foci (graph:part-of node)))
      ;(highlight-node self :off)))
  )

(defmethod get-object ((self gio-node-window-mixin))
  (representative-of self))

(defmethod (setf get-object) (object (self gio-node-window-mixin))
  (setf (representative-of self) object))

(defcontact gio-text-node-window (gio-node-window-mixin object-mixin
				  basic-node-window text-dispel)
  ())

(defcontact gio-bitmap-node-window (gio-node-window-mixin object-mixin
				    basic-node-window bitmap-dispel)
  ())

(defmethod gio-node-io-option (object)
  `(:io (gio-text-node-window
	 :name :object
	 :text ,(convert-to-string object)
	 :font (:face :italic)
	 :reactivity-entries ((:select :none)
			      (:metasystem :none))
	 )))

(defmethod gio-node-io-option ((self basic-contact))
  `(:io (gio-text-node-window
	 :name :window
	 :text ,(string-downcase (format nil "<~A ~A>"
					 (class-name (class-of self))
					 (contact-name self)))
	 :font (:size :small)
	 )))

(defmethod gio-node-io-option ((self text-dispel))
  (with-slots (text) self
    `(:io (gio-text-node-window
	   :name :text-dispel
	   :text ,(if (string= text "")
		      "<no text>"
		      text)
	   :reactivity-entries ((:select :none)
				(:edit)
				(:accept-event
				 (call :eval
				       (setf (text (get-object *contact*))
					   (text *contact*))))))
	  )))

(defmethod first-text-line ((self multi-line-text-dispel))
  (with-slots (text-lines) self
    (text-line-string (first (text-lines-lines text-lines)))))

(defmethod gio-node-io-option ((self multi-line-text-dispel))
  (let ((first-line (first-text-line self)))
    `(:io (gio-text-node-window
	   :name :text-dispel
	   :text ,(concatenate 'string first-line "...")
	   ))))

(defmethod gio-node-io-option ((self bitmap-dispel))
  `(:io (gio-bitmap-node-window
	 :name :bitmap-dispel
	 :bitmap ,(bitmap self)
	  )))

(defmethod gio-node-io-option ((self layouter))
  `(:io (gio-text-node-window
	 :name :layouter
	 :text ,(convert-to-string (class-name (class-of self)))
	 :font (:face :italic)
	 :reactivity-entries ((:select :none)
			      (:metasystem
			       "Change layout"
			       (call :eval
				     (select-layout-meta-sheet-for
				      (window (get-object *contact*))))))
	  )))

;;___________________________________________________________________________
;;
;;                          io options for edges
;;___________________________________________________________________________

(defmethod gio-edge-io-option (relation)
  `(:io (labelled-directed-edge-window
	 :name :link
	 :text ,(princ-to-string relation))))

(defmethod gio-edge-io-option ((relation (eql :part)))
  `(:io (labelled-directed-edge-window
	 :name :part-link
	 :text ,(princ-to-string relation))))

(defmethod gio-edge-io-option ((relation (eql :part-of)))
  `(:io (labelled-directed-edge-window
	 :name :part-of-link
	 :text ,(princ-to-string relation))))

(defmethod gio-edge-io-option ((relation (eql :view-of)))
  `(:io (labelled-directed-edge-window
	 :name :view-of-link
	 :text ,(princ-to-string relation))))

(defmethod gio-edge-io-option ((relation (eql :layouter)))
  `(:io (labelled-directed-edge-window
	 :name :layouter-link
	 :text ,(princ-to-string relation))))

(defmethod gio-edge-io-option ((relation (eql :icon)))
  `(:io (labelled-directed-edge-window
	 :name :icon-link
	 :text ,(princ-to-string relation))))

(defmethod gio-edge-io-option ((relation (eql :popup-part)))
  `(:io (labelled-directed-edge-window
	 :name :popup-part-link
	 :text ,(princ-to-string relation))))

;;;___________________________________________________________________________
;;;
;;;                             Graph Generator
;;;___________________________________________________________________________

(defclass gio-dependents-generator (graph:graph-relations-generator)
  ((relation :type (member :parent :parts)
		:initform :parts
		:initarg :relation
		:accessor window-relation)))

(defmethod generator-applicable-p ((self gio-dependents-generator) objects)
  (if (listp objects)
      (every #'window-p objects)
      (window-p objects)))

(defmethod generator-relation-name ((self gio-dependents-generator))
  (with-slots (relation) self
    (format nil " ~@(~A~) Hierarchy" relation)))

(defmethod graph:generate ((self gio-dependents-generator) &optional objects)
  (declare (ignore objects))
  (with-slots (relation) self
    (case relation
      (:parent
	(setf (graph:graph-relations self)
	      `((,#'part-of-dependents . :part-of)
		(,#'view-of-dependents . :view-of)
		(,#'layouter-dependents . :layouter)
		(,#'window-icon-dependents . :icon)
		(,#'popup-part-dependents . :popup-part)
		)))	      
      (:parts
	(setf (graph:graph-relations self)
	      `((,#'part-dependents . :part)
		(,#'view-of-dependents . :view-of)
		(,#'layouter-dependents . :layouter)
		(,#'window-icon-dependents . :icon)
		(,#'popup-part-dependents . :popup-part)
		))))
    (call-next-method)))

(defmethod graph:generator-default-node-options APPEND ((self gio-dependents-generator)
							object)
  (gio-node-io-option object))

(defmethod graph:generator-default-edge-options APPEND ((self gio-dependents-generator)
							relation)
  (gio-edge-io-option relation))

(defmethod generator-properties ((self gio-dependents-generator))
  '((:label "Relation:"
     :read-function window-relation
     :reactivity-entries
     ((:part-event (call :write))
      (:write-event (call :self write-value)
		    (call :eval
			  (relation-changed
			   (xgraph::io (graph:graph (view-of *self*)))
			   (value *self*)))))
     :label-part (:display-position :upper-right)
     :value-part (:class single-choice-text-menu
		  :border-width 0
		  :inside-border 0
		  :layouter (distance-layouter :orientation :right)
		  :parts ((:view-of :parts
			   :text "Parts"
			   :action-docu "Generate Part Hierarchy")
			  (:view-of :parent
			   :text "Parent"
			   :action-docu "Generate Part-Of Hierarchy")))
     )

    ;; roots are specified by the SELECT option of the browser!
    
    (:class caching-text-property-field
     :label "Cutoff Depth:"
     :read-function graph:generator-cutoff-depth
     :read-transformation convert-to-pretty-readable-string
     :value-width 100
     :label-part (:display-position :upper-right)
     :value-part (:display-position :upper-right :border-width 1))
    ))

;;;___________________________________________________________________________
;;;
;;;                             Graph Layouter
;;;___________________________________________________________________________

(defclass gio-dependents-layouter (window-hierarchy-layouter)
     ())

(graph:define-node-sort-predicate-for-predecessor-ordering gios-ordered-p
  (lambda (window)
    (let ((ordered-gios nil))
      (when (typep window 'composite)
	(setq ordered-gios (composite-children window)))
      (when (typep window 'layouted-window)
	(push (layouter window) ordered-gios))
      (when (typep window 'popup-part-connection)
	(push (popup-part window) ordered-gios))
      (when (typep window 'window-icon-mixin)
	(push (window-icon window) ordered-gios))
      (when (typep window 'interaction-window)
	(push (view-of window) ordered-gios))
      ordered-gios)))
		 
	

;;;___________________________________________________________________________
;;;
;;;                             GIO Browser
;;;___________________________________________________________________________

(defun make-browser (browser-class &rest browser-initargs)
  (multiple-value-bind (parts layouter)
      (default-parts&layouter-options browser-class)
    (setq parts (or (getf browser-initargs :parts) parts)
	  layouter (or (getf browser-initargs :layouter) layouter))
    (let ((new-browser (apply #'make-window browser-class
			      (append (and parts (list :parts parts))
				      (and layouter (list :layouter layouter))
				      browser-initargs))))
      new-browser)))

(defcontact gio-graph-window (object-relation-graph-window)
  ())

(defmethod generators&options :around ((self gio-graph-window))
  '((gio-dependents-generator
      :relation :parts
      :cutoff-depth 2)))

(defmethod layouters&options :around ((self gio-graph-window))
  '((gio-dependents-layouter
       :node-sort-predicate gios-ordered-p
       :orientation :right
       :minimum-horizontal-spacing 20
       :minimum-vertical-spacing 50)))

(defmethod relation-changed ((self gio-graph-window) relation)
  (let* ((graph (view-of self))
	 (current-layouter (graph:graph-layouter graph)))
    ;; update corresponding layouter options
    (case relation
      (:parent
       (setf (graph:layouter-node-sort-predicate current-layouter)
	   nil))
      (:parts
	(setf (graph:layouter-node-sort-predicate current-layouter)
	      #'gios-ordered-p)))
    ;; update metasystem
    (read-from-application
     (client-window (part (meta-part self) :layouter-properties)))))

(defcontact gio-browser (object-browser)
  ((name :initform :meta-gio-browser)))

(defmethod default-parts&layouter-options ((class (eql 'gio-browser)))
  (values
    ;; the parts
    '(;; header
      (:class browser-header 
       :adjust-size? nil
       :prefix "Interaction Object Browser"
       )
      
      ;; window operation buttons 
      (:class window-button
       :name :button-refresh
       :bitmap "button-refresh"
       :view-of refresh-window
       :action-docu "Refresh Window")
      (:class window-button
       :name :button-move
       :bitmap "button-move"
       :view-of move-window
       :action-docu "Move Window")
      (:class window-button
       :name :button-resize
       :bitmap "button-resize"
       :view-of resize-window
       :action-docu "Resize Window")
      (:class window-button
       :name :button-totop
       :bitmap "button-totop"
       :view-of totop-window
       :action-docu "Put Window on Top")
      (:class window-button
       :name :button-tobottom
       :bitmap "button-tobottom"
       :view-of tobottom-window
       :action-docu "Put Window to Bottom")
      (:class window-button
       :name :button-shrink
       :bitmap "button-shrink"
       :view-of shrink
       :action-docu "Shrink Window to Icon")
      (:class window-button
       :name :button-kill
       :bitmap "button-kill"
       :view-of destroy
       :action-docu "Remove Window")
      
      ;; global browser operations
      (:class text-dispel
       :name :update-button
       :text "Update"
       :mouse-feedback :border
       :reactivity-entries
       ((:select "Update objects that depend on the selected object"
		     (call :eval
			   (object-updated (part-of *contact*)
					   (selected-object (part-of *contact*))))))
       )
      (:class text-dispel
       :name :select-button
       :text "Select"
       :mouse-feedback :border
       :reactivity-entries
       ((:select "Select an Object"
		     (call :eval
			   (accept-object (part-of *contact*)
					  :type T))))	; accept anything
       )
      (:class text-dispel
       :name :spawn-button
       :text "Spawn"
       :mouse-feedback :border
       :reactivity-entries
       ((:select "Invoke a SubBrowser on the selected object"
		     (call :eval
			   (spawn-browser (part-of *contact*)))))
       )

      ;; the grapher window
      (:class object-margined-window
       :name :grapher
       :adjust-size? nil
       :border-width 0
       :margins
       ((standard-margins-with-scroll-bars
	  :label-options (:text "Current Relation:  none") 
	  :scroll-bar-options (:locations (:left :bottom))))
       :client-window
       (gio-graph-window
	 :border-width 0
	 :inside-border 0))
      )
    
    ;; the layout
    '(pane-layouter
       :configuration configuration-1
       :configurations
      ((configuration-1
	  ((:header :ask)
	   (empty 3)
	   (button-strip (:ask :button-move) :h
			 (empty 10)
			 (:update-button :ask)
			 (empty 10)
			 (:select-button :ask)
			 (empty 10)
			 (:spawn-button :ask)
			 (empty :even)
			 (:button-refresh :ask)
			 (empty 3)
			 (:button-move :ask)
			 (empty 3)
			 (:button-resize :ask)
			 (empty 3)
			 (:button-totop :ask)
			 (empty 3)
			 (:button-tobottom :ask)
			 (empty 3)
			 (:button-shrink :ask)
			 (empty 3)
			 (:button-kill :ask)
			 (empty 3))
	   (empty 3)
	   (:grapher :even)))
       ))
    ))

;; Problem: Icon bitmap is generated from the name of the browser window!

(defun make-meta-gio-browser ()
    (let ((browser
	   (make-browser 'gio-browser :state :managed)))
      (setf (graph:node-edge-connection (view-of (grapher browser)))
	  :left-right-preferred-border-center)
      browser))
     
(defun make-meta-object-browser ()
    (let ((browser
	   (make-browser 'object-browser
			 :name :meta-object-browser
			 :state :managed)))
      (setf (configuration (layouter browser)) 'configuration-3)
      browser))  
     
(defun make-meta-class-browser ()
    (let ((browser
	   (make-browser 'class-hierarchy-browser
			 :name :meta-class-browser
			 :state :managed)))
      browser))   

(defmethod meta-browse-gio ((self basic-contact))
  (declare (special *meta-gio-browser*))
  (graph::clear-graph (view-of (grapher *meta-gio-browser*)))
  (if (expanded? *meta-gio-browser*)
      (totop-window *meta-gio-browser*)
    (expand *meta-gio-browser*))
  (while-busy ()
     (let ((*suppress-describe-object* T))
       (setf (selected-object *meta-gio-browser*) self))))

(defmethod meta-browse-object (object)
  (declare (special *meta-object-browser*))
  (if (expanded? *meta-object-browser*)
      (totop-window *meta-object-browser*)
    (expand *meta-object-browser*))
  (while-busy ()
     (setf (selected-object *meta-object-browser*) object)))

(defmethod meta-browse-class ((class standard-class))
  (declare (special *meta-class-browser*))
  (graph::clear-graph (view-of (grapher *meta-class-browser*)))
  (if (expanded? *meta-class-browser*)
      (totop-window *meta-class-browser*)
    (expand *meta-class-browser*))
  (while-busy ()
     (setf (selected-object *meta-class-browser*) class)))

(defmethod meta-browse-class ((class symbol))
  (call-next-method (find-class class)))

;;;___________________________________________________________________________
;;;
;;;                             XBROWSE extensions
;;;___________________________________________________________________________

#||
(defmethod generators&options APPEND ((self object-relation-graph-window))
  '((graph:graph-from-root-generator)
    (graph:graph-relations-generator)
    (graph:graph-from-node-edge-list-generator)
    (class-hierarchy-generator)
    (window-hierarchy-generator
      :relation :sub
      :cutoff-depth 1)
    (gio-dependents-generator
      :relation :parts
      :cutoff-depth 1)
    (clos-object-net-generator)
    (graph-representation-generator)
    (number-generator)
    (nodes-generator)
    (bicycle-tour-generator)
    ))

(defmethod layouters&options APPEND ((self object-relation-graph-window))
  '((graph:hierarchical-graph-layouter
      :minimum-horizontal-spacing 20
      :minimum-vertical-spacing 50)
    (class-hierarchy-layouter
       :node-sort-predicate nil
       :orientation :down
       :minimum-horizontal-spacing 20
       :minimum-vertical-spacing 50)
    (window-hierarchy-layouter
       :node-sort-predicate subwindows-ordered-p
       :orientation :down
       :minimum-horizontal-spacing 20
       :minimum-vertical-spacing 50)
    (gio-dependents-layouter
       :node-sort-predicate gios-ordered-p
       :orientation :down
       :minimum-horizontal-spacing 20
       :minimum-vertical-spacing 50)
    (graph:net-layouter
      :minimum-horizontal-spacing 20
      :minimum-vertical-spacing 20)
    (graph:dynamic-balancing-net-layouter
      :minimum-horizontal-spacing 0
      :minimum-vertical-spacing 20)
    (bicycle-tour-layouter
      :orientation :left
      :minimum-horizontal-spacing 10
      :minimum-vertical-spacing 10
      :iteration-steps 16)
    ))
||#