;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;________________________________________________________________________
;;;
;;;                       System: XACT
;;;                       Module: top window
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/xact/top-window.lisp
;;; File Creation Date: 02/11/92 16:20:47
;;; Last Modification Time: 12/14/92 10:57:26
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_________________________________________________________________________
		    
;___________________________________________________________________________
;
;                           window classes
;___________________________________________________________________________

(in-package :xit)

(defcontact window-button (bitmap-dispel)
  ((mouse-feedback :initform :border)))

(defmethod initialize-instance :after ((self window-button) &rest initargs
				       &key action-docu)
  (unless (reactivity-entry self :select)
    (let ((actions `((call :part-of ,(view-of self)))))
      (apply #'change-reactivity self :select
	     (if action-docu
		 (cons action-docu actions)
		 actions)))))

(defcontact work-area-window (intel)
  ((reactivity :initform
	       '((:metasystem "Select metasystem"
		     (call :self select-meta-system-for-part-with-event))))))

(defmethod select-meta-system-for-selected-part ((self composite))
  (let ((selected-part
	 (identify-window (toplevel-window self)
			  :test #'(lambda (window)
				    (ancestor-p window self))
			  :mouse-documentation "Select object for metasystem")))
    (when selected-part 
      (select-meta-system selected-part))))

(defmethod select-meta-system-for-part-with-event ((self work-area-window))
  "to be used as action for user event, e.g. a button click"
  (with-event (child x y)
    (if child
      (select-meta-system child)
      (select-meta-system-for-selected-part self))))

(defmethod do-create-part :around (type (parent work-area-window) &optional init-list)
  (call-next-method type parent
		    (append init-list '(:background "white"))))

(defmethod meta-toplevel-window ((self work-area-window))
  self)

(defmethod remove-all-objects ((self work-area-window))
  (broadcast self #'destroy))

(defmethod generate-code ((self work-area-window))
  (generate-and-write-code (parts self)))

;___________________________________________________________________________
;
;                           top window
;___________________________________________________________________________

(defcontact ui-construction-window (window-icon-mixin paned-window)
  ((name :initform :user-interface-construction-window)
   (inside-border :initform 3)
   (adjust-size? :initform nil)
   (reactivity :initform '((:select "Totop window")))))

(defmethod get-default-icon ((self ui-construction-window) &rest init-list)
  (apply #'make-window 'text-icon
	 :border-width 0
	 :inside-border 0
	 :layouter '(aligning-distance-layouter
		     :alignment :center
		     :distance -1)
	 :text-part `(:border-width 1
		      :background "white"
		      :text ,(text (part self :title))
		      :font (:size :small))
	 :bitmap-part '(:bitmap "xact"
			:background "white"
			:border-width 1)
	 :reactivity '((:move))
         init-list))

(defmethod work-area ((self ui-construction-window))
  (client-window (part self :work-area)))

(defmethod default-parts-options ((class (eql 'ui-construction-window)))
  '(;; header
      (:class text-dispel
       :name :title
       :adjust-size? nil
       :text "User Interface Construction Kit"
       :font (:face :bolditalic :size 14)
       :background "black"
       :foreground "white"
       :inside-border 4
       :display-position :center)
      
      ;; 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 operations
      (:class text-dispel
       :name :palette-button
       :text "Palette"
       :font (:size 14 :face :bold)
       :mouse-feedback :border
       :reactivity-entries
       ((:select "Select new interaction object from palette"
	 (call :eval (select-new-part-from-palette
		      (work-area (part-of *self*)))))))
      (:class text-dispel
       :name :catalog-button
       :text "Catalog"
       :font (:size 14 :face :bold)
       :mouse-feedback :border
       :reactivity-entries
       ((:select "Select new interaction object from catalog"
	 ;(call :eval (notify "Not yet implemented!"))
	 (call :eval (select-meta-catalog))
	 )))
      (:class text-dispel
       :name :metasystem-button
       :text "Metasystem"
       :font (:size 14 :face :bold)
       :mouse-feedback :border
       :reactivity-entries
       ((:select "Select metasystem for object in work area"
	 (call :eval (select-meta-system-for-selected-part
		      (work-area (part-of *self*))))
	 )))
      (:class text-dispel
       :name :load-button
       :text "Load"
       :font (:size 14 :face :bold)
       :mouse-feedback :border
       :reactivity-entries
       ((:select "Load code for interaction objects"
         (call :eval (load-code
		      (work-area (part-of *self*)))))))
      (:class text-dispel
       :name :save-button
       :text "Save"
       :font (:size 14 :face :bold)
       :mouse-feedback :border
       :reactivity-entries
       ((:select "Generate and save code for interaction objects"
         (call :eval (generate-code
		      (work-area (part-of *self*)))))))
      (:class text-dispel
       :name :clear-button
       :text "Clear"
       :font (:size 14 :face :bold)
       :mouse-feedback :border
       :reactivity-entries
       ((:select "Remove all interaction objects in work area"
	 (call :eval (remove-all-objects
		      (work-area (part-of *self*)))))))
      
      ;; work-area
      (:class margined-window
       :name :work-area
       :adjust-size? nil
       :border-width 0
       :margins
       ((standard-margins-with-scroll-bars 
	  :label-options (:text "Work Area" :display-position :left-center) 
	  :scroll-bar-options (:locations (:right :bottom))))
       :client-window
       (work-area-window
	:width 1000
	:height 1000
	:inside-border 0
	:adjust-size? nil
	))
      ))


(defmethod default-layouter-options ((class (eql 'ui-construction-window)))
  '(pane-layouter
       :configuration configuration-1
       :configurations
       ((configuration-1
	  ((:title :ask)
	   (empty 3)
	   (button-strip (:ask :button-move) :h
			 (empty 10)
			 (:palette-button :ask)
			 (empty 20)
			 (:catalog-button :ask)
			 (empty 20)
			 (:metasystem-button :ask)
			 (empty :even)
			 (:load-button :ask)
			 (empty 20)
			 (:save-button :ask)
			 (empty :even)
			 (:clear-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)
	   (:work-area :rest))
	   ))))
