;;; -*- 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-Instances2.Lisp
;;;
;;; Changes:
;;; 11-Jun-92 ecp  Added slot to polyline to allow genuine :point-in-gob
;;; 27-May-92 ecp  Added :save-under to the update-slots list of opal:window.
;;; 26-May-92 ecp  Added :modal-p to the update-slots list of opal:window.
;;; 16-Apr-92 amickish :ignored-slots value: :buffer-gc ===> (list :buffer-gc)
;;; 13-Apr-92 ecp  Must say :initial-element nil in make-array, since
;;;		   the default for CMUCL is 0.
;;; 10-Apr-92 ecp  Made :point-list of multipoint default to be
;;;		   a roughly equilateral triangle.
;;; 31-Mar-92 ecp  Added :draw-on-children and :icon-bitmap to
;;;		   :update-slots of window.
;;; 30-Mar-92 Duchier  Gv the :font-from-file of :font in the formula for
;;;		 :xfont of text, so that :xfont is recomputed whenever
;;;		 :family or :face of :font changes.
;;; 21-Jan-91 amickish  Added constant formula lists
;;;  9-Dec-91 ecp  Rewrote :text-extents formula of text to use
;;;		   multiple-value-bind instead of multiple-value-list.
;;; 25-Nov-91 koz  added init of update-slots-vals for fast-redraw-rectangle
;;; 18-Nov-91 Pervin  Added :background-color to windows.
;;;  4-Oct-91 amickish  Added fast-redraw-rectangle
;;; 10-Sep-91 ecp  Simplified :xfont formula of opal:text.
;;;  6-Aug-91 dzg  Safe versions of min, max in formulas of opal:line.
;;;  1-Aug-91 ecp  Made bitmap use filling-style instead of line-style.
;;; 20-May-91 ecp  Gray bitmaps now have :percent slot telling what percent
;;;		   of bits are filled.
;;;  4-Apr-91 ecp  New slot :omit-title-bar-p for windows.
;;; 22-Feb-91 amickish  New exported motif colors and filling styles.
;;; 22-Oct-90 ecp  New improved formulae for top, left, width, height of line.
;;; 17-Oct-90 ecp  In formula for :width of text, allowed string to be nil.
;;;  5-Oct-90 ecp  More work on formula for :width of text.
;;; 11-Sep-90 ecp  Changed formula for :width of text.
;;; 30-Aug-90 ecp  Multipoints whose line-thicknesses are 0 must be
;;;                treated as if their line-thicknesses were 1 (since
;;;                they're drawn that way).
;;; 14-Aug-90 bam  Added :local-only-slots slot to opal:window.
;;;  1-Aug-90 dzg  New :local-only-slots slot in opal:cursor-text.
;;; 27-Jun-90 bam  Made :buffer-gc be :ignored-slot of opal:window.
;;;  4-Jun-90 dzg  Removed (:parent NIL) from opal:window.
;;;  1-May-90 ecp  If :image of bitmap is nil, width and height are 0.
;;; 16-Apr-90 ecp  Moved defun of font-to-xfont from new-defs.lisp to
;;;		   create-instances2.lisp
;;; 23-Mar-90 ecp  New slot :fill-background-p for text objects.
;;; 19-Mar-90 ecp  Changed :tile to :stipple
;;; 12-Mar-90 ecp  Setting :title and :icon-title of windows
;;;		   in :initialize method.
;;; 13-Feb-90 ecp Implemented color.

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


;;; dzg
;;; Safe versions of min, max.  Return rather arbitrary value (i.e., 0) when
;;; all arguments are NIL
;;;
(defun safe-min (&rest numbers)
  (let ((result (first numbers)))
    (dolist (n (cdr numbers))
      (when n
	(if result
	    (if (< n result)
		(setf result n))
	    (setf result n))))
    result))



(defun safe-max (&rest numbers)
  (let ((result (first numbers)))
    (dolist (n (cdr numbers))
      (when n
	(if result
	    (if (> n result)
		(setf result n))
	    (setf result n))))
    result))



;;; This is only necessary because Lisp has problems with really large
;;; fasl files.  Great.

(create-instance 'opal:LINE opal:graphical-object
  (:maybe-constant '(:x1 :y1 :x2 :y2 :line-style :visible))
  (:x1 0)
  (:y1 0)
  (:x2 0)
  (:y2 0)
  (:left
   (o-formula (- (safe-min (gvl :x1) (gvl :x2))
		 (if (eq (gvl :line-style :cap-style) :projecting)
		     (safe-max 1 (gvl :line-style :line-thickness))
		     (floor (gvl :line-style :line-thickness) 2)))))
  (:top
   (o-formula  (- (safe-min (gvl :y1) (gvl :y2))
		  (if (eq (gvl :line-style :cap-style) :projecting)
		      (safe-max 1 (gvl :line-style :line-thickness))
		      (floor (gvl :line-style :line-thickness) 2)))))
  (:width
   (o-formula (+ (abs (- (or (gvl :x1) 0) (or (gvl :x2) 0)))
		 (* (if (eq (gvl :line-style :cap-style) :projecting) 2 1)
		    (safe-max 1 (gvl :line-style :line-thickness))))))
  (:height
   (o-formula (+ (abs (- (or (gvl :y1) 0) (or (gvl :y2) 0)))
		 (* (if (eq (gvl :line-style :cap-style) :projecting) 2 1)
		    (safe-max 1 (gvl :line-style :line-thickness))))))

  (:update-slots '(:visible :fast-redraw-p :x1 :x2 :y1 :y2 :line-style
		   :filling-style :draw-function)))


(create-instance 'opal:RECTANGLE opal:graphical-object
  (:maybe-constant '(:left :top :width :height :line-style :filling-style
		     :draw-function :visible))
  (:update-slots '(:visible :fast-redraw-p :top :left :width :height
		   :line-style :filling-style :draw-function)))

