From 7878b1eec83ebeac357447ce86a7d3e091ec1f38 Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Wed, 7 Apr 1993 09:07:31 +0000
Subject: [PATCH] Makefile.generic 	OLIT to use difference X libraries
 Makefile.sun4		OLIT to use difference X libraries
 Makefile.sun4.motif-1.1.4	OLIT to use difference X libraries
 clim/accept-values.lisp		graphical
 accept-values-command-buttons clim/graph-formatting.lisp	Removed
 assertion clim/graphics-recording.lisp		Comment
 clim/incremental-redisplay.lisp		Nothing changed
 clim/interactive-defs.lisp		Moved methods to
 interactive-protocol.lisp clim/interactive-protocol.lisp		Added
 methods from interactive-defs.lisp. They are specialized 		
 		on the stream clim/recording-protocol.lisp		Fixed
 incremental redisplay 					problem involve
 :parent 					argument. We now look in the 
 				parent for old-children climtoys/ib.lisp
 		Implemented multiple selections. 			
 	hbox/vbox adopt all selected widgets as their children 		
 		removed crap climtoys/pi.lisp		
 presentation-inspect calls winspect on presentation demo/bitmap-editor.lisp
 		Nothing demo/browser.lisp			Redid browser
 layout. Removed option not to merge duplicates 			
 	since that breaks redisplay. Removed call to 			
 	redisplay-frame-pane inside the avv display function since that 
 				interacts with the original stream problem to
 create empty 					output records.
 hpgl/hpgl-port.lisp			Combined duplicated
 initialize-instance methods test/test-suite.lisp		
 Nothing tk/xlib.lisp				Fixed compose-status typo
 tk-silica/xm-gadgets.lisp		Correct computation of pixmap label
 size tk-silica/xm-silica.lisp		Put focus policy back to pointer
 tk-silica/xt-graphics.lisp		Sped up rotated text by caching
 rotated strings tk-silica/xt-silica.lisp		Added rotated string
 cache to xt-port

---
 Makefile.generic                |  10 +-
 clim/accept-values.lisp         |  11 +-
 clim/graph-formatting.lisp      |   3 +-
 clim/incremental-redisplay.lisp |  53 +++---
 demo/browser.lisp               |  39 +++--
 test/test-suite.lisp            |  16 +-
 tk-silica/xm-gadgets.lisp       |  23 ++-
 tk-silica/xm-silica.lisp        |   4 +-
 tk-silica/xt-graphics.lisp      | 291 +++++++++++++++++++++-----------
 tk-silica/xt-silica.lisp        |   3 +-
 10 files changed, 295 insertions(+), 158 deletions(-)

diff --git a/Makefile.generic b/Makefile.generic
index 19fa82c6..805584e6 100644
--- a/Makefile.generic
+++ b/Makefile.generic
@@ -1,4 +1,4 @@
-# $fiHeader: Makefile.generic,v 1.5 93/04/02 13:35:41 cer Exp $
+# $fiHeader: Makefile.generic,v 1.6 93/04/02 18:40:38 cer Exp $
 #
 #  Makefile.generic for CLIM 2.0
 #
