Skip to content
Snippets Groups Projects
Commit 7af90e9a authored by colin's avatar colin
Browse files

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)
parent 0aaa66be
No related branches found
No related tags found
No related merge requests found
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- ;;; -*- 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) (in-package :clim-internals)
...@@ -115,10 +115,13 @@ ...@@ -115,10 +115,13 @@
(member char break-characters))) (member char break-characters)))
string :start start :end end)) string :start start :end end))
(width (text-size stream string (width (text-size stream string
:start start :end break))) :start start :end (or break end))))
(when (or (null break) (> break 0)) (when (or (null break) (> break 0))
(let ((ofp (fill-pointer buffer))) (let* ((ofp (fill-pointer buffer))
(incf (fill-pointer buffer) (- (or break end) start)) (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 (replace buffer string
:start1 ofp :start1 ofp
:start2 start :end2 break))) :start2 start :end2 break)))
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- ;;; -*- 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) (in-package :clim-internals)
...@@ -325,9 +325,9 @@ ...@@ -325,9 +325,9 @@
(let ((translators nil)) (let ((translators nil))
(flet ((collect-translators (translator) (flet ((collect-translators (translator)
(with-presentation-type-translator-key (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 (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) (when (and (presentation-subtypep-1 from-key translator-from-key)
;; PRESENTATION-SUBTYPEP will return T when the ;; PRESENTATION-SUBTYPEP will return T when the
;; translator is "context independent", that is, ;; translator is "context independent", that is,
...@@ -362,9 +362,10 @@ ...@@ -362,9 +362,10 @@
(floor (presentation-translator-priority translator1) 10) (floor (presentation-translator-priority translator1) 10)
(multiple-value-bind (high2 low2) (multiple-value-bind (high2 low2)
(floor (presentation-translator-priority translator2) 10) (floor (presentation-translator-priority translator2) 10)
(if (< high1 high2) (unless (< high2 high1)
(setf (car translators) translator2 (if (< high1 high2)
(car remaining) translator1) (setf (car translators) translator2
(car remaining) translator1)
(cond ((eq name1 name2) (cond ((eq name1 name2)
;; If the two types are the same, then use the low ;; If the two types are the same, then use the low
;; order part of the priority to break the tie ;; order part of the priority to break the tie
...@@ -374,7 +375,7 @@ ...@@ -374,7 +375,7 @@
((presentation-subtypep-1 type2 type1) ((presentation-subtypep-1 type2 type1)
;; The second type is more specific than the first, swap. ;; The second type is more specific than the first, swap.
(setf (car translators) translator2 (setf (car translators) translator2
(car remaining) translator1))))))))) (car remaining) translator1))))))))))
translators)) translators))
;; Return a list of all classes that are not provably disjoint from CLASS ;; Return a list of all classes that are not provably disjoint from CLASS
......
;; -*- 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))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment