diff --git a/collects/racket/draw/private/region.rkt b/collects/racket/draw/private/region.rkt index 0f131bf24e..c4d4a3f363 100644 --- a/collects/racket/draw/private/region.rkt +++ b/collects/racket/draw/private/region.rkt @@ -123,55 +123,73 @@ (cairo_identity_matrix cr) (init-matrix cr) (cairo_transform cr (make-cairo_matrix_t 1 0 0 1 scroll-dx scroll-dy))) - (for/fold ([v init]) ([pr (in-list paths)]) - (cairo_new_path cr) - (send (car pr) do-path cr values values) - (cairo_set_fill_rule cr - (case (cdr pr) - [(odd-even) CAIRO_FILL_RULE_EVEN_ODD] - [(winding) CAIRO_FILL_RULE_WINDING] - [else default-fill-rule])) - (install cr v)) + (if (null? paths) + (begin + (cairo_new_path cr) + (install cr init)) + (for/fold ([v init]) ([pr (in-list paths)]) + (cairo_new_path cr) + (send (car pr) do-path cr values values) + (cairo_set_fill_rule cr + (case (cdr pr) + [(odd-even) CAIRO_FILL_RULE_EVEN_ODD] + [(winding) CAIRO_FILL_RULE_WINDING] + [else default-fill-rule])) + (install cr v))) (when old-matrix (cairo_set_matrix cr old-matrix)))) (def/public (is-empty?) (really-is-empty?)) - (define/private (with-clipping proc) - (send - dc - in-cairo-context - (lambda (cr) - (cairo_save cr) - (install-region cr 0 0 values values) - (begin0 - (proc cr) - (cairo_restore cr))))) + (define/private (with-clipping who proc) + (unless dc + (raise-mismatch-error (method-name 'region% who) + "not allowed for a region without a drawing context: " + this)) + (send dc in-cairo-context + (lambda (cr) + (cairo_save cr) + (install-region cr 0 0 values values) + (begin0 + (proc cr) + (cairo_restore cr))))) (define/private (really-is-empty?) (or (null? paths) (if empty-known? known-empty? (let ([v (with-clipping + 'is-empty? (lambda (cr) (let-values ([(x1 y1 x2 y2) (cairo_clip_extents cr)]) (or (= x1 x2) (= y1 y2)))))]) (set! known-empty? v) (set! empty-known? #t) v)))) - - (def/public (in-region? [real? x] - [real? y]) + + (define/private (with-temp-cr proc) (let ([cr (call-as-atomic (lambda () (cond [temp-cr (begin0 temp-cr (set! temp-cr #f))] [else - (let ([s (cairo_image_surface_create CAIRO_FORMAT_A8 1 1)]) + (let ([s (cairo_image_surface_create CAIRO_FORMAT_A8 100 100)]) (begin0 (cairo_create s) (cairo_surface_destroy s)))])))]) + (begin0 + (proc cr) + (call-as-atomic + (lambda () + (cond + [temp-cr (cairo_destroy cr)] + [else (set! temp-cr cr)])))))) + + (def/public (in-region? [real? x] + [real? y]) + (with-temp-cr + (lambda (cr) (let-values ([(x y) (if matrix ;; need to use the DC's current transformation @@ -184,12 +202,7 @@ (vector-ref m 5)))) ;; no transformation needed (values x y))]) - (begin0 - (install-region cr #t values values (lambda (cr v) (and v (cairo_in_fill cr x y)))) - (call-as-atomic - (cond - [temp-cr (cairo_destroy cr)] - [else (set! temp-cr cr)])))))) + (install-region cr #t values values (lambda (cr v) (and v (cairo_in_fill cr x y)))))))) (def/public (set-arc [real? x] [real? y] diff --git a/collects/racket/draw/unsafe/cairo.rkt b/collects/racket/draw/unsafe/cairo.rkt index c60c959adc..4fbfb6d481 100644 --- a/collects/racket/draw/unsafe/cairo.rkt +++ b/collects/racket/draw/unsafe/cairo.rkt @@ -127,7 +127,15 @@ (x2 : (_ptr o _double)) (y2 : (_ptr o _double)) -> _void - -> (values x1 y1 x2 y2))) + -> (values x1 y1 x2 y2)) + ;; cairo_clip_extents is in version 1.4 and later + #:fail (lambda () + (let ([warned? #f]) + (lambda (cr) + (unless warned? + (log-warning "cairo_clip_extents is unavailable; returning the empty rectangle") + (set! warned? #t)) + (values 0 0 0 0))))) ;; Transforms (define-cairo cairo_translate (_fun _cairo_t _double* _double* -> _void)) diff --git a/collects/scribblings/draw/region-class.scrbl b/collects/scribblings/draw/region-class.scrbl index f0be83c7fa..870bcb1123 100644 --- a/collects/scribblings/draw/region-class.scrbl +++ b/collects/scribblings/draw/region-class.scrbl @@ -90,7 +90,9 @@ An intersect corresponds to clipping with this region's path, and then boolean?]{ Returns @scheme[#t] if the region is approximately empty, @scheme[#f] - otherwise. + otherwise, but only if the region is associated with a drawing context. + If the region is unassociated to any drawing context, the + @racket[exn:fail:contract] exception is raised. } diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 01b0632923..483d59507f 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -1053,70 +1053,71 @@ ;(send dc set-clipping-region #f) (send dc clear) - (if clock-clip? - (let ([r (make-object region% dc)]) - (send r set-arc 0. 60. 180. 180. clock-start clock-end) - (send dc set-clipping-region r)) - (let ([mk-poly (lambda (mode) - (let ([r (make-object region% dc)]) - (send r set-polygon octagon 0 0 mode) r))] - [mk-circle (lambda () - (let ([r (make-object region% dc)]) - (send r set-ellipse 0. 60. 180. 180.) r))] - [mk-rect (lambda () - (let ([r (make-object region% dc)]) - (send r set-rectangle 100 -25 10 400) r))]) - (case clip - [(none) (void)] - [(rect) (send dc set-clipping-rect 100 -25 10 400)] - [(rect2) (send dc set-clipping-rect 50 -25 10 400)] - [(poly) (send dc set-clipping-region (mk-poly 'odd-even))] - [(circle) (send dc set-clipping-region (mk-circle))] - [(wedge) (let ([r (make-object region% dc)]) - (send r set-arc 0. 60. 180. 180. (* 1/4 pi) (* 3/4 pi)) - (send dc set-clipping-region r))] - [(lam) (let ([r (make-object region% dc)]) - (send r set-path lambda-path) - (send dc set-clipping-region r))] - [(rect+poly) (let ([r (mk-poly 'winding)]) - (send r union (mk-rect)) - (send dc set-clipping-region r))] - [(rect+circle) (let ([r (mk-circle)]) - (send r union (mk-rect)) - (send dc set-clipping-region r))] - [(poly-rect) (let ([r (mk-poly 'odd-even)]) - (send r subtract (mk-rect)) - (send dc set-clipping-region r))] - [(poly&rect) (let ([r (mk-poly 'odd-even)]) - (send r intersect (mk-rect)) - (send dc set-clipping-region r))] - [(poly^rect) (let ([r (mk-poly 'odd-even)]) - (send r xor (mk-rect)) - (send dc set-clipping-region r))] - [(roundrect) (let ([r (make-object region% dc)]) - (send r set-rounded-rectangle 80 200 125 40 -0.25) - (send dc set-clipping-region r))] - [(empty) (let ([r (make-object region% dc)]) - (send dc set-clipping-region r))] - [(polka) - (let ([c (send dc get-background)]) - (send dc set-background (send the-color-database find-color "PURPLE")) - (send dc clear) - (send dc set-background c)) - (let ([r (make-object region% dc)] - [w 30] - [s 10]) - (let xloop ([x 0]) - (if (> x 300) - (send dc set-clipping-region r) - (let yloop ([y 0]) - (if (> y 500) - (xloop (+ x w s)) - (let ([r2 (make-object region% dc)]) - (send r2 set-ellipse x y w w) - (send r union r2) - (yloop (+ y w s)))))))) - (send dc clear)]))) + (let ([clip-dc dc]) + (if clock-clip? + (let ([r (make-object region% clip-dc)]) + (send r set-arc 0. 60. 180. 180. clock-start clock-end) + (send dc set-clipping-region r)) + (let ([mk-poly (lambda (mode) + (let ([r (make-object region% clip-dc)]) + (send r set-polygon octagon 0 0 mode) r))] + [mk-circle (lambda () + (let ([r (make-object region% clip-dc)]) + (send r set-ellipse 0. 60. 180. 180.) r))] + [mk-rect (lambda () + (let ([r (make-object region% clip-dc)]) + (send r set-rectangle 100 -25 10 400) r))]) + (case clip + [(none) (void)] + [(rect) (send dc set-clipping-rect 100 -25 10 400)] + [(rect2) (send dc set-clipping-rect 50 -25 10 400)] + [(poly) (send dc set-clipping-region (mk-poly 'odd-even))] + [(circle) (send dc set-clipping-region (mk-circle))] + [(wedge) (let ([r (make-object region% clip-dc)]) + (send r set-arc 0. 60. 180. 180. (* 1/4 pi) (* 3/4 pi)) + (send dc set-clipping-region r))] + [(lam) (let ([r (make-object region% clip-dc)]) + (send r set-path lambda-path) + (send dc set-clipping-region r))] + [(rect+poly) (let ([r (mk-poly 'winding)]) + (send r union (mk-rect)) + (send dc set-clipping-region r))] + [(rect+circle) (let ([r (mk-circle)]) + (send r union (mk-rect)) + (send dc set-clipping-region r))] + [(poly-rect) (let ([r (mk-poly 'odd-even)]) + (send r subtract (mk-rect)) + (send dc set-clipping-region r))] + [(poly&rect) (let ([r (mk-poly 'odd-even)]) + (send r intersect (mk-rect)) + (send dc set-clipping-region r))] + [(poly^rect) (let ([r (mk-poly 'odd-even)]) + (send r xor (mk-rect)) + (send dc set-clipping-region r))] + [(roundrect) (let ([r (make-object region% clip-dc)]) + (send r set-rounded-rectangle 80 200 125 40 -0.25) + (send dc set-clipping-region r))] + [(empty) (let ([r (make-object region% clip-dc)]) + (send dc set-clipping-region r))] + [(polka) + (let ([c (send dc get-background)]) + (send dc set-background (send the-color-database find-color "PURPLE")) + (send dc clear) + (send dc set-background c)) + (let ([r (make-object region% clip-dc)] + [w 30] + [s 10]) + (let xloop ([x 0]) + (if (> x 300) + (send dc set-clipping-region r) + (let yloop ([y 0]) + (if (> y 500) + (xloop (+ x w s)) + (let ([r2 (make-object region% clip-dc)]) + (send r2 set-ellipse x y w w) + (send r union r2) + (yloop (+ y w s)))))))) + (send dc clear)])))) (when clip-pre-scale? (send dc set-scale xscale yscale) @@ -1131,6 +1132,13 @@ (send r2 xor r) (send dc set-clipping-region r2)) (send dc set-clipping-region #f)))) + + (unless clock-clip? + (let ([r (send dc get-clipping-region)]) + (when r + (when (send r get-dc) + (unless (eq? (send r is-empty?) (eq? clip 'empty)) + (show-error 'draw-text "region `is-empty?' mismatch")))))) ;; check default pen/brush: (send dc draw-rectangle 0 0 5 5)