@@ -38,8 +38,8 @@ compile-ol:	$(OPENLOOK_OBJS) FORCE
 	  (lambda () \
 	    (setq *compile-print* $(COMPILE_PRINT)) \
 	    (setf excl:*load-xref-info* $(LOAD_XREF_INFO)) \
-	    (setq sys::*libxt-pathname* \"$(XTLIB)\") \
-	    (setq sys::*libx11-pathname* \"$(XLIB)\") \
+	    (setq sys::*libxt-pathname* \"$(OLXTLIB)\") \
+	    (setq sys::*libx11-pathname* \"$(OLXLIB)\") \
 	    (setq sys::*clim-olit-pathname* \"clim-olit$(DEBUGLIB).o\") \
 	    (setq *ignore-package-name-case* t) \
 	    (set-case-mode :case-insensitive-lower) \
@@ -146,8 +146,8 @@ clim-xm:	FORCE $(MOTIF_OBJS)
 clim-ol:	FORCE $(OPENLOOK_OBJS)
 	-$(RM) -f $(CLIMOL)
 	$(ECHO) " \
-		(setq sys::*libxt-pathname* \"$(XTLIB)\") \
-		(setq sys::*libx11-pathname* \"$(XLIB)\") \
+		(setq sys::*libxt-pathname* \"$(OLXTLIB)\") \
+		(setq sys::*libx11-pathname* \"$(OLXLIB)\") \
 	        (setq sys::*clim-olit-pathname* \"clim-olit$(DEBUGLIB).o\") \
 		(load \"misc/dev-load-1.lisp\") \
 		(load-it 'openlook-clim) \
diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp
index b0a3ea46..926bec3d 100644
--- a/clim/accept-values.lisp
+++ b/clim/accept-values.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: accept-values.lisp,v 1.57 93/03/31 10:38:30 cer Exp $
+;; $fiHeader: accept-values.lisp,v 1.58 93/04/02 13:35:55 cer Exp $
 
 (in-package :clim-internals)
 
@@ -1376,9 +1376,14 @@
 		   
 		   :label (if (stringp prompt)
 			      prompt
-			    (pixmap-from-menu-item stream 
+			    ;;-- Does this suck or what???
+			    ;;-- If you do a
+			    ;;surrounding-output-with-border without
+			    ;;this write-string output does not get bordered.
+			    (let ((*original-stream* nil))
+			      (pixmap-from-menu-item stream 
 						     prompt
 						     #'funcall
-						     nil)))))))
+						     nil))))))))
 
 
diff --git a/clim/graph-formatting.lisp b/clim/graph-formatting.lisp
index 4bcaeaf9..5049ae6a 100644
--- a/clim/graph-formatting.lisp
+++ b/clim/graph-formatting.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: graph-formatting.lisp,v 1.26 93/03/31 10:38:37 cer Exp $
+;; $fiHeader: graph-formatting.lisp,v 1.27 93/04/02 18:40:58 cer Exp $
 
 (in-package :clim-internals)
 
@@ -812,7 +812,6 @@ circular graphs without accounting for this case.
 		  (setf (generation-start-depth descr) depth-so-far)
 		  (incf depth-so-far (+ generation-separation (generation-depth descr))))
 		;; Determine breadth-spacing
