From 94480ee157289f1bb0f0a1bd28c5c000c98398e5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 3 May 2007 07:08:35 +0000 Subject: [PATCH] fix shrink clipping svn: r6125 --- collects/htdp/image.ss | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/collects/htdp/image.ss b/collects/htdp/image.ss index afa0e27a6e..3eb860f7ab 100644 --- a/collects/htdp/image.ss +++ b/collects/htdp/image.ss @@ -270,8 +270,12 @@ plt/collects/tests/mzscheme/image-test.ss [px left] [py up] [dc-proc (lambda (dc dx dy) - (let ([clip (send dc get-clipping-region)]) - (send dc set-clipping-rect dx dy width height) + (let ([clip (send dc get-clipping-region)] + [rgn (make-object region% dc)]) + (send rgn set-rectangle dx dy width height) + (when clip + (send rgn intersect clip)) + (send dc set-clipping-region rgn) (dc-proc dc (- dx delta-w) (- dy delta-h)) (send dc set-clipping-region clip)))] [argb-proc (lambda (argb dx dy) (argb-proc argb (- dx delta-w) (- dy delta-h)))]