From c42a3f6d89e8174a5416c19da55cbbcbbd14acf4 Mon Sep 17 00:00:00 2001
From: colin <colin>
Date: Tue, 7 Sep 1993 21:47:44 +0000
Subject: [PATCH] see changelog for Tue Sep  7 14:42:57 PDT 1993

---
 ChangeLog.n                  |  60 +++++++++
 Makefile.defs                |   4 +-
 clim/frames.lisp             |  33 ++---
 clim/gadget-output.lisp      |   4 +-
 clim/graphics-recording.lisp |   5 +-
 clim/output-protocol.lisp    |   4 +-
 demo/plot.lisp               |   8 +-
 silica/gadgets.lisp          |  10 +-
 silica/medium.lisp           |   9 +-
 silica/port.lisp             |   4 +-
 test/test.lisp               |  12 +-
 tk-silica/image.lisp         |   7 +-
 tk-silica/xm-gadgets.lisp    |   5 +-
 tk-silica/xt-frames.lisp     |  28 +++--
 tk-silica/xt-gadgets.lisp    |  15 +--
 tk-silica/xt-graphics.lisp   | 228 +++++++++++++++++++----------------
 tk-silica/xt-silica.lisp     |  31 +++--
 utils/designs.lisp           |   8 +-
 utils/packages.lisp          |   3 +-
 19 files changed, 282 insertions(+), 196 deletions(-)

diff --git a/ChangeLog.n b/ChangeLog.n
index 462412e5..5ee9e768 100644
--- a/ChangeLog.n
+++ b/ChangeLog.n
@@ -1,3 +1,63 @@
+from colin: Tue Sep  7 14:42:57 PDT 1993
+
+Makefile.defs			now using devel.17
+
+clim/output-recording-defs.lisp	removed
+clim/standard-sequence.lisp	removed
+clim/standard-tree.lisp 	removed
+clim/text-output-recording.lisp removed
+
+clim/frames.lisp		added function limit-size-to-graft
+
+clim/graphics-recording.lisp	bounding rectangle for text-output-records
+				changed to use medium-merged-text-style
+				rather than medium-text-style
+
+clim/output-protocol.lisp	silica::scrolled-pane-line-scroll-amount
+				uses medium-merged-text-style rather than
+				medium-text-style 
+
+demo/plot.lisp			use medium-merged-text-style...
+
+silica/medium.lisp		engraft-medium sets text-style of new
+				medium to nil (not medium-default-text-style)
+				added setf medium-text-style :before method
+				which invalidates medium-merged-text-style
+
+silica/port.lisp		added defgeneric port-type, port-name
+
+test/test.lisp			use pattern for icon pixmap
+
+tk-silica/image.lisp		added truename for files passed to pbm
+				filters in read-bitmap-file 
+
+tk-silica/xm-gadgets.lisp	hack to make setf (gadget-alignment) work
+
+tk-silica/xt-frames.lisp	made update-frame-settings use
+				pixmap-from-pattern with bitmap format
+				limit size of top level shell to size of
+				graft 
+				
+tk-silica/xt-gadgets.lisp	decode-gadget-background handles patterns
+				properly 
+
+tk-silica/xt-graphics.lisp	engraft-medium doesn't set indirect-inks to
+				nil anymore (only degraft-medium does) and
+				doesn't call invalidate-indirect-inks
+				added gf deallocate-ink
+				decode-pattern-ink split into
+				decode-pattern-ink and pixmap-from-pattern
+
+tk-silica/xt-silica.lisp	added port-name
+				made get-xt-resources more robust to
+				invalid resource specifications
+
+utils/designs.lisp		fixed bug in (method color-rgb (ihs-color))
+
+utils/packages.lisp		export port-name from clim package
+
+-------------------------------------------------------------------------------
+
 Thu Aug 12 12:01:08 1993  Kevin Layer  (layer@sole)
 
 	* Makefile.cobjs-svr4: make sure setup_LLP exists before using it.
diff --git a/Makefile.defs b/Makefile.defs
index a969f056..bb9db1f1 100644
--- a/Makefile.defs
+++ b/Makefile.defs
@@ -1,9 +1,9 @@
-# $fiHeader: Makefile.defs,v 1.16 1993/07/29 20:51:15 layer Exp $
+# $fiHeader: Makefile.defs,v 1.18 1993/08/31 04:53:51 layer Exp $
 #
 #  Makefile.defs for CLIM 2.0
 #
 
-CL	= /usr/fi/dcl-4.2.devel.15
+CL	= /usr/fi/dcl-4.2.devel.17
 
 PWD	= /usr/tech/cer/stuff/clim-2.0
 DUMP-CL	= $(CL)
diff --git a/clim/frames.lisp b/clim/frames.lisp
index 5eadafd9..9d5085d5 100644
--- a/clim/frames.lisp
+++ b/clim/frames.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: frames.lisp,v 1.70 1993/07/22 15:37:51 cer Exp $
+;; $fiHeader: frames.lisp,v 1.71 1993/07/27 01:39:24 colin Exp $
 
 (in-package :clim-internals)
 