-		(assert broadest-gen-descr)
 		(incf max-gen-breadth
 		      (* within-generation-separation (generation-size broadest-gen-descr)))
 		(loop for descr in generation-descriptors do
diff --git a/clim/incremental-redisplay.lisp b/clim/incremental-redisplay.lisp
index e4f1536b..d0443ce9 100644
--- a/clim/incremental-redisplay.lisp
+++ b/clim/incremental-redisplay.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: incremental-redisplay.lisp,v 1.16 93/03/19 09:43:33 cer Exp $
+;; $fiHeader: incremental-redisplay.lisp,v 1.17 93/03/31 10:38:40 cer Exp $
 
 (in-package :clim-internals)
 
@@ -172,24 +172,32 @@
 		(apply #'match-output-records candidate initargs))))
     (let ((elts-to-find (when use-old-children (output-record-old-children record))))
       (if use-old-children
+	  ;; Bugger me, you learn several new things about
+	  ;; incremental redisplay every day. This code does not do a
+	  ;; full search of the old-children but rather just looks at
+	  ;; the first two. I suppose its reasonable since things
+	  ;; normally get created in the same order again. However, in
+	  ;; the case of the grapher things tend to get created in a
+	  ;; more random order causing this to fail unnecessarily.
 	  (let ((found-record
-		  (if unique-id
-		      (find-with-test unique-id elts-to-find
-				      #'output-record-unique-id id-test)
-		      ;; UNIQUE-ID can be NIL when we are coming through
-		      ;; INVOKE-WITH-NEW-OUTPUT-RECORD to create new records
-		      (or (and (do-match (first elts-to-find)) (first elts-to-find))
-			  (let ((candidate (second elts-to-find)))
-			    (and (do-match candidate)
-				 ;; assume the first one was deleted, and
-				 ;; therefore we don't want to match
-				 ;; against it anymore.
-				 ;; If they want better performance, they
-				 ;; should use UID's.
-				 (setf (output-record-old-children record)
-				       (nconc (rest elts-to-find)
-					      (list (first elts-to-find))))
-				 candidate))))))
+		 (if unique-id
+		     (find-with-test unique-id elts-to-find
+				     #'output-record-unique-id id-test)
+		   ;; UNIQUE-ID can be NIL when we are coming through
+		   ;; INVOKE-WITH-NEW-OUTPUT-RECORD to create new records
+		   (or (and (do-match (first elts-to-find))
+			    (first elts-to-find))
+		       (let ((candidate (second elts-to-find)))
+			 (and (do-match candidate)
+			      ;; assume the first one was deleted, and
+			      ;; therefore we don't want to match
+			      ;; against it anymore.
+			      ;; If they want better performance, they
+			      ;; should use UID's.
+			      (setf (output-record-old-children record)
+				(nconc (rest elts-to-find)
+				       (list (first elts-to-find))))
+			      candidate))))))
 	    (when found-record
 	      (setf (output-record-old-children record)
 		    (delete found-record (output-record-old-children record)))
@@ -438,6 +446,7 @@
 		      (old-x-offset (coordinate 0)) (old-y-offset (coordinate 0)))
   (declare (type coordinate x-offset y-offset old-x-offset old-y-offset))
   (declare (values erases moves draws erase-overlapping move-overlapping))
+  #+ignore (when (eq record wt::*c*) (break "found it"))
   (let ((erases nil)
 	(moves nil)
 	(draws nil)
@@ -649,7 +658,7 @@
 	       (with-bounding-rectangle* (left top right bottom) rectangle
 		 (translate-coordinates xoff yoff left top right bottom)
 		 (draw-rectangle* stream left top right bottom
-				  :ink +background-ink+  :filled t)
+				  :ink #+ignore +red+ +background-ink+  :filled t)
 		 #+ignore
 		 (break "erase ~S" (list left top right bottom))))
 	     (replay-record (record stream region)
@@ -932,6 +941,12 @@
 	  ;; is if another, more deeply nested output record, was moved
 	  ;; from somewhere in the hierarchy that was >not< erased.  In that
 	  ;; case, we could just bitblt, but we won't detect that anymore.
+
+	  ;;--- I dont understand how this is right
+	  ;;--- since we have to do the erase first
+	  ;;--- Anyway things are screwed up when the parent has changed
+	  ;;--- Since we dont know where things are.
+	  
 	  ((and old-parent
 		(not (eq (output-record-parent record) old-parent))
 		(not (eq (output-record-generation-tick old-parent) *generation-tick*)))
diff --git a/demo/browser.lisp b/demo/browser.lisp
index c48be0a6..747c51ef 100644
--- a/demo/browser.lisp
+++ b/demo/browser.lisp
@@ -3,7 +3,7 @@
 ;;; Simple extensible browser
 ;;; Scott McKay
 
-;; $fiHeader: browser.lisp,v 1.18 93/01/18 13:55:04 cer Exp $
+;; $fiHeader: browser.lisp,v 1.19 93/03/19 09:44:09 cer Exp $
 
 (in-package :clim-browser)
 
@@ -747,18 +747,20 @@
 	   :end-of-line-action :allow)
     (interactor :interactor :height '(5 :line))
     (control-panel :accept-values
-		   :height :compute
+		   :height :compute :width :compute
+		   :max-height :compute :max-width :compute
+		   :scroll-bars nil
 		   :display-function
 		   '(accept-values-pane-displayer
-		      :displayer accept-call-graph-options)))
+		     :align-prompts t
+		     :displayer accept-call-graph-options)))
   (:layouts
    (default
      (vertically ()
-       (3/4 graph)
-       (:fill 
-	 (horizontally ()
-	   (1/2 interactor) 
-	   (:fill control-panel)))))))
+       (:fill graph)
+       (horizontally ()
+	 (:fill interactor) 
+	 control-panel)))))
 
   
 #+genera (define-genera-application browser :select-key #\)
