;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: OPAL; Base: 10 -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         The Garnet User Interface Development Environment.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This code was written as part of the Garnet project at          ;;;
;;; Carnegie Mellon University, and has been placed in the public   ;;;
;;; domain.  If you are using this code or any part of Garnet,      ;;;
;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Opal:Create-Instances.Lisp
;;;
;;; This file contains all the calls to KR:Create-Instance which are in Opal.
;;; They appear in the order in which they are listed in the overall Opal
;;; hierarchy, which is listed first.  Please keep it that way!
;;; NOTE:  the first entry of ":update-slots" MUST be :visible (unless the
;;;   value is NIL), elsewise the update algorithm will break!
;;;
;;; Change Log:
;;;     date     who    what
;;;     ----     ---    ----
;;;   23-Aug-93  amickish  Changed default hit-threshold to 0
;;;   24-May-93  amickish  Changed :width and :height formulas of aggregate to
;;;                        depend on aggregate's own :left and :top
;;;    3-May-93  amickish  Added s-value's in :xcolor formula of opal:COLOR;
;;;                        added :ps-font-name/size to opal::FONT-FROM-FILE
;;;   19-Apr-93  amickish  Added formulas to opal::FONT-FROM-FILE; added
;;;                        opal:CURSOR-FONT
;;;    3-Mar-93  amickish  Added :visible type declaration to VIEW-OBJECT
;;;   10-Feb-93  amickish  Added :known-as type declaration to VIEW-OBJECT
;;;   13-Jan-93  amickish  Added :xfont, :max-char-ascent, :max-char-descent,
;;;                        :font-height, and :char-width slots to opal:font;
;;;                        added parameter declarations
;;;   30-Dec-92  amickish  Set :standard-p in get-standard-font for save-agg
;;;    3-Jun-92  amickish  Added opal:white-line
;;;    7-Apr-92  amickish  Made Get-Standard-Font use default values if NIL
;;;                        parameters were supplied and added error checking.
;;;    2-Apr-92  rgm    new multifont
;;;   25-Mar-92  amickish  Get-Values ---> G-Value
;;;   26-Feb-92  ecp    An opal:color may have a :color-name slot with a
;;;			string like "pink".
;;;   21-Jan-92  amickish  Made opal:default-font an instance of opal:font,
;;;                     added constant formula lists.
;;;    6-Aug-91  dzg    Added extra error checking in formulas for :width
;;;			and height of aggregate.
;;;    6-Aug-91  amickish  Added :ps-font-name and :ps-font-size to opal:font
;;;    5-Aug-91  ecp    Made opal:default-font be same as opal:font.
;;;   26-Mar-91  ecp    Added :components to :local-only-slots slot of
;;;			opal:aggregate.
;;;    7-Mar-91  ecp    The question of whether the screen is color or
;;;			black-and-white is now determined in defs.lisp.
;;;   22-Feb-91  amickish  New exported motif colors and filling styles.
;;;   14-Feb-91  ecp    Yet more changes to color so that colors are
;;;                     deallocated when they are not used anymore.
;;;    8-Feb-91  ecp    Added :color-p slot to opal:color to tell if
;;;                     screen is black-and-white or color.
;;;   10-Aug-90  loyall Made :width, :height of aggregate not depend
;;;                     directly on :top, :left.
;;;    1-Aug-90  dzg    New :local-only-slots slot in opal:view-object
;;;   19-Jul-90  ecp    Made thickness of line-1 be 1.
;;;   20-Jun-90  ecp    Temporarily made thickness of dotted-line be 1,
;;;			due to new CLX bug.
;;;    4-Jun-90  ecp    Removed inverse relation between :parent and :child
;;;   16-Apr-90  ecp    Moved creation of default-font earlier.
;;;   27-Mar-90  ecp    In build-pixmap, changed 0 and 1 to *black*
;;;			and *white*.
;;;   19-Mar-90  ecp    Got rid of Garnet-Font-Pathname.
;;;			Changed :tile to :stipple
;;;    1-Mar-90  ecp    In build-pixmap, changed the :bitmap-p argument
;;;			to xlib:put-image from t to nil.
;;;   13-Feb-90  ecp    Implemented color.
;;;   25-Jan-90  ecp    Changes to fonts.
;;;    5-Dec-89  ecp    Moved create-instance of FONT-FROM-FILE earlier.
;;;     ******* SEE OPAL CHANGE.LOG ********
;;;   15-Jun-89  koz	Placed Graphic-Quality hierarchy before View-Object
;;;			to resolve forward references (instead of s-value).
;;;			This should fix bug that made Cursor-Text not inherit
;;;			the right slots at creation time.
;;;   15-Jun-89  koz	Converted from kr:formula to kr:o-formula.
;;;   15-Jun-89  koz	Extracted all forward references and placed them all
;;;			in S-VALUEs at the end of this file, or in other files
;;;			if they needed functions not yet defined...
;;;   14-Jun-89  koz    Created.  Simply extracted all the calls to kr:create-
;;;			instance from all the Opal files.  No modifications
;;;			were made to them.

