;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XACT
;;;                       Module: Generate Interaction Objects
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/xam/generate-objects.lisp
;;; File Creation Date: 02/11/92 08:36:27
;;; Last Modification Time: 09/22/92 11:22:55
;;; Last Modification By: Juergen Herczeg
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_____________________________________________________________________________

(in-package :xit)

(defun remove-initargs (initlist &rest initargs)
  (dolist (initarg initargs)
    (remf initlist initarg))
  initlist)

(defun reactivity-without-meta (reactivity)
 (remove :metasystem reactivity :key #'car))

(defmethod generate-class-name ((self clos::standard-object))
  (class-name (class-of self)))

(defmethod function-specifier ((self symbol))
  self)

(defmethod function-specifier ((self cons))
  self)

#+allegro
(defmethod function-specifier ((self function))
  (multiple-value-bind (lambda-form ignore name)
      (function-lambda-expression self)
    (declare (ignore ignore))
    (or lambda-form name)))

(defmethod generate-init-list ((self basic-contact))
  (with-slots (name x y width height border-width state sensitive) self
    (append
     `(:name ,name
       :x ,x
       :y ,y
       :width ,width
       :height ,height
       :border-width ,border-width)
     (unless (eq state :mapped)
       `(:state ,state))
     (unless (eq sensitive :on)
       `(:sensitive ,sensitive)))))

(defmethod generate-init-list :around ((self contact))
  (append
   (call-next-method)
   (with-slots (background) self
     (unless (or (eq background :parent-relative)
		 (typep background 'pixmap))
       `(:background ,background)))))

(defmethod generate-init-list :around ((self basic-window))
  (append
   (call-next-method)
   (with-slots (inside-border layouted?) self
     (append
      `(:inside-border ,inside-border)
      (when layouted? '(:layouted? t))))))

(defmethod generate-init-list :around ((self view))
  (append
   (call-next-method)
   (with-slots (view-of) self
     (when view-of
       `(:view-of ,(typecase view-of
		     (basic-contact `(find-window ,(contact-name view-of)
						  *parent-window*))
		     (standard-object nil)
		     (t view-of)))))))

(defmethod generate-init-list :around ((self graphical-feedback-window))
  (append
   (call-next-method)
   (with-slots (inverse? shaded?) self
     (append 
      (when inverse? '(:inverse? t))
      (when shaded? '(:shaded? t))))))

#+allegro
(defmethod generate-init-list :around ((self application-mixin))
  (append (call-next-method)
	  (with-slots (read-function write-function) self
	    (append
	     (when read-function
	       `(:read-function ,(function-specifier read-function)))
	     (when write-function
	       `(:write-function ,(function-specifier write-function)))))))

(defmethod generate-init-list :around ((self interaction-window))
  (append
   (call-next-method)
   (with-slots (selected? mouse-feedback reactivity
		compute-mouse-documentation? mouse-documentation) self
     (append 
      (when selected? '(:selected? t))
      (unless (eq mouse-feedback :none)
	`(:mouse-feedback ,mouse-feedback))
      (unless (eq compute-mouse-documentation? :if-needed)
	`(:compute-mouse-documentation? ,compute-mouse-documentation?))
      (when (and mouse-documentation
		 (eq compute-mouse-documentation? :never))
	`(:mouse-documentation ,mouse-documentation))
      `(:reactivity ,(reactivity-without-meta reactivity))))))

(defmethod generate-init-list :around ((self timer-mixin))
  (append
   (call-next-method)
   (let ((timer-interval (timer-interval self)))
     (when timer-interval
       `(:timer ,timer-interval)))))
   
(defmethod generate-init-list :around ((self adjustable-window))
  (append
   (call-next-method)
   (with-slots (adjust-size?) self
     (unless adjust-size? '(:adjust-size? nil)))))

(defmethod generate-init-list :around ((self layouted-window))
  (append
   (call-next-method)
   (with-slots (layout-window? layouter) self
     (append
      (unless layout-window? '(:layout-window? nil))
      (when layouter (layouter-init-list layouter))))))

(defmethod layouter-init-list ((self layouter))
  `(:layouter (,(generate-class-name self)
	       ,@(generate-init-list self))))

(defmethod generate-init-list ((self layouter))
  nil)

(defmethod generate-init-list ((self pane-layouter))
  (append
   (call-next-method)
   `(:configuration ,(configuration self)
     :configurations ,(configurations self))))

(defmethod generate-init-list ((self basic-layouter))
  (with-slots (alignment constraint) self
    (append
     (call-next-method)
     `(:alignment ,alignment
       :constraint ,constraint))))

(defmethod generate-init-list ((self distance-layouter))
  (with-slots (distance orientation) self
    (append
     (call-next-method)
     `(:distance ,distance
       :orientation ,orientation))))

(defmethod generate-init-list ((self multiline-distance-layouter))
  (with-slots (items-per-line line-offset) self
    (append
     (call-next-method)
     `(:items-per-line ,items-per-line
       :line-offset ,line-offset))))

(defmethod generate-init-list ((self indent-distance-layouter))
  (with-slots (indent) self
    (append
     (call-next-method)
     `(:indent ,indent))))

(defmethod generate-init-list ((self aligning-distance-layouter))
  (with-slots (alignment divide-equally?) self
    (append
     (call-next-method)
     `(:alignment ,alignment
		  :divide-equally? ,divide-equally?))))

;(defmethod generate-init-list ((self offset-layouter))
;  (with-slots (offset) self
;    (append
;     (call-next-method)
;     `(:offset ,(point (point-x offset) (point-y offset)))))) ;; doesn't work

(defmethod generate-init-list :around ((self intel))
  (append
   (call-next-method)
   (when (parts self)
     (parts-init-list self))))

(defmethod parts-init-list ((self intel))
  `(:parts ,(mapcar #'(lambda (part)
                        (part-init-list self part))
                    (parts self))))

(defmethod part-init-list ((self intel) (part basic-contact))
  (append
   (let ((part-class-name (generate-class-name part)))
       `(:class ,part-class-name))
   (generate-init-list part)))

(defmethod part-init-list ((self uniform-part-intel) (part basic-contact))
  (append
   (with-slots (part-class) self
     (let ((part-class-name (generate-class-name part)))
       (unless (eq part-class-name part-class)
	 `(:class ,part-class-name))))
   (generate-init-list part)))

(defmethod generate-init-list :around ((self popup-part-connection))
  (append
   (call-next-method)
   (with-slots (popup-part) self
     (when popup-part
       `(:popup-part ,(if (typep popup-part 'basic-contact)
			  `(find-window ,(contact-name popup-part)
			    *parent-window*)
			popup-part))))))

(defmethod generate-init-list :around ((self popup-window))
  (append
   (call-next-method)
   (with-slots (popup-position hide-on-mouse-exit? hide-on-part-event?) self
     `(:popup-position ,popup-position
       :hide-on-mouse-exit? ,hide-on-mouse-exit?
       :hide-on-part-event? ,hide-on-part-event?))))

(defmethod generate-init-list :around ((self window-icon-mixin))
  (append
   (call-next-method)
   (with-slots (window-icon window-icon-pos) self
     (when window-icon
       `(:window-icon (find-window ,(contact-name window-icon)
				   *parent-window*)
	 :window-icon-pos ,window-icon-pos)))))

(defmethod generate-init-list :around ((self foreground-color-mixin))
  (append
   (call-next-method)
   (with-slots (foreground) self
     `(:foreground ,foreground))))

(defmethod generate-init-list :around ((self font-mixin))
  (append
   (call-next-method)
   (with-slots (font) self
     `(:font ,(get-font-description font)))))

(defmethod generate-init-list :around ((self basic-dispel))
  (append
   (call-next-method)
   (with-slots (display-position) self
     `(:display-position ,display-position))))
                
(defmethod generate-init-list :around ((self text-dispel))
  (append
   (call-next-method)
   (with-slots (text edit-value?) self
     (append
      `(:text ,text)
      (when edit-value? '(:edit? t))))))

(defmethod generate-init-list :around ((self bitmap-dispel))
  (append
   (call-next-method)
   `(:bitmap ,(get-bitmap-name self))))

(defmethod parts-init-list ((self icon))
  `(:bitmap-part
     ,(let ((bitmap-part (part self :bitmap)))
	(when bitmap-part (list :bitmap
				(get-bitmap-name bitmap-part))))))

(defmethod parts-init-list :around ((self text-icon))
  (append
   (call-next-method)
   `(:text-part
     ,(let ((text-part (part self :text)))
	(when text-part (generate-init-list text-part))))))


(defmethod generate-init-list :around ((self basic-menu))
  (append
   (call-next-method)
   (with-slots (part-mouse-feedback) self
       (unless (eq part-mouse-feedback :border)
	 `(:part-mouse-feedback ,part-mouse-feedback)))))

(defmethod part-init-list ((self basic-menu) (part basic-contact))
  (if (typep part (part-class self))
      (with-slots (view-of) part
	(let ((part-event-type (part-event-type self)))
	  `(:view-of ,view-of
	    :action ,(reactivity-actions-for part part-event-type)
	    :action-docu ,(reactivity-documentation-for part part-event-type))))
    (call-next-method)))

(defmethod part-init-list :around ((self basic-menu) (part text-dispel))
  (if (typep part (part-class self))
      (append
       (call-next-method)
       (with-slots (text) part
	 `(:text ,text)))
    (call-next-method)))

(defmethod part-init-list :around ((self basic-menu) (part bitmap-dispel))
  (if (typep part (part-class self))
      (append
       (call-next-method)
       (with-slots (bitmap) part `(:bitmap ,bitmap)))
    (call-next-method)))

(defmethod part-init-list :around ((self basic-menu) (part labelled-choice-box))
  (if (typep part (part-class self))
      (append
       (call-next-method)
       (let ((label (part part :choice-box-label)))
	 (when label `(:text ,(text label)))))
    (call-next-method)))

(defmethod generate-init-list :around ((self text-menu))
  (append
   (call-next-method)
   `(:part-font ,(get-font-description (part-font self)))))

(defmethod generate-init-list :around ((self switch))
  (append (call-next-method)
	  (with-slots (action-mode) self
	    `(:action-mode ,action-mode))))

(defmethod generate-init-list :around ((self property-field))
  (append (call-next-method)
	  '(:read-initially? nil)
	  #+allegro
	  `(:read-transformation
	    ,(function-specifier (read-transformation self))
	    :write-transformation
	    ,(function-specifier (write-transformation self)))))

(defmethod parts-init-list ((self property-field))
  (let ((label-part (part self :label))
	(value-part (part self :value)))
    (append
     (when label-part
       `(:label ,(text label-part)))
     (when value-part
       `(:value-part ,(part-init-list self value-part))))))

(defmethod part-init-list ((self property-field) (part dispel))
   (with-slots (value-class) self
     (let ((part-class-name (generate-class-name part)))
       (unless (eq part-class-name value-class)
	 `(:class ,part-class-name)))))

(defmethod parts-init-list ((self margined-window))
  `(:margins
    ,(let* ((label (part self :margin-label))
	    (scroll-bars (parts self :margin-scroll-bar))
	    (space (part self :margin-space))
	    (has-label (and label (eq (contact-state label) :mapped)))
	    (has-scrollbars
	     (and scroll-bars
		  ;; one of the scroll-bars is mapped?
		  (member :mapped (mapcar #'contact-state scroll-bars))))
	    (standard-margins-type
	     (cond ((and has-label has-scrollbars)
		    'standard-margins-with-scroll-bars)
		   (has-label 'standard-margins)
		   (has-scrollbars 'standard-margins-with-scroll-bars-without-label)
		   (t 'margin-quad-space))))
       (list
	(cons standard-margins-type
	      (append
	       (when has-label
		 `(:label-options
		   (;:name :label
		    :thickness ,(margin-thickness label)
		    :location ,(margin-location label)
		    :background ,(contact-background label)
		    :foreground ,(foreground label)
		    :text ,(text label)
		    :font ,(get-font-description (font label))
		    :display-position ,(display-position label))))
	       (when has-scrollbars
		 `(:scroll-bar-options
		   (;:name :scroll-bar
		    :thickness ,(margin-thickness (first scroll-bars))
		    :locations ,(mapcar #'margin-location
					(remove-if-not
 					 #'(lambda (part)
					     (eq (contact-state part) :mapped))
 					 scroll-bars)))))
	       `(:quad-space-options
		 (;:name :space
		  :thickness ,(margin-thickness space)
		  :background ,(contact-background space)))))))
    :client-window
    ,(let ((client (client-window self)))
       `(,(generate-class-name client)
	 ,@(remove-initargs (generate-init-list client)
			    :x :y
			    ;:width :height
			    )))))

(defmethod parts-init-list ((self container-window))
  `(:client-window
    ,(let ((client (client-window self)))
       `(,(generate-class-name client)
	 ,@(remove-initargs (generate-init-list client)
			    :x :y
			    ;:width :height
			    )))))

(defmethod generate-init-list :around ((self title-window))
  (append
   (call-next-method)
   `(:title ,(title self)
     :title-font ,(get-font-description (title-font self)))))

#||
(defmethod generate-init-list :around ((self paned-window))
  (append
   (call-next-method)
   `(:layouter ,(list 
                'pane-layouter
                :configuration (configuration (layouter self))
                :configurations (configurations (layouter self))))))

(defmethod generate-init-list :around
	   ((self shadow-popup-text-menu-with-title))
  (append
   (call-next-method)
   `(:title ,(title self)
     :title-font ,(get-font-description (title-font self)))))
||#

#+allegro
(defmethod generate-init-list :around ((self window-identifier))
  (append (call-next-method)
	  (with-slots (action identify-mode) self
	    `(:action ,(function-specifier action)
	      :identify-mode ,identify-mode))))

(defmethod generate-init-list :around ((self identifier))
  (append (call-next-method)
	  (with-slots (variable-name) self
	    `(:variable-name ,variable-name))))