@@ -521,32 +521,33 @@
 		  ;; Maintain ALL-PANES in the order the panes are created
 		  (setq all-panes (nconc all-panes (list new-pane)))
 		  new-pane)))))
- 
+
+(defmacro limit-size-to-graft (width height graft)
+  `(multiple-value-bind (graft-width graft-height)
+       (bounding-rectangle-size ,graft)
+     ;;--- This fudge factor stuff looks dubious  --SWM
+     (let ((fudge-factor #+Allegro 0.9 #-Allegro 1))
+       (minf-or ,width (* graft-width fudge-factor))
+       (minf-or ,height (* graft-height fudge-factor)))))
+
 (defmethod layout-frame ((frame standard-application-frame) &optional width height)
   (let ((panes (frame-panes frame))
 	(*application-frame* frame))
     (when panes
       (clear-space-requirement-caches-in-tree panes)
-      (multiple-value-bind (graft-width graft-height) 
-	  (bounding-rectangle-size (graft frame))
-	(cond ((and width height)
-	       (minf width graft-width) 
-	       (minf height graft-height))
-	      (t
-	       (let ((sr (compose-space panes)))
-		 (setq width  (or width (space-requirement-width sr))
-		       height (or height (space-requirement-height sr)))
-		 ;;--- This fudge factor stuff looks dubious  --SWM
-		 (let ((fudge-factor #+Allegro 0.9 #-Allegro 1))
-		   (minf-or width (* graft-width fudge-factor))
-		   (minf-or height (* graft-height fudge-factor)))))))
+      (unless (and width height)
+	(let ((sr (compose-space panes)))
+	  (setq width  (or width (space-requirement-width sr))
+		height (or height (space-requirement-height sr)))))
+      (limit-size-to-graft width height (graft frame))
+
       ;;--- Don't bother with this if the size didn't change?
       (let ((top-sheet (or (frame-top-level-sheet frame) panes)))
 	(if (and (sheet-enabled-p top-sheet)
 		 (not (frame-resizable frame)))
 	    (multiple-value-call #'allocate-space 
 	      top-sheet (bounding-rectangle-size top-sheet)) 
-	    (resize-sheet top-sheet width height))))))
+	  (resize-sheet top-sheet width height))))))
 
 (defvar *frame-layout-changing-p* nil)
 
diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp
index 83a4fa5b..0b0ecbdd 100644
--- a/clim/gadget-output.lisp
+++ b/clim/gadget-output.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: gadget-output.lisp,v 1.51 1993/05/25 20:40:49 cer Exp $
+;; $fiHeader: gadget-output.lisp,v 1.52 1993/07/27 01:39:32 colin Exp $
 
 (in-package :clim-internals)
 
@@ -703,8 +703,6 @@
 	(multiple-value-bind (object type index)
 	    (accept-from-string (accept-values-query-type query) new-value)
 	  (declare (ignore type))
-	  ;; we can put this back in when we handle ol text-fields
-	  ;; correctly (see tk-silica/ol-gadgets)
 	  (assert (= index (length new-value)))
 	  object)
 	(error (c) 
diff --git a/clim/graphics-recording.lisp b/clim/graphics-recording.lisp
index 5fb370e4..3876e5fd 100644
--- a/clim/graphics-recording.lisp
+++ b/clim/graphics-recording.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: graphics-recording.lisp,v 1.22 93/04/07 09:06:40 cer Exp $
+;; $fiHeader: graphics-recording.lisp,v 1.23 1993/07/27 01:39:42 colin Exp $
 
 (in-package :clim-internals)
 
@@ -517,7 +517,8 @@
 (define-graphics-recording draw-text (ink text-style clipping-region)
   :bounding-rectangle
     (medium-text-bounding-box medium string-or-char x y
-			      start end align-x align-y text-style
+			      start end align-x align-y
+			      (medium-merged-text-style medium)
 			      towards-x towards-y transform-glyphs transformation))
 
 (defmethod medium-text-bounding-box ((sheet standard-sheet-output-mixin) string x y
diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp
index 532edb37..c2344715 100644
--- a/clim/output-protocol.lisp
+++ b/clim/output-protocol.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: output-protocol.lisp,v 1.37 1993/05/05 01:38:48 cer Exp $
+;; $fiHeader: output-protocol.lisp,v 1.38 1993/06/04 16:06:23 cer Exp $
 
 (in-package :clim-internals)
 
@@ -1095,7 +1095,7 @@
 						     orientation
 						     direction)
   (declare (ignore direction))
-  (let ((style (medium-text-style pane)))
+  (let ((style (medium-merged-text-style pane)))
     (ecase orientation
       (:horizontal (text-style-width style pane))
       (:vertical (+ (text-style-height style pane)
diff --git a/demo/plot.lisp b/demo/plot.lisp
index a8022818..85ed7ace 100644
--- a/demo/plot.lisp
+++ b/demo/plot.lisp
@@ -1,7 +1,7 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
 
 ;;
-;;				-[Thu Jul 22 17:14:40 1993 by colin]-
+;;				-[Mon Aug 23 14:13:24 1993 by colin]-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
 ;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA  All rights reserved.
@@ -21,7 +21,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: plot.lisp,v 1.25 1993/07/27 01:45:58 colin Exp $
+;; $fiHeader: plot.lisp,v 1.26 1993/08/12 16:03:37 cer Exp $
 
 (in-package :clim-demo)
 
@@ -200,8 +200,8 @@
 			   :cache-value (cons type (copy-list y-labels))
 			   :cache-test #'equalp)
     (let ((n-lines (length y-labels))
-	  (ascent (text-style-ascent (medium-text-style stream) stream))
-	  (descent (text-style-descent (medium-text-style stream) stream))
+	  (ascent (text-style-ascent (medium-merged-text-style stream) stream))
+	  (descent (text-style-descent (medium-merged-text-style stream) stream))
 	  (i 0))
       (surrounding-output-with-border (stream)
 	(formatting-table (stream)
diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp
index d7eccea8..42794ca0 100644
--- a/silica/gadgets.lisp
+++ b/silica/gadgets.lisp
@@ -1,6 +1,6 @@
 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: gadgets.lisp,v 1.55 1993/07/22 15:38:53 cer Exp $
+;; $fiHeader: gadgets.lisp,v 1.56 1993/08/12 16:04:16 cer Exp $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright (c) 1992 by Symbolics, Inc.  All rights reserved."
@@ -374,7 +374,7 @@
   (when (eq value t)
     (setf (radio-box-current-selection client) selection)
     (value-changed-callback 
-      client (gadget-client client) (gadget-id client) selection))
+     client (gadget-client client) (gadget-id client) selection))
   (call-next-method))
 
 
@@ -433,10 +433,10 @@
   (declare (ignore gadget-id))
   (if (eq value t)
       (pushnew selection (check-box-current-selection client))
-      (setf (check-box-current-selection client)
-	    (delete selection (check-box-current-selection client))))
+    (setf (check-box-current-selection client)
+      (delete selection (check-box-current-selection client))))
   (value-changed-callback
-    client (gadget-client client) (gadget-id client) (check-box-current-selection client))
+   client (gadget-client client) (gadget-id client) (check-box-current-selection client))
   (call-next-method))
 
 
diff --git a/silica/medium.lisp b/silica/medium.lisp
index 4f1ae338..45227352 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.35 1993/06/02 18:41:56 cer Exp $
+;; $fiHeader: medium.lisp,v 1.37 1993/08/19 20:10:13 smh Exp $
 
 (in-package :silica)
 
@@ -159,6 +159,7 @@
 
 (defmethod engraft-medium :after
 	   ((medium basic-medium) port (sheet sheet-with-resources-mixin))
+  (declare (ignore port))
   ;; We set the slots directly in order to avoid running any per-port
   ;; :AFTER methods (or whatever).  That work should be done by similar
   ;; per-port methods on ENGRAFT-MEDIUM.
@@ -168,7 +169,7 @@
     (setf foreground (pane-foreground sheet)
  	  background (pane-background sheet)
 	  default-text-style (parse-text-style (pane-text-style sheet))
-	  text-style default-text-style
+	  text-style nil
 	  merged-text-style-valid nil)))
 
 
@@ -393,6 +394,10 @@
   (declare (ignore new))
   (setf (medium-merged-text-style-valid medium) nil))
 
+(defmethod (setf medium-text-style) :before (new (medium basic-medium))
+  (declare (ignore new))
+  (setf (medium-merged-text-style-valid medium) nil))
+
 (defmethod medium-merged-text-style ((medium basic-medium))
   (with-slots (text-style default-text-style
 	       merged-text-style merged-text-style-valid) medium
diff --git a/silica/port.lisp b/silica/port.lisp
index ce0d41a9..ff916f0a 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.30 93/02/08 15:57:38 cer Exp $
+;; $fiHeader: port.lisp,v 1.31 1993/07/22 15:38:59 cer Exp $
 
 (in-package :silica)
 
@@ -66,6 +66,8 @@
 (defmethod find-port-type (x)
   (error "Cannot find port type: ~S" x))
 
+(defgeneric port-type (port))
+(defgeneric port-name (port))
 
 (defmethod initialize-instance :around ((port basic-port) &key server-path)
   (setf (slot-value port 'server-path) (copy-list server-path))
diff --git a/test/test.lisp b/test/test.lisp
index c98b7ff9..349dc8c0 100644
--- a/test/test.lisp
+++ b/test/test.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: test.lisp,v 1.50 1993/06/21 20:51:31 cer Exp $
+;; $fiHeader: test.lisp,v 1.51 1993/08/12 16:04:35 cer Exp $
 
 (in-package :clim-user)
 
@@ -84,13 +84,9 @@
   (:command-table test-frame)
   (:pane (make-clim-interactor-pane))
   (:icon :name "foo" 
-	 :pixmap (make-pattern 
-		   (let ((x (make-array '(48 48))))
-		     (dotimes (i 48)
-		       (dotimes (j 48)
-			 (setf (aref x i j) (random 2))))
-		     x)
-		   (list +red+ +green+)))
+	 :pixmap (make-pattern-from-bitmap-file
+		  "/usr/include/X11/bitmaps/terminal"
+		  :designs (list +red+ +green+)))
   (:pointer-documentation t)
   (:geometry :width 800 :height 800))
 
diff --git a/tk-silica/image.lisp b/tk-silica/image.lisp
index d9598866..cb6cbd21 100644
--- a/tk-silica/image.lisp
+++ b/tk-silica/image.lisp
@@ -1,6 +1,6 @@
 ;; -*- mode: common-lisp; package: xm-silica -*-
 ;;
-;;				-[Mon Jul 12 14:47:08 1993 by colin]-
+;;				-[Mon Aug  2 10:00:30 1993 by colin]-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: image.lisp,v 1.13 1993/07/22 15:39:27 cer Exp $
+;; $fiHeader: image.lisp,v 1.14 1993/07/27 01:54:53 colin Exp $
 
 (in-package :xm-silica)
 
@@ -58,7 +58,8 @@
 	(format filter)
 	(compute-filter-for-bitmap-format format)
       (with-open-stream (fstream (excl:run-shell-command
-				  (format nil "cat ~A | ~A" pathname filter)
+				  (format nil "cat ~A | ~A"
+					  (truename pathname) filter)
 				  :wait nil
 				  :error-output :stream
 				  :output :stream))
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index 6f36f17a..080d78dc 100644
--- a/tk-silica/xm-gadgets.lisp
+++ b/tk-silica/xm-gadgets.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-gadgets.lisp,v 1.79 1993/07/27 01:55:28 colin Exp $
+;; $fiHeader: xm-gadgets.lisp,v 1.80 1993/08/12 16:05:07 cer Exp $
 
 (in-package :xm-silica)
 
@@ -131,7 +131,8 @@
                     :alignment (ecase nv
                                  ((:left nil) :beginning)
                                  (:center :center)
-                                 (:right :end)))))
+                                 (:right :end))
+		    :label-string (or (gadget-label sheet) ""))))
 
 ;;; Motif widgets that support the activate callback
 
diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp
index ff4106d9..d492280d 100644
--- a/tk-silica/xt-frames.lisp
+++ b/tk-silica/xt-frames.lisp
@@ -1,6 +1,6 @@
 ;; -*- mode: common-lisp; package: xm-silica -*-
 ;;
-;;				-[Mon Jul 19 18:52:07 1993 by colin]-
+;;				-[Thu Aug 26 18:34:07 1993 by colin]-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-frames.lisp,v 1.37 1993/07/27 01:55:36 colin Exp $
+;; $fiHeader: xt-frames.lisp,v 1.38 1993/08/12 16:05:10 cer Exp $
 
 
 (in-package :xm-silica)
@@ -248,17 +248,22 @@
 
 (defmethod update-frame-settings ((framem xt-frame-manager) (frame t))
   ;;--- Lets see how this works out
-  (let ((shell (sheet-shell (frame-top-level-sheet frame))))
-    (let ((sr (compose-space (frame-top-level-sheet frame))))
+  (let ((graft (graft framem))
+	(shell (sheet-shell (frame-top-level-sheet frame))))
+    (let* ((sr (compose-space (frame-top-level-sheet frame)))
+	   (width (fix-coordinate (space-requirement-min-width sr)))
+	   (height (fix-coordinate (space-requirement-min-height sr))))
+      (clim-internals::limit-size-to-graft width height graft)
       (tk::set-values shell
-		      :min-width (fix-coordinate (space-requirement-min-width sr))
-		      :min-height (fix-coordinate (space-requirement-min-height sr))))
+		      :min-width width
+		      :min-height height))
 
     (let ((geo (clim-internals::frame-geometry frame)))
       (destructuring-bind
 	  (&key left top width height &allow-other-keys) geo
 	;;-- what about width and height
 	(when (and width height)
+	  (clim-internals::limit-size-to-graft width height graft)
 	  (tk::set-values shell :width (fix-coordinate width) 
 			  :height (fix-coordinate height)))
 	(when (and left top)
@@ -268,24 +273,21 @@
     
     (tk::set-values shell :title (frame-pretty-name frame))
     (let ((icon (clim-internals::frame-icon frame)))
-      (flet ((decode-pixmap (x)
+      (flet ((decode-bitmap (x)
 	       (etypecase x
 		 (string x)
 		 (pattern 
 		  (let ((sheet (frame-top-level-sheet frame)))
 		    (with-sheet-medium (medium sheet)
-		      (destructuring-bind (&key background-pixmap)
-			  (decode-gadget-background medium sheet x)
-			background-pixmap)))))))
+		      (pixmap-from-pattern x medium :bitmap)))))))
 	(destructuring-bind
 	    (&key (name (frame-pretty-name frame)) pixmap clipping-mask) icon
 	  ;;-- Dialog shells do not have :icon-name resource
 	  (when (typep shell 'tk::top-level-shell)
 	    (tk::set-values shell :icon-name name))
 	  (when pixmap
-	    (tk::set-values shell :icon-pixmap (decode-pixmap pixmap)))
-	  (when clipping-mask
-	    (tk::set-values shell :clip-mask (decode-pixmap clipping-mask))))))))
+	    (tk::set-values shell :icon-pixmap (decode-bitmap pixmap)))
+	  (when clipping-mask (tk::set-values shell :clip-mask (decode-bitmap clipping-mask))))))))
 
 (defmethod frame-manager-note-pretty-name-changed ((framem xt-frame-manager) 
 						   (frame standard-application-frame))
diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp
index 4e39f989..4aff18ec 100644
--- a/tk-silica/xt-gadgets.lisp
+++ b/tk-silica/xt-gadgets.lisp
@@ -1,6 +1,6 @@
 ;; -*- mode: common-lisp; package: xm-silica -*-
 ;;
-;;				-[Fri Jul 30 15:12:38 1993 by colin]-
+;;				-[Thu Aug 19 15:39:02 1993 by colin]-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-gadgets.lisp,v 1.36 1993/07/27 01:55:40 colin Exp $
+;; $fiHeader: xt-gadgets.lisp,v 1.37 1993/07/30 23:58:39 colin Exp $
 
 (in-package :xm-silica)
 
@@ -87,15 +87,13 @@
     
 (defmethod decode-gadget-background (medium sheet ink)
   (declare (ignore sheet))
-  (let ((gc (decode-ink ink medium)))
-    (if (tk::gcontext-stipple gc)
-	(list :background-pixmap (tk::gcontext-stipple gc))
-      (list :background (tk::gcontext-foreground gc)))))
+  (let ((pixel (decode-color ink medium)))
+    (list :background pixel)))
 
 (defmethod decode-gadget-background (medium sheet (ink pattern))
   (declare (ignore sheet))
-  (let ((gc (decode-ink ink medium)))
-    (list :background-pixmap (tk::gcontext-stipple gc))))
+  (let ((pixmap (pixmap-from-pattern ink medium :pixmap)))
+    (list :background-pixmap pixmap)))
 
 (defmethod decode-gadget-foreground (medium sheet ink)
   (declare (ignore sheet))
@@ -113,7 +111,6 @@
       (apply #'tk::set-values m (decode-gadget-background medium pane ink)))))
 
 
-
 (defclass xt-pane (basic-pane) 
 	  ;;--- Is this useful a hack enabling things to be passed through
 	  ;;--- to the mirror
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index e1db2bda..16414dea 100644
--- a/tk-silica/xt-graphics.lisp
+++ b/tk-silica/xt-graphics.lisp
@@ -1,6 +1,6 @@
 ;; -*- mode: common-lisp; package: tk-silica -*-
 ;;
-;;				-[Thu Jul 22 18:06:19 1993 by colin]-
+;;				-[Thu Aug 19 18:38:51 1993 by colin]-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
@@ -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.76 1993/06/23 00:13:59 cer Exp $
+;; $fiHeader: xt-graphics.lisp,v 1.77 1993/07/27 01:55:47 colin Exp $
 
 (in-package :tk-silica)
 
@@ -309,14 +309,12 @@
     (let ((palette (medium-palette medium)))
       (with-slots (white-pixel black-pixel)
 	  palette
-	(setf indirect-inks nil 
-	      device-clip-region nil)
+	(setf device-clip-region nil)
 	(setf (medium-sheet medium) sheet)
 	(when (and drawable
 		   (not (eq (port-display port)
 			    (tk::object-display drawable))))
-	  (error "drawable and display do not match"))
-	(invalidate-indirect-inks medium)))))
+	  (error "drawable and display do not match"))))))
 
 (defmethod degraft-medium :after ((medium xt-medium) (port xt-port) sheet)
   (declare (ignore sheet))
@@ -325,12 +323,8 @@
     (setf drawable nil
 	  (medium-sheet medium) nil)
     (maphash #'(lambda (ink gc) 
-		 (declare (ignore ink))
-		 (let ((pixmap (or (tk::gcontext-stipple gc)
-				   (tk::gcontext-tile gc))))
-		   (when pixmap
-		     (tk::destroy-pixmap pixmap))
-		   (tk::free-gcontext gc)))
+		 (declare (ignore gc))
+		 (deallocate-ink ink medium))
 	     ink-table)
     (clrhash ink-table)
     (setf indirect-inks nil)))
@@ -339,15 +333,15 @@
   (with-slots (ink-table indirect-inks)
       medium
     (dolist (ink indirect-inks)
-      (let* ((gc (gethash ink ink-table))
-	     (pixmap (or (tk::gcontext-stipple gc)
-			 (tk::gcontext-tile gc))))
-	(when pixmap
-	  (tk::destroy-pixmap pixmap))
-	(tk::free-gcontext gc))
+      (deallocate-ink ink medium)
       (remhash ink ink-table))
     (setf indirect-inks nil)))
 
+(defmethod deallocate-ink ((ink design) (medium xt-medium))
+  (with-slots (ink-table) medium
+    (let ((gc (gethash ink ink-table)))
+      (tk::free-gcontext gc))))
+
 (defmethod (setf medium-background) :after (ink (medium xt-medium))
   (declare (ignore ink))
   (invalidate-indirect-inks medium)
@@ -477,15 +471,6 @@
 
 (defgeneric decode-ink (ink medium))
 
-;;; we provide this around method which implement a cache of already
-;;; decoded inks
-
-;;; if the decode method for an ink calculates the gcontext by calling
-;;; decode-ink it should also return t as it's second value. (eg for
-;;; contrasting inks) This prevent problems with having multiple
-;;; entries for the same gc in the table which causes problems when
-;;; they need to be freed
-
 (defmethod decode-ink ((ink design) (medium xt-medium))
   (with-slots (ink-table indirect-inks) medium
     (or (gethash ink ink-table)
@@ -513,9 +498,11 @@
 	  (setf (tk::gcontext-plane-mask new-gc) mask)))
       new-gc)))
 
+#+ignore
 (defmethod decode-ink-1 ((x (eql +foreground-ink+)) (medium xt-medium))
   (decode-ink-1 (medium-foreground medium) medium))
 
+#+ignore
 (defmethod decode-ink-1 ((x (eql +background-ink+)) (medium xt-medium))
   (decode-ink-1 (medium-background medium) medium))
 
@@ -597,84 +584,111 @@
       (decode-rectangular-tile ink)
     (declare (ignore width height))
     (decode-pattern-ink pattern medium t)))
-      
-(defun decode-pattern-ink (pattern medium &optional tile-p)
+
+(defmethod deallocate-ink :before ((ink pattern) (medium xt-medium))
+  (deallocate-pattern-ink ink medium))
+
+(defmethod deallocate-ink :before ((ink rectangular-tile) (medium xt-medium))
+  (deallocate-pattern-ink ink medium))
+
+(defun deallocate-pattern-ink (ink medium)
+  (with-slots (ink-table) medium
+    (let* ((gc (gethash ink ink-table))
+	   (pixmap (or (tk::gcontext-stipple gc)
+		       (tk::gcontext-tile gc))))
+      (when pixmap
+	(tk::destroy-pixmap pixmap)))))
+
+(defun pixmap-from-pattern (pattern medium &optional format)
   (multiple-value-bind (array designs)
       (decode-pattern pattern)
-    (let* ((height (array-dimension array 0))
+    (let* ((n-designs (length designs))
+	   (height (array-dimension array 0))
 	   (width (array-dimension array 1))
-	   (image-data (make-array (list height width)))
-	   (design-pixels (make-array (length designs)))
-	   (two-color-p (eql (length designs) 2))
-	   two-color-fg
-	   two-color-bg)
-      (declare (simple-vector design-pixels))
-
-      ;; Cache the decoded designs from the pattern
-      (dotimes (n (length designs))
-	(let ((design (elt designs n)))
-	  (if (eql design +nowhere+)
-	      (unless two-color-p
-		(error "Transparent pattern ~S has more than two designs" pattern))
-	    (setf (svref design-pixels n)
-	      (decode-color design medium)))))
-
-      (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 width
-				   :height height
-				   :data image-data
-				   :depth depth))
-	     (gc (make-instance 'ink-gcontext :drawable drawable))
-	     (pixmap 
-	      (make-instance 'tk::pixmap
-			     :drawable drawable
-			     :width width
-			     :height height
-			     :depth depth)))
-	(tk::put-image pixmap 
-		       (if two-color-p
-			   (port-copy-gc-depth-1 port)
-			 gc) 
-		       image)
-	(tk::destroy-image image)
-	(if two-color-p
+	   (pixels (make-array n-designs))
+	   (image-data (make-array (list height width))))
+      (declare (simple-vector pixels))
+      
+      (unless format
+	(setq format (if (eql n-designs 2) :bitmap :pixmap)))
+
+      (let ((bitmap
+	     (case format
+	       (:bitmap (or (eql n-designs 2)
+			    (error "Can't make a bitmap from pattern with more than two designs"))) 
+	       (:pixmap (and (member +nowhere+ designs)
+			     (error "Can't make a pixmap from a transparent pattern"))))))
+	
+	(dotimes (n (length designs))
+	  (let ((design (elt designs n)))
+	    (setf (svref pixels n) 
+	      (and (not (eql design +nowhere+))
+		   (decode-color design medium)))))
+
+	(let ((bitmap-bg (and bitmap
+			      (svref pixels 1) (svref pixels 0))))
+	  (dotimes (w width)
+	    (dotimes (h height)
+	      (let ((pixel (svref pixels (aref array h w))))
+		(setf (aref image-data h w)
+		  (if bitmap
+		      (if (eq pixel bitmap-bg) 0 1)
+		    pixel))))))
+
+	(when bitmap
+	  (when (null (svref pixels 1))
+	    (rotatef (svref pixels 0) (svref pixels 1))))
+	
+	(let* ((port (port (medium-sheet medium)))
+	       (drawable (or (slot-value medium 'drawable)
+			     (tk::display-root-window (port-display port))))
+	       (depth (if bitmap
+			  1
+			(tk::drawable-depth drawable)))
+	       (image (make-instance 'tk::image
+			:width width
+			:height height
+			:data image-data
+			:depth depth))
+	       (pixmap (make-instance 'tk::pixmap
+			 :drawable drawable
+			 :width width
+			 :height height
+			 :depth depth)))
+	  (tk::put-image pixmap 
+			 (if bitmap
+			     (port-copy-gc-depth-1 port)
+			   (port-copy-gc port))
+			 image)
+	  (tk::destroy-image image)
+	  (values pixmap format pixels))))))
+
+
+(defun decode-pattern-ink (pattern medium &optional tile-p)
+  (multiple-value-bind (pixmap format pixels)
+      (pixmap-from-pattern pattern medium)
+    (let* ((drawable (or (slot-value medium 'drawable)
+			 (tk::display-root-window
+			  (port-display (port (medium-sheet medium))))))
+	   (gc (make-instance 'ink-gcontext :drawable drawable)))
+      (if (eq format :bitmap)
+	  (let ((bg (svref pixels 0))
+		(fg (svref pixels 1)))
 	    (setf (tk::gcontext-stipple gc) pixmap
-		  (tk::gcontext-fill-style gc) (if two-color-bg
+		  (tk::gcontext-fill-style gc) (if 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))
-	(unless tile-p
-	  (setf (ink-gcontext-shift-tile-origin gc) t
-		(ink-gcontext-ink-clip-region gc)
-		(make-bounding-rectangle 0 0 width height)))
-	gc))))
+		  (tk::gcontext-foreground gc) (or fg 0)
+		  (tk::gcontext-background gc) (or bg 0)))
+      (setf (tk::gcontext-tile gc) pixmap
+	    (tk::gcontext-fill-style gc) :tiled))
+      (unless tile-p
+	(setf (ink-gcontext-shift-tile-origin gc) t
+	      (ink-gcontext-ink-clip-region gc)
+	      (make-bounding-rectangle 0 0
+				       (pattern-width pattern)
+				       (pattern-height pattern))))
+      gc)))
 
 ;;; decode color
 
@@ -695,7 +709,7 @@
 (defmethod decode-color ((ink standard-opacity) (medium xt-medium))
   (if (> (opacity-value ink) 0.5)
       (decode-color +foreground-ink+ medium)
-      (decode-color +background-ink+ medium)))
+    (decode-color +background-ink+ medium)))
 
 (defmethod decode-color ((ink contrasting-ink) (medium xt-medium))
   (decode-color (decode-contrasting-ink ink medium) medium))
@@ -1308,7 +1322,8 @@
       (let* ((port (port medium))
 	     (sheet (medium-sheet medium))
 	     (transform (sheet-device-transformation sheet))
-	     (font (text-style-mapping port (medium-text-style medium)))
+	     (text-style (medium-merged-text-style medium))
+	     (font (text-style-mapping port text-style))
 	     (ascent (tk::font-ascent font)))
 	(convert-to-device-coordinates transform x y)
 	(discard-illegal-coordinates medium-draw-text* x y)
@@ -1318,26 +1333,25 @@
 	  (setq string-or-char (string string-or-char)))
 	(ecase align-x
 	  (:right
-	   (let ((dx (text-size sheet string-or-char
-				:text-style (medium-text-style medium)
+	   (let ((dx (text-size sheet string-or-char :text-style text-style
 				:start start :end end)))
 	     (when towards-x (decf towards-x dx))
 	     (decf x dx)))
 	  (:center 
 	   (let ((dx (floor (text-size sheet string-or-char
-				       :text-style (medium-text-style medium)
+				       :text-style text-style
 				       :start start :end end) 2)))
 	     (when towards-x (decf towards-x dx))
 	     (decf x dx)))
 	  (:left nil))
 	(ecase align-y
 	  (:bottom
-	   (let ((dy (text-style-descent (medium-text-style medium) medium)))
+	   (let ((dy (text-style-descent text-style medium)))
 	     (decf y dy)
 	     (when towards-y (decf towards-y dy))))
 	  (:center 
-	   (let ((dy (- (text-style-descent (medium-text-style medium) medium)
-			(floor (text-style-height (medium-text-style medium) medium) 2))))
+	   (let ((dy (- (text-style-descent text-style medium)
+			(floor (text-style-height text-style medium) 2))))
 	     (decf y dy)
 	     (when towards-y (decf towards-y dy))))
 	  (:baseline nil)
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index 51b8f34b..202c76df 100644
--- a/tk-silica/xt-silica.lisp
+++ b/tk-silica/xt-silica.lisp
@@ -1,6 +1,6 @@
 ;; -*- mode: common-lisp; package: xm-silica -*-
 ;;
-;;				-[Thu Jul 22 16:32:23 1993 by colin]-
+;;				-[Wed Aug 25 11:15:21 1993 by colin]-
 ;; 
 ;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
 ;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
@@ -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.86 1993/07/27 01:55:59 colin Exp $
+;; $fiHeader: xt-silica.lisp,v 1.87 1993/08/12 16:05:13 cer Exp $
 
 (in-package :xm-silica)
 
@@ -51,6 +51,9 @@
 (defmethod port-type ((port xt-port))
   ':xt)
 
+(defmethod port-name ((port xt-port))
+  (ff:char*-to-string 
+   (x11:display-display-name (port-display port))))
 
 (defmethod port-copy-gc ((port xt-port))
   ;;-- Assume 1-1 port-graft mapping?
@@ -1196,8 +1199,8 @@
       (find-widget-class-and-initargs-for-sheet port parent sheet)
     (let ((class-name 
 	   (tk::widget-class-name (tk::class-handle (find-class class)))))
-      (values (getf initargs :name 
-		    (string-downcase class-name :start 0 :end 1))
+      (values (or (getf initargs :name)
+		  (string-downcase class-name :start 0 :end 1))
 	      class-name))))
 
 (defmethod find-widget-name-and-class
@@ -1268,17 +1271,21 @@
 		*resource-class* resource-class)
 	  `(,@(and background `(:background ,background))
 	    ,@(and foreground `(:foreground ,foreground))
-	    ,@(and text-style
-		   `(:text-style
-		     ,(let ((spec (read-from-string text-style)))
-			(etypecase spec
-			  (cons (parse-text-style spec))
-			  (string (silica::make-device-font 
-				   port 
+	    ,@(let ((style (convert-text-style port display text-style)))
+		(and style `(:text-style ,style)))))))))
+
+(defun convert-text-style (port display text-style)
+  (ignore-errors
+   (let ((spec (read-from-string text-style)))
+     (if (consp spec)
+	 (parse-text-style spec)
+       (let ((font-name (or (and (stringp spec) spec)
+			    text-style)))
+	 (silica::make-device-font port 
 				   (make-instance 'tk::font 
 				     :display display
 				     :name (car (tk::list-font-names
-						 display spec)))))))))))))))
+						 display font-name)))))))))
 
 ;;;--- Gadget activation deactivate
 
diff --git a/utils/designs.lisp b/utils/designs.lisp
index 5609876b..332fb226 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.15 93/05/13 16:32:53 colin Exp $
+;; $fiHeader: designs.lisp,v 1.16 1993/07/27 01:57:08 colin Exp $
 
 (in-package :clim-utils)
 
@@ -296,9 +296,9 @@
 	 (hh (mod (- hue .5f0) 1.0f0))
 	 (hh (- (* hh 2.0f0 3.1415926535f0) 3.1415926535f0))
 	 (s3 (sin saturation))
-	 (x (* (sqrt ihs-rgb-c1) s3 (cos hh) intensity))
-	 (y (* (sqrt ihs-rgb-c2) s3 (sin hh) intensity))
-	 (z (* (sqrt ihs-rgb-c3) (cos saturation) intensity)))
+	 (x (* ihs-rgb-c1 s3 (cos hh) intensity))
+	 (y (* ihs-rgb-c2 s3 (sin hh) intensity))
+	 (z (* ihs-rgb-c3 (cos saturation) intensity)))
     (macrolet ((range (x)
 		 `(max 0.0f0 (min 1.0f0 ,x))))
       (values (range (+ x x z))
diff --git a/utils/packages.lisp b/utils/packages.lisp
index 3b0a9512..ebde891f 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.56 1993/07/27 01:57:48 colin Exp $
+;; $fiHeader: packages.lisp,v 1.57 1993/08/12 16:05:20 cer Exp $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
 
@@ -1851,6 +1851,7 @@
     port-alive-p
     port-keyboard-input-focus
     port-modifier-state
+    port-name
     port-pointer
     port-properties
     port-server-path
-- 
GitLab