@@ -1027,16 +1029,17 @@
   (with-slots (browser-type browser-subtype tree-depth
 	       merge-duplicate-nodes auto-snapshot browser-options 
 	       root-nodes root-node-maker all-nodes) browser
-    (flet ((accept (type default prompt query-id)
-	     (fresh-line stream)
-	     (accept type
+    (flet ((accept (type default prompt query-id &rest options)
+	     (apply #'accept type
 		     :stream stream :default default
 		     :query-identifier query-id
-		     :prompt prompt)))
+		     :prompt prompt 
+		     options)))
       (declare (dynamic-extent #'accept))
       (multiple-value-bind (new-type ignore type-changed)
 	  (accept `(member ,@*browser-types*) (or browser-type (first *browser-types*))
-		  "Browser type" 'type)
+		  "Browser type" 'type
+		  :view '(radio-box-view :columns 2))
 	(declare (ignore ignore))
 	(let* ((sub-ptype
 		 (browser-type-subtypes new-type))
@@ -1046,10 +1049,8 @@
 			 "Browser subtype" 'subtype))
 	       (new-depth
 		 (accept '(integer 1 10) tree-depth
-			 "Starting depth" 'depth))
-	       (new-merge
-		 (accept 'boolean merge-duplicate-nodes
-			 "Merge duplicate nodes" 'merge))
+			 "Starting depth" 'depth :view
+					 '(text-field-view :width (4 :character))))
 	       (new-auto-snapshot
 		 (accept 'boolean auto-snapshot
 			 "Automatic snapshots" 'auto-snapshot)))
@@ -1057,7 +1058,6 @@
 	    (when additional-dialog
 	      (funcall additional-dialog browser stream)))
 	  (setq tree-depth new-depth
-		merge-duplicate-nodes new-merge
 		auto-snapshot new-auto-snapshot)
 	  (when (or (not (eql new-type browser-type))
 		    (not (eql new-subtype browser-subtype)))
@@ -1072,8 +1072,7 @@
 		      ;; ALL-NODES and ROOT-NODES must not be EQ lists...
 		      (setq all-nodes (copy-list root-nodes))))
 	    ;; Regenerate and redisplay the call graph
-	    (generate-call-graph browser root-nodes)
-	    (redisplay-frame-pane *application-frame* 'graph :force-p t)))))))
+	    (generate-call-graph browser root-nodes)))))))
 
 
 ;;; Browser commands
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index 9574d408..644b75f2 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.56 93/03/25 15:40:54 colin Exp $
+;; $fiHeader: test-suite.lisp,v 1.57 93/03/31 10:39:51 cer Exp $
 
 (in-package :clim-user)
 
@@ -708,15 +708,23 @@ people, shall not perish from the earth.
       (draw-text* stream "Some fox jumped over something" 200 200
 		  :towards-x 0 :towards-y 200
 		  :text-style '(nil :bold :large)))
-    
     (with-output-as-presentation (stream 4 'form) 
       (draw-text* stream "Some fox jumped over something" 200 200
 		  :towards-x 200 :towards-y 0
 		  :text-style '(nil :bold :small)))
-    (do ((x 300 (+ x 20)))
+    (do* ((x 300 (+ x 20))
+	  (all-packages (list-all-packages)))
 	((> x 1000))
       (with-output-as-presentation (stream 4 'form) 
-	(draw-text* stream "Dont be silly in the City." x 200
+	(draw-text* stream 
+		    (let ((r ""))
+		      (dotimes (i 5 r)
+			(setq r (concatenate 'string
+				  r " " (package-name (nth (random
+							  (length
+							   all-packages))
+							 all-packages))))))
+		    x 200
 		    :towards-x x :towards-y 0)))))
 
 (define-test (negative-extent graphics) (stream)
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index e598bb26..bc84c504 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.69 93/03/31 10:40:20 cer Exp $
+;; $fiHeader: xm-gadgets.lisp,v 1.70 93/04/02 13:37:26 cer Exp $
 
 (in-package :xm-silica)
 
@@ -172,8 +172,8 @@
 	:height (process-height-specification sheet `(1 :line))))
       (tk::pixmap
        (make-space-requirement
-	:width (xt::pixmap-width label)
-	:height (xt::pixmap-height label))))))
+	:width (+ (xt::pixmap-width label) (text-gadget-margin-width sheet))
+	:height (+ (xt::pixmap-height label) (text-gadget-margin-height sheet)))))))
 
 ;;; Push button
 
