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