diff --git a/Makefile.defs b/Makefile.defs index 5e7cc28f0f1d27d7ba52c4a0fe1ddb8fc19837a7..eeb439fe6e071d69495e16f2d6ee3e4736633916 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 380aba9572ff49f96a24f37963a1ac3f34e11a59..c73205dea511c36cc5dbda68bd20d1f886b5dfe3 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 287ebe4a59b3b0828996b981f907b2b693711e1b..612b2a3e701de4c98e7b6451d8aef4c5307938a9 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 a7918234963e891c26b5c60a0063b4f39e0ac561..3d9ac1130d4cf7aa5e0a5517664facf91a5cb3d2 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 3e0dcb3209475e2554ebb25e397481d6cc9a1a3c..f4331b5489f028099f5454c16b582e6ec2808a3d 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 d4a1a5cfd55c82ec97deafbd91bdb595866e9135..7287a94f2fa9d4a2bbe76e3e267668ea8256a64c 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 641bcada14520812f7d90c2f939398f3655f3e63..617ff7370c65138701d927bc46280fb5d6e2c9a0 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 43ac0dab3509f9de8759e6a636ab4d4161400776..59773011a52e0cf92eb45134e8b4397aa81ff88b 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 0c882f1018ec3e295e8a4c71eb5b7d1463016e63..d1f2bd5256610ec8e8fb4f2c373541cfe3d93200 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 34e6752340cf79a3cee6af10b02363a2098cf447..f5ca78424c24d183a6cc8ebee41228608efbdc50 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 1082b5fc3fe3469beda37ca941517e8917dc3cb8..4a2b1cb464146ec0487beff85230c64dac950377 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 8bb2567653a6b1ed06950b1c1e9472d2a12698a8..959d06f746ebe99af48951808b13489be935831d 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 69b43180a5b1ddf070465500d05c3c7e1defdd82..2417ca06d7f821a890eddd54fc2055ead68a865e 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 0d2f1323f7ecd5282f4dc6b2d1dbcc9d78e7eed6..50d6200ed14f1f2273d7ae67de13a9f6b4bf0c81 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 fe6a22da2bb7a0b4cf32e0c8a6f5d84077510678..bd12773432a9bd17164eb762d145cba767c9e476 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 da4efcc9dc0fecffb003d331ff1b001a963750d7..daae5b541eb4413fcc9d7d7f3960a72db972095b 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 c8968f92ebf77cb32583ee1e978ec92801e7f4b8..8b99fa00234fb2032764db4c8f46fa04f721179c 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)))