Skip to content
Snippets Groups Projects
Commit 3d78e246 authored by colin's avatar colin
Browse files

fixed problem with gcontext clip mask not being updated when device region

changed
parent 40abc126
No related branches found
No related tags found
No related merge requests found
...@@ -20,24 +20,24 @@ ...@@ -20,24 +20,24 @@
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable. ;; 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) (in-package :tk-silica)
(defclass ink-gcontext (tk::gcontext) (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) (last-line-style :initform nil :fixed-index 3)
(shift-tile-origin :initform nil :fixed-index 4) (shift-tile-origin :initform nil :fixed-index 4)
(ink-clip-region :initform nil :fixed-index 5))) (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))) `(locally (declare (optimize (speed 3) (safety 0)))
(excl::slot-value-using-class-name 'ink-gcontext ,gcontext (excl::slot-value-using-class-name 'ink-gcontext ,gcontext
'last-device-clip-region))) 'last-clip-region-tick)))
(defsetf ink-gcontext-last-device-clip-region (gcontext) (value) (defsetf ink-gcontext-last-clip-region-tick (gcontext) (value)
`(locally (declare (optimize (speed 3) (safety 0))) `(locally (declare (optimize (speed 3) (safety 0)))
(setf (excl::slot-value-using-class-name 'ink-gcontext ,gcontext (setf (excl::slot-value-using-class-name 'ink-gcontext ,gcontext
'last-device-clip-region) 'last-clip-region-tick)
,value))) ,value)))
(defmacro ink-gcontext-last-line-style (gcontext) (defmacro ink-gcontext-last-line-style (gcontext)
...@@ -74,7 +74,8 @@ ...@@ -74,7 +74,8 @@
((drawable :initform nil) ((drawable :initform nil)
(ink-table :initform (make-hash-table :test #'equal)) (ink-table :initform (make-hash-table :test #'equal))
(indirect-inks :initform nil) (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) (defmethod make-medium ((port xt-port) sheet)
(make-instance 'xt-medium (make-instance 'xt-medium
...@@ -264,14 +265,17 @@ ...@@ -264,14 +265,17 @@
;; 3. medium's sheet's device transformation changes ;; 3. medium's sheet's device transformation changes
(defun medium-device-clip-region (medium) (defun medium-device-clip-region (medium)
(with-slots (sheet device-clip-region) medium (with-slots (sheet device-clip-region device-clip-region-tick)
(or device-clip-region medium
(setf device-clip-region (unless device-clip-region
(let ((dr (sheet-device-region sheet)) (setf device-clip-region
(mcr (medium-clipping-region medium))) (let ((dr (sheet-device-region sheet))
(region-intersection (mcr (medium-clipping-region medium)))
dr (region-intersection
(transform-region (sheet-device-transformation sheet) mcr))))))) 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)) (defmethod (setf medium-clipping-region) :after (cr (medium xt-medium))
(declare (ignore cr)) (declare (ignore cr))
...@@ -298,12 +302,15 @@ ...@@ -298,12 +302,15 @@
(tk::widget-window mirror nil)) (tk::widget-window mirror nil))
(defmethod engraft-medium :after ((medium xt-medium) (port xt-port) sheet) (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 medium
(let ((palette (medium-palette medium))) (let ((palette (medium-palette medium)))
(with-slots (white-pixel black-pixel) (with-slots (white-pixel black-pixel)
palette 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) (setf (medium-sheet medium) sheet)
(when (and drawable (when (and drawable
(not (eq (port-display port) (not (eq (port-display port)
...@@ -413,34 +420,36 @@ ...@@ -413,34 +420,36 @@
(setf (ink-gcontext-last-line-style gc) line-style))) (setf (ink-gcontext-last-line-style gc) line-style)))
;; clip mask ;; clip mask
(let ((device-clip-region (medium-device-clip-region medium)) (let ((ink-clip-region (ink-gcontext-ink-clip-region gc)))
(ink-clip-region (ink-gcontext-ink-clip-region gc))) (multiple-value-bind (device-clip-region device-clip-region-tick)
(when ink-clip-region (medium-device-clip-region medium)
(setq device-clip-region (when ink-clip-region
(region-intersection (transform-region (setq device-clip-region
(make-translation-transformation x-origin y-origin) (region-intersection (transform-region
ink-clip-region) (make-translation-transformation x-origin y-origin)
device-clip-region))) ink-clip-region)
(unless (eq (ink-gcontext-last-device-clip-region gc) device-clip-region)))
device-clip-region) (unless (and (eq (ink-gcontext-last-clip-region-tick gc)
(setf (tk::gcontext-clip-mask gc) device-clip-region-tick)
(macrolet ((region-rectangle (region) (null ink-clip-region))
`(with-bounding-rectangle* (left top right bottom) ,region (setf (tk::gcontext-clip-mask gc)
(list (fix-coordinate left) (fix-coordinate top) (macrolet ((region-rectangle (region)
(fix-coordinate (- right left)) `(with-bounding-rectangle* (left top right bottom) ,region
(fix-coordinate (- bottom top)))))) (list (fix-coordinate left) (fix-coordinate top)
(etypecase device-clip-region (fix-coordinate (- right left))
(everywhere :none) (fix-coordinate (- bottom top))))))
(nowhere nil) (etypecase device-clip-region
(standard-rectangle-set (everywhere :none)
(let ((regions (region-set-regions device-clip-region)) (nowhere nil)
(rectangles nil)) (standard-rectangle-set
(dolist (region regions) (let ((regions (region-set-regions device-clip-region))
(push (region-rectangle region) rectangles)) (rectangles nil))
rectangles)) (dolist (region regions)
(standard-bounding-rectangle (push (region-rectangle region) rectangles))
(list (region-rectangle device-clip-region)))))) rectangles))
(setf (ink-gcontext-last-device-clip-region gc) device-clip-region))) (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 ;; tile and stipple origin
(when (ink-gcontext-shift-tile-origin gc) (when (ink-gcontext-shift-tile-origin gc)
...@@ -1396,7 +1405,7 @@ ...@@ -1396,7 +1405,7 @@
#+ignore (setf (tk::gcontext-clip-mask gcontext) pixmap) #+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 start (setq start 0))
(unless end (setq end (length string))) (unless end (setq end (length string)))
...@@ -1433,7 +1442,7 @@ ...@@ -1433,7 +1442,7 @@
(3 (values (- x ascent) (- y pixmap-height)))) (3 (values (- x ascent) (- y pixmap-height))))
(setf (tk::gcontext-clip-mask gcontext) string-pixmap) (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 (setf (tk::gcontext-clip-x-origin gcontext) dst-x
(tk::gcontext-clip-y-origin gcontext) dst-y) (tk::gcontext-clip-y-origin gcontext) dst-y)
(tk::draw-rectangle drawable gcontext (tk::draw-rectangle drawable gcontext
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment