From 45aa75b8441d1ecc2374c9b899ef26ed421d9d79 Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Thu, 29 Oct 1992 16:55:47 +0000
Subject: [PATCH] fixes

---
 demo/color-editor.lisp     |  29 ++---
 demo/graphics-editor.lisp  |  26 +++--
 demo/ico.lisp              | 131 +++++++++++----------
 demo/plot.lisp             |   2 +-
 demo/puzzle.lisp           |  52 ++++-----
 silica/medium.lisp         |  38 +------
 silica/port.lisp           |   6 +-
 tk-silica/xm-silica.lisp   |  19 ++--
 tk-silica/xt-graphics.lisp | 228 ++++++++++++++++++-------------------
 tk-silica/xt-silica.lisp   |   2 +-
 tk/xlib.lisp               |   8 +-
 utils/base-designs.lisp    |  57 +++++-----
 utils/designs.lisp         | 214 +++++++++++++++++-----------------
 utils/packages.lisp        |  66 ++++-------
 14 files changed, 410 insertions(+), 468 deletions(-)

diff --git a/demo/color-editor.lisp b/demo/color-editor.lisp
index c056f41c..d707f0e3 100644
--- a/demo/color-editor.lisp
+++ b/demo/color-editor.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: color-editor.lisp,v 1.7 92/10/07 14:43:21 cer Exp $
+;; $fiHeader: color-editor.lisp,v 1.8 92/10/28 11:32:53 cer Exp $
 
 (in-package :clim-demo)
 
