From 7af90e9a64b73bb8db17cf8a96e1a1dfb6b8063b Mon Sep 17 00:00:00 2001
From: colin <colin>
Date: Thu, 4 Mar 1993 19:02:38 +0000
Subject: [PATCH] Makefile.defs - got rid of clim/stipples and introduced
 tk-silica/xt-stipples

clim/accept-values.lisp
- made :cache-value in find-or-add-query for av fields depend on ptype

clim/gadget-output.lisp
- temp fix in accept-values-string-field-changed-callback for openlook

clim/standard-types.lisp
- fix presentation type for form to properly inherit from expression
to handle auto-activate correctly

clim/stipples.lisp
- REMOVED (never used)

clim/text-formatting.lisp
- fixed a couple of bugs with filling-stream in stream-write-string
method

clim/translators.lisp
- fixed bug in find-presentation-translators-1 so that translators are
sorted by priority correctly

silica/classes.lisp
- changed initform for text-style to be nil rather than
*default-text-style* in basic-medium. This was causing text style
resources to be ignored.

sys/sysdcl.lisp
- removed clim/stipples and added tk-silica/xt-stipples

tk/xlib.lisp
- fixed up images for screen depths other than 8,1 and added support
made images take a :format arg (controls zpixmap/xypixmap/xybitmap)

tk-silica/ol-gadgets.lisp
- temp fix to make text-fields work

tk-silica/xm-gadgets.lisp
- label widgets set :recompute-size resource to nil
- bug fix for text-editor field and setf gadget-value

tk-silica/xt-graphics.lisp
- a whole bunch of changes/bug fixes. stippling now much improved and
simplified mechanism for ink table handling. foreground and background
and flipping ink are now treated like any other indirect inks with
their gcontexts kept in the ink table. tile-gcontext scrapped - now in
the port. luminisoty and opacity stuff merged into xt-stipples. bug
fixes for opacities.

tk-silica/xt-silica.lisp
- opacities stuff removed - moved to xt-stipples.
- added port-resize-frame

tk-silica/xt-stipples.lisp
- NEWFILE
- new opacity and luminosity stuff - 1 bit pixmaps on a per port basis

utils/packages.lisp
- export port-resize-frame from xm-silica

test/postscript-tests.lisp
- put in *hearts-tile* (grabbed it from clim/stipples.lisp)
---
 clim/text-formatting.lisp  |  11 ++--
 clim/translators.lisp      |  15 ++---
 tk-silica/xt-stipples.lisp | 111 +++++++++++++++++++++++++++++++++++++
 3 files changed, 126 insertions(+), 11 deletions(-)
 create mode 100644 tk-silica/xt-stipples.lisp

diff --git a/clim/text-formatting.lisp b/clim/text-formatting.lisp
index d45f7523..38dee66d 100644
--- a/clim/text-formatting.lisp
+++ b/clim/text-formatting.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: text-formatting.lisp,v 1.10 92/09/08 15:18:37 cer Exp $
+;; $fiHeader: text-formatting.lisp,v 1.11 92/11/06 19:00:40 cer Exp $
 
 (in-package :clim-internals)
 
@@ -115,10 +115,13 @@
 					   (member char break-characters)))
 				   string :start start :end end))
 	       (width (text-size stream string 
-				 :start start :end break)))
+				 :start start :end (or break end))))
 	  (when (or (null break) (> break 0))
-	    (let ((ofp (fill-pointer buffer)))
-	      (incf (fill-pointer buffer) (- (or break end) start))
+	    (let* ((ofp (fill-pointer buffer))
+		   (nfp (+ ofp (- (or break end) start))))
+	      (when (> nfp (array-dimension buffer 0))
+		(adjust-array buffer (+ nfp nfp)))
+	      (setf (fill-pointer buffer) nfp)
 	      (replace buffer string
 		       :start1 ofp
 		       :start2 start :end2 break)))
diff --git a/clim/translators.lisp b/clim/translators.lisp
index eb021587..3f816c32 100644
--- a/clim/translators.lisp
+++ b/clim/translators.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: translators.lisp,v 1.10 92/11/06 19:00:47 cer Exp $
+;; $fiHeader: translators.lisp,v 1.11 92/11/19 14:18:36 cer Exp $
 
 (in-package :clim-internals)
 
@@ -325,9 +325,9 @@
   (let ((translators nil))
     (flet ((collect-translators (translator)
 	     (with-presentation-type-translator-key
-	       (translator-from-key (presentation-translator-from-type translator))
+		 (translator-from-key (presentation-translator-from-type translator))
 	       (with-presentation-type-translator-key
-		 (translator-to-key (presentation-translator-to-type translator))
+		   (translator-to-key (presentation-translator-to-type translator))
 		 (when (and (presentation-subtypep-1 from-key translator-from-key)
 			    ;; PRESENTATION-SUBTYPEP will return T when the
 			    ;; translator is "context independent", that is,
@@ -362,9 +362,10 @@
 	      (floor (presentation-translator-priority translator1) 10)
 	    (multiple-value-bind (high2 low2)
 		(floor (presentation-translator-priority translator2) 10)
-	      (if (< high1 high2)
-		  (setf (car translators) translator2
-			(car remaining) translator1)
+	      (unless (< high2 high1)
+		(if (< high1 high2)
+		    (setf (car translators) translator2
+			  (car remaining) translator1)
 		  (cond ((eq name1 name2)
 			 ;; If the two types are the same, then use the low
 			 ;; order part of the priority to break the tie
@@ -374,7 +375,7 @@
 			((presentation-subtypep-1 type2 type1)
 			 ;; The second type is more specific than the first, swap.
 			 (setf (car translators) translator2
-			       (car remaining) translator1)))))))))
+			       (car remaining) translator1))))))))))
     translators))
 
 ;; Return a list of all classes that are not provably disjoint from CLASS