@@ -575,10 +575,14 @@
 		  (first width))
 		 (string (length width)))))
     (multiple-value-bind (font-list margin highlight shadow)
-	(tk::get-values (sheet-direct-mirror sheet)
-			:font-list :margin-width :highlight-thickness :shadow-thickness)
-      (let ((font-width (font-list-max-width-and-height font-list)))
-	(+ (* 2 (+ margin highlight shadow)) (* font-width chars))))))
+	(tk::get-values (sheet-direct-mirror sheet) :font-list
+			:margin-width :highlight-thickness :shadow-thickness)
+      (+ (* 2 (+ margin highlight shadow)) (* (font-list-max-width-and-height font-list) chars)))))
+
+(defun text-gadget-margin-width (sheet)
+  (multiple-value-bind (margin highlight shadow)
+      (tk::get-values (sheet-direct-mirror sheet) :margin-width :highlight-thickness :shadow-thickness)
+    (+ (* 2 (+ margin highlight shadow)))))
 
 (defun font-list-max-width-and-height (font-list)
   (let* ((max-width most-negative-fixnum)
@@ -605,6 +609,11 @@
 			:font-list :margin-height :highlight-thickness :shadow-thickness)
       (let ((font-height (nth-value 1 (font-list-max-width-and-height font-list))))
 	(+ (* 2 (+ margin highlight shadow)) (* font-height chars))))))
+
+(defun text-gadget-margin-height (sheet)
+  (multiple-value-bind (margin highlight shadow)
+      (tk::get-values (sheet-direct-mirror sheet) :margin-height :highlight-thickness :shadow-thickness)
+    (+ (* 2 (+ margin highlight shadow)))))
 
 
 #+ignore
diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp
index 35eb162d..a33d6d70 100644
--- a/tk-silica/xm-silica.lisp
+++ b/tk-silica/xm-silica.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-silica.lisp,v 1.32 93/03/31 10:40:23 cer Exp $
+;; $fiHeader: xm-silica.lisp,v 1.33 93/04/02 13:37:30 cer Exp $
 
 (in-package :xm-silica)
 