(create-instance 'opal::FAST-REDRAW-RECTANGLE opal:rectangle
   (:line-style NIL))
(let ((update-vals (s-value opal::FAST-REDRAW-RECTANGLE :update-slots-values
			(make-array 9 :initial-element nil))))
   (setf (aref update-vals *rect-draw-function*) :copy)
   (setf (aref update-vals 0) T)
   (setf (aref update-vals 1) :rectangle))

(create-instance 'opal:ROUNDTANGLE opal:rectangle
  (:maybe-constant '(:left :top :width :height :radius :line-style
		     :filling-style :draw-function :visible))
  (:radius :small)
  (:update-slots '(:visible :fast-redraw-p
		   :top :left :width :height :radius :draw-radius
		   :line-style :filling-style :draw-function))
  (:draw-radius (o-formula (let ((r (gvl :radius))
                                (smaller-side (min (gvl :width)
                                                   (gvl :height))))
                            (if (numberp r)
                                (min (max r 0) (floor smaller-side 2))
                                (case r
                                  (:small (floor smaller-side 5))
                                  (:medium (floor smaller-side 4))
                                  (:large (floor smaller-side 3))
                                  (t 0)))))))


(create-instance 'opal:ARC opal:graphical-object
  (:maybe-constant '(:left :top :width :height :line-style :filling-style
		     :draw-function :angle1 :angle2 :visible))
  (:angle1 0)
  (:angle2 (/ pi 4))
  (:update-slots '(:visible :fast-redraw-p :left :top :width :height
                           :angle1 :angle2
			   :line-style :filling-style :draw-function)))


