diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 7acbbabd75752d07d0e80fc3a7e56001834eb33a..29b6c52901cb0e5551fd3e02c0471c7e7a29dfdf 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,24 +20,24 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.69 93/04/07 09:07:27 cer Exp $ +;; $fiHeader: xt-graphics.lisp,v 1.70 93/04/08 13:19:15 colin Exp $ (in-package :tk-silica) (defclass ink-gcontext (tk::gcontext) - ((last-device-clip-region :initform nil :fixed-index 2) + ((last-clip-region-tick :initform nil :fixed-index 2) (last-line-style :initform nil :fixed-index 3) (shift-tile-origin :initform nil :fixed-index 4) (ink-clip-region :initform nil :fixed-index 5))) -(defmacro ink-gcontext-last-device-clip-region (gcontext) +(defmacro ink-gcontext-last-clip-region-tick (gcontext) `(locally (declare (optimize (speed 3) (safety 0))) (excl::slot-value-using-class-name 'ink-gcontext ,gcontext - 'last-device-clip-region))) -(defsetf ink-gcontext-last-device-clip-region (gcontext) (value) + 'last-clip-region-tick))) +(defsetf ink-gcontext-last-clip-region-tick (gcontext) (value) `(locally (declare (optimize (speed 3) (safety 0))) (setf (excl::slot-value-using-class-name 'ink-gcontext ,gcontext - 'last-device-clip-region) + 'last-clip-region-tick) ,value))) (defmacro ink-gcontext-last-line-style (gcontext) @@ -74,7 +74,8 @@ ((drawable :initform nil) (ink-table :initform (make-hash-table :test #'equal)) (indirect-inks :initform nil) - (device-clip-region :initform nil))) + (device-clip-region :initform nil) + (device-clip-region-tick :initform 0))) (defmethod make-medium ((port xt-port) sheet) (make-instance 'xt-medium @@ -264,14 +265,17 @@ ;; 3. medium's sheet's device transformation changes (defun medium-device-clip-region (medium) - (with-slots (sheet device-clip-region) medium - (or device-clip-region - (setf device-clip-region - (let ((dr (sheet-device-region sheet)) - (mcr (medium-clipping-region medium))) - (region-intersection - dr - (transform-region (sheet-device-transformation sheet) mcr))))))) + (with-slots (sheet device-clip-region device-clip-region-tick) + medium + (unless device-clip-region + (setf device-clip-region + (let ((dr (sheet-device-region sheet)) + (mcr (medium-clipping-region medium))) + (region-intersection + dr + (transform-region (sheet-device-transformation sheet) mcr)))) + (incf device-clip-region-tick)) + (values device-clip-region device-clip-region-tick))) (defmethod (setf medium-clipping-region) :after (cr (medium xt-medium)) (declare (ignore cr)) @@ -298,12 +302,15 @@ (tk::widget-window mirror nil)) (defmethod engraft-medium :after ((medium xt-medium) (port xt-port) sheet) - (with-slots (indirect-inks drawable device-clip-region) + (with-slots (indirect-inks drawable device-clip-region + device-clip-region-tick) medium (let ((palette (medium-palette medium))) (with-slots (white-pixel black-pixel) palette - (setf indirect-inks nil device-clip-region nil) + (setf indirect-inks nil + device-clip-region nil + device-clip-region-tick 0) (setf (medium-sheet medium) sheet) (when (and drawable (not (eq (port-display port) @@ -413,34 +420,36 @@ (setf (ink-gcontext-last-line-style gc) line-style))) ;; clip mask - (let ((device-clip-region (medium-device-clip-region medium)) - (ink-clip-region (ink-gcontext-ink-clip-region gc))) - (when ink-clip-region - (setq device-clip-region - (region-intersection (transform-region - (make-translation-transformation x-origin y-origin) - ink-clip-region) - device-clip-region))) - (unless (eq (ink-gcontext-last-device-clip-region gc) - device-clip-region) - (setf (tk::gcontext-clip-mask gc) - (macrolet ((region-rectangle (region) - `(with-bounding-rectangle* (left top right bottom) ,region - (list (fix-coordinate left) (fix-coordinate top) - (fix-coordinate (- right left)) - (fix-coordinate (- bottom top)))))) - (etypecase device-clip-region - (everywhere :none) - (nowhere nil) - (standard-rectangle-set - (let ((regions (region-set-regions device-clip-region)) - (rectangles nil)) - (dolist (region regions) - (push (region-rectangle region) rectangles)) - rectangles)) - (standard-bounding-rectangle - (list (region-rectangle device-clip-region)))))) - (setf (ink-gcontext-last-device-clip-region gc) device-clip-region))) + (let ((ink-clip-region (ink-gcontext-ink-clip-region gc))) + (multiple-value-bind (device-clip-region device-clip-region-tick) + (medium-device-clip-region medium) + (when ink-clip-region + (setq device-clip-region + (region-intersection (transform-region + (make-translation-transformation x-origin y-origin) + ink-clip-region) + device-clip-region))) + (unless (and (eq (ink-gcontext-last-clip-region-tick gc) + device-clip-region-tick) + (null ink-clip-region)) + (setf (tk::gcontext-clip-mask gc) + (macrolet ((region-rectangle (region) + `(with-bounding-rectangle* (left top right bottom) ,region + (list (fix-coordinate left) (fix-coordinate top) + (fix-coordinate (- right left)) + (fix-coordinate (- bottom top)))))) + (etypecase device-clip-region + (everywhere :none) + (nowhere nil) + (standard-rectangle-set + (let ((regions (region-set-regions device-clip-region)) + (rectangles nil)) + (dolist (region regions) + (push (region-rectangle region) rectangles)) + rectangles)) + (standard-bounding-rectangle + (list (region-rectangle device-clip-region)))))) + (setf (ink-gcontext-last-clip-region-tick gc) device-clip-region-tick)))) ;; tile and stipple origin (when (ink-gcontext-shift-tile-origin gc) @@ -1396,7 +1405,7 @@ #+ignore (setf (tk::gcontext-clip-mask gcontext) pixmap) - #+ignore (setf (ink-gcontext-last-device-clip-region gcontext) nil) + #+ignore (decf (ink-gcontext-last-clip-region-tick gcontext)) (unless start (setq start 0)) (unless end (setq end (length string))) @@ -1433,7 +1442,7 @@ (3 (values (- x ascent) (- y pixmap-height)))) (setf (tk::gcontext-clip-mask gcontext) string-pixmap) - (setf (ink-gcontext-last-device-clip-region gcontext) nil) + (decf (ink-gcontext-last-clip-region-tick gcontext)) (setf (tk::gcontext-clip-x-origin gcontext) dst-x (tk::gcontext-clip-y-origin gcontext) dst-y) (tk::draw-rectangle drawable gcontext