From 0cbb8955fd6656e9e5ba4c346b5f1920602eab9f Mon Sep 17 00:00:00 2001
From: colin <colin>
Date: Mon, 11 Jan 1993 15:46:36 +0000
Subject: [PATCH] Makefile misc/dump.lisp - added DUMP-CLIM and
 sys::*clim-dump-name* - support for dumping a   clim image somewhere other
 than /tmp

clim/output-protocol.lisp
- engraft-medium :after changes text-style only if not already set

demo/demo-driver.lisp
- added :force argument to start-demo

silica/classes.lisp
- wrapped a print-unreadable-object around print-object method for
  window-event

silica/medium.lisp
- initform for text-style in foreground-background-and-text-style-mixin
  changed from *default-text-style* to nil (#+allegro)

test/test-suite.lisp
- changed "Colored patterns" test to draw a different polygon so that
  pattern used as ink is visible (and not clipped out of existance as
  before)

tk/foreign.lisp
- added functions display-database and get-application-name-and-class

tk/xt-defs.lisp
tk/make-classes.lisp
- changed class x-resource to xt-resource and all references

tk/resources.lisp
- added a convert-resource-in for 'alignment

tk/widget.lisp
- app-create-shell sets up application name and class as "clim", "Clim"
- initialize-toolkit passes on initargs to app-create-shell
- added functions xt-name and  xt-class
- added function widget-resource-name-and-class

tk/xlib.lisp
- added class resource-database
- added functions get-resource and convert-string
- added parse-color

tk/xt-defs.lisp
- removed xrm-resource and xrm-resource-array
- changed x-resource to xt-resource

tk/xt-funs.lisp
- added xt_database, xt_get_application_name_and_class,
  xt_convert_and_store, xt_name and xt_class

xtk.lisp removed (no longer used)

tk-silica/xm-frames.lisp
- realize-mirror :around method on menu-bar queries textStyle resource

tk-silica/xm-gadgets.lisp
- removed make-pane-class method on scroller-pane and put it in
  main make-pane-class method on motif-frame-manager
- find-widget-class-and-initargs-for-sheet on xm-viewport sets up
  :name resource

tk-silica/xt-gadgets.lisp
- find-widget-class-and-initargs-for-sheet :around method on
  foreground-background-and-text-style-mixin queries textStyle
  resource

tk-silica/xt-graphics.lisp
- find-named-color uses parse-color rather than lookup-color (so that
  #rgb works - in R5 should be able to use lookup-color again)
- changed refs to tk::x-colormap-error to tk::x-colormap-full
- changed text-style-{width,height,ascent,descent} to specialize on
  (text-style t) rather than standard-text-style. This makes them work
  for device-fonts.
- added decode-contrasting-ink (avoids some code duplication)
- on monochrome made luminosity == 0.5 decode to white rather than
  black (makes contrasting ink work better)

tk-silica/xt-silica.lisp
- added a bunch of define-xt-keysyms and fixed some wrong ones
- removed default-from-mirror-resources
- added default-from-resources - queries the resource database to get
  background, foreground and text-style
---
 Makefile                   | 47 ++++++++++---------
 clim/output-protocol.lisp  |  5 +-
 silica/classes.lisp        |  9 ++--
 silica/medium.lisp         |  5 +-
 test/test-suite.lisp       |  4 +-
 tk-silica/xm-frames.lisp   | 24 ++++++++--
 tk-silica/xm-gadgets.lisp  | 13 +++---
 tk-silica/xt-gadgets.lisp  | 32 +++++++++++--
 tk-silica/xt-graphics.lisp | 49 +++++++++-----------
 tk-silica/xt-silica.lisp   | 94 ++++++++++++++++++++++++--------------
 tk/make-classes.lisp       | 18 ++++----
 tk/resources.lisp          |  8 +++-
 tk/widget.lisp             | 29 ++++++++++--
 tk/xlib.lisp               | 40 +++++++++++++++-
 14 files changed, 253 insertions(+), 124 deletions(-)

diff --git a/Makefile b/Makefile
index 67c06301..a5d35b57 100644
--- a/Makefile
+++ b/Makefile
@@ -1,4 +1,4 @@
-# $fiHeader: Makefile,v 1.70 92/12/07 12:13:43 cer Exp $
+# $fiHeader: Makefile,v 1.71 92/12/14 15:01:50 cer Exp $
 #
 #  Makefile for CLIM 2.0
 #
@@ -8,6 +8,14 @@ PWD	= /usr/tech/cer/stuff/clim-2.0
 DUMP-CL	= $(CL)
 CLOPTS	= -qq
 
+DEVICE	= /dev/null
+RM	= /bin/rm
+CAT	= /bin/cat
+ECHO	= /bin/echo
+MV	= /usr/fi/mv-nfs
+TAGS	= /usr/fi/lib/emacs/etc/etags
+TMP	= /tmp
+
 # Training
 
 TRAIN_TIMES=2
@@ -40,19 +48,13 @@ SAFETY	= 1
 DEBUG   = 2
 
 COMPILE_PRINT=nil 
-# Name of dumped lisp
+# Where to dump all clim images
+DUMP-CLIM = $(TMP)/clim.temp_`whoami`
+# Where images are then move to (can be same as DUMP-CLIM)
 CLIM	= ./slim
 CLIMOL= $(CLIM)
 CLIMXM= $(CLIM)
 
-make = make SPEED=${SPEED} SAFETY=${SAFETY} DEBUG=${DEBUG} \
-	LOAD_SOURCE_FILE_INFO=${LOAD_SOURCE_FILE_INFO} \
-	RECORD_SOURCE_FILE_INFO=${RECORD_SOURCE_FILE_INFO} \
-	LOAD_XREF_INFO=${LOAD_XREF_INFO} \
-	RECORD_XREF_INFO=${RECORD_XREF_INFO} \
-	CLIM=${CLIM} CLIMOL=${CLIMOL} CLIMXM=${CLIMXM} \
-	COMPILE_PRINT=${COMPILE_PRINT}
-
 XINCLUDES=-I/x11/motif-1.1/lib
 
 CFLAGS	= -O -D_NO_PROTO -DSTRINGS_ALIGNED -DNO_REGEX -DNO_ISDIR -DUSE_RE_COMP -DUSER_GETWD $(XINCLUDES)
@@ -68,14 +70,6 @@ DIRS0	=  tk tk-silica misc cloe climtoys
 DIRS	= $(PUBDIRS) xlib $(DIRS0)
 CHEAP_CLEAN	= $(PUBDIRS) $(DIRS0)
 
-DEVICE	= /dev/null
-RM	= /bin/rm
-CAT	= /bin/cat
-ECHO	= /bin/echo
-MV	= /usr/fi/mv-nfs
-TAGS	= /usr/fi/lib/emacs/etc/etags
-TMP	= /tmp
-
 SRC_FILES = */*.lisp *.lisp Makefile misc/make-stub-file \
 	    misc/undefinedsymbols misc/undefinedsymbols.olit misc/undefinedsymbols.colit \
 	    misc/undefinedsymbols.motif misc/undefinedsymbols.cmotif misc/undefinedsymbols.xt \
@@ -514,6 +508,14 @@ GENERIC-OBJS= $(CLIM-UTILS-OBJS) $(CLIM-SILICA-OBJS) $(CLIM-STANDALONE-OBJS)
 MOTIF-OBJS = $(LOAD-XM-OBJS) $(XT-TK-OBJS) $(XM-TK-OBJS) $(MOTIF-CLIM-OBJS) 
 OPENLOOK-OBJS = $(LOAD-OL-OBJS) $(XT-TK-OBJS) $(OL-CLIM-OBJS) $(OPENLOOK-CLIM-OBJS)
 
+make = make SPEED=${SPEED} SAFETY=${SAFETY} DEBUG=${DEBUG} \
+	LOAD_SOURCE_FILE_INFO=${LOAD_SOURCE_FILE_INFO} \
+	RECORD_SOURCE_FILE_INFO=${RECORD_SOURCE_FILE_INFO} \
+	LOAD_XREF_INFO=${LOAD_XREF_INFO} \
+	RECORD_XREF_INFO=${RECORD_XREF_INFO} \
+	CLIM=${CLIM} CLIMOL=${CLIMOL} CLIMXM=${CLIMXM} DUMP-CLIM=${DUMP-CLIM} \
+	COMPILE_PRINT=${COMPILE_PRINT}
+
 default: all-xm
 
 trained-clim-xm:	
@@ -644,8 +646,9 @@ clim-xm:	FORCE $(MOTIF_OBJS)
 	        (setq sys::*clim-motif-pathname* \"clim-motif$(DEBUGLIB).o\") \
 		(load \"misc/dev-load-1.lisp\") \
 		(load-it 'motif-clim) \
+		(setq sys::*clim-dump-name* \"$(DUMP-CLIM)\") \
 		(load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch
-	$(MV) $(TMP)/clim.temp_`whoami` $(CLIMXM)
+	$(MV) $(DUMP-CLIM) $(CLIMXM)
 	ls -lLt $(CLIMXM) >> Clim-sizes.n
 	size $(CLIMXM) >> Clim-sizes.n
 	ls -lLt $(CLIMXM)
@@ -659,8 +662,9 @@ clim-ol:	FORCE $(OPENLOOK_OBJS)
 	        (setq sys::*clim-olit-pathname* \"clim-olit$(DEBUGLIB).o\") \
 		(load \"misc/dev-load-1.lisp\") \
 		(load-it 'openlook-clim) \
+		(setq sys::*clim-dump-name* \"$(DUMP-CLIM)\") \
 		(load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch
-	$(MV) $(TMP)/clim.temp_`whoami` $(CLIMOL)
+	$(MV) $(DUMP-CLIM) $(CLIMOL)
 	ls -lLt $(CLIMOL) >> Clim-sizes.n
 	size $(CLIMOL) >> Clim-sizes.n
 	ls -lLt $(CLIMOL)
@@ -669,8 +673,9 @@ clim-ol:	FORCE $(OPENLOOK_OBJS)
 clim-small:	FORCE
 	$(ECHO) " \
 		(load \"misc/load-xm.lisp\") \
+		(setq sys::*clim-dump-name* \"$(DUMP-CLIM)\") \
 		(load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch
-	$(MV) $(TMP)/clim.temp_`whoami` $(CLIM-SMALL)
+	$(MV) $(DUMP-CLIM) $(CLIM-SMALL)
 	ls -lt $(CLIM-SMALL) >> Clim-sizes.n
 	size $(CLIM-SMALL) >> Clim-sizes.n
 	ls -lt $(CLIM-SMALL)
diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp
index 4bc08e90..b9946b9c 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.30 92/12/03 10:27:20 cer Exp $
+;; $fiHeader: output-protocol.lisp,v 1.31 92/12/16 16:46:48 cer Exp $
 
 (in-package :clim-internals)
 
@@ -117,7 +117,8 @@
 				  (setf (slot-value stream 'default-text-style)
 					(port-default-text-style port))))
 	  silica::text-style 
-	    (parse-text-style silica::default-text-style)
+	    (or (medium-text-style stream)
+		(parse-text-style silica::default-text-style))
 	  silica::merged-text-style-valid nil)))
 
 ;;--- I sure don't like having to do this to make string streams work
diff --git a/silica/classes.lisp b/silica/classes.lisp
index f12873e8..43ac0dab 100644
--- a/silica/classes.lisp
+++ b/silica/classes.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: classes.lisp,v 1.28 92/12/14 15:03:28 cer Exp $
+;; $fiHeader: classes.lisp,v 1.29 92/12/16 16:48:28 cer Exp $
 
 (in-package :silica)
 
@@ -182,9 +182,10 @@
 		   :initarg :sheet :initarg :mirrored-sheet)))
 
 (defmethod print-object ((event window-event) stream)
-  (with-bounding-rectangle* (left top right bottom) (window-event-region event)
-    (print-unreadable-object (event stream :type t)
-      (format stream "/x ~D:~D y ~D:~D/" left right top bottom))))
+  (print-unreadable-object (event stream :type t)
+    (when (slot-boundp event 'region)
+      (with-bounding-rectangle* (left top right bottom) (window-event-region event)
+         (format stream "/x ~D:~D y ~D:~D/" left right top bottom)))))
 
 (define-event-class window-configuration-event (window-event) ())
 (define-event-class window-repaint-event (window-event) ())
diff --git a/silica/medium.lisp b/silica/medium.lisp
index e9519e7f..ef7e5f81 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.30 92/12/02 13:31:06 colin Exp $
+;; $fiHeader: medium.lisp,v 1.31 92/12/16 16:49:35 cer Exp $
 
 (in-package :silica)
 
@@ -99,7 +99,8 @@
 		 :accessor pane-foreground)
      (background :initform nil :initarg :background
 		 :accessor pane-background)
-     (text-style :initform *default-text-style* :initarg :text-style
+     (text-style :initform #+allegro nil #-allegro *default-text-style*
+		 :initarg :text-style
 		 :accessor pane-text-style)))
 
 (defmethod initialize-instance :after ((pane foreground-background-and-text-style-mixin)
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index 3b6f6028..e3d0fd4b 100644
--- a/test/test-suite.lisp
+++ b/test/test-suite.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: test-suite.lisp,v 1.51 92/12/16 16:50:14 cer Exp $
+;; $fiHeader: test-suite.lisp,v 1.52 92/12/17 15:33:30 cer Exp $
 
 (in-package :clim-user)
 
@@ -875,7 +875,7 @@ people, shall not perish from the earth.
 				:ink (generate-stipple +red+ +yellow+))
 	(format-graphics-sample stream "Green/Transparent" sample
 				:ink (generate-stipple +green+ (make-opacity 0.1)))))
-    (let ((sample '(draw-polygon* (0 0 45 100 100 0))))
+    (let ((sample '(draw-polygon* (0 0 0 100 100 50))))
       (formatting-graphics-samples (stream "Colored patterns")
 	(format-graphics-sample stream "Black/White" sample
 				:ink (generate-image +white+ +black+ +white+ +black+))
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index 41bc6184..5248ec94 100644
--- a/tk-silica/xm-frames.lisp
+++ b/tk-silica/xm-frames.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-frames.lisp,v 1.43 92/12/07 12:15:56 cer Exp $
+;; $fiHeader: xm-frames.lisp,v 1.44 92/12/14 15:04:33 cer Exp $
 
 (in-package :xm-silica)
 
@@ -94,8 +94,26 @@
   
   (let* ((mirror (call-next-method))
 	 (text-style (menu-bar-text-style sheet))
-	 (font-list (and text-style
-			 (list :font-list (list (text-style-mapping port text-style)))))
+	 (font-list 
+	  (if text-style
+	      (list :font-list (text-style-mapping port text-style))
+	    (multiple-value-bind (name class)
+		(xt::widget-resource-name-and-class mirror)
+	      (let* ((display (silica::port-display port))
+		     (db (tk::display-database display))
+		     (text-style (xt::get-resource db name "textStyle"
+						   class "TextStyle")))
+		(when text-style
+		  (let ((spec (read-from-string text-style)))
+		    (list :font-list
+			  (etypecase spec
+			    (cons
+			     (text-style-mapping port (parse-text-style spec)))
+			    (string
+			     (make-instance 'tk::font 
+					    :display display
+					    :name (car (tk::list-font-names
+							display spec))))))))))))
 	 (options font-list))
     (labels ((update-menu-item-sensitivity (widget frame commands)
 	       (declare (ignore widget))
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index 35c66002..75ae1588 100644
--- a/tk-silica/xm-gadgets.lisp
+++ b/tk-silica/xm-gadgets.lisp
@@ -18,18 +18,15 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-gadgets.lisp,v 1.59 92/11/20 08:46:44 cer Exp $
+;; $fiHeader: xm-gadgets.lisp,v 1.60 92/12/14 15:04:36 cer Exp $
 
 (in-package :xm-silica)
 
 (defmethod make-pane-class ((framem motif-frame-manager) class &rest options) 
   (declare (ignore options))
-  (second (assoc class '(
-                         ;; Another experiment
-                         ;; experiment
+  (second (assoc class '((scroller-pane motif-scroller-pane)
                          (outlined-pane motif-frame-pane)
                          (silica::separator motif-separator)
-                         ;;
                          (scroll-bar motif-scroll-bar)
                          (slider motif-slider)
                          (push-button motif-push-button)
@@ -688,10 +685,11 @@
                                                      (parent t)
                                                      (sheet xm-viewport))
   (values 'tk::xm-my-drawing-area
-          '(:scrolling-policy :application-defined
+          `(:scrolling-policy :application-defined
             :margin-width 0 :margin-height 0
             :resize-policy :none
-            :scroll-bar-display-policy :static)))
+            :scroll-bar-display-policy :static
+	    :name ,(string (pane-name (car (sheet-children sheet)))))))
 
 
 (defclass motif-radio-box (motif-geometry-manager
@@ -1425,6 +1423,7 @@
 ;; Utilize a motif scrolling window to provide the scrollbars and
 ;; geometry management
 
+#+ignore ;; added this to assoc list in make-pane-class at top of file
 (defmethod make-pane-class ((framem motif-frame-manager) 
                             (class (eql 'scroller-pane)) 
                             &rest options) 
diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp
index 0b82e0fc..be709096 100644
--- a/tk-silica/xt-gadgets.lisp
+++ b/tk-silica/xt-gadgets.lisp
@@ -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.25 92/11/13 14:47:19 cer Exp $
+;; $fiHeader: xt-gadgets.lisp,v 1.26 92/12/03 10:30:19 cer Exp $
 
 (in-package :xm-silica)
 
@@ -82,10 +82,32 @@
 	    (append (decode-gadget-foreground medium sheet silica::foreground)
 		    initargs))))
 
-      (when text-style
-	(setf (getf initargs :font-list)
-	  (text-style-mapping port text-style)))
-
+      (if text-style
+	  (setf (getf initargs :font-list)
+	    (text-style-mapping port text-style))
+	(multiple-value-bind (parent-name parent-class)
+	    (xt::widget-resource-name-and-class parent)
+	  (let* ((full-class (concatenate 'string parent-class "."
+					  (string class)))
+		 (full-name (concatenate 'string parent-name "." 
+					 (or "" (getf initargs
+						      :name))))
+		 (display (silica::port-display port))
+		 (db (tk::display-database display))
+		 (text-style (xt::get-resource db full-name "textStyle"
+					       full-class "TextStyle")))
+	    (when text-style
+	      (let ((spec (read-from-string text-style)))
+		(setf (getf initargs :font-list)
+		  (etypecase spec
+		    (cons
+		     (text-style-mapping port (parse-text-style spec)))
+		    (string
+		     (make-instance 'tk::font 
+				    :display display
+				    :name (car (tk::list-font-names
+						display spec)))))))))))
+	
       (values class initargs))))
 
 (defmethod decode-gadget-background (medium sheet ink)
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index cea2dcc7..5ddbe283 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.59 92/12/16 16:50:54 cer Exp $
+;; $fiHeader: xt-graphics.lisp,v 1.60 92/12/17 15:33:46 cer Exp $
 
 (in-package :tk-silica)
 
@@ -149,7 +149,10 @@
     (setq name (substitute #\space #\- (string name)))
     (or (gethash name named-color-cache)
 	(setf (gethash name named-color-cache)
-	  (let ((xcolor (tk::lookup-color (palette-colormap palette) name))
+	  ;; we use parse-color rather than lookup-color here because
+	  ;; it also understands about #rgb format. in R5 we should
+	  ;; change this to lookup-color
+	  (let ((xcolor (tk::parse-color (palette-colormap palette) name))
 		(x #.(1- (ash 1 16))))
 	    (if xcolor
 		(make-rgb-color (/ (x11:xcolor-red xcolor) x)
@@ -159,7 +162,6 @@
 		  (error 'color-not-found :color name)
 		(return-from find-named-color nil))))))))
 
-
 (defmethod update-palette-entry ((palette xt-palette) pixel color)
   (let ((xcolor (get-xcolor color palette)))
     (setf (x11:xcolor-pixel xcolor) pixel)
@@ -339,9 +341,6 @@
 					       :background white-pixel)))
 	  (recompute-gcs medium))))))
 
-
-
-
 (defmethod degraft-medium :after ((medium xt-medium) (port xt-port) sheet)
   (declare (ignore sheet))
   (with-slots 
@@ -615,14 +614,14 @@ and on color servers, unless using white or black")
 	    (setf (tk::gcontext-stipple new-gc) (decode-opacity opacity port)
 		  (tk::gcontext-fill-style new-gc) :stippled)
 	    (setf (gethash key ink-table) new-gc))))))
-  
+
+(defmethod decode-contrasting-ink ((ink contrasting-ink) medium)
+  (if (palette-color-p (medium-palette medium))
+      (make-color-for-contrasting-ink ink)
+    (make-gray-color-for-contrasting-ink ink)))
  
 (defmethod decode-ink ((ink contrasting-ink) medium)
-  (let ((palette (medium-palette medium)))
-    (decode-ink (if (palette-color-p palette)
-		    (make-color-for-contrasting-ink ink)
-		    (make-gray-color-for-contrasting-ink ink))
-		medium)))
+  (decode-ink (decode-contrasting-ink ink medium) medium))
 
 (defmethod decode-ink ((ink pattern) medium)
   (with-slots (ink-table) medium
@@ -647,6 +646,9 @@ and on color servers, unless using white or black")
       (decode-color +foreground-ink+ medium)
       (decode-color +background-ink+ medium)))
 
+(defmethod decode-color ((ink contrasting-ink) (medium xt-medium))
+  (decode-color (decode-contrasting-ink ink medium) medium))
+
 (defmethod decode-color-in-palette ((design design) (palette xt-palette))
   (error "Drawing with design: ~A not yet implemented" design))
 
@@ -659,13 +661,13 @@ and on color servers, unless using white or black")
 		   (handler-case
 		       (tk::allocate-color
 			(palette-colormap palette) (get-xcolor color palette))
-		     (tk::x-colormap-error ()
+		     (tk::x-colormap-full ()
 		       (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))))))))))
+		       (if (< luminosity 0.5) black-pixel white-pixel))))))))))
 
 (defmethod decode-color-in-palette ((color dynamic-color) (palette xt-palette))
   (let ((dynamic-color-cache (palette-dynamic-color-cache palette)))
@@ -673,7 +675,7 @@ and on color servers, unless using white or black")
 	(let ((pixel (aref (handler-case
 			       (tk::alloc-color-cells
 				(palette-colormap palette) 1 0)
-			     (tk::x-colormap-error ()
+			     (tk::x-colormap-full ()
 			       (error 'palette-full)))
 			   0)))
 	  (update-palette-entry palette pixel (dynamic-color-color color))
@@ -724,7 +726,7 @@ and on color servers, unless using white or black")
 	(handler-case
 	    (tk::alloc-color-cells
 	     (palette-colormap palette) 1 total-nplanes)
-	  (tk::x-colormap-error ()
+	  (tk::x-colormap-full ()
 	    (error 'palette-full)))
       (let ((pixel (aref pixels 0))
 	    (count 0)
@@ -746,13 +748,6 @@ and on color servers, unless using white or black")
 		 (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)))
-    (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))
 
@@ -1916,17 +1911,17 @@ and on color servers, unless using white or black")
 		 to-left to-top))
 
 
-(defmethod text-style-width ((text-style standard-text-style) (medium xt-medium))
+(defmethod text-style-width ((text-style t) (medium xt-medium))
   (tk::font-width (text-style-mapping (port medium) text-style)))
 
-(defmethod text-style-height ((text-style standard-text-style) (medium xt-medium))
+(defmethod text-style-height ((text-style t) (medium xt-medium))
   ;; Optimization
   (tk::font-height (text-style-mapping (port medium) text-style)))
 
-(defmethod text-style-ascent ((text-style standard-text-style) (medium xt-medium))
+(defmethod text-style-ascent ((text-style t) (medium xt-medium))
   (tk::font-ascent (text-style-mapping (port medium) text-style)))
 					
-(defmethod text-style-descent ((text-style standard-text-style) (medium xt-medium))
+(defmethod text-style-descent ((text-style t) (medium xt-medium))
   (tk::font-descent (text-style-mapping (port medium) text-style)))
 					
 
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index cb5921cf..0af96042 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.65 92/12/16 16:50:58 cer Exp $
+;; $fiHeader: xt-silica.lisp,v 1.66 92/12/17 15:33:50 cer Exp $
 
 (in-package :xm-silica)
 
@@ -668,7 +668,12 @@
 	   ((port xt-port) (parent t) (sheet basic-sheet))
   (multiple-value-bind (class initargs)
       (call-next-method)
-    (setq initargs (compute-initial-mirror-geometry parent sheet initargs))
+    (setq initargs (compute-initial-mirror-geometry parent sheet
+						    initargs)) 
+    ;;; it seems that xt or motif or someone doesn't know about
+    ;;; ParentRelative and tries to give treat this as a pixmap
+    ;;; and put it into a gcontext tile
+    #+ignore (setf (getf initargs :background-pixmap) x11:parentrelative)
     (values class initargs)))
 
 
@@ -1118,12 +1123,18 @@
 (define-xt-keysym (keysym 255 097) :refresh)
 (define-xt-keysym (keysym 255 011) :clear-input)
 
+(define-xt-keysym (keysym 255 #x51) :left)
+(define-xt-keysym (keysym 255 #x52) :up)
+(define-xt-keysym (keysym 255 #x53) :right)
+(define-xt-keysym (keysym 255 #x54) :down)
+
+
 ;;;
 
 
 ;;; Some nonstandard keys
 
-(define-xt-keysym (keysym 255 #xb3) :f1)
+(define-xt-keysym (keysym 255 #xbe) :f1)
 (define-xt-keysym (keysym 255 #xbf) :f2)
 (define-xt-keysym (keysym 255 #xc0) :f3)
 (define-xt-keysym (keysym 255 #xc1) :f4)
@@ -1155,6 +1166,11 @@
 (define-xt-keysym (keysym 255 #xd9) :r8)
 (define-xt-keysym (keysym 255 #xda) :r9)
 (define-xt-keysym (keysym 255 #xdb) :r10)
+(define-xt-keysym (keysym 255 #xdc) :r11)
+(define-xt-keysym (keysym 255 #xdd) :r12)
+(define-xt-keysym (keysym 255 #xde) :r13)
+(define-xt-keysym (keysym 255 #xdf) :r14)
+(define-xt-keysym (keysym 255 #xe0) :r15)
 
 ;; Finally, the shifts
 ;; snarfed from translate.cl
@@ -1246,19 +1262,19 @@
 ;;;---- This is just an experiment
 
 ;(defmethod engraft-medium :before ((medium t) (port xt-port) (pane clim-stream-pane))
-;  (default-from-mirror-resources port pane))
+;  (default-from-resources medium port pane))
 ;
 ;(defmethod engraft-medium :before ((medium t) (port xt-port) (pane top-level-sheet))
-;  (default-from-mirror-resources port pane))
+;  (default-from-resources medium port pane))
 
 
 ;;--- Why is medium class-specialized on T here?  --SWM
 (defmethod engraft-medium :before ((medium t) (port xt-port) 
 				   (pane clim-internals::output-protocol-mixin))
-  (default-from-mirror-resources port pane))
+  (default-from-resources medium port pane))
 
 (defmethod engraft-medium :before ((medium t) (port xt-port) (pane viewport))
-  (default-from-mirror-resources port pane))
+  (default-from-resources medium port pane))
 
 ;; whats wrong with this?
 ;; Well I think there is some dreadful method combination order
@@ -1266,7 +1282,7 @@
 
 #+ignore
 (defmethod engraft-medium :before ((medium t) (port xt-port) (pane standard-sheet-output-mixin))
-  (default-from-mirror-resources port pane))
+  (default-from-resources medium port pane))
 
 
 ;;-- What do we do about pixmap streams. I guess they should inherit
@@ -1279,34 +1295,42 @@
 ;; If we wanted to get a font then we are in trouble because there is
 ;; not such resource here
 
-(defun default-from-mirror-resources (port pane)
-  (unless (and (medium-foreground pane)
-	       (medium-background pane))
-    (let* ((w (sheet-mirror pane))
-	   (shellp (typep w 'tk::shell)))
-      ;;; Make sure we dont have a pixmp
-      (when (typep w 'xt::xt-root-class)
-	;;-- What about the case when there is a pixmap
-	(multiple-value-bind
-	    (foreground background)
-	    (if shellp
-		(values nil (tk::get-values w :background))
-	      (tk::get-values w :foreground :background))
-	  ;; Now we have to convert into CLIM colors.
-	  (flet ((ccm (x)
-		   (multiple-value-bind
-		       (r g b)
-		       (tk::query-color (tk::default-colormap (port-display port)) x)
-		     (let ((x #.(1- (ash 1 16))))
-		       (make-rgb-color 
-			(/ r x)
-			(/ g x)
-			(/ b x))))))
-	    (when foreground
-	      (unless (medium-foreground pane)
-		(setf (medium-foreground pane) (ccm foreground))))
+(defun default-from-resources (medium port pane)
+  (let* ((w (sheet-mirror pane))
+	 (display (silica::port-display port))
+	 (db (tk::display-database display))
+	 (palette (medium-palette medium)))
+    ;; Make sure we dont have a pixmp
+    ;;-- What about the case when there is a pixmap
+    (when (typep w 'xt::xt-root-class)
+      (multiple-value-bind (name class)
+	  (xt::widget-resource-name-and-class w)
+	(let ((background (xt::get-resource db name "background"
+					    class "Background"))
+	      (foreground (xt::get-resource db name "foreground" 
+					    class "Foreground"))
+	      (text-style (xt::get-resource db name "textStyle"
+					    class "TextStyle")))
+	  (when text-style
+	    (unless (medium-default-text-style pane)
+	      (setf (medium-text-style pane) 
+		(let ((spec (read-from-string text-style)))
+		  (etypecase spec
+		    (cons (parse-text-style spec))
+		    (string (silica::make-device-font 
+			     port 
+			     (make-instance 'tk::font 
+					    :display display
+					    :name (car (tk::list-font-names
+							display spec))))))))))
+	  (when foreground
+	    (unless (medium-foreground pane)
+	      (setf (medium-foreground pane)
+		(find-named-color foreground palette))))
+	  (when background
 	    (unless (medium-background pane)
-	      (setf (medium-background pane) (ccm background)))))))))
+	      (setf (medium-background pane)
+		(find-named-color background palette)))))))))
 
 ;;;--- Gadget activation deactivate
 
diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp
index 61c18bcb..eabd955b 100644
--- a/tk/make-classes.lisp
+++ b/tk/make-classes.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: make-classes.lisp,v 1.26 92/09/30 11:44:34 cer Exp $
+;; $fiHeader: make-classes.lisp,v 1.27 92/12/14 15:03:53 cer Exp $
 
 (in-package :tk)
 
@@ -40,8 +40,8 @@
 	  (n (aref y 0)))
       (setq result
 	(dotimes (i n)
-	  (let* ((res (x-resource-list resources i))
-		 (original-name (x-resource-name res))
+	  (let* ((res (xt-resource-list resources i))
+		 (original-name (xt-resource-name res))
 		 (name (lispify-resource-name (char*-to-string original-name))))
 	    (if (equal name resource-name)
 		(let ((*package* (find-package :tk)))
@@ -49,9 +49,9 @@
 			    :original-name original-name
 			    :name name
 			    :class (lispify-resource-class 
-				    (char*-to-string (x-resource-class res)))
+				    (char*-to-string (xt-resource-class res)))
 			    :type (lispify-resource-type 
-				   (char*-to-string (x-resource-type res))))))))))
+				   (char*-to-string (xt-resource-type res))))))))))
       (xt_free resources))
     #+ignore
     (unless result
@@ -117,12 +117,12 @@
       (dotimes (i n)
 	(push (make-instance
 	       resource-class
-	       :original-name (x-resource-name (x-resource-list resources i))
-	       :name (lispify-resource-name (char*-to-string (x-resource-name (x-resource-list resources i))))
+	       :original-name (xt-resource-name (xt-resource-list resources i))
+	       :name (lispify-resource-name (char*-to-string (xt-resource-name (xt-resource-list resources i))))
 	       :class (lispify-resource-class 
-		       (char*-to-string (x-resource-class (x-resource-list resources i))))
+		       (char*-to-string (xt-resource-class (xt-resource-list resources i))))
 	       :type (lispify-resource-type 
-		      (char*-to-string (x-resource-type (x-resource-list resources i)))))
+		      (char*-to-string (xt-resource-type (xt-resource-list resources i)))))
 	      r))
       (xt_free resources)
       r)))
diff --git a/tk/resources.lisp b/tk/resources.lisp
index 420fffcd..36bffe69 100644
--- a/tk/resources.lisp
+++ b/tk/resources.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: resources.lisp,v 1.38 92/11/20 08:46:16 cer Exp $
+;; $fiHeader: resources.lisp,v 1.39 92/12/17 15:33:40 cer Exp $
 
 (in-package :tk)
 
@@ -502,6 +502,12 @@
     (:beginning 0)
     (:end 2)))
 
+(defmethod convert-resource-in ((parent t) (type (eql 'alignment)) value)
+  (ecase value
+    (1 :center)
+    (0 :beginning)
+    (2 :end)))
+
 (defmethod convert-resource-out ((parent t) (type (eql 'prim-foreground-pixmap)) value)
   (convert-pixmap-out parent value))
 
diff --git a/tk/widget.lisp b/tk/widget.lisp
index 5a1b6924..91f3b0cb 100644
--- a/tk/widget.lisp
+++ b/tk/widget.lisp
@@ -20,13 +20,13 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: widget.lisp,v 1.26 92/12/01 09:46:53 cer Exp $
+;; $fiHeader: widget.lisp,v 1.27 92/12/14 15:04:04 cer Exp $
 
 (in-package :tk)
 
 (defun app-create-shell (&rest args
-			       &key (application-name 0)
-			       (application-class 0)
+			       &key (application-name "clim")
+			       (application-class "Clim")
 			       (widget-class (error "Class not specified"))
 			       (display (error "Display not specifie"))
 			       &allow-other-keys)
@@ -259,12 +259,31 @@
 
 ;; Could not think of anywhere better!
 
+;; note that this is different from xt-initialize which calls
+;; XtToolkitInitialize. This is closer to XtAppInitialize
+
 (defun initialize-toolkit (&rest args)
   (let* ((context (create-application-context))
 	 (display (apply #'make-instance 'display 
 			 :context context
 			 args))
-	 (app (app-create-shell :display display
-				:widget-class 'application-shell)))
+	 (app (apply #'app-create-shell 
+		     :display display
+		     :widget-class 'application-shell
+		     args)))
     (values context display app)))
 
+
+(defun xt-name (w) (char*-to-string (xt_name w)))
+(defun xt-class (w) (char*-to-string (xt-class-name (xt_class w))))
+
+(defun widget-resource-name-and-class (w)
+  (do* ((name "" (concatenate 'string (xt-name w) "." name))
+	(class "" (concatenate 'string (xt-class w) "." class))
+	(w w parent)
+	(parent (widget-parent w) (widget-parent w)))
+      ((null parent)
+       (multiple-value-bind (app-name app-class)
+	   (get-application-name-and-class (widget-display w))
+	 (values (concatenate 'string app-name "." name)
+		 (concatenate 'string app-class "." class))))))
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index 340045fb..f62eea99 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.36 92/12/07 12:15:45 cer Exp $
+;; $fiHeader: xlib.lisp,v 1.37 92/12/16 16:50:29 cer Exp $
 
 (in-package :tk)
 
@@ -180,6 +180,34 @@
 	 depth))
       (register-xid p display))))
 
+(defclass resource-database (ff:foreign-pointer) ())
+
+(defmethod initialize-instance :after
+	   ((db resource-database) &key foreign-address)
+  (unless foreign-address
+    (setf (foreign-pointer-address db) (x11:xrmgetstringdatabase ""))))
+
+(defun get-resource (db name resource-name class resource-class)
+  (with-ref-par ((type 0))
+    (let ((xrmvalue (x11:make-xrmvalue)))
+      (unless (zerop (x11:xrmgetresource db 
+					 (concatenate 'string name resource-name)
+					 (concatenate 'string class resource-class)
+					 type xrmvalue))
+	(values (char*-to-string (x11:xrmvalue-addr xrmvalue))
+		(char*-to-string (aref type 0)))))))
+
+(defun convert-string (widget string to-type)
+  (let ((from (x11:make-xrmvalue))
+	(to-in-out (x11:make-xrmvalue)))
+    (setf (x11:xrmvalue-size from) (1+ (length string))
+	  (x11:xrmvalue-addr from) (string-to-char* string)
+	  (x11:xrmvalue-addr to-in-out) 0)
+    (unless (zerop (xt::xt_convert_and_store widget "String" from to-type
+				      to-in-out))
+      (values (x11:xrmvalue-size to-in-out)
+	      (x11:xrmvalue-addr to-in-out)))))
+
 ;; --
 ;; Error handling
 
@@ -241,6 +269,7 @@
     (error 'x-connection-lost :display display)))
 
 
+
 (defun get-error-text (code display-handle)
   (let ((s (make-string 1000)))
     (x11::xgeterrortext display-handle code s 1000)
@@ -328,6 +357,15 @@
       (values (make-instance 'color :foreign-address exact)
 	      (make-instance 'color :foreign-address closest)))))
 
+(defun parse-color (colormap name)
+  (let ((exact (x11::make-xcolor :in-foreign-space t)))
+    (unless (zerop (x11:xparsecolor
+		    (object-display colormap)
+		    colormap
+		    name
+		    exact))
+      (values (make-instance 'color :foreign-address exact)))))
+
 (defun allocate-color (colormap x)
   (let ((y (x11::make-xcolor :in-foreign-space t))
 	(x x))
-- 
GitLab