(in-package "OPAL" :use '("LISP" "KR"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; I *hate* to do this, but this function needs to go here so that the
;;; the reference to it below doesn't generate a warning at compile time.  Of
;;; course, we *should* be able to just declare it, but no...  Bug in compiler!
(defun build-pixmap (drawable image width height bitmap-p)
  (let* ((pixmap (xlib:create-pixmap :width width :height height
                                     :drawable drawable
                                     :depth 1))
         (gc (xlib:create-gcontext :drawable pixmap :function boole-1
                                   :foreground opal::*black*
                                   :background opal::*white*
                                   )))
    (xlib:put-image pixmap gc image
		    :x 0 :y 0 :width width :height height :bitmap-p bitmap-p)
    (xlib:free-gcontext gc)
    pixmap))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;  The Opal Hierarchy  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#|
  opal:GRAPHIC-QUALITY
	opal:FONT
		opal:DEFAULT-FONT
	opal:COLOR
		opal:WHITE
		opal:BLACK
		opal:RED
		opal:GREEN
		opal:BLUE
		opal:YELLOW
		opal:CYAN
		opal:ORANGE
		opal:PURPLE
		opal:MOTIF-GRAY
		opal:MOTIF-BLUE
		opal:MOTIF-ORANGE
		opal:MOTIF-GREEN
	opal:LINE-STYLE
		opal:DEFAULT-LINE-STYLE
		opal:THIN-LINE
		opal:LINE-0
		opal:LINE-1
		opal:LINE-2
		opal:LINE-4
		opal:LINE-8
		opal:DOTTED-LINE
		opal:DASHED-LINE
		opal:RED-LINE
		opal:GREEN-LINE
		opal:BLUE-LINE
		opal:YELLOW-LINE
		opal:ORANGE-LINE
		opal:CYAN-LINE
		opal:PURPLE-LINE
		opal:WHITE-LINE
	opal:FILLING-STYLE
		opal:DEFAULT-FILLING-STYLE
		opal:WHITE-FILL
		opal:LIGHT-GRAY-FILL
		opal:GRAY-FILL
		opal:DARK-GRAY-FILL
		opal:BLACK-FILL
		opal:RED-FILL
		opal:GREEN-FILL
		opal:BLUE-FILL
		opal:YELLOW-FILL
		opal:ORANGE-FILL
		opal:CYAN-FILL
		opal:PURPLE-FILL
		opal:MOTIF-GRAY-FILL
		opal:MOTIF-BLUE-FILL
		opal:MOTIF-ORANGE-FILL
		opal:MOTIF-GREEN-FILL
	opal:FONT-FROM-FILE
  opal:VIEW-OBJECT
	opal:AGGREGATE
		opal:MULTIFONT-TEXT
		opal:AGGREGADGET
		opal:AGGRELIST
	opal:GRAPHICAL-OBJECT
		opal:LINE
		opal:RECTANGLE
			opal:ROUNDTANGLE
		opal:ARC
			opal:OVAL
			opal:CIRCLE
		opal:MULTIPOINT
			opal:POLYLINE
                                opal:ARROWHEAD
		opal:TEXT
			opal:CURSOR-TEXT
                        opal:MULTI-TEXT
                                opal:CURSOR-MULTI-TEXT
		opal:BITMAP
			opal::WHITE-FILL-BITMAP
			opal::LIGHT-GRAY-FILL-BITMAP
			opal::GRAY-FILL-BITMAP
			opal::DARK-GRAY-FILL-BITMAP
			opal:ARROW-CURSOR
			opal:ARROW-CURSOR-MASK
			opal:PIXMAP
		opal:VIRTUAL-AGGREGATE
	opal:WINDOW

|#
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;  Graphic-Quality Hierarchy  ;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(create-instance 'opal:GRAPHIC-QUALITY NIL)

(define-method :destroy-me opal:graphic-quality (quality)
  (destroy-schema quality))

(define-method :destroy opal:graphic-quality (quality)
  (dolist (instance (copy-list (g-local-value quality :is-a-inv)))
    (destroy instance))
  (destroy-me quality))
			   

(create-instance 'opal::FONT-FROM-FILE opal:graphic-quality
  :declare ((:parameters :font-path :font-name)
	    (:type (string :font-name)
		   ((or null string) :font-path))
	    (:ignored-slots :display-xfont-plist))
  (:xfont (o-formula (fff-to-xfont (gvl :font-from-file) *default-x-display*)))
  (:max-char-ascent (o-formula (xlib:max-char-ascent (gvl :xfont))))
  (:max-char-descent (o-formula (xlib:max-char-descent (gvl :xfont))))
  (:font-height (o-formula (+ (gvl :max-char-ascent) (gvl :max-char-descent))))
  (:display-xfont-plist NIL)
  (:font-path NIL)
  (:font-name "")
  ;; Can't transport machine-dependent font info, so just use Courier
  (:ps-font-name "/Courier")
  (:ps-font-size (o-formula (gvl :font-height))))

(define-method :initialize opal:font-from-file (fff)
  (s-value fff :font-from-file fff))

(setf (gethash '(:fixed :roman :medium) *font-hash-table*)
  (create-instance 'opal::default-font-from-file opal:font-from-file
    (:font-name (make-xfont-name '(:fixed :roman :medium)))))

(defun fff-to-xfont (fff display)
  (let ((dx-plist (g-value fff :display-xfont-plist)))
    (or (getf dx-plist display)
	(let ((font-path (opal::fix-font-path (g-value fff :font-path)))
	      (font-name (g-value fff :font-name)))
	  (when font-path
	    (let ((xfont-path (mapcar #'opal::remove-null-char
				      (xlib:font-path display))))
	      ;;; Add the font-path to the font-path, if necessary
	      (unless (member font-path xfont-path :test #'string=)
		(setf (xlib:font-path display)
		      (cons font-path xfont-path))
		;;; Now make sure it's there!
		(unless (member font-path (xlib:font-path display)
				:test #'string=)
		  (format t "WARNING: X did not add ~A to font-path!!~%"
			  font-path)))))
	  ;;; Open the font only if it's on the font-path
	  (if (xlib:list-font-names display font-name)
	      (let ((xfont (xlib:open-font display font-name)))
		(s-value fff :display-xfont-plist
			 (cons display (cons xfont dx-plist)))
		xfont)
	      (progn
		(format t "WARNING: Font '~A' not on font path!~%"
			font-name)
		(format t "  ****   Resorting to Default Font!~%")
		(fff-to-xfont default-font-from-file display)
		))))))


(create-instance 'opal:FONT opal:graphic-quality
  :declare ((:type ((member :fixed :serif :sans-serif) :family)
		   ((member :roman :bold :italic :bold-italic) :face)
		   ((member :small :medium :large :very-large) :size))
	    (:maybe-constant :family :face :size))
  (:ps-font-name (o-formula (ps-font-name (gvl :family) (gvl :face))))
  (:ps-font-size (o-formula (ps-font-size (gvl :size))))
  (:family :fixed)
  (:face :roman)
  (:size :medium)
  (:xfont (o-formula (fff-to-xfont (gvl :font-from-file) *default-x-display*)))
  (:char-width (o-formula (if (eq (gvl :family) :fixed)
			      (xlib:text-width (gvl :xfont) "X"))))
  (:max-char-ascent (o-formula (xlib:max-char-ascent (gvl :xfont))))
  (:max-char-descent (o-formula (xlib:max-char-descent (gvl :xfont))))
  (:font-height (o-formula (+ (gvl :max-char-ascent) (gvl :max-char-descent))))
  (:font-from-file
    (o-formula
     (let ((key (list (gvl :family) (gvl :face) (gvl :size))))
       (or (gethash key *font-hash-table*)
	   (let ((xfont-name (make-xfont-name key)))
	     (if (stringp xfont-name)
		 (setf (gethash key *font-hash-table*)
		       (create-instance NIL opal:font-from-file
			 (:font-name xfont-name)))
		 (progn
		   (warn "~A not allowed for :~A slot of font; substituting default-font." (car xfont-name) (cdr xfont-name))
		   opal::default-font-from-file))))))))

(create-instance 'opal:DEFAULT-FONT opal:FONT
   (:constant T))

(create-instance 'opal::CURSOR-FONT opal:FONT-FROM-FILE
  (:constant T)
  (:font-name "cursor"))

;;; Used in multifonts
(defvar *Font-Table* (make-array '(3 4 4)
      :initial-contents '(((nil nil nil nil) (nil nil nil nil)
                           (nil nil nil nil) (nil nil nil nil))
                          ((nil nil nil nil) (nil nil nil nil)
                           (nil nil nil nil) (nil nil nil nil))
                          ((nil nil nil nil) (nil nil nil nil)
                           (nil nil nil nil) (nil nil nil nil)))))

;; Fetch a font from the font table corresponding to the attribute parameters.
(defun GET-STANDARD-FONT (family face size)
  "
Get-Standard-Font returns a font object.  If this function is called multiple
times with the same font specification, the same object will be returned, thus
avoiding wasted objects.
    Allowed values:
    family -- :fixed, :serif, :sans-serif, or NIL (NIL == :fixed)
    face   -- :roman, :italic, :bold, :bold-italic, or NIL (NIL == :roman)
    size   -- :small, :medium, :large, :very-large, or NIL (NIL == :medium)"
  (let ((family-num (case (or family (setf family :fixed))
		      (:fixed 0)
		      (:serif 1)
		      (:sans-serif 2)
		      (t (error "Invalid font family -- ~S" family))))
	(face-num (case (or face (setf face :roman))
		    (:roman 0)
		    (:italic 1)
		    (:bold 2)
		    (:bold-italic 3)
		    (t (error "Invalid font face -- ~S" face))))
	(size-num (case (or size (setf size :medium))
		    (:small 0)
		    (:medium 1)
		    (:large 2)
		    (:very-large 3)
		    (t (error "Invalid font size -- ~S" size)))))
    (or (aref *Font-Table* family-num face-num size-num)
	(setf (aref *Font-Table* family-num face-num size-num)
	      (create-instance nil opal:font
		(:constant T)
		(:standard-p T)
		(:family family)
		(:face face)
		(:size size))))))

(setf (aref *Font-Table* 0 0 1) opal:default-font)

;;; Find out the first colormap index that you are actually allowed to
;;; allocate and deallocate.
(when *is-this-a-color-screen?*
  (let ((indices (xlib:alloc-color-cells opal::*default-x-colormap* 1)))
    (setq *first-allocatable-colormap-index* (car indices))
    (xlib:free-colors opal::*default-x-colormap* indices)))

(create-instance 'opal:COLOR opal:graphic-quality
  :declare ((:parameters :red :green :blue :color-name)
	    (:type #+(or lucid allegro-V3.1) (number :red :green :blue)
		   #-(or lucid allegro-V3.1) ((real 0 1) :red :green :blue)
		   ((or string atom) :color-name))
	    (:constant :color-p))
  (:red 1.0)
  (:green 1.0)
  (:blue 1.0)
  (:color-p *is-this-a-color-screen?*)
  (:xcolor (o-formula
	    (let ((name (gvl :color-name)))
	      (if name
		  (let* ((xcolor (xlib:lookup-color opal::*default-x-colormap*
						    name)))
		    ;; The PS module needs the RGB values
		    (s-value (gv :self) :red (xlib:color-red xcolor))
		    (s-value (gv :self) :green (xlib:color-green xcolor))
		    (s-value (gv :self) :blue (xlib:color-blue xcolor))
		    name)
		  (xlib:make-color :red (gvl :red)
				   :green (gvl :green)
				   :blue (gvl :blue))))))
  (:colormap-index
     (o-formula
	(let ((old-index (g-cached-value (gv :self) :colormap-index))
              (new-index (xlib:alloc-color opal::*default-x-colormap*
				           (gvl :xcolor))))
	  (when *is-this-a-color-screen?*
	    (when (and old-index
		       (>= old-index *first-allocatable-colormap-index*)
		       (zerop (decf (aref *colormap-index-table* old-index))))
	      (xlib:free-colors opal::*default-x-colormap* (list old-index)))
	    (incf (aref *colormap-index-table* new-index)))
	  new-index))))
	

(define-method :destroy-me opal:color (hue)
  (when *is-this-a-color-screen?*
    (let ((index (g-cached-value hue :colormap-index)))
      (when (and index
		 (zerop (decf (aref *colormap-index-table* index)))
		 (>= index *first-allocatable-colormap-index*))
	    (xlib:free-colors opal::*default-x-colormap* (list index)))))
  (destroy-schema hue))
				    
(create-instance 'opal:RED opal:color
  (:red 1.0) (:green 0.0) (:blue 0.0))

(create-instance 'opal:GREEN opal:color
  (:red 0.0) (:green 1.0) (:blue 0.0))

(create-instance 'opal:BLUE opal:color
  (:red 0.0) (:green 0.0) (:blue 1.0))

(create-instance 'opal:YELLOW opal:color
  (:red 1.0) (:green 1.0) (:blue 0.0))

(create-instance 'opal:CYAN opal:color
  (:red 0.0) (:green 1.0) (:blue 1.0))

(create-instance 'opal:PURPLE opal:color
  (:red 1.0) (:green 0.0) (:blue 1.0))

(create-instance 'opal:ORANGE opal:color
  (:red 1.0) (:green 0.65) (:blue 0.0))

(create-instance 'opal:WHITE opal:color
  (:red 1.0) (:green 1.0) (:blue 1.0))

(create-instance 'opal:BLACK opal:color
  (:red 0.0) (:green 0.0) (:blue 0.0))

(create-instance 'opal:LINE-STYLE opal:graphic-quality
  :declare ((:type (integer :line-thickness)
		   (keyword :line-style :cap-style :join-style)
		   ((is-a-p opal:color) :foreground-color :background-color))
	    (:maybe-constant :line-thickness :line-style :cap-style :join-style
			     :dash-pattern :foreground-color :background-color
			     :stipple))
  (:line-thickness 0)
  (:line-style :solid)    ;; or :dash or :double-dash
  (:cap-style :butt)      ;; or :not-last, :round or :projecting
  (:join-style :miter)    ;; or :round or :bevel
  (:dash-pattern nil)
  (:foreground-color opal::black)
  (:background-color opal::white)
  (:stipple nil))


(create-instance 'opal:DEFAULT-LINE-STYLE opal:line-style
  (:constant T))


(create-instance 'opal::LINE-0 opal:line-style
  (:constant T))
(defvar opal::THIN-LINE opal::LINE-0)
(create-instance 'opal::LINE-1 opal:line-style
  (:constant T)
  (:line-thickness 1))
(create-instance 'opal::LINE-2 opal:line-style
  (:constant T)
  (:line-thickness 2))
(create-instance 'opal::LINE-4 opal:line-style
  (:constant T)
  (:line-thickness 4))
(create-instance 'opal::LINE-8 opal:line-style
  (:constant T)
  (:line-thickness 8))

(create-instance 'opal:RED-LINE opal:line-style
  (:constant T)
  (:foreground-color opal:red))
(create-instance 'opal:GREEN-LINE opal:line-style
  (:constant T)
  (:foreground-color opal:green))
(create-instance 'opal:BLUE-LINE opal:line-style
  (:constant T)
  (:foreground-color opal:blue))
(create-instance 'opal:CYAN-LINE opal:line-style
  (:constant T)
  (:foreground-color opal:cyan))
(create-instance 'opal:YELLOW-LINE opal:line-style
  (:constant T)
  (:foreground-color opal:yellow))
(create-instance 'opal:ORANGE-LINE opal:line-style
  (:constant T)
  (:foreground-color opal:orange))
(create-instance 'opal:PURPLE-LINE opal:line-style
  (:constant T)
  (:foreground-color opal:purple))
(create-instance 'opal:WHITE-LINE opal:line-style
  (:constant T)
  (:foreground-color opal:white))

(create-instance 'opal::DOTTED-LINE opal:line-style
  (:constant T)
  (:line-style :dash)
  (:line-thickness 1)
  (:dash-pattern '(1 1)))


(create-instance 'opal::DASHED-LINE opal:line-style
  (:constant T)
  (:line-style :dash)
  (:dash-pattern '(4 4)))


(create-instance 'opal:FILLING-STYLE opal:graphic-quality
  :declare ((:parameters :foreground-color :background-color :fill-style
			 :fill-rule :stipple)
	    (:type ((member :solid :stippled :opaque-stippled) :fill-style)
		   ((member :even-odd :winding) :fill-rule)
		   ((is-a-p opal:color) :foreground-color :background-color)))
  (:fill-style :solid)    ;; or :opaque-stippled or :stippled
  (:fill-rule :even-odd)  ;; or :winding
  (:foreground-color opal::black)
  (:background-color opal::white)
  (:stipple nil))


(create-instance 'opal:DEFAULT-FILLING-STYLE opal:filling-style)

;;;; For the *-FILL schemas, please see the end of this file (to avoid
;;;; forward references, they had to be put there)....

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;  View-Object Hierarchy  ;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(create-instance 'opal:VIEW-OBJECT NIL
  :declare ((:type (integer :left :top)
		   ((integer 0) :width :height :hit-threshold)
		   (known-as-type :known-as)
		   (kr-boolean :visible))
	    (:update-slots :visible :fast-redraw-p)
	    (:local-only-slots (:window nil) (:parent nil))
	    (:sorted-slots :is-a :left :top :width :height :visible :line-style
			   :filling-style :draw-function :components :parent)
	    (:ignored-slots :depended-slots :update-slots :update-slots-values)
	    )
  (:left 0)
  (:top 0)
  (:width 0)
  (:height 0)
  (:hit-threshold 0)
  (:visible (o-formula (let ((parent (gvl :parent)))
			    (or (null parent) (gv parent :visible)))
                       t))
  ;; The following are the controls for the schema printer
  (:limit-values '((:is-a-inv 5)))
  (:global-limit-values 5))


;;; Aggregates allow for a group of graphical-objects to be associated
;;; together to form a new, more complex object.
;;;
;;; An implementation detail:
;;; The children of a gob are stored in a list from bottom most to top
;;; most, since we want to redraw fastest and redraws occur from bottom to
;;; top.

(create-instance 'opal:AGGREGATE opal:view-object
  :declare (:type (list :components))
  (:components)
  (:update-slots NIL)	;; New update does not use AGGREGATE'S visible!
  (:left (o-formula
          (let ((min-x 999999))
	    (dolist (child (gv-local (gv :self) :components))
	      (when (gv child :visible)
		(setf min-x (min min-x (gv child :left)))))
	    (if (= min-x 999999) 0 min-x))
	  0))
  (:top (o-formula
	 (let ((min-y 999999))
	   (dolist (child (gv-local (gv :self) :components))
	     (when (gv child :visible)
	       (setf min-y (min min-y (gv child :top)))))
	   (if (= min-y 999999) 0 min-y))
	 0))
  (:width (o-formula
	   (let ((max-x -999999)
		 (min-x (gvl :left)))
	     (dolist (child (gv-local (gv :self) :components))
	       (when (gv child :visible)
		 (setf max-x (max max-x (+ (or (gv child :left) 0)
					   (or (gv child :width) 0))))))
	     (max 0 (- max-x min-x)))))
  (:height (o-formula
	    (let ((max-y -999999)
		  (min-y (gvl :top)))
	      (dolist (child (gv-local (gv :self) :components))
                 (when (gv child :visible)
                   (setf max-y (max max-y (+ (or (gv child :top) 0)
					     (or (gv child :height) 0))))))
	      (max 0 (- max-y min-y)))))

  (:visible (o-formula (let ((parent (gvl :parent)))
			    (or (null parent) (gv parent :visible)))
                       t))

#| TOA OMITTED
  ;; The TOA is the Topmost-Overlapping-Aggregate.  This slot will hopefully
  ;; improve the performance of the update algorithm.  The formula given here
  ;; is only for AGGREGATEs.  A different one appears within Graphical-Object.
  (:toa (o-formula
	  (let ((parent (gvl :parent)))
	    (or (and parent (gv parent :toa))
		(if (gvl :overlapping) kr::*schema-self*)))))
|#
)


;;; Class Graphical-object
(create-instance 'opal:GRAPHICAL-OBJECT opal:view-object
  :declare ((:type ((or (is-a-p opal:line-style) null) :line-style)
		   ((or (is-a-p opal:filling-style) null) :filling-style)
		   ((member :copy :xor :no-op :or :clear :set :copy-inverted
			    :invert :and :equiv :nand :nor :and-inverted
			    :and-reverse :or-inverted :or-reverse)
		    :draw-function))
	    (:update-slots :visible :fast-redraw-p :line-style :filling-style
			   :draw-function))
  (:top 0)
  (:left 0)
  (:width 20)
  (:height 20)
  (:draw-function :copy)
  (:line-style opal:default-line-style)
  (:filling-style nil)
  (:select-outline-only nil)

#| OMITTING TOA
  ;; The TOA is the Topmost-Overlapping-Aggregate.  This slot will hopefully
  ;; improve the performance of the update algorithm.  The formula given here
  ;; is for NON-AGGREGATE objects.  A different one appears within Aggregates.
  (:toa (o-formula
	  (let ((parent (gvl :parent)))
	    (and parent (gv parent :toa)))))
|#
  )