diff --git a/tk-silica/xt-stipples.lisp b/tk-silica/xt-stipples.lisp
new file mode 100644
index 00000000..60c19279
--- /dev/null
+++ b/tk-silica/xt-stipples.lisp
@@ -0,0 +1,111 @@
+;; -*- mode: common-lisp; package: xm-silica -*-
+;;
+;;				-[]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+
+;;; stipples are bitmaps used for monochrome half-toning and to
+;;; implement opacities.
+
+(in-package :xm-silica)
+
+(defvar *stipple-images*
+    (mapcar #'(lambda (entry)
+		(let* ((intensity (first entry))
+		       (data (second entry))
+		       (height (array-dimension data 0))
+		       (width (array-dimension data 1)))
+		  (cons intensity
+			(make-instance 'tk::image
+				       :width width :height height
+				       :data data :depth 1))))
+	    '((0.05 #2A((0)))
+	      (0.1  #2A((1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
+			(0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0)
+			(0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0)
+			(0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0)
+			(0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0)
+			(0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0)
+			(0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0)
+			(0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0)))
+	      (0.2  #2A((1 0 0 0 0 0 0 0)
+			(0 0 0 1 0 0 0 0)
+			(0 0 0 0 0 0 1 0)
+			(0 1 0 0 0 0 0 0)
+			(0 0 0 0 1 0 0 0)
+			(0 0 0 0 0 0 0 1)
+			(0 0 1 0 0 0 0 0)
+			(0 0 0 0 0 1 0 0)))
+	      (0.3  #2A((1 0 0 0)
+			(0 0 1 0)
+			(0 1 0 0)
+			(0 0 0 1)))
+	      (0.4  #2A((1 0 0)
+			(0 1 0)
+			(0 0 1))) 
+	      (0.6  #2A((1 0)
+			(0 1)))
+	      (0.7  #2A((0 1 1)
+			(1 0 1)
+			(1 1 0)))
+	      (0.8  #2A((0 1 1 1) 
+			(1 1 0 1)
+			(1 0 1 1)
+			(1 1 1 0)))
+	      (0.9  #2A((0 1 1 1 1 1 1 1)
+			(1 1 1 0 1 1 1 1)
+			(1 1 1 1 1 1 0 1)
+			(1 0 1 1 1 1 1 1)
+			(1 1 1 1 0 1 1 1)
+			(1 1 1 1 1 1 1 0)
+			(1 1 0 1 1 1 1 1)
+			(1 1 1 1 1 0 1 1)))
+	      (0.95 #2A((0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)
+			(1 1 1 1 1 1 0 1 1 1 1 1 1 1 1 1)
+			(1 1 1 1 1 1 1 1 1 1 1 1 0 1 1 1)
+			(1 1 0 1 1 1 1 1 1 1 1 1 1 1 1 1)
+			(1 1 1 1 1 1 1 1 0 1 1 1 1 1 1 1)
+			(1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1)
+			(1 1 1 1 0 1 1 1 1 1 1 1 1 1 1 1)
+			(1 1 1 1 1 1 1 1 1 1 0 1 1 1 1 1)))
+	      (1   #2A((1))))))
+
+(defun decode-stipple (luminosity port)
+  (dolist (entry (port-stipples port))
+    (let ((l (car entry))
+	  (stipple (cdr entry)))
+      (when (<= luminosity l)
+	(return-from decode-stipple stipple)))))
+
+(defun setup-stipples (port display)
+  (let ((stipples nil)
+	(root (tk::display-root-window display))
+	(gc (port-copy-gc-depth-1 port)))
+    (dolist (entry *stipple-images*)
+      (let* ((intensity (car entry))
+	     (image (cdr entry))
+	     (pixmap (make-instance 'tk::pixmap
+				    :drawable root
+				    :width (tk::image-width image)
+				    :height (tk::image-height image)
+				    :depth 1)))
+	(tk::put-image pixmap gc image)
+	(push (cons intensity pixmap) stipples)))
+    (setf (port-stipples port) (nreverse stipples))))
-- 
GitLab