@@ -71,7 +71,7 @@
 	      (append
 	       (let ((x (find-shell-of-calling-frame sheet)))
 		 (and x `(:transient-for ,x)))
-	       ;;'(:keyboard-focus-policy :pointer)
+	       '(:keyboard-focus-policy :pointer)
 	       (and (typep (pane-frame sheet)
 			   'clim-internals::menu-frame)
 		    '(:override-redirect t))))
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index f1d621e9..19a4f23b 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.67 93/03/31 10:40:30 cer Exp $
+;; $fiHeader: xt-graphics.lisp,v 1.68 93/04/02 13:37:36 cer Exp $
 
 (in-package :tk-silica)
 
@@ -1538,59 +1538,20 @@
 	   (min-char (xt::font-range font))
 	   (ascent (xt::font-ascent font))
 	   (descent (xt::font-descent font)))
-    (multiple-value-bind
-	(pixmap columns 
-	 width 
-	 leftover-width 
-	 rows height
-	 leftover-height)
-	(find-rotated-text-pixmap
-	 port font rotation)
-      (flet ((compute-next-x-and-y (char-width x y)
-	       (let ()
-		 (case rotation
-		   (0 (values (+ x char-width) y))
-		   (3 (values x (- y char-width)))
-		   (2 (values (- x char-width) y))
-		   (1 (values x (+ y char-width))))))
-	     (compute-clip-x-and-clip-y (char char-width x y)
-	       ;;-- This has to get to the right character in the pixmap
-	       (multiple-value-bind
-		(row column)
-		(truncate (- char min-char) columns)
-		;; Now we have to take into account the rotation
-		(let ((columns columns)
-		      (rows rows))
-		  #+debug
-		  (format t "Was Row ~D of ~D, Column ~D of ~D~%" 
-					row rows column columns)
-		  (dotimes (i rotation)
-		    (psetf column (- (1- rows) row) row column)
-		    (rotatef rows columns)))
-		#+debug
-		(format t "Now Row ~D of ~D, Column ~D of ~D~%" 
-			row rows column columns)
-		(let ((px (* column (if (oddp rotation) height width)))
-		      (py (* row (if (oddp rotation) width height)))
-		      (w (- width char-width)))
-		  (ecase rotation
-		    (0)
-		    (3 (incf py leftover-width)
-		       (incf py w))
-		    (2 (incf px leftover-width)
-		       (incf px w)
-		       (incf py leftover-height))
-		    (1 (incf px leftover-height)))
-		  #+debug
-		  (format t "x ~D y ~D px ~D py ~D~%" x y px py)
-		  (values (- x px) (- y py))))))
-	(let  ((ox x)
-	       (oy y))
-	  (declare (ignore oy)
-		   (ignore ox))
-
-	  (setf (tk::gcontext-clip-mask gcontext) pixmap)
-	  (setf (ink-gcontext-last-medium-clip-mask gcontext) nil)
+      (multiple-value-bind
+	  (pixmap columns 
+	   width 
+	   leftover-width 
+	   rows height
+	   leftover-height)
+	  (find-rotated-text-pixmap
+	   port font rotation)
+	(flet ()
+
+
+	  #+ignore (setf (tk::gcontext-clip-mask gcontext) pixmap)
+	  #+ignore (setf (ink-gcontext-last-medium-clip-mask gcontext) nil)
+	  
 	  (unless start (setq start 0))
 	  (unless end (setq end (length string)))
 	  
@@ -1601,43 +1562,174 @@
 			 drawable 0 0)
 	  #+debug
 	  (progn
+	    (setf (tk::gcontext-clip-mask gcontext) pixmap)
 	    (setf (tk::gcontext-clip-x-origin gcontext) 0
 		  (tk::gcontext-clip-y-origin gcontext) 70)
 	    (tk::draw-rectangle drawable gcontext 0 70 256 256 t))
-	  
-	  #-debug
-	  (dotimes (i (- end start))
-	    (let* ((char (char-int (aref string (+ start i))))
-		   (char-width (xt::char-width font char))
-		   (cx x)
-		   (cy y))
+
+	  ;;-- This should be drawing onto an appropriately size bitmap
+	  ;;-- that should be cached
+	  ;;-- Width/height is the width of string
+	  ;;-- Height/width is the height of the font
+
+	  (multiple-value-bind (string-pixmap pixmap-width pixmap-height)
+	      (find-or-cache-string-pixmap port
+					   string start end font
+					   ascent descent height rotation pixmap
+					   min-char columns rows width
+				    leftover-width leftover-height)
+	    ;; Now its time to 
+	    (multiple-value-bind (dst-x dst-y)
+		(ecase rotation
+		  (0 (values x (- y ascent)))
+		  (1 (values (- x descent) y))
+		  (2 (values (- x pixmap-width) (- y descent)))
+		  (3 (values (- x ascent) (- y pixmap-height))))
+		    
+	      (setf (tk::gcontext-clip-mask gcontext) string-pixmap)
+	      (setf (ink-gcontext-last-medium-clip-mask gcontext) nil)
+	      (setf (tk::gcontext-clip-x-origin gcontext) dst-x
+		    (tk::gcontext-clip-y-origin gcontext) dst-y)
+	      (tk::draw-rectangle drawable gcontext
+				  dst-x dst-y pixmap-width
+				  pixmap-height t))))))))
+
+#+ignore
+(defun clear-rotation-caches (&optional (port (find-port)))
+  (setf (tk-silica::port-rotated-font-cache port) nil
+	(xm-silica::port-rotated-string-cache port) nil))
+#+ignore
+(clear-rotation-caches)
+
+(defun find-or-cache-string-pixmap (port string start end font ascent
+				    descent height rotation pixmap
+				    min-char columns rows width
+				    leftover-width leftover-height)
+  (psetq string (subseq string start end)
+	 start 0
+	 end (- end start))
+  (let ((strings-for-font (assoc (cons rotation font)
+				 (port-rotated-string-cache port)
+				 :test #'equal)))
+    (let ((res (assoc string (cdr strings-for-font) :test #'string=)))
+      (when res (return-from find-or-cache-string-pixmap 
+		  (values-list (cdr res)))))
+    (flet ((compute-string-dimensions ()
+	     (values (do ((r 0)
+			  (i start (1+ i)))
+			 ((= i end) r)
+		       (incf r 
+			     (xt::char-width font (char-int (aref string i)))))
+		     (+ ascent descent)))
+	   (compute-clip-x-and-clip-y (char char-width)
+	     ;;-- This has to get to the right character in the pixmap
+	     (multiple-value-bind
+		 (row column)
+		 (truncate (- char min-char) columns)
+	       ;; Now we have to take into account the rotation
+	       (let ((columns columns)
+		     (rows rows))
+		 #+debug
+		 (format t "Was Row ~D of ~D, Column ~D of ~D~%" 
+			 row rows column columns)
+		 (dotimes (i rotation)
+		   (psetf column (- (1- rows) row) row column)
+		   (rotatef rows columns)))
+	       #+debug
+	       (format t "Now Row ~D of ~D, Column ~D of ~D~%" 
+		       row rows column columns)
+	       (let ((px (* column (if (oddp rotation) height width)))
+		     (py (* row (if (oddp rotation) width height)))
+		     (w (- width char-width)))
+		 (ecase rotation
+		   (0)
+		   (3 (incf py leftover-width)
+		      (incf py w))
+		   (2 (incf px leftover-width)
+		      (incf px w)
+		      (incf py leftover-height))
+		   (1 (incf px leftover-height)))
+		 #+debug
+		 (format t "x ~D y ~D px ~D py ~D~%" x y px py)
+		 (values px py))))
+	   (compute-next-x-and-y (char-width x y)
+	     (let ()
+	       (case rotation
+		 ;; Normal
+		 (0 (values (+ x char-width) y))
+		 ;; -ve y coordinates (up)
+		 (3 (values x (- y char-width)))
+		 ;; -ve x (back)
+		 (2 (values (- x char-width) y))
+		 ;; +ve y (down)
+		 (1 (values x (+ y char-width)))))))
+      (multiple-value-bind (string-width string-height)
+	  (compute-string-dimensions)
+	(multiple-value-bind (pixmap-width pixmap-height)
+	    (ecase rotation
+	      ((0 2) (values string-width string-height))
+	      ((1 3) (values string-height string-width)))
+	  (let ((string-pixmap (make-instance 'tk::pixmap 
+					      :depth 1
+					      :drawable pixmap
+					      :width pixmap-width
+					      :height
+					      pixmap-height)))
+	    #+ignore
+	    (tk::draw-rectangle string-pixmap clear-gc 
+				0 0 
+				pixmap-width pixmap-height
+				t)
+	    (multiple-value-bind (x y)
+		(ecase rotation
+		  (0 (values 0 ascent))
+		  (1 (values descent 0))
+		  (2 (values pixmap-width descent))
+		  (3 (values ascent pixmap-height)))
+	      (let ((copy-gc (port-copy-gc-depth-1 port)
+			     #+ignore (make-instance 'tk::gcontext
+					    :drawable pixmap)))
+		(dotimes (i (- end start))
+		  (let* ((char (char-int (aref string (+ start i))))
+			 (char-width (xt::char-width font char))
+			 (cx x)
+			 (cy y))
 	      
-	      (ecase rotation
-		(0 (decf cy ascent))
-		(3 (decf cx ascent)
-		   (decf cy char-width))
-		(2 (decf cy descent)
-		   (decf cx char-width))
-		(1 (decf cx descent)))
+		    (ecase rotation
+		      (0 (decf cy ascent))
+		      (3 (decf cx ascent)
+			 (decf cy char-width))
+		      (2 (decf cy descent)
+			 (decf cx char-width))
+		      (1 (decf cx descent)))
 	      
-	      (multiple-value-bind
-		  (clip-x clip-y)
-		  (compute-clip-x-and-clip-y char char-width cx cy)
-		#+debug
-		(format t "CLip-x, clip-y ~D,~D~%" clip-x clip-y)
-		(setf (tk::gcontext-clip-x-origin gcontext) clip-x
-		      (tk::gcontext-clip-y-origin gcontext) clip-y
-		      ))
-	      ;;-- We have lost the clipping region at this point!
-	      ;;--- We should draw in the background color also
-	      (tk::draw-rectangle drawable gcontext 
-				  cx cy 
-				  (if (oddp rotation) height char-width)
-				  (if (oddp rotation) char-width height)
-				  t)
-	      ;;
-	      (multiple-value-setq
-		  (x y) (compute-next-x-and-y char-width x y))))))))))
+		    (multiple-value-bind
+			(clip-x clip-y)
+			(compute-clip-x-and-clip-y char char-width)
+		      #+debug
+		      (format excl:*initial-terminal-io* "CLip-x, clip-y ~D,~D~%" 
+			      clip-x clip-y)
+		      #+ignore
+		      (setf (tk::gcontext-clip-x-origin gcontext) clip-x
+			    (tk::gcontext-clip-y-origin gcontext) clip-y
+			    )
+		      ;;-- We have lost the clipping region at this point!
+		      ;;--- We should draw in the background color also
+		      (tk::copy-area pixmap 
+				     copy-gc
+				     clip-x clip-y 
+				     (if (oddp rotation) height char-width)
+				     (if (oddp rotation) char-width height)
+				     string-pixmap cx cy ))
+		    ;;
+		    (multiple-value-setq
+			(x y) (compute-next-x-and-y char-width x y))))))
+	    (unless strings-for-font
+	      (push (setq strings-for-font (list (cons rotation font)))
+		    (port-rotated-string-cache port)))
+	    (push (list string string-pixmap pixmap-width pixmap-height) 
+		  (cdr strings-for-font))
+	    (values string-pixmap pixmap-width pixmap-height)))))))
 
 (defun find-rotated-text-pixmap (port font rotation)
   (let ((x (assoc (list font rotation) (port-rotated-font-cache port) 
@@ -1668,6 +1760,7 @@
 					  :depth 1
 					  :width n
 					  :height n))
+		   ;;--- Perhaps we should reuse this gc instead
 		   (gc (make-instance 'ink-gcontext
 				      :drawable pixmap
 				      :font font
@@ -1692,6 +1785,7 @@
 				 string)
 		(incf col))
 	      (rotate-pixmap pixmap rotation)
+	      (xt::free-gcontext gc)
 	      (values-list
 	       (cdr (car
 		     (push (list* (list font rotation)
@@ -1708,16 +1802,20 @@
   ;;   converted to clim, 19mar92 by nlc.
   ;; the bit array must be square and a power of two bits on a side.
   (let* ((array-size (xt::pixmap-width source-pixmap))
+	 ;;-- Perhaps we should be clever and reuse these if the next
+	 ;;-- time through the map is the same
 	 (mask-pixmap (make-instance 'tk::pixmap
-		       :drawable source-pixmap
-		       :width array-size
-		       :height array-size
-		       :depth 1))
+				     :drawable source-pixmap
+				     :width array-size
+				     :height array-size
+				     :depth 1))
 	 (temp-pixmap (make-instance 'tk::pixmap
-		       :drawable source-pixmap
-		       :width array-size
-		       :height array-size
-		       :depth 1))
+				     :drawable source-pixmap
+				     :width array-size
+				     :height array-size
+				     :depth 1))
+	 ;;-- Perhaps we should reuse this bitmap instead of
+	 ;;-- destroying it
 	 (gc (make-instance 'ink-gcontext :drawable source-pixmap)))
     (dotimes (i n)
       (macrolet ((copy-all-to (from xoffset yoffset to alu)
@@ -1753,7 +1851,10 @@
 			 mask-pixmap boole-and) ;13
 	  (copy-all-to mask-pixmap quad 0 mask-pixmap boole-ior) ; 14
 	  (copy-all-to mask-pixmap 0 quad mask-pixmap boole-ior) ; 15
-	  )))))
+	  )))
+    (xt::destroy-pixmap mask-pixmap)
+    (xt::destroy-pixmap temp-pixmap)
+    (xt::free-gcontext gc)))
 
 (defun stream-bitblt-support (gc
 			      from from-left from-top
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index 7b7858f9..2da8f4bc 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.74 93/03/31 10:40:33 cer Exp $
+;; $fiHeader: xt-silica.lisp,v 1.75 93/04/02 13:37:41 cer Exp $
 
 (in-package :xm-silica)
 
@@ -37,6 +37,7 @@
      (event-lock :initform (clim-sys:make-lock "port event lock")
 		 :reader port-event-lock)
      (rotated-font-cache :initform nil :accessor port-rotated-font-cache)
+     (rotated-string-cache :initform nil :accessor port-rotated-string-cache)
      (depth :accessor port-depth)
      (visual-class :accessor port-visual-class)
      (cursor-font :initform nil)
-- 
GitLab