diff --git a/silica/medium.lisp b/silica/medium.lisp
index dfde5fc89be2fac1665ad5926b62efa794e6d27c..a11292927c7e075abcea39f7e6dfe7a38257f3f5 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.28 92/10/29 16:54:58 cer Exp $
+;; $fiHeader: medium.lisp,v 1.29 92/11/06 19:03:53 cer Exp $
 
 (in-package :silica)
 
@@ -255,55 +255,56 @@
 		 line-joint-shape line-cap-shape
 		 (text-style nil text-style-p) (text-family nil text-family-p)
 		 (text-face nil text-face-p) (text-size nil text-size-p))
-  (with-slots ((medium-ink ink)
-	       (medium-transformation transformation)
-	       (transformed-clipping-region region)
-	       (medium-line-style line-style)) medium
-    (let* ((saved-ink medium-ink)
-	   (saved-transformation medium-transformation)
-	   (saved-clipping-region transformed-clipping-region)
-	   (saved-line-style medium-line-style))
-      (unwind-protect
-	  (progn
-	    (when ink
-	      (setf medium-ink ink))
-	    (when transformation
-	      (setf medium-transformation
-		    (compose-transformations saved-transformation transformation)))
-	    (when clipping-region
-	      (setf transformed-clipping-region
-		    (region-intersection saved-clipping-region
-					 (transform-region medium-transformation
-							   clipping-region))))
-	    (cond ((or line-unit line-thickness line-joint-shape line-cap-shape dashes-p)
-		   (when (null line-style)
-		     (setf line-style saved-line-style))
-		   (setf medium-line-style
-			 (make-line-style-1
-			   (or line-unit (line-style-unit line-style))
-			   (or line-thickness (line-style-thickness line-style))
-			   (if dashes-p line-dashes (line-style-dashes line-style))
-			   (or line-joint-shape (line-style-joint-shape line-style))
-			   (or line-cap-shape (line-style-cap-shape line-style)))))
-		  (line-style
-		   (setf medium-line-style line-style)))
-	    (when (or text-family-p text-face-p text-size-p)
-	      (if text-style-p
-		  (setq text-style (with-stack-list (style text-family text-face text-size)
-				     (merge-text-styles style text-style)))
+  (with-accessors ((transformed-clipping-region medium-clipping-region))
+      medium
+    (with-slots ((medium-ink ink)
+		 (medium-transformation transformation)
+		 (medium-line-style line-style)) medium
+      (let* ((saved-ink medium-ink)
+	     (saved-transformation medium-transformation)
+	     (saved-clipping-region transformed-clipping-region)
+	     (saved-line-style medium-line-style))
+	(unwind-protect
+	    (progn
+	      (when ink
+		(setf medium-ink ink))
+	      (when transformation
+		(setf medium-transformation
+		  (compose-transformations saved-transformation transformation)))
+	      (when clipping-region
+		(setf transformed-clipping-region
+		  (region-intersection saved-clipping-region
+				       (transform-region medium-transformation
+							 clipping-region))))
+	      (cond ((or line-unit line-thickness line-joint-shape line-cap-shape dashes-p)
+		     (when (null line-style)
+		       (setf line-style saved-line-style))
+		     (setf medium-line-style
+		       (make-line-style-1
+			(or line-unit (line-style-unit line-style))
+			(or line-thickness (line-style-thickness line-style))
+			(if dashes-p line-dashes (line-style-dashes line-style))
+			(or line-joint-shape (line-style-joint-shape line-style))
+			(or line-cap-shape (line-style-cap-shape line-style)))))
+		    (line-style
+		     (setf medium-line-style line-style)))
+	      (when (or text-family-p text-face-p text-size-p)
+		(if text-style-p
+		    (setq text-style (with-stack-list (style text-family text-face text-size)
+				       (merge-text-styles style text-style)))
 		  (setq text-style (make-text-style text-family text-face text-size)
 			text-style-p t)))
-	    (if text-style-p
-		(flet ((call-continuation (stream)
-			 (declare (ignore stream))
-			 (funcall continuation)))
-		  (declare (dynamic-extent #'call-continuation))
-		  (invoke-with-text-style medium #'call-continuation text-style medium))
+	      (if text-style-p
+		  (flet ((call-continuation (stream)
+			   (declare (ignore stream))
+			   (funcall continuation)))
+		    (declare (dynamic-extent #'call-continuation))
+		    (invoke-with-text-style medium #'call-continuation text-style medium))
 	        (funcall continuation)))
-	(setf medium-line-style saved-line-style)
-	(setf transformed-clipping-region saved-clipping-region)
-	(setf medium-transformation saved-transformation)
-	(setf medium-ink saved-ink)))))
+	  (setf medium-line-style saved-line-style)
+	  (setf transformed-clipping-region saved-clipping-region)
+	  (setf medium-transformation saved-transformation)
+	  (setf medium-ink saved-ink))))))
 
 
 (defmethod allocate-medium (port sheet)
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index a65536973b676bbcb1bf48b192b45d5d861c03ef..322583234a3c7f398b873a7ed060e500835f429e 100644
--- a/tk-silica/xt-graphics.lisp
+++ b/tk-silica/xt-graphics.lisp
@@ -20,34 +20,55 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-graphics.lisp,v 1.54 92/11/20 08:46:56 cer Exp $
+;; $fiHeader: xt-graphics.lisp,v 1.55 92/12/01 09:47:15 cer Exp $
 
 (in-package :tk-silica)
 
-(defclass fast-gcontext (tk::gcontext)
-  ((last-medium-clip-mask :initform nil :fixed-index 1)
-   (last-line-style :initform nil :fixed-index 2)))
+(defclass ink-gcontext (tk::gcontext)
+  ((last-clip-mask :initform nil :fixed-index 1)
+   (last-line-style :initform nil :fixed-index 2)
+   (shift-tile-origin :initform nil :fixed-index 3)
+   (ink-clip-mask :initform nil :fixed-index 4)))
 
-(defmacro fast-gcontext-last-line-style (gcontext)
+(defmacro ink-gcontext-last-line-style (gcontext)
   `(locally (declare (optimize (speed 3) (safety 0)))
-     (excl::slot-value-using-class-name 'fast-gcontext ,gcontext
+     (excl::slot-value-using-class-name 'ink-gcontext ,gcontext
 					'last-line-style)))
-(defsetf fast-gcontext-last-line-style (gcontext) (value)
+(defsetf ink-gcontext-last-line-style (gcontext) (value)
   `(locally (declare (optimize (speed 3) (safety 0)))
-     (setf (excl::slot-value-using-class-name 'fast-gcontext ,gcontext
+     (setf (excl::slot-value-using-class-name 'ink-gcontext ,gcontext
 					      'last-line-style)
        ,value)))
 
-(defmacro fast-gcontext-last-medium-clip-mask (gcontext)
+(defmacro ink-gcontext-last-clip-mask (gcontext)
   `(locally (declare (optimize (speed 3) (safety 0)))
-     (excl::slot-value-using-class-name 'fast-gcontext ,gcontext
-					'last-medium-clip-mask)))
-(defsetf fast-gcontext-last-medium-clip-mask (gcontext) (value)
+     (excl::slot-value-using-class-name 'ink-gcontext ,gcontext
+					'last-clip-mask)))
+(defsetf ink-gcontext-last-clip-mask (gcontext) (value)
   `(locally (declare (optimize (speed 3) (safety 0)))
-     (setf (excl::slot-value-using-class-name 'fast-gcontext ,gcontext
-					      'last-medium-clip-mask)
+     (setf (excl::slot-value-using-class-name 'ink-gcontext ,gcontext
+					      'last-clip-mask)
        ,value)))
 
+(defmacro ink-gcontext-shift-tile-origin (gcontext)
+  `(locally (declare (optimize (speed 3) (safety 0)))
+     (excl::slot-value-using-class-name 'ink-gcontext ,gcontext
+					'shift-tile-origin)))
+(defsetf ink-gcontext-shift-tile-origin (gcontext) (value)
+  `(locally (declare (optimize (speed 3) (safety 0)))
+     (setf (excl::slot-value-using-class-name 'ink-gcontext ,gcontext
+					      'shift-tile-origin)
+       ,value)))
+
+(defmacro ink-gcontext-ink-clip-mask (gcontext)
+  `(locally (declare (optimize (speed 3) (safety 0)))
+     (excl::slot-value-using-class-name 'ink-gcontext ,gcontext
+					'ink-clip-mask)))
+(defsetf ink-gcontext-ink-clip-mask (gcontext) (value)
+  `(locally (declare (optimize (speed 3) (safety 0)))
+     (setf (excl::slot-value-using-class-name 'ink-gcontext ,gcontext
+					      'ink-clip-mask)
+       ,value)))
 
 (defclass xt-medium (basic-medium)
   ((foreground-gcontext :reader medium-foreground-gcontext :initform nil)
@@ -168,7 +189,7 @@
 ;;; things we can install in a palete
 ;;; 1 - color (rgb etc)
 ;;; 2 - dynamic-color
-;;; 3 - layered-color
+;;; 3 - layered-color or it's layered-color-set
 
 (defmethod allocate-color ((color color) (palette xt-palette))
   (unless (gethash color (palette-color-cache palette))
@@ -202,6 +223,7 @@
 (defmethod deallocate-color ((color layered-color) (palette xt-palette))
   (deallocate-color (layered-color-set color) palette))
 
+;;--- maybe some more of this could be made more port independent
 (defmethod deallocate-color ((set layered-color-set) (palette xt-palette))
   (let* ((layered-color-cache (palette-layered-color-cache palette))
 	 (pixel-planes (gethash set layered-color-cache)))
@@ -236,12 +258,13 @@
 ;;   1. medium's sheet's device region changes
 ;;   2. medium's clipping region changes
 ;;   3. medium's sheet's device transformation changes
+
 (defmethod medium-clip-mask ((medium xt-medium))
   (with-slots (sheet clip-mask) medium
     (or clip-mask
 	(setf clip-mask
-	  (let* ((dr (sheet-device-region sheet))
-		 (mcr (medium-clipping-region medium)))
+	  (let ((dr (sheet-device-region sheet))
+		(mcr (medium-clipping-region medium)))
 	    (unless (eq mcr +everywhere+)
 	      (setq mcr (transform-region (sheet-device-transformation sheet) mcr))
 	      (setq dr (region-intersection dr (bounding-rectangle mcr))))
@@ -261,10 +284,12 @@
     (setf clip-mask nil)))
 
 (defmethod invalidate-cached-regions :after ((medium xt-medium))
-  (with-slots (clip-mask) medium (setf clip-mask nil)))
+  (with-slots (clip-mask) medium
+    (setf clip-mask nil)))
 
 (defmethod invalidate-cached-transformations :after ((medium xt-medium))
-  (with-slots (clip-mask) medium (setf clip-mask nil)))
+  (with-slots (clip-mask) medium
+    (setf clip-mask nil)))
 
 
 
@@ -280,14 +305,13 @@
 (defmethod engraft-medium :after ((medium xt-medium) (port xt-port) sheet)
   (with-slots (foreground-gcontext background-gcontext
 				   flipping-gcontext
-				   indirect-inks
+				   indirect-inks 
 				   drawable tile-gcontext clip-mask)
       medium
     (let ((palette (medium-palette medium)))
       (with-slots (white-pixel black-pixel)
 	  palette
-	(setf indirect-inks nil)
-	(setf clip-mask nil)
+	(setf indirect-inks nil clip-mask nil)
 	(setf (medium-sheet medium) sheet)
 	(when (and drawable
 		   (not (eq (port-display port)
@@ -297,18 +321,18 @@
 	       (drawable (or drawable
 			     (tk::display-root-window display))))
 	  (unless foreground-gcontext
-	    (setf foreground-gcontext (tk::make-instance 'fast-gcontext
+	    (setf foreground-gcontext (tk::make-instance 'ink-gcontext
 							 :drawable drawable)))
 	  (unless background-gcontext
-	    (setf background-gcontext (tk::make-instance 'fast-gcontext
+	    (setf background-gcontext (tk::make-instance 'ink-gcontext
 							 :drawable drawable)))
 	  (unless flipping-gcontext
 	    (setf flipping-gcontext
-	      (tk::make-instance 'fast-gcontext 
+	      (tk::make-instance 'ink-gcontext 
 				 :drawable drawable
 				 :function boole-xor)))
 	  (unless tile-gcontext
-	    (setf tile-gcontext (make-instance 'fast-gcontext
+	    (setf tile-gcontext (make-instance 'ink-gcontext
 					       :drawable drawable
 					       :foreground black-pixel
 					       :background white-pixel)))
@@ -451,7 +475,7 @@
 ;;; (indirect-ink-p ink) returns t if ink is an indirect ink or
 ;;; derived from an indirect ink
 
-;;; not sure if these should be here 
+;;;--- not sure if these should be here - they should probably be in designs
 
 (defgeneric indirect-ink-p (ink))
 
@@ -484,7 +508,7 @@
     (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)))
+	       (new-gc (make-instance 'ink-gcontext :drawable drawable)))
 	  (multiple-value-bind (pixel mask)
 	      (decode-color-in-palette ink (medium-palette medium))
 	    (setf (tk::gcontext-foreground new-gc) pixel)
@@ -506,12 +530,12 @@
 
 (defmethod decode-ink ((ink flipping-ink) (medium xt-medium))
   (let ((palette (medium-palette medium)))
-    (with-slots (ink-table sheet tile-gcontext drawable indirect-inks)
+    (with-slots (ink-table sheet 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 
+		 (new-gc (make-instance 'ink-gcontext 
 					:drawable drawable
 					:function boole-xor)))
 	    (multiple-value-bind (color1 color2)
@@ -538,7 +562,7 @@
 	    (let* ((drawable 
 		    (or drawable 
 			(tk::display-root-window (port-display (port sheet)))))
-		   (new-gc (make-instance 'fast-gcontext :drawable drawable)))
+		   (new-gc (make-instance 'ink-gcontext :drawable drawable)))
 	      (cond ((palette-color-p palette)
 		     (setf (tk::gcontext-foreground new-gc)
 		       (decode-color-in-palette ink palette)))
@@ -574,8 +598,7 @@
   (decode-ink-opacity ink medium))
 
 (defmethod decode-ink-opacity (opacity medium)
-  (with-slots (ink-table sheet tile-gcontext drawable
-			 foreground-gcontext ink-table)
+  (with-slots (ink-table sheet drawable foreground-gcontext ink-table)
       medium
     (let ((key (cons opacity foreground-gcontext)))
       (or (gethash key ink-table)
@@ -586,9 +609,8 @@ and on color servers, unless using white or black")
 	  (let* ((port (port sheet))
 		 (display (port-display port))
 		 (drawable (or drawable (tk::display-root-window display)))
-		 (new-gc (make-instance 'fast-gcontext :drawable drawable)))
-  
-	    (x11:xcopygc display foreground-gcontext -1 new-gc)
+		 (new-gc (make-instance 'ink-gcontext :drawable drawable)))
+  	    (x11:xcopygc display foreground-gcontext -1 new-gc)
 	    (setf (tk::gcontext-stipple new-gc) (decode-opacity opacity port)
 		  (tk::gcontext-fill-style new-gc) :stippled)
 	    (setf (gethash key ink-table) new-gc))))))
@@ -601,14 +623,11 @@ and on color servers, unless using white or black")
 		    (make-gray-color-for-contrasting-ink ink))
 		medium)))
 
-(defmethod decode-ink ((ink rectangular-tile) medium)
-  (multiple-value-bind (pattern width height)
-      (decode-rectangular-tile ink)
-    (xt-decode-pattern pattern medium width height t)))
-
 (defmethod decode-ink ((ink pattern) medium)
-  (xt-decode-pattern ink medium))
-    
+  (with-slots (ink-table) medium
+    (or (gethash ink ink-table)
+	(setf (gethash ink ink-table)
+	  (decode-pattern-ink ink medium)))))
 
 (defmethod decode-color ((design design) (medium xt-medium))
   (decode-color-in-palette design (medium-palette medium)))
@@ -626,7 +645,7 @@ and on color servers, unless using white or black")
       (decode-color +foreground-ink+ medium)
       (decode-color +background-ink+ medium)))
 
-(defmethod decode-color-in-palette ((design design) (medium xt-medium))
+(defmethod decode-color-in-palette ((design design) (palette xt-palette))
   (error "Drawing with design: ~A not yet implemented" design))
 
 (defmethod decode-color-in-palette ((color color) (palette xt-palette))
@@ -736,7 +755,7 @@ and on color servers, unless using white or black")
 (defvar *default-dashes* '(4 4))
 
 (defun adjust-ink (gc medium line-style x-origin y-origin)
-  (unless (eq (fast-gcontext-last-line-style gc) line-style)
+  (unless (eq (ink-gcontext-last-line-style gc) line-style)
     (let* ((dashes (line-style-dashes line-style))
 	   (gc-line-style (if dashes :dash :solid)))
 	
@@ -768,67 +787,273 @@ and on color servers, unless using white or black")
 	  (if (excl::sequencep dashes) dashes *default-dashes*))
 	;; The following isn't really right, but it's better than nothing.
 	(setf (tk::gcontext-dash-offset gc) (1- y-origin))))
-    (setf (fast-gcontext-last-line-style gc) line-style))
-
-  (let ((mcm (medium-clip-mask medium)))
-    (unless (eq (fast-gcontext-last-medium-clip-mask gc) mcm)
-      (setf (tk::gcontext-clip-mask gc) (medium-clip-mask medium))
-      (setf (fast-gcontext-last-medium-clip-mask gc) mcm)))
-    
-  (when (member (tk::gcontext-fill-style gc) '(:tiled :stippled) :test #'eq)
+    (setf (ink-gcontext-last-line-style gc) line-style))
+
+  (let ((ink-clip-mask (ink-gcontext-ink-clip-mask gc))
+	(medium-clip-mask (medium-clip-mask medium))
+	(last-clip-mask (ink-gcontext-last-clip-mask gc)))
+    (multiple-value-bind (clip-mask x-origin y-origin)
+	(adjust-clip-mask medium ink-clip-mask medium-clip-mask x-origin y-origin)
+      (unless (eq last-clip-mask clip-mask)
+	(when (and (not (eq last-clip-mask ink-clip-mask))
+		   (typep last-clip-mask 'tk::pixmap))
+	  (tk::destroy-pixmap last-clip-mask))
+	(setf (tk::gcontext-clip-mask gc) clip-mask
+	      (ink-gcontext-last-clip-mask gc) clip-mask))
+      (when x-origin
+	(setf (tk::gcontext-clip-x-origin gc) x-origin
+	      (tk::gcontext-clip-y-origin gc) y-origin))))
+      
+  (when (ink-gcontext-shift-tile-origin gc)
     (setf (tk::gcontext-ts-x-origin gc) x-origin
 	  (tk::gcontext-ts-y-origin gc) y-origin))
   gc)
 
+(defun adjust-clip-mask (medium ink-clip-mask medium-clip-mask x-origin y-origin)
+  (if ink-clip-mask
+      (cond 
+       ((eq medium-clip-mask :nowhere) :nowhere)
+       ((eq medium-clip-mask :none) 
+	  (values ink-clip-mask x-origin y-origin))
+       (t
+	;; all subsequent co-ordinates are relative to x,y-origin
+	(let ((ink-pixmap-p (typep ink-clip-mask 'tk::pixmap))
+	      (medium-x (- (first medium-clip-mask) x-origin))
+	      (medium-y (- (second medium-clip-mask) y-origin))
+	      (medium-width (third medium-clip-mask))
+	      (medium-height (fourth medium-clip-mask))
+	      ink-x ink-y ink-width ink-height)
+	  (if ink-pixmap-p
+	      (setq ink-x 0 ink-y 0
+		    ink-width (tk::pixmap-width ink-clip-mask)
+		    ink-height (tk::pixmap-height ink-clip-mask))
+	    (setq ink-x (first ink-clip-mask)
+		  ink-y (second ink-clip-mask)
+		  ink-width (third ink-clip-mask)
+		  ink-height (fourth ink-clip-mask)))
+	  #+ignore (format excl:*initial-terminal-io* "~&ink:~d,~d,~d,~d"
+			   ink-x ink-y ink-width ink-height)
+	  #+ignore (format excl:*initial-terminal-io* "~&medium:~d,~d,~d,~d"
+			   medium-x medium-y medium-width medium-height)
+	  (let* ((x (max ink-x medium-x))
+		 (width (- (min (+ ink-x ink-width)
+				(+ medium-x medium-width))
+			   x))
+		 (y (max ink-y medium-y))
+		 (height (- (min (+ ink-y ink-height)
+				 (+ medium-y medium-height))
+			    y)))
+	    (if (or (<= width 0) (<= height 0))
+		:nowhere
+	      (if (and (= width ink-width) (= height ink-height))
+		  (values ink-clip-mask x-origin y-origin)
+		(if ink-pixmap-p
+		    (let* ((clip-pixmap (make-instance 'tk::pixmap
+						       :drawable ink-clip-mask
+						       :width width
+						       :height height
+						       :depth 1))
+			   (port (port (medium-sheet medium))))
+		      (stream-bitblt-support (port-copy-gc-depth-1 port)
+					     ink-clip-mask x y
+					     clip-pixmap 0 0
+					     width height)
+		      (values clip-pixmap (+ x-origin x) (+ y-origin y)))
+		  (values (list x y width height) x-origin y-origin))))))))
+    medium-clip-mask))
+
 #+ignore
 (defmethod decode-ink :around ((ink t) (medium xt-medium))
   (let ((gc (call-next-method)))
     gc))
 
-(defmethod xt-decode-pattern ((pattern pattern) medium &optional width height tiled-p)    
-  (let ((ink-table (slot-value medium 'ink-table)))
-    (or (gethash pattern ink-table)
-	(let* ((drawable (or (slot-value medium 'drawable)
-			     (tk::display-root-window
-			      (port-display (port (medium-sheet medium))))))
-	       (depth (tk::drawable-depth drawable)))
-	  (setf (gethash pattern ink-table)
+(defmethod decode-pattern-design ((ink (eql +nowhere+)) (medium xt-medium))
+  nil)
+
+(defmethod decode-pattern-design ((ink design) (medium xt-medium))
+  (decode-color ink medium))
+
+(defmethod decode-pattern-ink ((pattern pattern) medium) 
+  (multiple-value-bind (array designs)
+      (decode-pattern pattern)
+    (let* ((height (array-dimension array 0))
+	   (width (array-dimension array 1))
+	   (image-data (make-array (list height width)))
+	   (clip-image-data (make-array (list height width)
+					:initial-element 1))
+	   (design-pixels (make-array (length designs)))
+	   (transparent-p nil))
+	(declare (simple-vector design-pixels))
+
+	;; Cache the decoded designs from the pattern
+	(dotimes (n (length designs))
+	  (let ((pixel (decode-pattern-design (elt designs n) medium))) 
+	    (setf (svref design-pixels n) pixel)
+	    (unless pixel
+	      (setf transparent-p t))))
+	
+	(dotimes (w width)
+	  (dotimes (h height)
+	    (let ((pixel (svref design-pixels (aref array h w))))
+	      (setf (aref image-data h w)
+		(or pixel
+		    (setf (aref clip-image-data h w) 0))))))
+	(let* ((port (port (medium-sheet medium)))
+	       (drawable (or (slot-value medium 'drawable)
+			     (tk::display-root-window (port-display port))))
+	       (depth (tk::drawable-depth drawable))
+	       (image (make-instance 'tk::image
+				    :width width
+				    :height height
+				    :data image-data
+				    :depth depth))
+	       (clip-image (and transparent-p
+				(make-instance 'tk::image
+					       :width width
+					       :height height
+					       :data clip-image-data
+					       :depth 1)))
+	       (gc (make-instance 'ink-gcontext :drawable drawable))
+	       (pixmap (make-instance 'tk::pixmap
+				      :drawable drawable
+				      :width width
+				      :height height
+				      :depth depth))
+	       (clip-mask (if transparent-p
+			      (make-instance 'tk::pixmap
+					     :drawable drawable
+					     :width width
+					     :height height
+					     :depth 1)
+			    (list 0 0 width height))))
+	  (tk::put-image pixmap gc image)
+	  (when transparent-p
+	    (tk::put-image clip-mask 
+			   (port-copy-gc-depth-1 port)
+			   clip-image))
+	  (setf (tk::gcontext-tile gc) pixmap
+		(tk::gcontext-fill-style gc) :tiled
+		(ink-gcontext-ink-clip-mask gc) clip-mask
+		(ink-gcontext-shift-tile-origin gc) t)
+	  gc))))
+
+;;---the following extends a pattern for tiling by making it
+;;transparent. This causes problems in the test-suite.
+#+ignore 
+(defun decode-extended-pattern (pattern width height)
+  (multiple-value-bind (array designs)
+      (decode-pattern pattern)
+    (if (and (= (array-dimension array 0) height)
+	     (= (array-dimension array 1) width))
+	(values array designs)
+      (let* ((transparent (position +nowhere+ designs))
+	     (extended-designs 
+	      (if transparent
+		  designs
+		(progn
+		  (setq transparent (length designs))
+		  (concatenate 'vector designs (vector +nowhere+)))))
+	     (extended-array (make-array (list height width))))
+	(dotimes (w width)
+	  (dotimes (h height)
+	    (setf (aref extended-array h w)
+	      (if (array-in-bounds-p array h w)
+		  (aref array h w)
+		transparent))))
+	(values extended-array extended-designs)))))
+
+;; for the moment we use this one which replicates the pattern
+(defun decode-extended-pattern (pattern width height)
+  (multiple-value-bind (array designs)
+      (decode-pattern pattern)
+    (let ((pattern-height (array-dimension array 0))
+	  (pattern-width (array-dimension array 1)))
+      (if (or (< pattern-height height)
+	      (< pattern-width width))
+	  (let* ((extended-array (make-array (list height width))))
+	    (dotimes (w width)
+	      (dotimes (h height)
+		(setf (aref extended-array h w)
+		  (aref array (mod h pattern-height) (mod w pattern-width)))))
+	    (values extended-array designs))
+	(values array designs)))))
+	    
+(defmethod decode-ink ((ink rectangular-tile) medium)
+  (with-slots (ink-table) medium
+    (or (gethash ink ink-table)
+	(setf (gethash ink ink-table)
+	  (multiple-value-bind (pattern width height)
+	      (decode-rectangular-tile ink)
 	    (multiple-value-bind (array designs)
-		(decode-pattern pattern)
-	      (let ((image-data (make-array (array-dimensions array)))
-		    (design-pixels (make-array (length designs))))
+		(decode-extended-pattern pattern width height)
+	      (let* ((image-data (make-array (list height width)))
+		     (design-pixels (make-array (length designs)))
+		     (two-color-p (= (length designs) 2)) 
+		     two-color-fg two-color-bg)
 		(declare (simple-vector design-pixels))
+
 		;; Cache the decoded designs from the pattern
-		(do* ((num-designs (length designs))
-		      (n 0 (1+ n))
-		      design)
-		    ((eq n num-designs))
-		  (setq design (elt designs n))
-		  (setf (svref design-pixels n) (decode-color design medium)))
-		(dotimes (w (array-dimension array 1))
-		  (dotimes (h (array-dimension array 0))
-		    (setf (aref image-data h w)
-		      (svref design-pixels (aref array h w)))))
-		(let* ((pattern-height (array-dimension array 0))
-		       (pattern-width (array-dimension array 1))
+		(dotimes (n (length designs))
+		  (let ((pixel (decode-pattern-design (elt designs n) medium)))
+		    (setf (svref design-pixels n) pixel)
+		    (unless (or two-color-p pixel)
+		      (error "Transparent tiled pattern ~S has more than two designs"
+			     pattern))))
+		
+		(when two-color-p
+		  (setq two-color-bg (svref design-pixels 0)
+			two-color-fg (svref design-pixels 1))
+		  ;; make sure that any transparent design is the bg
+		  (when (null (svref design-pixels 1))
+		    (rotatef two-color-bg two-color-fg)))
+	    
+		(dotimes (w width)
+		  (dotimes (h height)
+		    (let ((pixel (svref design-pixels (aref array h w))))
+		      (setf (aref image-data h w)
+			(if two-color-p
+			    (if (eq pixel two-color-bg)
+				0
+			      1)
+			  pixel)))))
+
+		(let* ((port (port (medium-sheet medium)))
+		       (drawable (or (slot-value medium 'drawable)
+				     (tk::display-root-window
+				      (port-display port)))) 
+		       (depth (if two-color-p
+				  1
+				(tk::drawable-depth drawable)))
 		       (image (make-instance 'tk::image
-				:width pattern-width
-				:height pattern-height
-				:data image-data
-				:depth depth))
-		       (gc 
-			(make-instance 'fast-gcontext :drawable drawable))
+					     :width width
+					     :height height
+					     :data image-data
+					     :depth depth))
+		       (gc (make-instance 'ink-gcontext :drawable drawable))
 		       (pixmap 
 			(make-instance 'tk::pixmap
-			  :drawable drawable
-			  :width pattern-width
-			  :height pattern-height
-			  :depth depth)))
-		  (tk::put-image pixmap gc image)
-		  (setf (tk::gcontext-tile gc) pixmap
-			(tk::gcontext-fill-style gc) :tiled)
+				       :drawable drawable
+				       :width width
+				       :height height
+				       :depth depth)))
+		  (tk::put-image pixmap 
+				 (if two-color-p
+				     (port-copy-gc-depth-1 port)
+				   gc) 
+				 image)
+		  (if two-color-p
+		      (setf (tk::gcontext-stipple gc) pixmap
+			    (tk::gcontext-fill-style gc) (if two-color-bg
+							     :opaque-stippled
+							   :stippled)
+			    (tk::gcontext-foreground gc) (or two-color-fg 0)
+			    (tk::gcontext-background gc) (or two-color-bg 0))
+		    (setf (tk::gcontext-tile gc) pixmap
+			  (tk::gcontext-fill-style gc) :tiled))
 		  gc))))))))
 
+
+
 
 
 ;; Line (& maybe eventually non-rectangular polygon) clipping
@@ -1006,7 +1231,7 @@ and on color servers, unless using white or black")
 		thickness 0 2pi
 		t)))))))
 
-(defmethod medium-draw-points* ((medium xt-medium) position-seq)
+ (defmethod medium-draw-points* ((medium xt-medium) position-seq)
   (let ((drawable (medium-drawable medium)))
     (when drawable
       (let* ((ink (medium-ink medium))
@@ -1515,7 +1740,7 @@ and on color servers, unless using white or black")
 	  (declare (ignore oy)
 		   (ignore ox))
 	  (setf (tk::gcontext-clip-mask gcontext) pixmap)
-	  (setf (fast-gcontext-last-medium-clip-mask gcontext) nil)
+	  (setf (ink-gcontext-last-clip-mask gcontext) nil)
 	  (unless start (setq start 0))
 	  (unless end (setq end (length string)))
 	  (dotimes (i (- end start))
@@ -1588,7 +1813,7 @@ and on color servers, unless using white or black")
 					  :depth 1
 					  :width n
 					  :height n))
-		   (gc (make-instance 'fast-gcontext
+		   (gc (make-instance 'ink-gcontext
 				      :drawable pixmap
 				      :font font
 				      :foreground 1
@@ -1638,7 +1863,7 @@ and on color servers, unless using white or black")
 		       :width array-size
 		       :height array-size
 		       :depth 1))
-	 (gc (make-instance 'fast-gcontext :drawable source-pixmap)))
+	 (gc (make-instance 'ink-gcontext :drawable source-pixmap)))
     (dotimes (i n)
       (macrolet ((copy-all-to (from xoffset yoffset to alu)
 		   `(stream-bitblt-support gc
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index ab4bf422d65ac6320a975fc03b350c073ba35d7d..7c59bfa135545f7f9fbc6a94ba31811b5bdeaf91 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.60 92/11/20 08:47:01 cer Exp $
+;; $fiHeader: xt-silica.lisp,v 1.61 92/12/01 09:47:21 cer Exp $
 
 (in-package :xm-silica)
 
@@ -29,6 +29,7 @@
      (display :reader port-display)
      (context :reader port-context)     
      (copy-gc :initform nil)
+     (copy-gc-depth-1 :initform nil)
      (opacities :initform nil)
      ;; This next is true for servers like Suns, which (pretty much) always
      ;; can safely copy-area without generating graphics-exposures.
@@ -59,6 +60,20 @@
 	    :foreign-address (x11:screen-default-gc
  			      (x11:xdefaultscreenofdisplay display)))))))
 
+;;--- I don't know of a better way of getting a depth 1 drawable
+;;other than by making a dummy depth 1 pixmap
+(defmethod port-copy-gc-depth-1 ((port xt-port))
+  ;;-- Assume 1-1 port-graft mapping?
+  (with-slots (copy-gc-depth-1 display) port
+    (or copy-gc-depth-1
+	(let ((pixmap (make-instance 'tk::pixmap
+				     :drawable
+				     (tk::display-root-window display)
+				     :depth 1 :width 1 :height 1)))
+	  (prog1
+	      (setf copy-gc-depth-1
+		(make-instance 'tk::gcontext :drawable pixmap))
+	    (tk::destroy-pixmap pixmap))))))
 
 
 (defmethod restart-port ((port xt-port))
@@ -230,7 +245,7 @@
 		    (cons (first entry)
 			  (apply #'make-stipple-image (second entry))))
 		'((+nowhere+ (1 1 (#b0)))
-		  (0.05 (8 06 (#b1000000000000000
+		  (0.05 (8 16 (#b1000000000000000
 			      #b0000001000000000
 			      #b0000000000001000
 			      #b0010000000000000
@@ -270,7 +285,7 @@
 			     #b11111110
 			     #b11011111
 			     #b11111011)))
-		  (0.9 (8 06 (#b0111111111111111
+		  (0.9 (8 16 (#b0111111111111111
 			       #b1111110111111111
 			       #b1111111111110111
 			       #b1101111111111111
diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp
index 53b517dbc03536e07678af7884df6c424b4a30ba..524dfc60b457196945f3bba30037032bbfc94424 100644
--- a/tk/gcontext.lisp
+++ b/tk/gcontext.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: gcontext.lisp,v 1.18 92/06/16 19:10:48 cer Exp $
+;; $fiHeader: gcontext.lisp,v 1.19 92/07/01 15:44:30 cer Exp $
 
 (in-package :tk)
 
@@ -345,6 +345,26 @@
      1
      x11:unsorted)))
 
+;; this will come in useful when we can handle region sets for clip regions
+#+ignore
+(defmethod (setf gcontext-clip-mask) ((nv cons) (gc gcontext))
+  (let ((n (length nv))
+	(rs (x11:make-xrectangle-array :number n)))
+    (dotimes (i n)
+      (let ((r (pop nv)))
+	(setf (x11:xrectangle-array-x rs i) (first r)
+	      (x11:xrectangle-array-y rs i) (second r)
+	      (x11:xrectangle-array-width rs i) (third r)
+	      (x11:xrectangle-array-height rs i) (fourth r))))
+    (x11:xsetcliprectangles
+     (object-display gc)
+     gc
+     0					; clip-x-origin
+     0					; clip-y-origin
+     rs
+     n
+     x11:unsorted)))
+
 (defmethod (setf gcontext-clip-mask) ((nv (eql :nowhere)) (gc gcontext))
   (x11:xsetcliprectangles
    (object-display gc)
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index 61c656410f75338f072899225540cd1fe4f069e3..c72075b02e8d9126ff2250cc312dab27978be3f1 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.33 92/11/06 19:04:21 cer Exp $
+;; $fiHeader: xlib.lisp,v 1.34 92/11/18 15:54:57 colin Exp $
 
 (in-package :tk)
 
@@ -607,7 +607,7 @@
 	     (setf (sys::memref-int v (+ (* h width) w) 0 :unsigned-byte)
 	       (aref data h w)))))
 	(1
-	 (setq format x11:xybitmap)
+	 (setq format x11:zpixmap)
 	 (setq bytes-per-line (ceiling (/ width bitmap-pad)))
 	 (setq v (excl::malloc (* bytes-per-line height)))))
       (let* ((visual (x11:screen-root-visual
diff --git a/xlib/xlib-defs.lisp b/xlib/xlib-defs.lisp
index e28c17d649a946ab4ddeaa92f620c5643b305258..c7548fad2d95696b4ae57bbf1ccd06cada57623d 100644
--- a/xlib/xlib-defs.lisp
+++ b/xlib/xlib-defs.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;;; $fiHeader: xlib-defs.lisp,v 1.4 92/07/27 19:29:32 cer Exp $
+;;; $fiHeader: xlib-defs.lisp,v 1.5 92/09/30 18:03:28 cer Exp $
 
 ;;      (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design
 ;;      patents pending in the U.S. and foreign countries. OPEN LOOK is a
@@ -852,6 +852,11 @@
   (width :type unsigned-short)
   (height :type unsigned-short))
 
+(ff::def-c-type (xrectangle-array :no-defuns) 1 xrectangle)
+(eval-when (compile load eval)
+  (export '(xrectangle-array-x xrectangle-array-y xrectangle-array-width
+	    xrectangle-array-height xrectangle-array make-xrectangle-array)))
+
 (def-exported-foreign-struct xarc
   (x :type short)
   (y :type short)