;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;________________________________________________________________________
;;;
;;;                       System: XAM 
;;;                       Module: create window
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/xam/meta-create-window.lisp
;;; File Creation Date: 02/06/92 14:18:01
;;; Last Modification Time: 07/30/92 14:48:54
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;________________________________________________________________________

(in-package :xit)

;___________________________________________________________________________
;
;                          window palette
;___________________________________________________________________________

(defvar *meta-window-pallete*)

(defmethod select-new-part-from-palette ((parent composite))
  (select-meta-window-pallete parent 'create-new-part))

(defmethod select-client-window-from-palette ((parent composite))
  (select-meta-window-pallete parent 'create-client-window))
 
(defmethod select-meta-window-pallete ((parent composite) creation-function)
  (declare (special *meta-window-pallete*))
  (unless (and (boundp '*meta-window-pallete*) *meta-window-pallete*)
    (setq *meta-window-pallete* (make-meta-window-pallete)))
  (setf (view-of *meta-window-pallete*) parent)
  (setf (view-of (client-window *meta-window-pallete*)) creation-function)
  (popup *meta-window-pallete*))

(defun destroy-meta-window-pallete ()
  (declare (special *meta-window-pallete*))
  (destroy-and-make-unbound *meta-window-pallete*))

(defun make-meta-window-pallete ()
  (while-busy nil
    (make-gio 
     'shadow-popup-margined-window
     :name :window-pallete
     :view-of (make-instance 'access-controller)
     :destroy-after? nil
     :margins 
     '((standard-margins
	:label-options
	(:name :label
	 :inside-border 3
	 :display-position :center
	 :text "Palette")
	:quad-space-options
	(:name :space
	 :thickness 1)))
     :client-window 
     '(bitmap-menu
       :layouter (aligning-multiline-distance-layouter
		  :alignment :center
		  :orientation :down
		  :items-per-line 5
		  :line-offset 15	;135
		  :distance 15)
       :adjust-size? t
       :reactivity-entries
       ((:part-event
	 ;;(call :pass-part-event)
	 ;;(call :eval (display-force-output (contact-display *self*))) ;; unmap the palette if neccessary
	 (call :self hide-popup-parent)
	 (call :eval (funcall (view-of *self*)
			      *part-value*
			      (view-of (part-of *self*))))))
       :part-mouse-feedback :inverse
       :parts ((:view-of text-dispel
		:bitmap "a-text-dispel"
		:action-docu "Make text dispel")
	       (:view-of bitmap-dispel
		:bitmap "a-bitmap-dispel"
		:action-docu "Make bitmap dispel")
	       (:view-of text-icon
		:bitmap "an-icon"
		:action-docu "Make icon")
	       (:view-of soft-button
		:bitmap "a-button"
		:action-docu "Make button")
	       (:view-of shadow-borders-popup-container
		:bitmap "a-popup-window"
		:action-docu "Make popup window")
	       (:view-of text-menu
		:bitmap "a-text-menu"
		:action-docu "Make text menu")
	       (:view-of single-choice-box-menu
		:bitmap "a-single-choice-menu"
		:action-docu "Make single choice menu")
	       (:view-of multiple-choice-box-menu
		:bitmap "a-multiple-choice-menu"
		:action-docu "Make multiple choice menu")
	       (:view-of text-switch
		:bitmap "a-switch"
		:action-docu "Make text switch")
	       (:class dispel
		:width 1 :height 1
		:state :managed)
	       (:view-of text-property-sheet
		:bitmap "a-property-sheet"
		:action-docu "Make property sheet")
	       (:view-of intel
		:bitmap "an-intel"
		:action-docu "Make intel")
	       (:view-of paned-window
		:bitmap "a-paned-window"
		:action-docu "Make paned window")
	       (:view-of margined-window
		:bitmap "a-margined-window"
		:action-docu "Make margined window")
	       )))))

;___________________________________________________________________________
;
;                          window creation
;___________________________________________________________________________

(defmethod resize-created-part? ((self basic-contact))
  t)

(defmethod resize-created-part? ((self adjustable-window))
  (not (adjust-size? self)))

(defmethod create-client-window (type (parent margined-window))
  (let ((old-client-window (client-window parent))
        (new-window (create-new-part type parent)))
    (when old-client-window (destroy old-client-window))
    new-window))

(defmethod create-client-window (type (parent container-window))
  (let ((old-client-window (client-window parent))
        (new-window (create-new-part type parent)))
    (when old-client-window (destroy old-client-window))
    new-window))

(defmethod create-new-part (type (parent composite) &optional init-list)
  (create-and-position-part type parent init-list))

(defmethod create-new-part (type (parent paned-window) &optional init-list)
  (create-and-position-part type parent init-list))

(defmethod create-new-part (type (parent layouted-window) &optional init-list)
  (if (layouter parent)
    (create-part type parent init-list)
    (create-and-position-part type parent init-list)))

(defmethod create-and-position-part (type (parent composite)
				     &optional init-list)
  (let ((display (contact-display parent))
	(window (create-part type parent init-list)))
    (update-state display)
    (process-all-events display)
    (when (eq (contact-state window) :mapped)
      (unless (and (getf init-list :x)
		   (getf init-list :y))
	(move-window window))
      (when (and (resize-created-part? window)
		 (not (and (getf init-list :width)
		   (getf init-list :height))))
	(resize-window window)))
    window))

(defmethod create-part (type (parent composite) &optional init-list)
  (while-busy nil (do-create-part type parent init-list)))

(defmethod do-create-part (type (parent composite) &optional init-list)
  (apply #'make-gio type
	 :parent parent
	 :reactivity-entries '((:metasystem))
	 init-list))

(defmethod do-create-part ((type (eql 'text-dispel)) (parent composite)
			   &optional init-list)
  (apply #'make-gio 'text-dispel
	 :name (genstring ":text-dispel")
	 :parent parent
	 :text "Text"
	 :reactivity-entries '((:metasystem))
	 init-list))

(defmethod do-create-part ((type (eql 'bitmap-dispel)) (parent composite)
			   &optional init-list)
  (apply #'make-gio 'bitmap-dispel
	 :name (genstring ":bitmap-dispel")
	 :parent parent
	 :bitmap "a-bitmap-dispel"
	 :reactivity-entries '((:metasystem))
	 init-list))

(defmethod do-create-part ((type (eql 'intel)) (parent composite)
			   &optional init-list)
  (apply #'make-gio 'intel
	 :name (genstring ":intel")
	 :parent parent
	 :width 100
	 :height 100
	 :border-width 1
	 :adjust-size? nil
	 :reactivity-entries '((:metasystem))
	 init-list))

(defmethod do-create-part ((type (eql 'popup-container)) (parent composite)
			   &optional init-list)
  (apply #'make-gio 'popup-container
	 :name (genstring ":popup-container")
	 :parent parent
	 :reactivity-entries '((:metasystem))
	 :client-window :none
	 init-list))

(defmethod do-create-part ((type (eql 'shadow-borders-popup-container))
			   (parent composite)
			   &optional init-list)
  (apply #'make-gio 'shadow-borders-popup-container
	 :name (genstring ":popup-container")
	 :parent parent
	 :width 100
	 :height 100
	 :border-width 1
	 :reactivity-entries '((:metasystem))
	 (append
	  init-list
	  `(:client-window (intel
			    :name ,(genstring ":intel")
			    :adjust-size? nil
			    :reactivity-entries ((:metasystem)))
	    :state :mapped
	    :adjust-size? nil))))

(defmethod create-new-part :around ((type
				     (eql 'shadow-borders-popup-container))
				    (parent composite)
				    &optional init-list)
  (declare (ignore init-list))
  (let ((new-window (call-next-method)))
    (change-layout new-window)
    (setf (adjust-size? new-window) t)
    new-window))

(defmethod do-create-part ((type (eql 'popup-part-container))
			   (parent composite)
			   &optional init-list)
  (apply #'make-gio 'popup-part-container
	 :name (genstring ":popup-part-container")
	 :parent parent
	 :reactivity-entries '((:metasystem))
	 :client-window :none
	 init-list))

(defmethod do-create-part ((type (eql 'window-icon-popup-part-container))
			   (parent composite)
			   &optional init-list)
  (apply #'make-gio 'window-icon-popup-part-container
	 :name (genstring ":window-icon-popup-part-container")
	 :parent parent
	 :reactivity-entries '((:metasystem))
	 :client-window :none
	 init-list))

(defmethod do-create-part ((type (eql 'window-icon-container))
			   (parent composite)
			   &optional init-list)
  (apply #'make-gio 'window-icon-container
	 :name (genstring ":window-icon-container")
	 :parent parent
	 :reactivity-entries '((:metasystem))
	 :client-window :none
	 init-list))

(defmethod do-create-part ((type (eql 'text-icon)) (parent composite)
			   &optional init-list)
  (apply #'make-gio 'text-icon
	 :name (genstring ":icon")
	 :parent parent
	 :reactivity-entries '((:metasystem))
	 :text-part '(:x 30 :y 20  :text "text")
	 :bitmap-part '(:bitmap "icon-bitmap")
	 init-list))

(defmethod do-create-part ((type (eql 'soft-button)) (parent composite)
			   &optional init-list)
  (apply #'make-gio 'soft-button
	 :name (genstring ":button")
	 :parent parent
	 :reactivity-entries '((:metasystem))
	 :text-part '(:text "Button"
		      ;;:reactivity-entries ((:metasystem))
		      )
	 :bitmap-part '(:bitmap "button-ml"
			;;:reactivity-entries ((:metasystem))
			)
	 init-list))

(defmethod do-create-part ((type (eql 'text-menu)) (parent composite)
			   &optional init-list)
  (apply #'make-gio 'text-menu
	 :name (genstring ":text-menu")
	 :parent parent
	 :border-width 1
	 :reactivity-entries '((:metasystem))
	 init-list))

(defmethod create-new-part :around ((type (eql 'text-menu)) (parent composite)
			   &optional init-list)
  (declare (ignore init-list))
  (let ((new-window (call-next-method)))
    (select-meta-add-part-sheet new-window)
    new-window))

(defmethod do-create-part ((type (eql 'single-choice-box-menu))
			   (parent composite) &optional init-list)
  (apply #'make-gio 'single-choice-box-menu
	 :name (genstring ":single-choice-box-menu")
	 :parent parent
	 :border-width 1
	 :reactivity-entries '((:metasystem))
	 init-list))

(defmethod create-new-part :around ((type (eql 'single-choice-box-menu))
				    (parent composite)
				    &optional init-list)
  (declare (ignore init-list))
  (let ((new-window (call-next-method)))
    (select-meta-add-part-sheet new-window)
    new-window))

(defmethod do-create-part ((type (eql 'multiple-choice-box-menu)) (parent composite) &optional init-list)
  (apply #'make-gio 'multiple-choice-box-menu
	 :name (genstring ":multiple-choice-box-menu")
	 :parent parent
	 :border-width 1
	 :reactivity-entries '((:metasystem))
	 init-list))

(defmethod create-new-part :around ((type (eql 'multiple-choice-box-menu))
				    (parent composite)
				    &optional init-list)
  (declare (ignore init-list))
  (let ((new-window (call-next-method)))
    (select-meta-add-part-sheet new-window)
    new-window))

(defmethod do-create-part ((type (eql 'text-switch)) (parent composite)
			   &optional init-list)
  (apply #'make-gio 'text-switch
	 :name (genstring ":text-switch")
	 :parent parent
	 :border-width 1
	 :reactivity-entries '((:metasystem))
	 init-list))

(defmethod create-new-part :around ((type (eql 'text-switch))
				    (parent composite)
				    &optional init-list)
  (declare (ignore init-list))
  (let ((new-window (call-next-method)))
    (select-meta-add-part-sheet new-window)
    new-window))

(defmethod do-create-part ((type (eql 'property-sheet)) (parent composite)
			   &optional init-list)
  (apply #'make-gio 'property-sheet
	 :name (genstring ":property-sheet")
	 :parent parent
	 :border-width 1
	 :reactivity-entries '((:metasystem))
	 init-list))

(defmethod create-new-part :around ((type (eql 'property-sheet))
				    (parent composite)
				    &optional init-list)
  (declare (ignore init-list))
  (let ((new-window (call-next-method)))
    (select-meta-add-part-sheet new-window)
    new-window))

(defmethod do-create-part ((type (eql 'text-property-sheet)) (parent composite) &optional init-list)
  (apply #'make-gio 'text-property-sheet
	 :name (genstring ":property-sheet")
	 :parent parent
	 :border-width 1
	 :reactivity-entries '((:metasystem))
	 init-list))

(defmethod create-new-part :around ((type (eql 'text-property-sheet))
				    (parent composite)
				    &optional init-list)
  (declare (ignore init-list))
  (let ((new-window (call-next-method)))
    (select-meta-add-part-sheet new-window)
    new-window))

(defmethod do-create-part ((type (eql 'paned-window)) (parent composite)
			   &optional init-list)
  (apply #'make-gio 'paned-window
	 :name (genstring ":paned-window")
	 :parent parent
	 :adjust-size? nil
	 :width 100
	 :height 100
	 ;;:inside-border 0
	 ;;:background "white"
	 :reactivity-entries '((:metasystem))
	 init-list))

(defmethod do-create-part ((type (eql 'margined-window)) (parent composite)
			   &optional init-list)
  (apply #'make-gio 'margined-window
	 :name (genstring ":margined-window")
	 :parent parent
	 :width 100
	 :height 100
	 :adjust-size? nil
	 :reactivity-entries '((:metasystem))
	 :margins 
	 `((standard-margins-with-scroll-bars 
	    :label-options (;:name :label
			    :text "Title"
			    :reactivity-entries ((:metasystem)))
	    :scroll-bar-options (;:name :scroll-bar 
				 :locations (:right :bottom)
				 :reactivity-entries ((:metasystem)))
	    :quad-space-options (;:name :space
				 :thickness 1
				 :reactivity-entries ((:metasystem)))))
	 :client-window `(intel
			  :name ,(genstring ":intel")
			  :reactivity-entries ((:metasystem)))
	 init-list))