(create-instance 'opal:OVAL opal:arc)


(create-instance 'opal:CIRCLE opal:arc)


(create-instance 'opal:MULTIPOINT opal:graphical-object
  (:maybe-constant '(:point-list :line-style :filling-style :draw-function
		     :visible))
  (:point-list '(18 10 10 24 26 24 18 10))  ;; a roughly equilateral triangle.
  (:update-slots '(:visible :fast-redraw-p :point-list
		   :line-style :filling-style :draw-function))
  (:left (o-formula
           (let* ((min-x 9999)
                  (line-style (gvl :line-style))
                  (lsthickness (if line-style
                                   (* 2 (max 1 (gv line-style :line-thickness)))
                                   0)))
             (do ((point (gvl :point-list) (cddr point)))
                 ((null point) (- min-x lsthickness))
               (setf min-x (min min-x (car point)))))))
  (:top (o-formula
           (let* ((min-y 9999)
                  (line-style (gvl :line-style))
                  (lsthickness (if line-style
                                   (* 2 (max 1 (gv line-style :line-thickness)))
                                   0)))
             (do ((point (gvl :point-list) (cddr point)))
                 ((null point) (- min-y lsthickness))
               (setf min-y (min min-y (cadr point)))))))
  (:width (o-formula
           (let* ((min-x 9999)
                  (max-x 0)
                  (line-style (gvl :line-style))
                  (lsthickness (if line-style
                                   (* 4 (max 1 (gv line-style :line-thickness)))
                                   0)))
             (do ((point (gvl :point-list) (cddr point)))
                 ((null point) (+ (- max-x min-x) lsthickness))
               (setf min-x (min min-x (car point)))
               (setf max-x (max max-x (car point)))))))
  (:height (o-formula
           (let* ((min-y 9999)
                  (max-y 0)
                  (line-style (gvl :line-style))
                  (lsthickness (if line-style
                                   (* 4 (max 1 (gv line-style :line-thickness)))
                                   0)))
             (do ((point (gvl :point-list) (cddr point)))
                 ((null point) (+ (- max-y min-y) lsthickness))
               (setf min-y (min min-y (cadr point)))
               (setf max-y (max max-y (cadr point))))))))


(create-instance 'opal:POLYLINE opal:multipoint
  (:hit-full-interior-p nil))

(defun font-to-xfont (opal-font display)
  (let* ((fff (g-value opal-font :font-from-file))
	 (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)
		(unless (eq opal-font opal:default-font)
		  (format t "  ****   Resorting to Default Font!~%")
		  (s-value opal-font :font-from-file opal:default-font)
		  (font-to-xfont opal:default-font display))
		))))))

(create-instance 'opal:TEXT opal:graphical-object
  (:maybe-constant '(:left :top :string :font :actual-heightp :line-style
		     :visible))
  (:string "")
  (:update-slots '(:visible :fast-redraw-p :top :left :height :width
                           :string :font :xfont :actual-heightp
			   :fill-background-p
			   :line-style :filling-style :draw-function
			   :text-extents))
  (:ignored-slots (list :depended-slots :update-slots :update-slots-values
			:xfont :text-extents))
  (:fill-background-p nil)
  (:actual-heightp nil)
  (:xfont (o-formula (let ((fnt (gvl :font)))
		       (gv fnt :font-from-file)
		       (opal::font-to-xfont fnt opal::*default-x-display*))))
  (:text-extents
   (o-formula (let ((xfont (gvl :xfont))
                    (string (gvl :string)))
                 (if (and xfont (not (zerop (length string))))
                     (multiple-value-bind
		          (a b c d e)  ;; the last 4 values are discarded
                          (xlib:text-extents xfont string)
			(list a b c d e))  ;; I wish I could avoid consing...
                     *default-text-extents*))))   ;; if font isn't present
  (:width
   (o-formula (let ((string (gvl :string))
		    (text-extents (gvl :text-extents)))
		(max *cursor-width* ; just in case it's really a cursor-text
		     (cond ((or (null string) (string= string "")) 0)
			   ; If the string ends with a space, use width...
			   ((eq (elt string (1- (length string))) #\space)
			    (the-width text-extents))
			   ; ... otherwise use right-bearing minus left-bearing
			   (t
			    (- (the-right-bearing text-extents)
			       (the-left-bearing text-extents))))))))
  (:height
   (o-formula (let ((text-extents (gvl :text-extents))
                    (xfont (gvl :xfont)))
                   (if (and text-extents xfont)
                       (if (gvl :actual-heightp)
                           (+ (the-actual-ascent text-extents)
                              (the-actual-descent text-extents))
                           (+ (xlib:max-char-ascent xfont)
                              (xlib:max-char-descent xfont)))
                       0)) 0))
  (:font opal:default-font))


(create-instance 'opal:CURSOR-TEXT opal:text
 (:update-slots '(:visible :fast-redraw-p :top :left :height :width
                           :string :font :xfont :actual-heightp
			   :fill-background-p
			   :line-style :filling-style :draw-function
			   :text-extents :cursor-index :x-substr))
 (:local-only-slots '((:cursor-index nil) (:window nil) (:parent nil)))
 (:height
  (o-formula (let ((text-extents (gvl :text-extents))
                   (xfont (gvl :xfont)))
              (if (and text-extents xfont)
                  (if (and (gvl :actual-heightp)
                           (not (zerop (length (gvl :string)))))
                      (+ (the-actual-ascent text-extents)
                         (the-actual-descent text-extents))
                      (+ (xlib:max-char-ascent xfont)
                         (xlib:max-char-descent xfont)))
                  0)) 0))
 (:x-substr (o-formula (let ((string (gvl :string))
                             (index (gvl :cursor-index)))
                        (cond ((null index) "")
			      ((<= index 0) "")
			      ((>= index (length string)) string)
			      (t (subseq string 0 index)))))))

;;; multi-line text
(create-instance 'opal:MULTI-TEXT opal:text
 (:update-slots '(:visible :fast-redraw-p :top :left :height :width
                           :string :font :xfont :actual-heightp
			   :fill-background-p
			   :line-style :filling-style :draw-function
			   :justification :cut-strings))
 (:justification :left)
 (:cut-strings (o-formula (let ((string (gvl :string))
				(font (gvl :xfont)))
			    (do* ((list nil)
				  (i -1 j)
				  (j 0)
				  (substring nil))
				 ((null i) (nreverse list))
			      (setf j (position #\Newline string :start (1+ i))
 				    substring (subseq string (1+ i) j))
			      (multiple-value-bind
				  (width dummy2 dummy3
					  left-bearing right-bearing)
				  (xlib:text-extents font substring)
				(declare (ignore dummy2 dummy3))
				(push (make-cut-string
				       :string substring
				       :width
					(cond ((or (null substring)
						   (string= substring "")) 0)
					      ; If the substring ends with a space,
					      ; use width...
			                      ((eq (elt substring (1- (length substring)))
						   #\space)
			                       width)
					      ; ... otherwise use difference of bearings
			                      (t (- right-bearing left-bearing)))
				       :left-bearing left-bearing)
				      list))))))
  (:height (o-formula (let ((font (gvl :xfont)))
			(if font
			    (* (+ (or (xlib:max-char-ascent font) 0)
				  (or (xlib:max-char-descent font) 0))
			       (length (gvl :cut-strings)))
			    0))))
  (:width (o-formula (let ((width *cursor-width*)) ;just in case it's really
		       (dolist (cstring (gvl :cut-strings)) ;a cursor-multi-text
			 (setq width (max width (cut-string-width cstring))))
		       width))))




(create-instance 'opal:CURSOR-MULTI-TEXT opal:multi-text
  (:update-slots '(:visible :fast-redraw-p :top :left :height :width
                            :string :font :xfont :actual-heightp
			    :fill-background-p
	 		    :line-style :filling-style :draw-function
  		 	    :justification :cut-strings
			    :cursor-index :x-substr))
  (:cursor-index NIL)
  (:x-substr
   (o-formula (let ((string (gvl :string))
                    (index (gvl :cursor-index)))
                (cond ((null index) "")
                      ((<= index 0) "")
                      (t (subseq
                          string
                          (1+ (or (position #\Newline string :from-end t
                                            :end (min index (length string)))
                                  -1))
                          index)))))))

(create-instance 'opal:BITMAP opal:graphical-object
  (:maybe-constant '(:left :top :image :line-style :filling-style
		     :visible))
  (:line-style nil)
  (:filling-style opal:default-filling-style)
  (:image nil)
  (:width (o-formula (if (gvl :image) (xlib:image-width (gvl :image)) 0)))
  (:height (o-formula (if (gvl :image) (xlib:image-height (gvl :image)) 0)))
  (:ignored-slots (list :depended-slots :update-slots :update-slots-values
			:root-pixmap-plist :image))
  (:update-slots '(:visible :fast-redraw-p :image :top :left
		   :line-style :filling-style :draw-function)))


;;; All the *-FILL-BITMAPs will have their :image slot set once the function
;;; "halftone-image" is defined...

(create-instance 'opal::WHITE-FILL-BITMAP opal:bitmap
	   (:percent 0)
           (:image))   ;;; will be (halftone-image 0)

(create-instance 'opal::LIGHT-GRAY-FILL-BITMAP opal:bitmap
	   (:percent 25)
           (:image))   ;;; will be (halftone-image 25)

(create-instance 'opal::GRAY-FILL-BITMAP opal:bitmap
	   (:percent 50)
           (:image))   ;;; will be (halftone-image 50)

(create-instance 'opal::DARK-GRAY-FILL-BITMAP opal:bitmap
	   (:percent 75)
           (:image))   ;;; will be (halftone-image 75)

;;; Colors and filling-styles for Motif

;;;  Orange, Green, Blue lists for defining colors
(defvar MOTIF-GRAY-VALUE (float (/ #xd3d3 #xffff)))

(defvar MOTIF-BLUE-VALUES
  (list (float (/ #x7272 #xffff)) (float (/ #x9f9f #xffff)) 1))

(defvar MOTIF-GREEN-VALUES
  (list (float (/ #x5f5f #xffff)) (float (/ #x9e9e #xffff))
        (float (/ #xa0a0 #xffff))))

(defvar MOTIF-ORANGE-VALUES (list 1 .6 .4))

(create-instance 'MOTIF-GRAY-FILL opal:default-filling-style
   (:foreground-color (create-instance 'MOTIF-GRAY opal:color
                         (:red MOTIF-GRAY-VALUE)
                         (:green MOTIF-GRAY-VALUE)
                         (:blue MOTIF-GRAY-VALUE))))

(create-instance 'MOTIF-BLUE-FILL opal:default-filling-style
   (:foreground-color (create-instance 'MOTIF-BLUE opal:color
                         (:red (first MOTIF-BLUE-VALUES))
                         (:green (second MOTIF-BLUE-VALUES))
                         (:blue (third MOTIF-BLUE-VALUES)))))

(create-instance 'MOTIF-ORANGE-FILL opal:default-filling-style
   (:foreground-color (create-instance 'MOTIF-ORANGE opal:color
                         (:red (first MOTIF-ORANGE-VALUES))
                         (:green (second MOTIF-ORANGE-VALUES))
                         (:blue (third MOTIF-ORANGE-VALUES)))))

(create-instance 'MOTIF-GREEN-FILL opal:default-filling-style
   (:foreground-color (create-instance 'MOTIF-GREEN opal:color
                         (:red (first MOTIF-GREEN-VALUES))
                         (:green (second MOTIF-GREEN-VALUES))
                         (:blue (third MOTIF-GREEN-VALUES)))))

;;;  default cursor  (an arrow head)
(create-instance 'opal::ARROW-CURSOR opal:bitmap
  (:image (read-image
	    (merge-pathnames
		"garnet.cursor"
                user::Garnet-Bitmap-PathName  ;; from garnet-loader.lisp
                ))))


(create-instance 'opal::ARROW-CURSOR-MASK opal:bitmap
  (:image (read-image
	    (merge-pathnames
		"garnet.mask"
                user::Garnet-Bitmap-PathName  ;; from garnet-loader.lisp
                ))))



(create-instance 'opal:ARROWHEAD opal:polyline
  (:maybe-constant '(:line-style :filling-style :length :diameter :open-p
		     :head-x :head-y :from-x :from-y :radius :visible))
  (:update-slots '(:visible :fast-redraw-p :point-list
		   :line-style :filling-style :draw-function
		   :head-x :head-y :from-x :from-y :length :diameter :open-p))
  (:head-x 0)
  (:head-y 0)
  (:from-x 0)
  (:from-y 0)
  (:radius (o-formula (/ (gvl :diameter) 2)))
  (:dx (o-formula (- (gvl :from-x) (gvl :head-x))))
  (:dy (o-formula (- (gvl :from-y) (gvl :head-y))))
  (:ftlength (o-formula (let ((dx (gvl :dx))
			      (dy (gvl :dy)))
			  (max 1.0 (sqrt (+ (* dx dx) (* dy dy)))))))
  (:ux (o-formula (/ (gvl :dx) (gvl :ftlength))))
  (:uy (o-formula (/ (gvl :dy) (gvl :ftlength))))
  (:connect-x (o-formula (round (+ (gvl :head-x) (* (gvl :length) (gvl :ux))))))
  (:connect-y (o-formula (round (+ (gvl :head-y) (* (gvl :length) (gvl :uy))))))
  (:ax (o-formula (round (- (gvl :connect-x) (* (gvl :radius) (gvl :uy))))))
  (:ay (o-formula (round (+ (gvl :connect-y) (* (gvl :radius) (gvl :ux))))))
  (:cx (o-formula (round (+ (gvl :connect-x) (* (gvl :radius) (gvl :uy))))))
  (:cy (o-formula (round (- (gvl :connect-y) (* (gvl :radius) (gvl :ux))))))
  (:point-list (o-formula (let ((ax (gvl :ax)) (ay (gvl :ay))
				(head-x (gvl :head-x))
				(head-y (gvl :head-y))
				(cx (gvl :cx)) (cy (gvl :cy)))
			    (if (gvl :open-p)
				(list ax ay head-x head-y cx cy)
				(list ax ay head-x head-y cx cy ax ay)))))
  (:length 10)
  (:diameter 10)
  (:open-p t)
)

;;; To create a window for displaying gobs, create a schema which is an
;;; instance of the window class described below specifying slots as
;;; needed. For example:
;;;
;;; (create-instance my-window opal:window
;;;   (:width 100)
;;;   (:height 100))
;;;
(create-instance 'opal:WINDOW opal:view-object
  (:maybe-constant '(:left :top :width :height :visible))
  (:left 0)
  (:top 0)
  (:width 355)
  (:height 277)
  (:display *default-x-display-name*)
  (:local-only-slots '((:drawable nil) (:parent nil) (:window nil)))
  (:omit-title-bar-p NIL)
  (:aggregate)
  (:title)       ; set in :initialize method
  (:icon-title)  ; set in :initialize method
  (:border-width 2)
  (:cursor (o-formula
	    (let ((parent (gvl :parent)))
	      (if parent
		  (gv parent :cursor)
		  (cons opal::arrow-cursor opal::arrow-cursor-mask)))))
  (:ignored-slots (list :buffer-gc))
  (:update-slots  '(:visible :fast-redraw-p :aggregate :parent
                    :top :left :width :height
                    :cursor :title :icon-title
                    :display :background-color :icon-bitmap :draw-on-children
		    :modal-p :save-under)))

;;; Vile, icky, ugly hack to allow fonts to have sizes before being
;;; associated with a aggregate in a window.  Very likely to cause problems
;;; when making a Opal/Garnet core.
;(create-instance 'opal::FONT-HACK-WINDOW opal:window
;  (:visible nil)
;  (:width 0)
;  (:height 0))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;  *-FILL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(create-instance 'opal::WHITE-FILL opal:filling-style
  (:fill-style :opaque-stippled)
  (:stipple opal::white-fill-bitmap))

(create-instance 'opal::LIGHT-GRAY-FILL opal:filling-style
  (:fill-style :opaque-stippled)
  (:stipple opal::light-gray-fill-bitmap))

(create-instance 'opal::GRAY-FILL opal:filling-style
  (:fill-style :opaque-stippled)
  (:stipple opal::gray-fill-bitmap))

(create-instance 'opal::DARK-GRAY-FILL opal:filling-style
  (:fill-style :opaque-stippled)
  (:stipple opal::dark-gray-fill-bitmap))

(create-instance 'opal::BLACK-FILL opal:filling-style
  (:fill-style :solid))

(create-instance 'opal::RED-FILL opal:filling-style
  (:foreground-color opal:red))
(create-instance 'opal::GREEN-FILL opal:filling-style
  (:foreground-color opal:green))
(create-instance 'opal::BLUE-FILL opal:filling-style
  (:foreground-color opal:blue))
(create-instance 'opal::YELLOW-FILL opal:filling-style
  (:foreground-color opal:yellow))
(create-instance 'opal::ORANGE-FILL opal:filling-style
  (:foreground-color opal:orange))
(create-instance 'opal::CYAN-FILL opal:filling-style
  (:foreground-color opal:cyan))
(create-instance 'opal::PURPLE-FILL opal:filling-style
  (:foreground-color opal:purple))