@@ -14,7 +14,7 @@
   (display-color (pane-frame stream) stream))
 
 (define-application-frame color-chooser ()
-    (color mutable-p
+    (color dynamic-p
      red blue green
      intensity hue saturation)
   (:menu-bar nil)
@@ -79,21 +79,22 @@
 	rgb ihs))))
 
 (defmethod run-frame-top-level :before ((frame color-chooser) &key)
-  (with-slots (color mutable-p) frame
-    (setf color (if (setf mutable-p (palette-color-p (frame-palette frame)))
-		    (make-mutable-color +black+)
-		    +black+))))
+  (with-slots (color dynamic-p) frame
+    (setf dynamic-p (palette-dynamic-p (frame-palette frame))
+	  color (if dynamic-p
+		    (make-dynamic-color +black+)
+		  +black+))))
 
 (defmethod color ((frame color-chooser))
-  (with-slots (color mutable-p) frame
-    (if mutable-p
-	(mutable-color-color color)
+  (with-slots (color dynamic-p) frame
+    (if dynamic-p
+	(dynamic-color-color color)
 	color)))
 
 (defmethod (setf color) (new-color (frame color-chooser))
-  (with-slots (color mutable-p) frame
-    (if mutable-p
-	(setf (mutable-color-color color) new-color)
+  (with-slots (color dynamic-p) frame
+    (if dynamic-p
+	(setf (dynamic-color-color color) new-color)
 	(setf color new-color))))
 
 (defmethod display-color ((frame color-chooser) stream)
@@ -167,8 +168,8 @@
 (defmethod value-changed-callback :after ((slider slider) (client (eql 'color)) id value)
   (declare (ignore id value))
   (let ((frame (pane-frame slider)))
-    (with-slots (mutable-p) frame
-      (unless mutable-p
+    (with-slots (dynamic-p) frame
+      (unless dynamic-p
 	;; Redisplay the color swatch only if we haven't done so
 	;; by changing the color in-place
 	(redisplay-frame-pane (pane-frame slider) 'display)))))
diff --git a/demo/graphics-editor.lisp b/demo/graphics-editor.lisp
index 706552b9..5b434ba5 100644
--- a/demo/graphics-editor.lisp
+++ b/demo/graphics-editor.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-GRAPHICS-EDITOR; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: graphics-editor.lisp,v 1.12 92/10/28 11:32:57 cer Exp Locker: cer $
+;; $fiHeader: graphics-editor.lisp,v 1.13 92/10/28 13:17:33 cer Exp $
 
 (in-package :clim-graphics-editor)
 
@@ -162,14 +162,6 @@
 		  (box-label object) (+ left (floor (- right left) 2))
 		  (+ top 2) :align-x :center :align-y :top))))
 
-#+allegro
-(defparameter *box-highlighting-ink*
-	      (make-flipping-ink +background-ink+ +red+))
-
-#+allegro
-(defparameter *box-highlighting-line-style*
-	      (make-line-style :thickness 2))
-
 #+allegro
 (define-presentation-method highlight-presentation ((type box) record stream state)
   (declare (ignore state))
@@ -180,8 +172,13 @@
       (draw-rectangle* stream 
 		       (+ xoff (- left 3)) (+ yoff (- top 3))
 		       (+ xoff right 3) (+ yoff bottom 3)
-		       :ink *box-highlighting-ink*
-		       :line-style *box-highlighting-line-style*
+		       :ink (make-flipping-ink 
+			     (if (palette-color-p
+				  (frame-palette (pane-frame stream)))
+				 +red+
+			       +foreground-ink+)
+			     +background-ink+)
+		       :line-style (make-line-style :thickness 2) 
 		       :filled nil))))
 
 (defmethod move-object :after ((object box) x y)
@@ -428,7 +425,12 @@
 	(last-box (slot-value *application-frame* 'last-box))
 	(style (slot-value *application-frame* 'style))
 	(shape (slot-value *application-frame* 'shape))
-	(flipping-ink #+allegro (make-flipping-ink +blue+ +background-ink+)
+	(flipping-ink #+allegro 
+		      (make-flipping-ink (if (palette-color-p
+					      (frame-palette *application-frame*))
+					     +blue+
+					   +foreground-ink+) 
+					 +background-ink+)
 		      #-allegro +flipping-ink+))
     ;;--- Zdrava supplies primitives to input basic objects such as
     ;;--- points, lines, rectangles and polygons, circles and ellipses,
diff --git a/demo/ico.lisp b/demo/ico.lisp
index 4950e493..66bbc55b 100644
--- a/demo/ico.lisp
+++ b/demo/ico.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: ico.lisp,v 1.11 92/10/28 11:32:58 cer Exp Locker: cer $
+;; $fiHeader: ico.lisp,v 1.12 92/10/28 13:17:35 cer Exp $
 
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
@@ -29,8 +29,8 @@
     ((ico-time-p :initform t)
      (ico-line-style :initform :thin)
      (ico-buffers :initform 1)
-     (ico-color-group2 :initform nil)
-     (ico-color-group3 :initform nil)
+     (ico-color-set2 :initform nil)
+     (ico-color-set3 :initform nil)
      (inks0 :initform (vector *background-color*))
      (inks1 :initform (vector *line-color*))
      (inks2 :initform (vector *face1-color*))
@@ -70,63 +70,54 @@
 				     :default ico-line-style
 				     :stream pane
 				     :prompt "Line style")))
+      (when (palette-dynamic-p (frame-palette frame))
 	(formatting-cell (pane)
-	    (let ((x (append (and draw-faces '(:faces))
-			     (and draw-edges '(:edges)))))
-	      (setf x (accept '(subset :faces :edges) :default x :stream pane :prompt "Choose"))
-	      (setf draw-edges (and (member :edges x) t)
-		    draw-faces (and (member :faces x) t))))
-	(formatting-cell (pane)
-	    (setf ico-line-style (accept '(member :thin :thick)
-					 :default ico-line-style
-					 :stream pane
-					 :prompt "Line Style")))
-	(when (palette-mutable-p (frame-palette frame))
-	  (formatting-cell (pane)
-	      (multiple-value-bind (buffering ptype changed)
-		  (accept '(member :single :double :triple)
-			  :default (svref #(:single :double :triple) (1- ico-buffers))
-			  :stream pane
-			  :prompt "Buffering")
-		(declare (ignore ptype))
-		(when changed
-		  (with-slots (ico-color-group2 ico-color-group3
-						inks0 inks1 inks2 inks3) frame    
-		    (case buffering
-		      (:single 
-		       (setf ico-buffers 1
-			     inks0 (vector *background-color*)
-			     inks1 (vector *line-color*)
-			     inks2 (vector *face1-color*)
-			     inks3 (vector *face2-color*)))
-		      (:double
-		       (let ((g (or ico-color-group2
-				    (setf ico-color-group2 (make-color-group 4 4)))))
-			 (setf ico-buffers 2
-			       inks0 (vector (group-color g 0 nil)
-					     (group-color g nil 0))
-			       inks1 (vector (group-color g 1 nil)
-					     (group-color g nil 1))
-			       inks2 (vector (group-color g 2 nil)
-					     (group-color g nil 2))
-			       inks3 (vector (group-color g 3 nil)
-					     (group-color g nil 3)))))
-		      (:triple
-		       (let ((g (or ico-color-group3
-				    (setf ico-color-group3 (make-color-group 4 4 4)))))
-			 (setf ico-buffers 3
-			       inks0 (vector (group-color g 0 nil nil)
-					     (group-color g nil 0 nil)
-					     (group-color g nil nil 0))
-			       inks1 (vector (group-color g 1 nil nil)
-					     (group-color g nil 1 nil)
-					     (group-color g nil nil 1))
-			       inks2 (vector (group-color g 2 nil nil)
-					     (group-color g nil 2 nil)
-					     (group-color g nil nil 2))
-			       inks3 (vector (group-color g 3 nil nil)
-					     (group-color g nil 3 nil)
-					     (group-color g nil nil 3))))))))))))))
+	    (multiple-value-bind (buffering ptype changed)
+		(accept '(member :single :double :triple)
+			:default (svref #(:single :double :triple) (1- ico-buffers))
+			:stream pane
+			:prompt "Buffering")
+	      (declare (ignore ptype))
+	      (when changed
+		(with-slots (ico-color-set2 ico-color-set3
+					    inks0 inks1 inks2 inks3) frame    
+		  (case buffering
+		    (:single 
+		     (setf ico-buffers 1
+			   inks0 (vector *background-color*)
+			   inks1 (vector *line-color*)
+			   inks2 (vector *face1-color*)
+			   inks3 (vector *face2-color*)))
+		    (:double
+		     (let ((g (or ico-color-set2
+				  (setf ico-color-set2 
+				    (make-layered-color-set 4 4)))))
+		       (setf ico-buffers 2
+			     inks0 (vector (layered-color g 0 nil)
+					   (layered-color g nil 0))
+			     inks1 (vector (layered-color g 1 nil)
+					   (layered-color g nil 1))
+			     inks2 (vector (layered-color g 2 nil)
+					   (layered-color g nil 2))
+			     inks3 (vector (layered-color g 3 nil)
+					   (layered-color g nil 3)))))
+		    (:triple
+		     (let ((g (or ico-color-set3
+				  (setf ico-color-set3
+				    (make-layered-color-set 4 4 4)))))
+		       (setf ico-buffers 3
+			     inks0 (vector (layered-color g 0 nil nil)
+					   (layered-color g nil 0 nil)
+					   (layered-color g nil nil 0))
+			     inks1 (vector (layered-color g 1 nil nil)
+					   (layered-color g nil 1 nil)
+					   (layered-color g nil nil 1))
+			     inks2 (vector (layered-color g 2 nil nil)
+					   (layered-color g nil 2 nil)
+					   (layered-color g nil nil 2))
+			     inks3 (vector (layered-color g 3 nil nil)
+					   (layered-color g nil 3 nil)
+					   (layered-color g nil nil 3))))))))))))))
 
 (define-ico-frame-command (com-ico-throw-ball :menu "Throw ball" :keystroke #\t) ()
   (with-application-frame (frame)
@@ -138,8 +129,16 @@
 
 (define-ico-frame-command (com-ico-quit :menu "Quit" :keystroke #\q) ()
   (with-application-frame (frame)
-    (catch-ball frame)
-    (frame-exit frame)))
+    (with-slots (ico-color-set2 ico-color-set3) frame
+      (let ((palette (frame-palette frame)))
+	(catch-ball frame)
+	(when ico-color-set2
+	  (remove-from-palette palette ico-color-set2)
+	  (setf ico-color-set2 nil))
+	(when ico-color-set3
+	  (remove-from-palette palette ico-color-set3)
+	  (setf ico-color-set3 nil))
+	(frame-exit frame)))))
 
 (defmethod disable-frame :after ((frame ico-frame))
   (catch-ball frame))
@@ -256,11 +255,11 @@
 					  (svref inks2 buffer)
 					  (svref inks3 buffer)))))
 	      (when (> ico-buffers 1)
-		(with-delayed-mutations
-		  (mutate-color (svref inks0 buffer) *background-color*)
-		  (mutate-color (svref inks1 buffer) *line-color*)
-		  (mutate-color (svref inks2 buffer) *face1-color*)
-		  (mutate-color (svref inks3 buffer) *face2-color*)))
+		(with-delayed-recoloring
+		  (setf (layered-color-color (svref inks0 buffer)) *background-color*
+			(layered-color-color (svref inks1 buffer)) *line-color*
+			(layered-color-color (svref inks2 buffer)) *face1-color*
+			(layered-color-color (svref inks3 buffer)) *face2-color*)))
 	      (silica:medium-force-output medium))
 	    
 	    #+xlib-ignore
diff --git a/demo/plot.lisp b/demo/plot.lisp
index 18394f09..f695ee36 100644
--- a/demo/plot.lisp
+++ b/demo/plot.lisp
@@ -21,7 +21,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: plot.lisp,v 1.13 92/10/28 11:33:05 cer Exp Locker: cer $
+;; $fiHeader: plot.lisp,v 1.14 92/10/29 15:02:50 cer Exp Locker: cer $
 
 (in-package :clim-demo)
 
diff --git a/demo/puzzle.lisp b/demo/puzzle.lisp
index d766f63e..320a19b0 100644
--- a/demo/puzzle.lisp
+++ b/demo/puzzle.lisp
@@ -1,28 +1,25 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: puzzle.lisp,v 1.19 92/10/07 14:43:50 cer Exp $
+;; $fiHeader: puzzle.lisp,v 1.20 92/10/28 11:33:08 cer Exp Locker: cer $
 
 (in-package :clim-demo)
 
 "Copyright (c) 1989, 1990, 1991, 1992 Symbolics, Inc.  All rights reserved."
 
 (define-application-frame puzzle ()
-    ((puzzle :initform (make-array '(4 4))
-	     :accessor puzzle-puzzle))
+			  ((puzzle :initform (make-array '(4 4))
+				   :accessor puzzle-puzzle))
   (:panes
-    (display :application
-	     :text-cursor nil
-	     :width :compute
-	     :max-width +fill+
-	     :height :compute
-	     :max-height +fill+
-	     :end-of-page-action :allow
-	     :end-of-line-action :allow
-	     :text-style '(:fix :bold :very-large)
-	     :incremental-redisplay t
-	     :display-function 'draw-puzzle))
+   (display :application
+	    :display-function 'draw-puzzle
+	    :text-style '(:fix :bold :very-large)
+	    :incremental-redisplay t
+	    :text-cursor nil
+	    :width :compute :height :compute
+	    :end-of-page-action :allow
+	    :end-of-line-action :allow))
   (:layouts
-    (:default display)))
+   (:default display)))
 
 (defmethod frame-standard-input ((puzzle puzzle))
   (get-frame-pane puzzle 'display))
@@ -72,22 +69,19 @@
 (defmethod draw-puzzle ((puzzle puzzle) stream &key max-width max-height)
   (declare (ignore max-width max-height))
   (let ((puzzle-array (puzzle-puzzle puzzle)))
-    ;; I'm not sure why the table sometimes draws in the wrong place if I don't do this
-    (stream-set-cursor-position stream 0 0)
-    (updating-output (stream)
-      (formatting-table (stream)
+    (formatting-table (stream)
 	(dotimes (row 4)
 	  (formatting-row (stream)
-	    (dotimes (column 4)
-	      (let* ((value (aref puzzle-array row column))
-		     (cell-id (encode-puzzle-cell row column)))
-		(updating-output (stream :unique-id cell-id 
-					 :cache-value value)
-		  (formatting-cell (stream :align-x :right)
-		    (unless (zerop value)
-		      (with-output-as-presentation 
-			  (stream cell-id 'puzzle-cell)
-			(format stream "~2D" value)))))))))))))
+	      (dotimes (column 4)
+		(let* ((value (aref puzzle-array row column))
+		       (cell-id (encode-puzzle-cell row column)))
+		  (updating-output (stream :unique-id cell-id 
+					   :cache-value value)
+		      (formatting-cell (stream :align-x :right)
+			  (unless (zerop value)
+			    (with-output-as-presentation 
+				(stream cell-id 'puzzle-cell)
+			      (format stream "~2D" value))))))))))))
 
 (defun find-open-cell (puzzle)
   (dotimes (row 4)
diff --git a/silica/medium.lisp b/silica/medium.lisp
index 0af27057..8268ad1f 100644
--- a/silica/medium.lisp
+++ b/silica/medium.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: medium.lisp,v 1.26 92/10/28 11:30:50 cer Exp Locker: cer $
+;; $fiHeader: medium.lisp,v 1.27 92/10/28 13:17:09 cer Exp $
 
 (in-package :silica)
 
@@ -448,39 +448,3 @@
 (generate-trampolines medium-protocol medium standard-sheet-output-mixin
 		      `(sheet-medium ,standard-sheet-output-mixin))
 
-;;; not clear that these should be here.
-
-(defmethod sheet-palette ((sheet sheet))
-  (let* ((frame (pane-frame sheet))
-	 (framem (and frame (frame-manager frame))))
-    (if framem
-	(frame-manager-palette framem)
-      (port-default-palette (port sheet)))))
-
-(defmethod medium-palette ((medium medium))
-  (sheet-palette (medium-sheet medium)))
-
-;;; especially these - could be with other named-color stuff in
-;;; utils/designs but things like port, sheet, medium aren't known
-;;; there.
-
-;;; think we might want a silica/palette.lisp
-
-(defmethod find-named-color (name (port port))
-  (find-named-color name (port-default-palette port)))
-
-(define-condition palette-full (serious-condition) ())
-
-(defmethod add-to-palette ((palette basic-palette) &rest colors)
-  (let ((colors-done nil))
-    (dolist (color colors)
-      (handler-case
-	  (allocate-color color palette)
-	(palette-full (condition)
-	  (dolist (color colors-done)
-	    (free-color color palette))
-	  (signal condition))))))
-
-(defmethod remove-from-palette ((palette basic-palette) &rest colors)
-  (dolist (color colors)
-    (free-color color palette)))
diff --git a/silica/port.lisp b/silica/port.lisp
index b8b1ccd9..7946a1ac 100644
--- a/silica/port.lisp
+++ b/silica/port.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: port.lisp,v 1.21 92/10/02 15:18:32 cer Exp $
+;; $fiHeader: port.lisp,v 1.22 92/10/28 11:30:53 cer Exp $
 
 (in-package :silica)
 
@@ -32,6 +32,9 @@
 			(return-from find-port port))))
   (make-port :server-path server-path))
 
+(defmethod find-named-color (name (port port))
+  (find-named-color name (port-default-palette port)))
+
 #+Genera
 (scl:add-initialization "Reset ports"
   '(progn
@@ -245,4 +248,3 @@
 (defgeneric graft-height (graft))
 (defgeneric graft-pixels-per-millimeter (graft))
 (defgeneric graft-pixels-per-inch (graft))
-
diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp
index 4ec57d56..5171e671 100644
--- a/tk-silica/xm-silica.lisp
+++ b/tk-silica/xm-silica.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-silica.lisp,v 1.25 92/08/18 17:54:31 cer Exp $
+;; $fiHeader: xm-silica.lisp,v 1.26 92/10/02 15:21:04 cer Exp $
 
 (in-package :xm-silica)
 
@@ -75,13 +75,16 @@
 		 :height 11
 		 :managed t))
 
-;(ff:defforeign 'xmprocesstraversal
-;    :entry-point "_XmProcessTraversal")
-;(defmethod port-note-cursor-change :after ((port motif-port)
-;					   cursor stream type old new)
-;  (declare (ignore old type cursor))
-;  (when new
-;    (xmprocesstraversal (sheet-mirror stream) 0)))
+#+ignore 
+(ff:defforeign 'xmprocesstraversal
+    :entry-point "_XmProcessTraversal")
+
+#+ignore 
+(defmethod port-note-cursor-change :after ((port motif-port)
+					   cursor stream type old new)
+  (declare (ignore old type cursor))
+  (when new
+    (xmprocesstraversal (sheet-mirror stream) 0)))
 
 (defmethod enable-xt-widget ((parent tk::xm-dialog-shell) (mirror t))
   ;; this is a nasty hack just to make sure that the child is managed.
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index 5f852215..bf53f82d 100644
--- a/tk-silica/xt-graphics.lisp
+++ b/tk-silica/xt-graphics.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-graphics.lisp,v 1.46 92/10/28 11:33:22 cer Exp Locker: cer $
+;; $fiHeader: xt-graphics.lisp,v 1.47 92/10/28 13:17:45 cer Exp $
 
 (in-package :tk-silica)
 
@@ -82,7 +82,7 @@
     (make-instance 'xt-palette
 		   :port port
 		   :colormap colormap
-		   :mutable-p (and 
+		   :dynamic-p (and 
 			       (member (port-visual-class port)
 				       '(:gray-scale :pseudo-color :direct-color))
 			       t)
@@ -93,6 +93,14 @@
 (defmethod make-palette ((port xt-port) &key)
   (make-xt-palette port (tk::create-colormap (port-display port))))
 
+(defmethod medium-palette ((medium xt-medium))
+  (let* ((sheet (medium-sheet medium))
+	 (frame (pane-frame sheet))
+	 (framem (and frame (frame-manager frame))))
+    (if framem
+	(frame-manager-palette framem)
+      (port-default-palette (port sheet)))))
+
 #+ignore
 (defmethod (setf frame-manager-palette) :after 
 	   ((palette xt-palette) (framem standard-frame-manager))
@@ -157,30 +165,23 @@
 
 ;;; things we can install in a palete
 ;;; 1 - color (rgb etc)
-;;; 2 - mutable-color
-;;; 3 - color-group or group-color or both ??
-
-(defmethod allocate-color :around (color (palette xt-palette))
-  (declare (ignore color))
-  (handler-case
-      (call-next-method)
-    (tk::x-colormap-error ()
-      (error 'palette-full))))
-  
+;;; 2 - dynamic-color
+;;; 3 - layered-color
+
 (defmethod allocate-color ((color color) (palette xt-palette))
   (unless (gethash color (palette-color-cache palette))
     (decode-color-in-palette color palette)))
 
-(defmethod allocate-color ((color mutable-color) (palette xt-palette))
-  (unless (gethash color (palette-mutable-color-cache palette))
+(defmethod allocate-color ((color dynamic-color) (palette xt-palette))
+  (unless (gethash color (palette-dynamic-color-cache palette))
     (decode-color-in-palette color palette)))
 
-(defmethod allocate-color ((group color-group) (palette xt-palette))
-  (unless (gethash group (palette-color-group-cache palette))
-    (decode-color-group group palette)))
+(defmethod allocate-color ((set layered-color-set) (palette xt-palette))
+  (unless (gethash set (palette-layered-color-cache palette))
+    (decode-layered-color-set set palette)))
 
-(defmethod allocate-color ((color group-color) (palette xt-palette))
-  (allocate-color (group-color-group color) palette))
+(defmethod allocate-color ((color layered-color) (palette xt-palette))
+  (allocate-color (layered-color-set color) palette))
 
 (defmethod free-color ((color color) (palette xt-palette))
   (let* ((color-cache (palette-color-cache palette))
@@ -189,22 +190,22 @@
       (tk::free-color-cells (palette-colormap palette) pixel 0)
       (remhash color color-cache))))
 
-(defmethod free-color ((color mutable-color) (palette xt-palette))
-  (let* ((mutable-color-cache (palette-mutable-color-cache palette))
-	 (pixel (gethash color mutable-color-cache)))
+(defmethod free-color ((color dynamic-color) (palette xt-palette))
+  (let* ((dynamic-color-cache (palette-dynamic-color-cache palette))
+	 (pixel (gethash color dynamic-color-cache)))
     (when pixel
       (tk::free-color-cells (palette-colormap palette) pixel 0)
-      (remhash color mutable-color-cache))))
+      (remhash color dynamic-color-cache))))
 
-(defmethod free-color ((color group-color) (palette xt-palette))
-  (free-color (group-color-group color) palette))
+(defmethod free-color ((color layered-color) (palette xt-palette))
+  (free-color (layered-color-set color) palette))
 
-(defmethod free-color ((group color-group) (palette xt-palette))
-  (let* ((color-group-cache (palette-color-group-cache palette))
-	 (pixel-planes (gethash group color-group-cache)))
+(defmethod free-color ((set layered-color-set) (palette xt-palette))
+  (let* ((layered-color-cache (palette-layered-color-cache palette))
+	 (pixel-planes (gethash set layered-color-cache)))
     (when pixel-planes
-      (let ((mutable-color-cache (palette-mutable-color-cache palette))
-	    (mutable-array (color-group-mutable-array group))
+      (let ((dynamic-color-cache (palette-dynamic-color-cache palette))
+	    (dynamic-array (layered-color-set-dynamic-array set))
 	    (planes 0))
 	(dolist (plane-masks (cdr pixel-planes))
 	  (dolist (plane-mask plane-masks)
@@ -212,28 +213,20 @@
 	(tk::free-color-cells (palette-colormap palette)
 			      (car pixel-planes)
 			      planes)
-	(map-over-group-colors
+	(map-over-layered-colors
 	 #'(lambda (dimensions)
-	     (let ((mutable-color (apply #'aref mutable-array dimensions)))
-	       (remhash mutable-color mutable-color-cache)
-	       (setf (mutable-color-palettes mutable-color)
-		 (delete palette (mutable-color-palettes mutable-color)))))
-	 group)
-	(maphash #'(lambda (group-color pixel-mask)
+	     (let ((dynamic-color (apply #'aref dynamic-array dimensions)))
+	       (remhash dynamic-color dynamic-color-cache)
+	       (setf (dynamic-color-palettes dynamic-color)
+		 (delete palette (dynamic-color-palettes dynamic-color)))))
+	 set)
+	(maphash #'(lambda (layered-color pixel-mask)
 		     (declare (ignore pixel-mask))
-		     (when (and (typep group-color 'group-color)
-				(eq (group-color-group group-color) group))
-		       (remhash group-color color-group-cache)))
-		 color-group-cache)
-	(remhash group color-group-cache)))))
-;;;
-
-(defmethod medium-drawable ((medium xt-medium))
-  (with-slots (drawable sheet) medium
-    (or drawable
-	(setf drawable (fetch-medium-drawable 
-			sheet
-			(sheet-mirror sheet))))))
+		     (when (and (typep layered-color 'layered-color)
+				(eq (layered-color-set layered-color) set))
+		       (remhash layered-color layered-color-cache)))
+		 layered-color-cache)
+	(remhash set layered-color-cache)))))
 
 
 ;;
@@ -482,7 +475,7 @@
 ;;; there otherwise make a gc using decode-color-in-palette to get the
 ;;; pixel value
 
-;;--- This is really on color, mutable-color, and group-color.
+;;--- This is really on color, dynamic-color, and layered-color.
 ;;--- Perhaps there should be a class like basic-color?
 
 (defmethod decode-ink ((ink design) (medium xt-medium))
@@ -512,34 +505,33 @@
 
 (defmethod decode-ink ((ink flipping-ink) (medium xt-medium))
   (let ((palette (medium-palette medium)))
-    (with-slots (color-p) palette
-      (with-slots (ink-table sheet tile-gcontext drawable indirect-inks)
-	  medium
-	(or (gethash ink ink-table)
-	    (let* ((drawable (or drawable
-				 (tk::display-root-window (port-display (port sheet)))))
-		   (new-gc (make-instance 'fast-gcontext 
-					  :drawable drawable
-					  :function boole-xor)))
-	      (multiple-value-bind (color1 color2)
-		  (decode-flipping-ink ink)
-		(cond (color-p
-		       (setf (tk::gcontext-foreground new-gc)
-			 (logxor (decode-color color1 medium)
-				 (decode-color color2 medium))))
-		      ;;-- support gray-scale here
-		      (t
-		       ;; in a monochrome context there is only one
-		       ;; flipping ink availiable ie white <-> black
-		       (slot-value medium 'flipping-gcontext)))
-		(when (indirect-ink-p ink)
-		  (push ink indirect-inks))
-		(setf (gethash ink ink-table) new-gc))))))))
+    (with-slots (ink-table sheet tile-gcontext drawable indirect-inks)
+	medium
+      (or (gethash ink ink-table)
+	  (let* ((drawable (or drawable
+			       (tk::display-root-window (port-display (port sheet)))))
+		 (new-gc (make-instance 'fast-gcontext 
+					:drawable drawable
+					:function boole-xor)))
+	    (multiple-value-bind (color1 color2)
+		(decode-flipping-ink ink)
+	      (cond ((palette-color-p palette)
+		     (setf (tk::gcontext-foreground new-gc)
+		       (logxor (decode-color color1 medium)
+			       (decode-color color2 medium))))
+		    ;;-- support gray-scale here
+		    (t
+		     ;; in a monochrome context there is only one
+		     ;; flipping ink availiable ie white <-> black
+		     (slot-value medium 'flipping-gcontext)))
+	      (when (indirect-ink-p ink)
+		(push ink indirect-inks))
+	      (setf (gethash ink ink-table) new-gc)))))))
 		 
 
 (defmethod decode-ink ((ink color) (medium xt-medium))
   (let ((palette (medium-palette medium)))
-    (with-slots (white-pixel black-pixel color-p) palette
+    (with-slots (white-pixel black-pixel) palette
       (with-slots (ink-table sheet tile-gcontext drawable) medium
 	(or (gethash ink ink-table)
 	    (let* ((drawable 
@@ -645,37 +637,43 @@ and on color servers, unless using white or black")
 	(setf (gethash color color-cache)
 	  (with-slots (white-pixel black-pixel) palette
 	    (cond ((palette-color-p palette)
-		   (tk::allocate-color
-		    (palette-colormap palette) (get-xcolor color palette)))
+		   (handler-case
+		       (tk::allocate-color
+			(palette-colormap palette) (get-xcolor color palette))
+		     (tk::x-colormap-error ()
+		       (error 'palette-full))))
 		  ;;-- support gray-scale here
 		  (t
 		   (multiple-value-bind (r g b) (color-rgb color)
 		     (let ((luminosity (color-luminosity r g b)))
 		       (if (> luminosity .5) white-pixel black-pixel))))))))))
 
-(defmethod decode-color-in-palette ((color mutable-color) (palette xt-palette))
-  (let ((mutable-color-cache (palette-mutable-color-cache palette)))
-    (or (gethash color mutable-color-cache)
-	(let ((pixel (aref (tk::alloc-color-cells
-			     (palette-colormap palette) 1 0)
+(defmethod decode-color-in-palette ((color dynamic-color) (palette xt-palette))
+  (let ((dynamic-color-cache (palette-dynamic-color-cache palette)))
+    (or (gethash color dynamic-color-cache)
+	(let ((pixel (aref (handler-case
+			       (tk::alloc-color-cells
+				(palette-colormap palette) 1 0)
+			     (tk::x-colormap-error ()
+			       (error 'palette-full)))
 			   0)))
-	  (update-palette-entry palette pixel (mutable-color-color color))
-	  (push palette (mutable-color-palettes color))
-	  (setf (gethash color mutable-color-cache) pixel)))))
+	  (update-palette-entry palette pixel (dynamic-color-color color))
+	  (push palette (dynamic-color-palettes color))
+	  (setf (gethash color dynamic-color-cache) pixel)))))
 
-(defmethod decode-color-in-palette ((color group-color) (palette xt-palette))
-  (let ((color-group-cache (palette-color-group-cache palette)))
+(defmethod decode-color-in-palette ((color layered-color) (palette xt-palette))
+  (let ((layered-color-cache (palette-layered-color-cache palette)))
     (values-list
-     (or (gethash color color-group-cache)
-	 (setf (gethash color color-group-cache)
-	   (let* ((group (group-color-group color))
-		  (pixel-planes (gethash group color-group-cache))) 
+     (or (gethash color layered-color-cache)
+	 (setf (gethash color layered-color-cache)
+	   (let* ((set (layered-color-set color))
+		  (pixel-planes (gethash set layered-color-cache))) 
 	     (unless pixel-planes
-	       (setq pixel-planes (decode-color-group group palette)))
+	       (setq pixel-planes (decode-layered-color-set set palette)))
 	     (multiple-value-list 
-		 (decode-group-color (group-color-layers color) pixel-planes))))))))
+		 (decode-layered-color (layered-color-layers color) pixel-planes))))))))
 
-(defun decode-group-color (layers pixel-planes)
+(defun decode-layered-color (layers pixel-planes)
   (let ((pixel (car pixel-planes))
 	(planes (cdr pixel-planes))
 	(mask 0)) 
@@ -692,11 +690,11 @@ and on color servers, unless using white or black")
 	    (setq mask (logior mask plane-mask))))))
     (values pixel (lognot mask))))
 
-(defun decode-color-group (group palette)
-  (let ((color-group-cache (palette-color-group-cache palette))
-	(mutable-color-cache (palette-mutable-color-cache palette))
-	(layers (color-group-layers group))
-	(mutable-array (color-group-mutable-array group))
+(defun decode-layered-color-set (set palette)
+  (let ((layered-color-cache (palette-layered-color-cache palette))
+	(dynamic-color-cache (palette-dynamic-color-cache palette))
+	(layers (layered-color-set-layers set))
+	(dynamic-array (layered-color-set-dynamic-array set))
 	layer-nplanes
 	(total-nplanes 0))
     (dolist (layer layers)
@@ -704,8 +702,11 @@ and on color servers, unless using white or black")
 	(push nplanes layer-nplanes)
 	(incf total-nplanes nplanes)))
     (multiple-value-bind (pixels masks)
-	(tk::alloc-color-cells
-	 (palette-colormap palette) 1 total-nplanes)
+	(handler-case
+	    (tk::alloc-color-cells
+	     (palette-colormap palette) 1 total-nplanes)
+	  (tk::x-colormap-error ()
+	    (error 'palette-full)))
       (let ((pixel (aref pixels 0))
 	    (count 0)
 	    (planes nil))
@@ -716,23 +717,22 @@ and on color servers, unless using white or black")
 	      (incf count))
 	    (push plane-masks planes)))
 	(let ((pixel-planes (cons pixel planes)))
-	  (map-over-group-colors 
+	  (map-over-layered-colors 
 	   #'(lambda (dimensions)
-	       (let ((mutable-color (apply #'aref mutable-array dimensions))
-		     (pixel (decode-group-color dimensions
-						pixel-planes)))
-		 (setf (gethash mutable-color mutable-color-cache) pixel)
-		 (update-palette-entry palette pixel (mutable-color-color mutable-color))
-		 (push palette (mutable-color-palettes mutable-color))))
-	   group)
-	  (setf (gethash group color-group-cache) pixel-planes))))))
+	       (let ((dynamic-color (apply #'aref dynamic-array dimensions))
+		     (pixel (decode-layered-color dimensions
+						  pixel-planes)))
+		 (setf (gethash dynamic-color dynamic-color-cache) pixel)
+		 (update-palette-entry palette pixel (dynamic-color-color dynamic-color))
+		 (push palette (dynamic-color-palettes dynamic-color))))
+	   set)
+	  (setf (gethash set layered-color-cache) pixel-planes))))))
 	    
 (defmethod decode-color ((ink contrasting-ink) (medium xt-medium))
   (let ((palette (medium-palette medium)))
-    (with-slots (color-p) palette
-      (decode-color (if color-p
-			(make-color-for-contrasting-ink ink)
-		      (make-gray-color-for-contrasting-ink ink)) medium))))
+    (decode-color (if (palette-color-p palette)
+		      (make-color-for-contrasting-ink ink)
+		    (make-gray-color-for-contrasting-ink ink)) medium)))
 
 (defvar *default-dashes* '(4 4))
 
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index a598429f..7386f2d3 100644
--- a/tk-silica/xt-silica.lisp
+++ b/tk-silica/xt-silica.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-silica.lisp,v 1.52 92/10/28 13:17:48 cer Exp Locker: cer $
+;; $fiHeader: xt-silica.lisp,v 1.53 92/10/29 15:02:59 cer Exp Locker: cer $
 
 (in-package :xm-silica)
 
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index ff1fcbba..6c574d66 100644
--- a/tk/xlib.lisp
+++ b/tk/xlib.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xlib.lisp,v 1.30 92/10/28 11:30:39 cer Exp Locker: cer $
+;; $fiHeader: xlib.lisp,v 1.31 92/10/28 13:17:01 cer Exp $
 
 (in-package :tk)
 
@@ -247,7 +247,7 @@
 (eval-when (load)
   (setup-error-handlers))
 
-(define-condition x-colormap-error (serious-condition) ())
+(define-condition x-colormap-full (serious-condition) ())
 
 ;;--
 
@@ -335,7 +335,7 @@
       ;;-- Perhaps the colormap code should enable the user to
       ;;-- intercept this or we should just resort to some kind of stippling
       (if (zerop z)
-	  (error 'x-colormap-error)
+	  (error 'x-colormap-full)
 	(values (x11:xcolor-pixel y)
 		(make-instance 'color :foreign-address y))))))
 
@@ -421,7 +421,7 @@
 	     pixels
 	     ncolors)))
     (when (zerop z)
-      (error 'x-colormap-error))
+      (error 'x-colormap-full))
     (values pixels masks)))
 
    
diff --git a/utils/base-designs.lisp b/utils/base-designs.lisp
index 22abcb74..469e7ad3 100644
--- a/utils/base-designs.lisp
+++ b/utils/base-designs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: base-designs.lisp,v 1.2 92/10/04 14:16:12 cer Exp $
+;; $fiHeader: base-designs.lisp,v 1.3 92/10/28 11:30:57 cer Exp $
 
 (in-package :clim-utils)
 
@@ -64,7 +64,6 @@
   (with-slots (red green blue) color
     `(make-rgb-color ,red ,green ,blue)))
 
-
 (defclass ihs-color (color)
     ((intensity  :type single-float :initarg :intensity)
      (hue	 :type single-float :initarg :hue)
@@ -85,14 +84,14 @@
 (defclass basic-palette (palette)
     ((port :reader palette-port :initarg :port)
      (color-p :reader palette-color-p :initarg :color-p)
-     (mutable-p :reader palette-mutable-p :initarg :mutable-p)
+     (dynamic-p :reader palette-dynamic-p :initarg :dynamic-p)
      (color-cache :reader palette-color-cache :initform (make-hash-table))
-     (mutable-color-cache :reader palette-mutable-color-cache
+     (dynamic-color-cache :reader palette-dynamic-color-cache
+			  :initform (make-hash-table))
+     (layered-color-cache :reader palette-layered-color-cache
 			  :initform (make-hash-table))
-     (color-group-cache :reader palette-color-group-cache
-			:initform (make-hash-table))
-     (delayed-mutations :reader palette-delayed-mutations
-			:initform (make-array 32 :adjustable t :fill-pointer 0))))
+     (delayed-recolors :reader palette-delayed-recolors
+			  :initform (make-array 32 :adjustable t :fill-pointer 0))))
 
 (defgeneric make-palette (port &key))
 
@@ -105,42 +104,42 @@
 (defgeneric update-palette-entries (palette updates))
 
 
-;;; Mutable Colors 
+;;; Dynamic Colors 
 
-(defclass mutable-color (color)
-    ((color :accessor mutable-color-color :initarg :color)
+(defclass dynamic-color (color)
+    ((color :accessor dynamic-color-color :initarg :color)
      (palettes :type list 
 	       :initform nil
-	       :accessor mutable-color-palettes)))
+	       :accessor dynamic-color-palettes)))
 
-(define-constructor make-mutable-color-1 mutable-color (color) 
+(define-constructor make-dynamic-color dynamic-color (color) 
 		    :color color)
 
-(defmethod make-load-form ((color mutable-color))
+(defmethod make-load-form ((color dynamic-color))
   (with-slots (color) color
-    `(make-mutable-color ,color)))
+    `(make-dynamic-color ,color)))
 
 
-;;; Color Groups
+;;; Layered Colors
 
-(defclass color-group ()
-    ((layers :initform nil :reader color-group-layers :initarg :layers)
-     (cache :initform (make-hash-table :test #'equal) :reader color-group-cache)
-     (mutable-array :reader color-group-mutable-array :initarg :mutable-array)))
+(defclass layered-color-set ()
+    ((layers :initform nil :reader layered-color-set-layers :initarg :layers)
+     (cache :initform (make-hash-table :test #'equal) :reader layered-color-set-cache)
+     (dynamic-array :reader layered-color-set-dynamic-array :initarg :dynamic-array)))
 
-(define-constructor make-color-group color-group (&rest layers)
+(define-constructor make-layered-color-set layered-color-set (&rest layers)
 		    :layers layers
-		    :mutable-array (make-array layers))
+		    :dynamic-array (make-array layers))
 
-(defgeneric group-color (color-group &rest layers))
+(defgeneric layered-color (layered-color-set &rest layers))
 
-(defclass group-color (design)
-    ((group :reader group-color-group :initarg :group)
-     (layers :initform nil :reader group-color-layers :initarg :layers)
-     (mutables :initform nil))) 
+(defclass layered-color (design)
+    ((set :reader layered-color-set :initarg :set)
+     (layers :initform nil :reader layered-color-layers :initarg :layers)
+     (dynamics :initform nil))) 
    
-(define-constructor make-group-color group-color (group layers)
-		    :group group :layers layers)
+(define-constructor make-layered-color layered-color (set layers)
+		    :set set :layers layers)
 
 
 ;;; Foreground and background (indirect) inks
diff --git a/utils/designs.lisp b/utils/designs.lisp
index 79fdd764..7cf1a54f 100644
--- a/utils/designs.lisp
+++ b/utils/designs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: designs.lisp,v 1.8 92/10/28 11:31:04 cer Exp Locker: cer $
+;; $fiHeader: designs.lisp,v 1.9 92/10/28 13:17:12 cer Exp $
 
 (in-package :clim-utils)
 
@@ -294,140 +294,134 @@
 (defmethod color-ihs ((color ihs-color))
   (with-slots (intensity hue saturation) color
     (values intensity hue saturation)))
-
 
-;;; Mutable Colors 
+;;; Palettes 
+
+(define-condition palette-full (serious-condition) ())
+
+(defmethod add-to-palette ((palette basic-palette) &rest colors)
+  (let ((colors-done nil))
+    (dolist (color colors)
+      (handler-case
+	  (progn
+	    (push color colors-done)
+	    (allocate-color color palette))
+	(palette-full (condition)
+	  (dolist (color colors-done)
+	    (free-color color palette))
+	  (error condition))))))
+
+(defmethod remove-from-palette ((palette basic-palette) &rest colors)
+  (dolist (color colors)
+    (free-color color palette)))
 
-(defun make-mutable-color (color)
-  (make-mutable-color-1 color))
+
+;;; Dynamic Colors 
 
-(defmethod print-object ((color mutable-color) stream)
+(defmethod print-object ((color dynamic-color) stream)
   (print-unreadable-object (color stream :type t :identity t)
-    (princ (mutable-color-color color) stream)))
+    (princ (dynamic-color-color color) stream)))
 
-(defmethod color-rgb ((color mutable-color))
-  (color-rgb (mutable-color-color color)))
+(defmethod color-rgb ((color dynamic-color))
+  (color-rgb (dynamic-color-color color)))
 
-(defmethod color-ihs ((color mutable-color))
-  (color-ihs (mutable-color-color color)))
+(defmethod color-ihs ((color dynamic-color))
+  (color-ihs (dynamic-color-color color)))
 
-(defvar *doing-delayed-mutations* nil)
+(defvar *doing-delayed-recolors* nil)
 
-(defmethod mutate-mutable ((mutable mutable-color) (color color))
-  (if *doing-delayed-mutations*
-      (dolist (palette (mutable-color-palettes mutable))
-	(let ((cell (gethash mutable (palette-mutable-color-cache palette)))
-	      (mutations (palette-delayed-mutations palette)))
+(defmethod recolor-dynamic ((dynamic-color dynamic-color) (color color))
+  (if *doing-delayed-recolors*
+      (dolist (palette (dynamic-color-palettes dynamic-color))
+	(let ((cell (gethash dynamic-color (palette-dynamic-color-cache palette)))
+	      (recolors (palette-delayed-recolors palette)))
 	  (without-scheduling
-	    (vector-push-extend cell mutations)
-	    (vector-push-extend color mutations))))
-      (dolist (palette (mutable-color-palettes mutable))
-	(let ((cell (gethash mutable (palette-mutable-color-cache palette))))
-	  (update-palette-entry palette cell color)))))
-
-(defmethod (setf mutable-color-color) :after ((color color) (mutable mutable-color))
-  (mutate-mutable mutable color))
-
-(defmethod mutate-color ((mutable mutable-color) (color color))
-  (setf (slot-value mutable 'color) color)
-  (mutate-mutable mutable color))
-
-;; Note that the actual color mutation occurs on exiting the outermost
-;; call to WITH-DELAYED-MUTATIONS
-(defmacro with-delayed-mutations (&body body)
-  (let ((outer-doing-delayed-mutations '#:outer-doing-delayed-mutations)
+	    (vector-push-extend cell recolors)
+	    (vector-push-extend color recolors))))
+    (dolist (palette (dynamic-color-palettes dynamic-color))
+      (let ((cell (gethash dynamic-color (palette-dynamic-color-cache palette))))
+	(update-palette-entry palette cell color)))))
+
+(defmethod (setf dynamic-color-color) :after
+	   ((color color) (dynamic-color dynamic-color))
+  (recolor-dynamic dynamic-color color))
+
+;; Note that the actual color recoloring occurs on exiting the outermost
+;; call to WITH-DELAYED-RECOLORING
+(defmacro with-delayed-recoloring (&body body)
+  (let ((outer-doing-delayed-recolors '#:outer-doing-delayed-recolors)
 	(palette '#:palette)
-	(mutations '#:mutations))
-    `(let ((,outer-doing-delayed-mutations *doing-delayed-mutations*)
-	   (*doing-delayed-mutations* t))
+	(recolors '#:recolors))
+    `(let ((,outer-doing-delayed-recolors *doing-delayed-recolors*)
+	   (*doing-delayed-recolors* t))
        (unwind-protect
 	   ,@body
 	 (progn
-	   (unless ,outer-doing-delayed-mutations
+	   (unless ,outer-doing-delayed-recolors
 	     (dolist (,palette *all-palettes*)
-	       (let ((,mutations (palette-delayed-mutations ,palette)))
-		 (update-palette-entries ,palette ,mutations)
-		 (setf (fill-pointer ,mutations) 0)))))))))
+	       (let ((,recolors (palette-delayed-recolors ,palette)))
+		 (update-palette-entries ,palette ,recolors)
+		 (setf (fill-pointer ,recolors) 0)))))))))
 
 
-;;; Color Groups
-
-(defun map-over-group-colors (function group &optional layers)
-  (declare (dynamic-extent function))
-  (let ((group-layers (color-group-layers group)))
-    ;; It would be nice if this didn't cons so much
-    (labels ((iterate (layers group-layers dimensions)
-	       (if group-layers
-		   (let ((layer (car layers))
-			 (group-layer (car group-layers)))
-		     (if layer
-			 (iterate (cdr layers) 
-				  (cdr group-layers) 
-				  (cons layer dimensions))
-			 (dotimes (i group-layer)
-			   (iterate (cdr layers)
-				    (cdr group-layers)
-				    (cons i dimensions)))))
-		   (funcall function dimensions))))
-      (iterate (reverse layers) (reverse group-layers) nil))))
-
-(defmethod initialize-instance :after ((group color-group) &key mutable-array)
-  (map-over-group-colors
-    #'(lambda (dimensions)
-	(setf (apply #'aref mutable-array dimensions)
-	      (make-mutable-color-1 +black+)))
-    group))
-
-(defmethod group-color ((color-group color-group) &rest layers)
-  (declare (dynamic-extent layers))
-  (let ((cache (color-group-cache color-group)))
-    (or (gethash layers cache)
-	(let ((layers (copy-list layers)))
-	  (setf (gethash layers cache)
-		(make-group-color color-group layers))))))
-
-(defmethod mutate-color ((group-color group-color) (color color))
-  (with-delayed-mutations
-      (dolist (mutable (group-color-mutables group-color))
-	(mutate-color mutable color))))
+;;; Layered Colors
 
-
-;; GROUP-COLOR-MUTABLES should not be exported to the user.  It is important
-;; that these mutables are not drawn with.  Instead the fully specified group
-;; colors should be used
-(defmethod group-color-mutables ((group-color group-color))
-  (with-slots (group layers mutables) group-color
-    (or mutables
-	(setf mutables
-	      (let ((mutable-array (color-group-mutable-array group))
-		    mutables)
-		(map-over-group-colors #'(lambda (dimensions)
-					   (push (apply #'aref mutable-array dimensions)
-						 mutables))
-				       group
-				       layers)
-		mutables)))))
-
-
-(defun map-over-group-colors (function group &optional layers)
-  (let* ((group-layers (color-group-layers group))
-	 (dimensions (make-list (length group-layers))))
-    (labels ((iterate (layers group-layers dims)
-	       (if group-layers
+(defun map-over-layered-colors (function set &optional layers)
+  (let* ((set-layers (layered-color-set-layers set))
+	 (dimensions (make-list (length set-layers))))
+    (labels ((iterate (layers set-layers dims)
+	       (if set-layers
 		   (let ((layer (car layers))
 			 (rest-layers (cdr layers))
-			 (group-layer (car group-layers))
-			 (rest-group-layers (cdr group-layers))
+			 (set-layer (car set-layers))
+			 (rest-set-layers (cdr set-layers))
 			 (rest-dims (cdr dims)))
 		     (if layer
 			 (progn 
 			   (setf (car dims) layer)
-			   (iterate rest-layers rest-group-layers rest-dims))
-		       (dotimes (i group-layer)
+			   (iterate rest-layers rest-set-layers rest-dims))
+		       (dotimes (i set-layer)
 			 (setf (car dims) i)
-			 (iterate rest-layers rest-group-layers rest-dims))))
+			 (iterate rest-layers rest-set-layers rest-dims))))
 		 (funcall function dimensions))))
-      (iterate layers group-layers dimensions))))
+      (iterate layers set-layers dimensions))))
+
+(defmethod initialize-instance :after ((set layered-color-set) &key dynamic-array)
+  (map-over-layered-colors
+    #'(lambda (dimensions)
+	(setf (apply #'aref dynamic-array dimensions)
+	      (make-dynamic-color +black+)))
+    set))
+
+(defmethod layered-color ((set layered-color-set) &rest layers)
+  (declare (dynamic-extent layers))
+  (let ((cache (layered-color-set-cache set)))
+    (or (gethash layers cache)
+	(let ((layers (copy-list layers)))
+	  (setf (gethash layers cache)
+		(make-layered-color set layers))))))
+
+(defmethod (setf layered-color-color) 
+    ((color color) (layered-color layered-color))
+  (with-delayed-recoloring
+      (dolist (dynamic-color (layered-color-dynamics layered-color))
+	(setf (dynamic-color-color dynamic-color) color))))
+  
+;; LAYERED-COLOR-DYNAMICS should not be exported to the user.  It is important
+;; that these dynamics are not drawn with.  Instead the fully specified layered
+;; colors should be used
+(defmethod layered-color-dynamics ((layered-color layered-color))
+  (with-slots (set layers dynamics) layered-color
+    (or dynamics
+	(setf dynamics
+	  (let ((dynamic-array (layered-color-set-dynamic-array set))
+		dynamics)
+	    (map-over-layered-colors 
+	     #'(lambda (dimensions)
+		 (push (apply #'aref dynamic-array dimensions) dynamics))
+	     set
+	     layers)
+	    dynamics)))))
 
 
 ;;; Foreground and background (indirect) inks
diff --git a/utils/packages.lisp b/utils/packages.lisp
index 1597652e..c2be0da9 100644
--- a/utils/packages.lisp
+++ b/utils/packages.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: packages.lisp,v 1.34 92/10/28 11:31:08 cer Exp Locker: cer $
+;; $fiHeader: packages.lisp,v 1.35 92/10/28 13:17:14 cer Exp $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
 
@@ -2029,38 +2029,22 @@
     design
     designp
     find-named-color
-    group-color
-    make-color-group
+    layered-color
+    layered-color-color
+    make-layered-color-set
     make-contrasting-inks
     make-flipping-ink
     make-gray-color
     make-ihs-color
-    make-mutable-color
+    make-dynamic-color
     make-opacity
     make-rgb-color
-    mutable-color-color
-    mutate-color
+    dynamic-color-color
     opacity
     opacity-value
     opacityp
-    with-delayed-mutations
+    with-delayed-recoloring
     
-
-    palette
-    palette-color-p
-    palette-mutable-p
-    palettep
-    make-palette
-    port-default-palette
-    medium-palette
-    sheet-palette
-    frame-palette
-    frame-manager-palette
-
-    palette-full
-    add-to-palette
-    remove-from-palette
-
     ;; Designs
     compose-in
     compose-out
@@ -2077,14 +2061,15 @@
     frame-manager-palette
     frame-palette
     make-palette
-    medium-palette
     palette
     palette-color-p
-    palette-mutable-p
+    palette-dynamic-p
     palettep
     port-default-palette
-    sheet-palette
-
+    palette-full
+    add-to-palette
+    remove-from-palette
+    
     ;; Extended output
     beep
     cursor
@@ -3261,10 +3246,11 @@
 
     ;; From BASE-DESIGNS and DESIGNS
     *all-palettes*
+    allocate-color
     basic-palette
-    color-group
-    color-group-layers
-    color-group-mutable-array
+    layered-color-set
+    layered-color-set-layers
+    layered-color-set-dynamic-array
     color-luminosity
     composite-in
     composite-out
@@ -3276,23 +3262,23 @@
     decode-rectangular-tile
     decode-tile-as-stipple
     flipping-ink
-    flipping-ink
+    flipping-ink 
+    free-color
     gray-color
     gray-color-luminosity
-    group-color-group
-    group-color-layers
+    layered-color-layers
     ihs-color
     make-color-for-contrasting-ink
     make-design-from-output-record
     make-flipping-ink
     make-gray-color-for-contrasting-ink
-    map-over-group-colors    
-    mutable-color
-    mutable-color-palettes
+    map-over-layered-colors    
+    dynamic-color
+    dynamic-color-palettes
     palette-color-cache
-    palette-mutable-color-cache
-    palette-color-group-cache
-    palette-delayed-mutations
+    palette-dynamic-color-cache
+    palette-layered-color-cache
+    palette-delayed-recolors
     pattern
     rectangular-tile
     rgb-color
@@ -3346,7 +3332,6 @@
     activate-gadget-event
     add-sheet-callbacks
     all-drawing-options-lambda-list
-    allocate-color
     allocate-event
     basic-pixmap-medium
     bury-mirror
@@ -3398,7 +3383,6 @@
     frame-user-specified-position-p
     frame-user-specified-size-p
     frame-wrapper
-    free-color
     gadget-alignment
     gadget-columns
     gadget-editable-p
-- 
GitLab