From 0aaa66be452b29ca0e23d341ecabdc6bec8a1714 Mon Sep 17 00:00:00 2001 From: colin <colin> Date: Thu, 4 Mar 1993 19:03:17 +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) --- Makefile.defs | 7 +- Makefile.generic | 4 +- clim/accept-values.lisp | 9 +- clim/cursor.lisp | 4 +- clim/gadget-output.lisp | 10 +- clim/standard-types.lisp | 7 +- misc/xtsupport.c | 4 +- silica/classes.lisp | 5 +- sys/sysdcl.lisp | 5 +- test/postscript-tests.lisp | 21 +- tk-silica/ol-gadgets.lisp | 11 +- tk-silica/xm-gadgets.lisp | 6 +- tk-silica/xt-graphics.lisp | 820 +++++++++++++++---------------------- tk-silica/xt-silica.lisp | 109 +---- tk/xlib.lisp | 74 ++-- utils/packages.lisp | 3 +- xlib/xlib-funs.lisp | 11 +- 17 files changed, 453 insertions(+), 657 deletions(-) diff --git a/Makefile.defs b/Makefile.defs index 5e7cc28f..eeb439fe 100644 --- a/Makefile.defs +++ b/Makefile.defs @@ -1,4 +1,4 @@ -# $fiHeader: Makefile.defs,v 1.1 93/03/01 14:26:08 cer Exp $ +# $fiHeader: Makefile.defs,v 1.2 93/03/01 15:59:11 cer Exp $ # # Makefile.defs for CLIM 2.0 # @@ -217,7 +217,6 @@ CLIM-STANDALONE-OBJS = clim/gestures.fasl \ clim/defresource.fasl \ clim/temp-strings.fasl \ clim/clim-defs.fasl \ - clim/stipples.fasl \ clim/stream-class-defs.fasl \ clim/interactive-defs.fasl \ clim/cursor.fasl \ @@ -313,6 +312,7 @@ OL-CLIM-OBJS = tk/ol-classes.fasl \ MOTIF-CLIM-OBJS = tk-silica/pkg.fasl \ tk-silica/xt-silica.fasl \ + tk-silica/xt-stipples.fasl \ tk-silica/xm-silica.fasl \ tk-silica/xt-graphics.fasl \ tk-silica/xm-graphics.fasl \ @@ -330,6 +330,7 @@ MOTIF-CLIM-OBJS = tk-silica/pkg.fasl \ OPENLOOK-CLIM-OBJS = tk-silica/pkg.fasl \ tk-silica/xt-silica.fasl \ + tk-silica/xt-stipples.fasl \ tk-silica/ol-silica.fasl \ tk-silica/xt-graphics.fasl \ tk-silica/ol-graphics.fasl \ @@ -395,7 +396,6 @@ ALL_SRC = utils/excl-verification.lisp \ clim/defresource.lisp \ clim/temp-strings.lisp \ clim/clim-defs.lisp \ - clim/stipples.lisp \ clim/stream-class-defs.lisp \ clim/interactive-defs.lisp \ clim/cursor.lisp \ @@ -483,6 +483,7 @@ ALL_SRC = utils/excl-verification.lisp \ tk/make-widget.lisp \ tk-silica/pkg.lisp \ tk-silica/xt-silica.lisp \ + tk-silica/xt-stipples.lisp \ tk-silica/xm-silica.lisp \ tk-silica/xt-graphics.lisp \ tk-silica/xm-graphics.lisp \ diff --git a/Makefile.generic b/Makefile.generic index 380aba95..c73205de 100644 --- a/Makefile.generic +++ b/Makefile.generic @@ -1,4 +1,4 @@ -# $fiHeader: Makefile.generic,v 1.1 93/03/01 14:26:10 cer Exp $ +# $fiHeader: Makefile.generic,v 1.2 93/03/01 15:59:14 cer Exp $ # # Makefile.generic for CLIM 2.0 # @@ -124,7 +124,7 @@ tk/xm-defs.fasl : tk/xm-defs.lisp # Building clim-xm: FORCE $(MOTIF_OBJS) - -$(RM) -f $(CLIM) + -$(RM) -f $(CLIMXM) $(ECHO) " \ (setq sys::*libxt-pathname* \"$(XTLIB)\") \ (setq sys::*libx11-pathname* \"$(XLIB)\") \ diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 287ebe4a..612b2a3e 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.52 93/01/21 14:57:35 cer Exp $ +;; $fiHeader: accept-values.lisp,v 1.53 93/02/08 15:56:36 cer Exp $ (in-package :clim-internals) @@ -156,10 +156,11 @@ (updating-output (stream :unique-id query-identifier :id-test #'equal - :cache-value (cons active-p - (if (accept-values-query-changed-p query) + :cache-value (list (if (accept-values-query-changed-p query) (accept-values-query-value query) - default)) + default) + ptype + active-p) :cache-test #'(lambda (x y) (unless (accept-values-query-changed-p query) (equal x y)))) diff --git a/clim/cursor.lisp b/clim/cursor.lisp index a7918234..3d9ac113 100644 --- a/clim/cursor.lisp +++ b/clim/cursor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cursor.lisp,v 1.21 92/12/03 10:26:15 cer Exp $ +;; $fiHeader: cursor.lisp,v 1.22 93/01/21 14:57:42 cer Exp $ (in-package :clim-internals) @@ -174,7 +174,7 @@ ;;; start blinking). (defmethod port-note-cursor-change :after ((port basic-port) cursor stream (type (eql 'cursor-focus)) old new) - (declare (ignore old type cursor)) + (declare (ignore old cursor)) ;;--- This should really only do this when PORT-INPUT-FOCUS-SELECTION ;;--- is :SHEET-UNDER-POINTER, since this causes the "wrong" thing to ;;--- happen from the perspective of Genera users. But where do we diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index 3e0dcb32..f4331b54 100644 --- a/clim/gadget-output.lisp +++ b/clim/gadget-output.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadget-output.lisp,v 1.43 93/01/18 13:54:32 cer Exp $ +;; $fiHeader: gadget-output.lisp,v 1.44 93/02/08 15:56:49 cer Exp $ (in-package :clim-internals) @@ -670,21 +670,21 @@ (declare (ignore new-value)) (setf (accept-values-query-changed-p query) t)) -;;--- This is mostly nonsense. If we enter something that is an error then -;;--- the field value is unchanged. What is the right thing to do? (defmethod accept-values-string-field-changed-callback ((gadget text-field) stream query) (let ((new-value (gadget-value gadget))) ;; Only do the accept when the field has changed + ;; Only call the callback if the query is still valid (when (and (accept-values-query-changed-p query) (accept-values-query-valid-p query (accept-values-query-presentation query))) - ;; Only call the callback if the query is still valid (handler-case (multiple-value-bind (object type index) (accept-from-string (accept-values-query-type query) new-value) (declare (ignore type)) - (assert (= index (length new-value))) + ;; we can put this back in when we handle ol text-fields + ;; correctly (see tk-silica/ol-gadgets) + #+ignore (assert (= index (length new-value))) object) (error () (setf (accept-values-query-error-p query) t)) diff --git a/clim/standard-types.lisp b/clim/standard-types.lisp index d4a1a5cf..7287a94f 100644 --- a/clim/standard-types.lisp +++ b/clim/standard-types.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: standard-types.lisp,v 1.24 92/12/14 15:02:19 cer Exp $ +;; $fiHeader: standard-types.lisp,v 1.25 92/12/16 16:46:58 cer Exp $ (in-package :clim-internals) @@ -1484,12 +1484,15 @@ (define-presentation-type form () :options ((auto-activate nil boolean)) ;; Handling of AUTO-ACTIVATE is done below... - :inherit-from `expression) + :inherit-from `((expression) :auto-activate ,auto-activate)) (define-presentation-method presentation-type-history ((type form)) ;; Share history with EXPRESSION (presentation-type-history-for-frame 'expression *application-frame*)) +;;; this overwrites the method defined by the above +;;; define-presentation-type form. This doesn't seem very satisfactory + (define-presentation-method map-over-presentation-type-supertypes ((type form) function) (with-presentation-type-decoded (name) type (funcall function name type) diff --git a/misc/xtsupport.c b/misc/xtsupport.c index 641bcada..617ff737 100644 --- a/misc/xtsupport.c +++ b/misc/xtsupport.c @@ -1,7 +1,7 @@ -/* $fiHeader: xtsupport.c,v 1.1 92/08/19 10:23:08 cer Exp $ */ +/* $fiHeader: xtsupport.c,v 1.2 93/03/01 14:26:21 cer Exp $ */ #ifdef sparc -#include "IntrinsicI.h +#include "/x11/R4/src/mit/lib/Xt/IntrinsicI.h" #endif #ifdef ultrix diff --git a/silica/classes.lisp b/silica/classes.lisp index 43ac0dab..59773011 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.29 92/12/16 16:48:28 cer Exp $ +;; $fiHeader: classes.lisp,v 1.30 93/01/11 15:45:14 colin Exp $ (in-package :silica) @@ -90,8 +90,7 @@ (foreground :initform +black+ :accessor medium-foreground) (background :initform +white+ :accessor medium-background) (ink :initform +foreground-ink+ :accessor medium-ink) - (text-style :initform *default-text-style* - :accessor medium-text-style) + (text-style :initform nil :accessor medium-text-style) (default-text-style :initform *default-text-style* :accessor medium-default-text-style) (merged-text-style :initform *default-text-style* diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index 0c882f10..d1f2bd52 100644 --- a/sys/sysdcl.lisp +++ b/sys/sysdcl.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sysdcl.lisp,v 1.34 92/12/16 16:50:03 cer Exp $ +;; $fiHeader: sysdcl.lisp,v 1.35 92/12/17 15:33:24 cer Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :cl-user) @@ -209,7 +209,6 @@ ("temp-strings") ("coral-defs" :features CCL-2) ("clim-defs") - ("stipples") ;; Definitions and protocols ("stream-class-defs") @@ -408,6 +407,7 @@ :load-before-compile (clim-standalone xm-tk)) ("pkg") ("xt-silica") + ("xt-stipples") ("xm-silica") ("xt-graphics") ("xm-graphics") @@ -432,6 +432,7 @@ :load-before-compile (clim-standalone ol-tk)) ("pkg") ("xt-silica") + ("xt-stipples") ("ol-silica") ("xt-graphics") ("ol-graphics") diff --git a/test/postscript-tests.lisp b/test/postscript-tests.lisp index 34e67523..f5ca7842 100644 --- a/test/postscript-tests.lisp +++ b/test/postscript-tests.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: postscript-tests.lisp,v 1.3 92/12/01 09:46:38 cer Exp $ +;; $fiHeader: postscript-tests.lisp,v 1.4 92/12/16 16:50:10 cer Exp $ (in-package :clim-user) @@ -238,14 +238,27 @@ ; (draw-text* stream "Quid fecit Dominus!?!" 200 200 ; :text-style '(:sans-serif :italic :large))))) +(defvar *hearts-tile* + (make-rectangular-tile + (make-pattern #2A((0 1 1 0 1 1 0 0) + (1 0 0 1 0 0 1 0) + (1 0 0 1 0 0 1 0) + (0 1 0 0 0 1 0 0) + (0 0 1 0 1 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)) + (list +foreground-ink+ +background-ink+)) + 8 8)) + ;(defun pat-ps (&optional file) ; (ps-test -; (draw-rectangle* stream 100 100 200 200 :ink *hearts-stipple*))) +; (draw-rectangle* stream 100 100 200 200 :ink *hearts-tile*))) (define-postscript-test (pattern-test "Draws a heart patterned rectangle" clim-user::graphics) () - (draw-rectangle* *standard-output* 100 100 200 200 :ink clim-internals::*hearts-stipple*)) + (draw-rectangle* *standard-output* 100 100 200 200 :ink *hearts-tile*)) ;(defun test-l-ps (&optional file) ; (ps-test @@ -294,7 +307,7 @@ ; (ps-test ; (flet ((draw (stream) ; (draw-rectangle* stream 0 0 50 50 -; :ink *hearts-stipple*) +; :ink *hearts-tile*) ; #+Ignore ; (draw-triangle* stream 50 50 50 75 75 50 :ink +cyan+) ; (draw-circle* stream 70 30 20))) diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index 1082b5fc..4a2b1cb4 100644 --- a/tk-silica/ol-gadgets.lisp +++ b/tk-silica/ol-gadgets.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-gadgets.lisp,v 1.37 93/01/18 13:58:07 cer Exp $ +;; $fiHeader: ol-gadgets.lisp,v 1.38 93/02/08 15:58:04 cer Exp $ (in-package :xm-silica) @@ -502,6 +502,11 @@ (defun openlook-text-field-edit-widget (tf &optional (mirror (sheet-direct-mirror tf))) (tk::get-values mirror :text-edit-widget)) +;;; --we need to define an event handler to deal with the losing focus +;;; correcly. At the moment this function is simply incorrect. +;;; when this is fixed put back assert in clim/gadget-output +;;; accept-values-string-field-changed-callback + (defmethod add-sheet-callbacks :after ((port openlook-port) (sheet openlook-text-field) (widget t)) @@ -509,6 +514,10 @@ (tk::add-callback (openlook-text-field-edit-widget sheet widget) :post-modify-notification 'queue-value-changed-event + sheet) + (tk::add-callback (openlook-text-field-edit-widget sheet widget) + :post-modify-notification + 'queue-losing-focus-event sheet))) (defmethod gadget-value ((gadget openlook-text-field)) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 8bb25676..959d06f7 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.63 93/02/08 15:58:10 cer Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.64 93/03/01 14:26:36 cer Exp $ (in-package :xm-silica) @@ -114,7 +114,8 @@ (ecase alignment ((:left nil) :beginning) (:center :center) - (:right :end))))) + (:right :end)))) + (setf (getf initargs :recompute-size) nil)) (values class initargs))) (defmethod (setf gadget-label) :after (nv (sheet motif-labelled-gadget)) @@ -530,6 +531,7 @@ ;;; (defclass motif-text-editor (motif-losing-focus-callback-pane + motif-value-changed-callback-pane motif-action-pane text-editor xt-leaf-pane) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 69b43180..2417ca06 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.62 93/01/21 14:59:31 cer Exp $ +;; $fiHeader: xt-graphics.lisp,v 1.63 93/02/10 10:04:25 cer Exp $ (in-package :tk-silica) @@ -71,14 +71,10 @@ ,value))) (defclass xt-medium (basic-medium) - ((foreground-gcontext :reader medium-foreground-gcontext :initform nil) - (background-gcontext :reader medium-background-gcontext :initform nil) - (flipping-gcontext :reader medium-flipping-gcontext :initform nil) - (drawable :initform nil) + ((drawable :initform nil) (ink-table :initform (make-hash-table :test #'equal)) - (clip-mask :initform nil) ; A cache. (indirect-inks :initform nil) - (tile-gcontext :initform nil))) + (clip-mask :initform nil))) (defmethod medium-drawable ((medium xt-medium)) (with-slots (drawable sheet) medium @@ -306,10 +302,7 @@ (tk::widget-window mirror nil)) (defmethod engraft-medium :after ((medium xt-medium) (port xt-port) sheet) - (with-slots (foreground-gcontext background-gcontext - flipping-gcontext - indirect-inks - drawable tile-gcontext clip-mask) + (with-slots (indirect-inks drawable clip-mask) medium (let ((palette (medium-palette medium))) (with-slots (white-pixel black-pixel) @@ -323,71 +316,32 @@ (let* ((display (port-display port)) (drawable (or drawable (tk::display-root-window display)))) - (unless foreground-gcontext - (setf foreground-gcontext (tk::make-instance 'ink-gcontext - :drawable drawable))) - (unless background-gcontext - (setf background-gcontext (tk::make-instance 'ink-gcontext - :drawable drawable))) - (unless flipping-gcontext - (setf flipping-gcontext - (tk::make-instance 'ink-gcontext - :drawable drawable - :function boole-xor))) - (unless tile-gcontext - (setf tile-gcontext (make-instance 'ink-gcontext - :drawable drawable - :foreground black-pixel - :background white-pixel))) - (recompute-gcs medium)))))) + (invalidate-indirect-inks medium)))))) (defmethod degraft-medium :after ((medium xt-medium) (port xt-port) sheet) (declare (ignore sheet)) - (with-slots - (foreground-gcontext background-gcontext flipping-gcontext tile-gcontext - ink-table drawable) + (with-slots (ink-table indirect-inks drawable) medium (setf drawable nil (medium-sheet medium) nil) - (macrolet ((loose-gc (gc) - `(when ,gc - (tk::free-gcontext ,gc) - (setf ,gc nil)))) - (maphash #'(lambda (ink gc) - (declare (ignore ink)) - (tk::free-gcontext gc)) - ink-table) - (clrhash ink-table) - (loose-gc foreground-gcontext) - (loose-gc background-gcontext) - (loose-gc flipping-gcontext) - (loose-gc tile-gcontext)))) - -(defun recompute-gcs (medium) - (with-slots - (foreground-gcontext background-gcontext flipping-gcontext - ink-table indirect-inks) + (maphash #'(lambda (ink gc) + (declare (ignore ink)) + (tk::free-gcontext gc)) + ink-table) + (clrhash ink-table) + (setf indirect-inks nil))) + +(defun invalidate-indirect-inks (medium) + (with-slots (ink-table indirect-inks) medium - (when (and foreground-gcontext background-gcontext flipping-gcontext) - (let* ((palette (medium-palette medium)) - (foreground-pixel - (decode-color-in-palette (medium-foreground medium) palette)) - (background-pixel - (decode-color-in-palette (medium-background medium) palette))) - (setf (tk::gcontext-foreground foreground-gcontext) foreground-pixel - (tk::gcontext-background foreground-gcontext) background-pixel - (tk::gcontext-foreground background-gcontext) background-pixel - (tk::gcontext-background background-gcontext) background-pixel - (tk::gcontext-foreground flipping-gcontext) - (logxor foreground-pixel background-pixel)) - (dolist (ink indirect-inks) - (tk::free-gcontext (gethash ink ink-table)) - (remhash ink ink-table)) - (setf indirect-inks nil))))) + (dolist (ink indirect-inks) + (tk::free-gcontext (gethash ink ink-table)) + (remhash ink ink-table)) + (setf indirect-inks nil))) (defmethod (setf medium-background) :after (ink (medium xt-medium)) (declare (ignore ink)) - (recompute-gcs medium) + (invalidate-indirect-inks medium) ;;--- This should be a in Silica method ;;--- This breaks the default-from-mirror-resource code when you ;;--- change the layout of a sheet @@ -397,81 +351,12 @@ (defmethod (setf medium-foreground) :after (ink (medium xt-medium)) (declare (ignore ink)) - (recompute-gcs medium)) - -(defmethod (setf medium-ink) :after (ink (medium xt-medium)) - (declare (ignore ink)) - (recompute-gcs medium)) + (invalidate-indirect-inks medium)) ;;; Colors and their monochrome imposters ;;; Much of this is taken from CLX-IMPLEMENTATION -(defvar *luminosity-stipples* - (mapcar #'(lambda (entry) - (cons (first entry) (apply #'make-stipple-image (second entry)))) - '((0.1 (8 16 (#b0111111111111111 - #b1111110111111111 - #b1111111111110111 - #b1101111111111111 - #b1111111101111111 - #b1111111111111101 - #b1111011111111111 - #b1111111111011111))) - (0.2 (8 8 (#b01111111 - #b11101111 - #b11111101 - #b10111111 - #b11110111 - #b11111110 - #b11011111 - #b11111011))) - (0.3 (4 4 (#b0111 - #b1101 - #b1011 - #b1110))) - (0.4 (3 3 (#b011 - #b101 - #b110))) - (0.6 (2 2 (#b01 - #b10))) - (0.7 (3 3 (#b100 - #b010 - #b001))) - (0.8 (4 4 (#b1000 - #b0010 - #b0100 - #b0001))) - (0.9 (8 8 (#b10000000 - #b00010000 - #b00000010 - #b01000000 - #b00001000 - #b00000001 - #b00100000 - #b00000100))) - (0.95 (8 16 (#b1000000000000000 - #b0000001000000000 - #b0000000000001000 - #b0010000000000000 - #b0000000010000000 - #b0000000000000010 - #b0000100000000000 - #b0000000000100000)))))) - -;; The tk::image objects are created at load time to save startup time. -;; Here a '0' means white, '1' black. -(defun decode-luminosity (luminosity stipple-p) - (if (not stipple-p) - (if (< luminosity 0.5) 1 0) ; Questionable. XX - (if (< luminosity 0.05) - 1 - (dolist (entry *luminosity-stipples* 0) - (let ((l (car entry)) - (stipple (cdr entry))) - (when (< luminosity l) - (return-from decode-luminosity stipple))))))) - ;;; (indirect-ink-p ink) returns t if ink is an indirect ink or ;;; derived from an indirect ink @@ -479,14 +364,11 @@ (defgeneric indirect-ink-p (ink)) -(defmethod indirect-ink-p ((ink design)) - nil) - -(defmethod indirect-ink-p ((ink (eql +foreground-ink+))) - t) +(defmethod indirect-ink-p ((ink design)) nil) -(defmethod indirect-ink-p ((ink (eql +background-ink+))) - t) +(defmethod indirect-ink-p ((ink (eql +foreground-ink+))) t) +(defmethod indirect-ink-p ((ink (eql +background-ink+))) t) +(defmethod indirect-ink-p ((ink standard-opacity)) t) (defmethod indirect-ink-p ((ink flipping-ink)) (multiple-value-bind (ink1 ink2) @@ -494,260 +376,7 @@ (or (indirect-ink-p ink1) (indirect-ink-p ink2)))) -(defgeneric decode-ink (ink medium)) - -;;; the default decode-ink method. If it's in the table get gc from -;;; there otherwise make a gc using decode-color-in-palette to get the -;;; pixel value - -;;--- This is really on color, dynamic-color, and layered-color. -;;--- Perhaps there should be a class like basic-color? - -(defmethod decode-ink ((ink design) (medium xt-medium)) - (with-slots (ink-table sheet drawable) medium - (or (gethash ink ink-table) - (let* ((drawable (or drawable - (tk::display-root-window (port-display (port sheet))))) - (new-gc (make-instance 'ink-gcontext :drawable drawable))) - (multiple-value-bind (pixel mask) - (decode-color-in-palette ink (medium-palette medium)) - (setf (tk::gcontext-foreground new-gc) pixel) - (when mask - (setf (tk::gcontext-plane-mask new-gc) mask))) - (setf (gethash ink ink-table) new-gc))))) - -(defmethod decode-ink ((ink (eql +everywhere+)) medium) - (slot-value medium 'foreground-gcontext)) - -(defmethod decode-ink ((ink (eql +foreground-ink+)) medium) - (slot-value medium 'foreground-gcontext)) - -(defmethod decode-ink ((ink (eql +background-ink+)) medium) - (slot-value medium 'background-gcontext)) - -(defmethod decode-ink ((ink (eql +flipping-ink+)) stream) - (slot-value stream 'flipping-gcontext)) - -(defmethod decode-ink ((ink flipping-ink) (medium xt-medium)) - (let ((palette (medium-palette medium))) - (with-slots (ink-table sheet drawable indirect-inks) - medium - (or (gethash ink ink-table) - (let* ((drawable (or drawable - (tk::display-root-window (port-display (port sheet))))) - (new-gc (make-instance 'ink-gcontext - :drawable drawable - :function boole-xor))) - (multiple-value-bind (color1 color2) - (decode-flipping-ink ink) - (cond ((palette-color-p palette) - (setf (tk::gcontext-foreground new-gc) - (logxor (decode-color color1 medium) - (decode-color color2 medium)))) - ;;-- support gray-scale here - (t - ;; in a monochrome context there is only one - ;; flipping ink availiable ie white <-> black - (slot-value medium 'flipping-gcontext))) - (when (indirect-ink-p ink) - (push ink indirect-inks)) - (setf (gethash ink ink-table) new-gc))))))) - - -(defmethod decode-ink ((ink color) (medium xt-medium)) - (let ((palette (medium-palette medium))) - (with-slots (white-pixel black-pixel) palette - (with-slots (ink-table sheet tile-gcontext drawable) medium - (or (gethash ink ink-table) - (let* ((drawable - (or drawable - (tk::display-root-window (port-display (port sheet))))) - (new-gc (make-instance 'ink-gcontext :drawable drawable))) - (cond ((palette-color-p palette) - (setf (tk::gcontext-foreground new-gc) - (decode-color-in-palette ink palette))) - ;;-- support gray-scale here - (t - (multiple-value-bind (r g b) (color-rgb ink) - (let* ((luminosity (color-luminosity r g b)) - (color (decode-luminosity luminosity t))) - (cond - ((eq color 1) - (setf (tk::gcontext-fill-style new-gc) :solid - (tk::gcontext-foreground new-gc) black-pixel)) - ((eq color 0) - (setf (tk::gcontext-fill-style new-gc) :solid - (tk::gcontext-foreground new-gc) white-pixel)) - (t ; color is an image - (setf (tk::gcontext-fill-style new-gc) :tiled) - (let ((pixmap - (make-instance - 'tk::pixmap - :drawable drawable - :width (tk::image-width color) - :height (tk::image-height color) - :depth (tk::drawable-depth drawable)))) - (tk::put-image pixmap tile-gcontext color) - (setf (tk::gcontext-tile new-gc) pixmap)))))))) - (setf (gethash ink ink-table) new-gc))))))) - -(defmethod decode-ink ((ink (eql +nowhere+)) medium) - (decode-ink-opacity ink medium)) - -(defmethod decode-ink ((ink standard-opacity) medium) - (decode-ink-opacity ink medium)) - -(defmethod decode-ink-opacity (opacity medium) - (with-slots (ink-table sheet drawable foreground-gcontext ink-table) - medium - (let ((key (cons opacity foreground-gcontext))) - (or (gethash key ink-table) - (unless (eq :solid (tk::gcontext-fill-style foreground-gcontext)) - (warn "opacities may only be use with solid colors ~ -and on color servers, unless using white or black") - (return-from decode-ink-opacity foreground-gcontext)) - (let* ((port (port sheet)) - (display (port-display port)) - (drawable (or drawable (tk::display-root-window display))) - (new-gc (make-instance 'ink-gcontext :drawable drawable))) - (x11:xcopygc display foreground-gcontext -1 new-gc) - (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) - (decode-ink (decode-contrasting-ink ink medium) medium)) - -(defmethod decode-ink ((ink pattern) medium) - (with-slots (ink-table) medium - (or (gethash ink ink-table) - (setf (gethash ink ink-table) - (decode-pattern-ink ink medium))))) - - -(defmethod decode-color ((design design) (medium xt-medium)) - (decode-color-in-palette design (medium-palette medium))) - -(defmethod decode-color ((x (eql +foreground-ink+)) (medium xt-medium)) - (with-slots (foreground-gcontext) medium - (tk::gcontext-foreground foreground-gcontext))) - -(defmethod decode-color ((x (eql +background-ink+)) (medium xt-medium)) - (with-slots (background-gcontext) medium - (tk::gcontext-foreground background-gcontext))) - -(defmethod decode-color ((ink standard-opacity) (medium xt-medium)) - (if (> (opacity-value ink) 0.5) - (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)) - -(defmethod decode-color-in-palette ((color color) (palette xt-palette)) - (let ((color-cache (palette-color-cache palette))) - (or (gethash color color-cache) - (setf (gethash color color-cache) - (with-slots (white-pixel black-pixel) palette - (cond ((palette-color-p palette) - (handler-case - (tk::allocate-color - (palette-colormap palette) (get-xcolor color palette)) - (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 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))) - (or (gethash color dynamic-color-cache) - (let ((pixel (aref (handler-case - (tk::alloc-color-cells - (palette-colormap palette) 1 0) - (tk::x-colormap-full () - (error 'palette-full))) - 0))) - (update-palette-entry palette pixel (dynamic-color-color color)) - (push palette (dynamic-color-palettes color)) - (setf (gethash color dynamic-color-cache) pixel))))) - -(defmethod decode-color-in-palette ((color layered-color) (palette xt-palette)) - (let ((layered-color-cache (palette-layered-color-cache palette))) - (values-list - (or (gethash color layered-color-cache) - (setf (gethash color layered-color-cache) - (let* ((set (layered-color-set color)) - (pixel-planes (gethash set layered-color-cache))) - (unless pixel-planes - (setq pixel-planes (decode-layered-color-set set palette))) - (multiple-value-list - (decode-layered-color (layered-color-layers color) pixel-planes)))))))) - -(defun decode-layered-color (layers pixel-planes) - (let ((pixel (car pixel-planes)) - (planes (cdr pixel-planes)) - (mask 0)) - (dolist (layer layers) - (let ((plane-masks (pop planes))) - (if layer - (dolist (plane-mask plane-masks) - (when (zerop layer) - (return)) - (when (oddp layer) - (setq pixel (logior pixel plane-mask))) - (setq layer (ash layer -1))) - (dolist (plane-mask plane-masks) - (setq mask (logior mask plane-mask)))))) - (values pixel (lognot mask)))) - -(defun decode-layered-color-set (set palette) - (let ((layered-color-cache (palette-layered-color-cache palette)) - (dynamic-color-cache (palette-dynamic-color-cache palette)) - (layers (layered-color-set-layers set)) - (dynamic-array (layered-color-set-dynamic-array set)) - layer-nplanes - (total-nplanes 0)) - (dolist (layer layers) - (let ((nplanes (floor (log layer 2)))) - (push nplanes layer-nplanes) - (incf total-nplanes nplanes))) - (multiple-value-bind (pixels masks) - (handler-case - (tk::alloc-color-cells - (palette-colormap palette) 1 total-nplanes) - (tk::x-colormap-full () - (error 'palette-full))) - (let ((pixel (aref pixels 0)) - (count 0) - (planes nil)) - (dolist (nplanes layer-nplanes) - (let ((plane-masks nil)) - (dotimes (i nplanes) - (push (aref masks count) plane-masks) - (incf count)) - (push plane-masks planes))) - (let ((pixel-planes (cons pixel planes))) - (map-over-layered-colors - #'(lambda (dimensions) - (let ((dynamic-color (apply #'aref dynamic-array dimensions)) - (pixel (decode-layered-color dimensions - pixel-planes))) - (setf (gethash dynamic-color dynamic-color-cache) pixel) - (update-palette-entry palette pixel (dynamic-color-color dynamic-color)) - (push palette (dynamic-color-palettes dynamic-color)))) - set) - (setf (gethash set layered-color-cache) pixel-planes)))))) +;;; adjust ink (defvar *default-dashes* '(4 4)) @@ -859,18 +488,120 @@ and on color servers, unless using white or black") (values (list x y width height) x-origin y-origin)))))))) medium-clip-mask)) -#+ignore -(defmethod decode-ink :around ((ink t) (medium xt-medium)) - (let ((gc (call-next-method))) - gc)) +;;; decode ink + +(defgeneric decode-ink (ink medium)) -(defmethod decode-pattern-design ((ink (eql +nowhere+)) (medium xt-medium)) - nil) +;;; we provide this around method which implement a cache of already +;;; decoded inks -(defmethod decode-pattern-design ((ink design) (medium xt-medium)) - (decode-color ink medium)) +;;; if the decode method for an ink calculates the gcontext by calling +;;; decode-ink it should also return t as it's second value. (eg for +;;; contrasting inks) This prevent problems with having multiple +;;; entries for the same gc in the table which causes problems when +;;; they need to be freed -(defmethod decode-pattern-ink ((pattern pattern) medium) +(defmethod decode-ink :around ((ink design) (medium xt-medium)) + (with-slots (ink-table indirect-inks) medium + (or (gethash ink ink-table) + (multiple-value-bind (gc recursive-p) + (call-next-method) + (unless recursive-p + (when (indirect-ink-p ink) + (push ink indirect-inks)) + (setf (gethash ink ink-table) gc)) + gc)))) + +;;; the default decode-ink method. Make a gc using +;;; decode-color-in-palette to get the pixel value + +;;--- This is really only makes sense for color, dynamic-color, and +;;--- layered-color. Perhaps there should be a class like basic-color? + +(defmethod decode-ink ((ink design) (medium xt-medium)) + (with-slots (sheet drawable) medium + (let* ((drawable (or drawable + (tk::display-root-window (port-display (port sheet))))) + (new-gc (make-instance 'ink-gcontext :drawable drawable))) + (multiple-value-bind (pixel mask) + (decode-color ink medium) + (setf (tk::gcontext-foreground new-gc) pixel) + (when mask + (setf (tk::gcontext-plane-mask new-gc) mask))) + new-gc))) + +(defmethod decode-ink ((ink flipping-ink) (medium xt-medium)) + (with-slots (sheet drawable) + medium + (let* ((drawable (or drawable + (tk::display-root-window (port-display (port sheet))))) + (new-gc (make-instance 'ink-gcontext + :drawable drawable + :function boole-xor))) + (multiple-value-bind (color1 color2) + (decode-flipping-ink ink) + (setf (tk::gcontext-foreground new-gc) + (logxor (decode-color color1 medium) + (decode-color color2 medium)))) + new-gc))) + +(defmethod decode-ink ((ink color) (medium xt-medium)) + (let ((palette (medium-palette medium))) + (with-slots (white-pixel black-pixel) palette + (with-slots (sheet drawable) medium + (let* ((port (port sheet)) + (drawable + (or drawable + (tk::display-root-window (port-display port)))) + (new-gc (make-instance 'ink-gcontext :drawable drawable))) + (cond ((palette-color-p palette) + (setf (tk::gcontext-foreground new-gc) + (decode-color-in-palette ink palette))) + ;;-- support gray-scale here + (t + (multiple-value-bind (r g b) (color-rgb ink) + (let ((luminosity (color-luminosity r g b))) + (cond + ((<= luminosity 0.05) + (setf (tk::gcontext-foreground new-gc) black-pixel)) + ((< 0.95 luminosity) + (setf (tk::gcontext-foreground new-gc) white-pixel)) + (t + (setf (tk::gcontext-fill-style new-gc) :opaque-stippled + (tk::gcontext-foreground new-gc) white-pixel + (tk::gcontext-background new-gc) black-pixel + (tk::gcontext-stipple new-gc) + (decode-stipple luminosity port)))))))) + new-gc))))) + +(defmethod decode-ink ((ink (eql +nowhere+)) (medium xt-medium)) + (decode-ink-opacity ink medium)) + +(defmethod decode-ink ((ink standard-opacity) (medium xt-medium)) + (decode-ink-opacity ink medium)) + +(defmethod decode-ink-opacity (opacity (medium xt-medium)) + (with-slots (sheet drawable) + medium + (let* ((port (port sheet)) + (display (port-display port)) + (drawable (or drawable (tk::display-root-window display))) + (new-gc (make-instance 'ink-gcontext :drawable drawable))) + (setf (tk::gcontext-foreground new-gc) (decode-color +foreground-ink+ medium) + (tk::gcontext-stipple new-gc) (decode-stipple (opacity-value opacity) port) + (tk::gcontext-fill-style new-gc) :stippled) + new-gc))) + +(defmethod decode-contrasting-ink ((ink contrasting-ink) (medium xt-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 xt-medium)) + (values + (decode-ink (decode-contrasting-ink ink medium) medium) t)) + +(defmethod decode-ink ((pattern pattern) (medium xt-medium)) (multiple-value-bind (array designs) (decode-pattern pattern) (let* ((height (array-dimension array 0)) @@ -884,10 +615,11 @@ and on color servers, unless using white or black") ;; Cache the decoded designs from the pattern (dotimes (n (length designs)) - (let ((pixel (decode-pattern-design (elt designs n) medium))) - (setf (svref design-pixels n) pixel) - (unless pixel - (setf transparent-p t)))) + (let ((design (elt designs n))) + (if (eql design +nowhere+) + (setf transparent-p t) + (setf (svref design-pixels n) + (decode-color design medium))))) (dotimes (w width) (dotimes (h height) @@ -935,7 +667,9 @@ and on color servers, unless using white or black") gc)))) ;;---the following extends a pattern for tiling by making it -;;transparent. This causes problems in the test-suite. +;;transparent. This causes problems in the test-suite. This is more +;;correct with regards to the spec but maybe the spec is "wrong" on +;;this one #+ignore (defun decode-extended-pattern (pattern width height) (multiple-value-bind (array designs) @@ -975,82 +709,202 @@ and on color servers, unless using white or black") (values extended-array designs)) (values array designs))))) -(defmethod decode-ink ((ink rectangular-tile) medium) - (with-slots (ink-table) medium - (or (gethash ink ink-table) - (setf (gethash ink ink-table) - (multiple-value-bind (pattern width height) - (decode-rectangular-tile ink) - (setf (gethash pattern ink-table) - (multiple-value-bind (array designs) - (decode-extended-pattern pattern width height) - (let* ((image-data (make-array (list height width))) - (design-pixels (make-array (length designs))) - (two-color-p (= (length designs) 2)) - two-color-fg two-color-bg) - (declare (simple-vector design-pixels)) - - ;; Cache the decoded designs from the pattern - (dotimes (n (length designs)) - (let ((pixel (decode-pattern-design (elt designs n) medium))) - (setf (svref design-pixels n) pixel) - (unless (or two-color-p pixel) - (error "Transparent tiled pattern ~S has more than two designs" - pattern)))) +(defmethod decode-ink ((ink rectangular-tile) (medium xt-medium)) + (multiple-value-bind (pattern width height) + (decode-rectangular-tile ink) + (multiple-value-bind (array designs) + (decode-extended-pattern pattern width height) + (let* ((image-data (make-array (list height width))) + (design-pixels (make-array (length designs))) + (two-color-p (= (length designs) 2)) + two-color-fg two-color-bg) + (declare (simple-vector design-pixels)) + + ;; Cache the decoded designs from the pattern + (dotimes (n (length designs)) + (let ((design (elt designs n))) + (if (eql design +nowhere+) + (unless two-color-p + (error "Transparent tiled pattern ~S has more than two designs" + pattern)) + (setf (svref design-pixels n) + (decode-color design medium))))) - (when two-color-p - (setq two-color-bg (svref design-pixels 0) - two-color-fg (svref design-pixels 1)) - ;; make sure that any transparent design is the bg - (when (null (svref design-pixels 1)) - (rotatef two-color-bg two-color-fg))) + (when two-color-p + (setq two-color-bg (svref design-pixels 0) + two-color-fg (svref design-pixels 1)) + ;; make sure that any transparent design is the bg + (when (null (svref design-pixels 1)) + (rotatef two-color-bg two-color-fg))) - (dotimes (w width) - (dotimes (h height) - (let ((pixel (svref design-pixels (aref array h w)))) - (setf (aref image-data h w) - (if two-color-p - (if (eq pixel two-color-bg) - 0 - 1) - pixel))))) - - (let* ((port (port (medium-sheet medium))) - (drawable (or (slot-value medium 'drawable) - (tk::display-root-window - (port-display port)))) - (depth (if two-color-p - 1 - (tk::drawable-depth drawable))) - (image (make-instance 'tk::image - :width width - :height height - :data image-data - :depth depth)) - (gc (make-instance 'ink-gcontext :drawable drawable)) - (pixmap - (make-instance 'tk::pixmap - :drawable drawable - :width width - :height height - :depth depth))) - (tk::put-image pixmap - (if two-color-p - (port-copy-gc-depth-1 port) - gc) - image) - (if two-color-p - (setf (tk::gcontext-stipple gc) pixmap - (tk::gcontext-fill-style gc) (if two-color-bg - :opaque-stippled - :stippled) - (tk::gcontext-foreground gc) (or two-color-fg 0) - (tk::gcontext-background gc) (or two-color-bg 0)) - (setf (tk::gcontext-tile gc) pixmap - (tk::gcontext-fill-style gc) :tiled)) - gc))))))))) + (dotimes (w width) + (dotimes (h height) + (let ((pixel (svref design-pixels (aref array h w)))) + (setf (aref image-data h w) + (if two-color-p + (if (eq pixel two-color-bg) + 0 + 1) + pixel))))) + + (let* ((port (port (medium-sheet medium))) + (drawable (or (slot-value medium 'drawable) + (tk::display-root-window + (port-display port)))) + (depth (if two-color-p + 1 + (tk::drawable-depth drawable))) + (image (make-instance 'tk::image + :width width + :height height + :data image-data + :depth depth)) + (gc (make-instance 'ink-gcontext :drawable drawable)) + (pixmap + (make-instance 'tk::pixmap + :drawable drawable + :width width + :height height + :depth depth))) + (tk::put-image pixmap + (if two-color-p + (port-copy-gc-depth-1 port) + gc) + image) + (if two-color-p + (setf (tk::gcontext-stipple gc) pixmap + (tk::gcontext-fill-style gc) (if two-color-bg + :opaque-stippled + :stippled) + (tk::gcontext-foreground gc) (or two-color-fg 0) + (tk::gcontext-background gc) (or two-color-bg 0)) + (setf (tk::gcontext-tile gc) pixmap + (tk::gcontext-fill-style gc) :tiled)) + gc))))) + +;;; decode color + +(defgeneric decode-color (design medium)) + +(defmethod decode-color ((design design) (medium xt-medium)) + (decode-color-in-palette design (medium-palette medium))) + +(defmethod decode-color ((x (eql +everywhere+)) (medium xt-medium)) + (decode-color-in-palette (medium-foreground medium) (medium-palette medium))) + +(defmethod decode-color ((x (eql +foreground-ink+)) (medium xt-medium)) + (decode-color-in-palette (medium-foreground medium) (medium-palette medium))) + +(defmethod decode-color ((x (eql +background-ink+)) (medium xt-medium)) + (decode-color-in-palette (medium-background medium) (medium-palette medium))) + +(defmethod decode-color ((ink standard-opacity) (medium xt-medium)) + (if (> (opacity-value ink) 0.5) + (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)) + +(defmethod decode-color-in-palette ((color color) (palette xt-palette)) + (let ((color-cache (palette-color-cache palette))) + (or (gethash color color-cache) + (setf (gethash color color-cache) + (with-slots (white-pixel black-pixel) palette + (cond ((palette-color-p palette) + (handler-case + (tk::allocate-color + (palette-colormap palette) (get-xcolor color palette)) + (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 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))) + (or (gethash color dynamic-color-cache) + (let ((pixel (aref (handler-case + (tk::alloc-color-cells + (palette-colormap palette) 1 0) + (tk::x-colormap-full () + (error 'palette-full))) + 0))) + (update-palette-entry palette pixel (dynamic-color-color color)) + (push palette (dynamic-color-palettes color)) + (setf (gethash color dynamic-color-cache) pixel))))) +(defmethod decode-color-in-palette ((color layered-color) (palette xt-palette)) + (let ((layered-color-cache (palette-layered-color-cache palette))) + (values-list + (or (gethash color layered-color-cache) + (setf (gethash color layered-color-cache) + (let* ((set (layered-color-set color)) + (pixel-planes (gethash set layered-color-cache))) + (unless pixel-planes + (setq pixel-planes (decode-layered-color-set set palette))) + (multiple-value-list + (decode-layered-color (layered-color-layers color) pixel-planes)))))))) +(defun decode-layered-color (layers pixel-planes) + (let ((pixel (car pixel-planes)) + (planes (cdr pixel-planes)) + (mask 0)) + (dolist (layer layers) + (let ((plane-masks (pop planes))) + (if layer + (dolist (plane-mask plane-masks) + (when (zerop layer) + (return)) + (when (oddp layer) + (setq pixel (logior pixel plane-mask))) + (setq layer (ash layer -1))) + (dolist (plane-mask plane-masks) + (setq mask (logior mask plane-mask)))))) + (values pixel (lognot mask)))) + +(defun decode-layered-color-set (set palette) + (let ((layered-color-cache (palette-layered-color-cache palette)) + (dynamic-color-cache (palette-dynamic-color-cache palette)) + (layers (layered-color-set-layers set)) + (dynamic-array (layered-color-set-dynamic-array set)) + layer-nplanes + (total-nplanes 0)) + (dolist (layer layers) + (let ((nplanes (floor (log layer 2)))) + (push nplanes layer-nplanes) + (incf total-nplanes nplanes))) + (multiple-value-bind (pixels masks) + (handler-case + (tk::alloc-color-cells + (palette-colormap palette) 1 total-nplanes) + (tk::x-colormap-full () + (error 'palette-full))) + (let ((pixel (aref pixels 0)) + (count 0) + (planes nil)) + (dolist (nplanes layer-nplanes) + (let ((plane-masks nil)) + (dotimes (i nplanes) + (push (aref masks count) plane-masks) + (incf count)) + (push plane-masks planes))) + (let ((pixel-planes (cons pixel planes))) + (map-over-layered-colors + #'(lambda (dimensions) + (let ((dynamic-color (apply #'aref dynamic-array dimensions)) + (pixel (decode-layered-color dimensions + pixel-planes))) + (setf (gethash dynamic-color dynamic-color-cache) pixel) + (update-palette-entry palette pixel (dynamic-color-color dynamic-color)) + (push palette (dynamic-color-palettes dynamic-color)))) + set) + (setf (gethash set layered-color-cache) pixel-planes)))))) ;; Line (& maybe eventually non-rectangular polygon) clipping diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 0d2f1323..50d6200e 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.68 93/01/21 14:59:36 cer Exp $ +;; $fiHeader: xt-silica.lisp,v 1.69 93/02/08 15:58:19 cer Exp $ (in-package :xm-silica) @@ -30,7 +30,7 @@ (context :reader port-context) (copy-gc :initform nil) (copy-gc-depth-1 :initform nil) - (opacities :initform nil) + (stipples :initform nil :accessor port-stipples) ;; This next is true for servers like Suns, which (pretty much) always ;; can safely copy-area without generating graphics-exposures. (safe-backing-store :initform nil :accessor port-safe-backing-store) @@ -220,7 +220,7 @@ ;;; Perhaps we should just grab the first font we can find. (t (error "Unable to determine default font")))))) - (setup-opacities port display)) + (setup-stipples port display)) (defparameter *xt-logical-size-alist* '((:tiny 6) @@ -236,103 +236,6 @@ (standardize-text-style-1 port style character-set *xt-logical-size-alist*)) -(defun make-stipple-image (height width patterns) - (make-instance 'tk::image :width width :height height - :data (clim-internals::make-stipple-array height width patterns) - :depth 1)) - -(defvar *opacity-stipples* - (mapcar #'(lambda (entry) - (cons (first entry) - (apply #'make-stipple-image (second entry)))) - '((+nowhere+ (1 1 (#b0))) - (0.05 (8 16 (#b1000000000000000 - #b0000001000000000 - #b0000000000001000 - #b0010000000000000 - #b0000000010000000 - #b0000000000000010 - #b0000100000000000 - #b0000000000100000))) - (0.1 (8 8 (#b10000000 - #b00010000 - #b00000010 - #b01000000 - #b00001000 - #b00000001 - #b00100000 - #b00000100))) - (0.2 (4 4 (#b1000 - #b0010 - #b0100 - #b0001))) - (0.3 (3 3 (#b100 - #b010 - #b001))) - (0.4 (2 2 (#b10 - #b01))) - (0.6 (3 3 (#b011 - #b101 - #b110))) - (0.7 (4 4 (#b0111 - #b1101 - #b1011 - #b1110))) - (0.8 (8 8 (#b01111111 - #b11101111 - #b11111101 - #b10111111 - #b11110111 - #b11111110 - #b11011111 - #b11111011))) - (0.9 (8 16 (#b0111111111111111 - #b1111110111111111 - #b1111111111110111 - #b1101111111111111 - #b1111111101111111 - #b1111111111111101 - #b1111011111111111 - #b1111111111011111))) - (+everywhere+ (1 1 (#b1)))))) - - -(defun setup-opacities (port display) - (let ((opacities nil) - (root (tk::display-root-window display)) - gc) - (dolist (ls *opacity-stipples*) - (let ((pixmap (make-instance 'tk::pixmap - :drawable root - :width (tk::image-width (cdr ls)) - :height (tk::image-height (cdr ls)) - :depth 1))) - (unless gc - (setq gc (make-instance 'tk::gcontext :drawable pixmap - :foreground 1 :background 0))) - (tk::put-image pixmap gc (cdr ls)) - (push (cons (car ls) pixmap) opacities))) - (when gc - (tk::free-gcontext gc)) - (setf (slot-value port 'opacities) (nreverse opacities)))) - -;; -;; Takes an opacity, and returns a clip mask (pixmap) for that opacity. -;; -(defun decode-opacity (opacity port) - (let ((pops (slot-value port 'opacities))) - (cond ((eq opacity +nowhere+) - (cdar pops)) - ((eq opacity +everywhere+) - (cdar (last pops))) - (t - (let ((lastpop (cdar pops)) - (value (opacity-value opacity))) - (dolist (pop (cdr pops) lastpop) - (if (< value (car pop)) - (return lastpop)) - (setq lastpop (cdr pop)))))))) - (defmethod destroy-mirror ((port xt-port) (sheet mirrored-sheet-mixin)) @@ -1723,8 +1626,12 @@ the geometry of the children. Instead the parent has control. ")) (check-type y (signed-byte 16)) (tk::set-values (frame-shell frame) :x x :y y)) +(defmethod port-resize-frame ((port xt-port) frame width height) + (check-type width (signed-byte 16)) + (check-type height (signed-byte 16)) + (tk::set-values (frame-shell frame) :width width :height height)) + (defmethod destroy-port ((port xt-port)) (when (port-process port) (clim-sys:destroy-process (port-process port))) (port-terminated port (make-condition 'error))) - diff --git a/tk/xlib.lisp b/tk/xlib.lisp index fe6a22da..bd127734 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.38 93/01/11 15:45:55 colin Exp $ +;; $fiHeader: xlib.lisp,v 1.39 93/02/08 15:57:57 cer Exp $ (in-package :tk) @@ -634,53 +634,49 @@ (height :reader image-height :initarg :height) (data :reader image-data :initarg :data) (depth :reader image-depth :initarg :depth) + (format :reader image-format :initform x11:zpixmap :initarg :format) (realized-displays :initform nil :accessor realized-displays))) +(defconstant bitmap-pad 8) + (defmethod realize-image (image display) (when (not (member display (realized-displays image))) - (let ((width (image-width image)) - (height (image-height image)) - (data (image-data image)) - (depth (image-depth image)) - v - format - (bytes-per-line 0) - (bitmap-pad 8)) ; Why is this 8 - if 0 get signal 8! - ; -- RTFM, dude. (jdi) - (ecase depth + (let* ((width (image-width image)) + (height (image-height image)) + (data (image-data image)) + (depth (image-depth image)) + (format (image-format image)) + (bits-per-line (* width depth)) + (padded-bits-per-line (* bitmap-pad + (ceiling bits-per-line bitmap-pad))) + (bytes-per-line (/ padded-bits-per-line 8)) + (v (excl::malloc (* bytes-per-line height))) + (visual (x11:screen-root-visual + (x11:xdefaultscreenofdisplay display))) + (offset 0) + (x (x11:xcreateimage display + visual + depth + format + offset + v + width + height + bitmap-pad + bytes-per-line))) + (case depth (8 - (setq format x11:zpixmap) - (setq v (excl::malloc (* width height))) (dotimes (h height) (dotimes (w width) - (setf (sys::memref-int v (+ (* h width) w) 0 :unsigned-byte) + (setf (sys::memref-int v (+ (* h bytes-per-line) w) 0 :unsigned-byte) (aref data h w))))) - (1 - (setq format x11:zpixmap) - (setq bytes-per-line (ceiling (/ width bitmap-pad))) - (setq v (excl::malloc (* bytes-per-line height))))) - (let* ((visual (x11:screen-root-visual - (x11:xdefaultscreenofdisplay display))) - (offset 0) - (x (x11:xcreateimage - display - visual - depth - format - offset - v - width - height - bitmap-pad - bytes-per-line))) - (case depth - (1 - (dotimes (h height) - (dotimes (w width) - (x11:xputpixel x w h (aref data h w)))))) - (setf (foreign-pointer-address image) x))) - (pushnew display (realized-displays image)))) + (t + (dotimes (h height) + (dotimes (w width) + (x11:xputpixel x w h (aref data h w)))))) + (setf (foreign-pointer-address image) x)) + (push display (realized-displays image)))) (defmethod put-image (pixmap gc image &key (src-x 0) (src-y 0) (dest-x 0) (dest-y 0)) diff --git a/utils/packages.lisp b/utils/packages.lisp index da4efcc9..daae5b54 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: packages.lisp,v 1.46 93/01/21 14:59:44 cer Exp $ +;; $fiHeader: packages.lisp,v 1.47 93/02/08 15:58:29 cer Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -3494,6 +3494,7 @@ port-invoke-with-pointer-grabbed port-mirror->sheet-table port-move-frame + port-resize-frame port-note-cursor-change port-note-frame-adopted port-note-gadget-activated diff --git a/xlib/xlib-funs.lisp b/xlib/xlib-funs.lisp index c8968f92..8b99fa00 100644 --- a/xlib/xlib-funs.lisp +++ b/xlib/xlib-funs.lisp @@ -45,7 +45,7 @@ ;; OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION ;; WITH THE USE OR PERFORMANCE OF THIS OBJECT CODE. -;;; $fiHeader: xlib-funs.lisp,v 1.8 92/09/30 18:03:32 cer Exp $ +;;; $fiHeader: xlib-funs.lisp,v 1.9 92/12/14 15:05:17 cer Exp $ (in-package :x11) @@ -2002,3 +2002,12 @@ (bytes-buffer int) (keysym-return (:pointer keysym)) (status-in-out (:pointer xcomposestatus))) + +#+ignore +(def-exported-foreign-function (xmatchvisualinfo (:return-type int) + (:name "XMatchVisualInfo")) + (dpy (:pointer display)) + (scr int) + (depth int) + (class int) + (vinfo-return (:pointer visual-info))) -- GitLab