suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix region% problems

Browse Source 
- fail gracefully with pre 1.4 Cairo
 - clip all drawing for an empty clipping region
 - disallow `is-empty?' on a region without a DC
   (since the test depends on the DC dimensions)
This commit is contained in:
Matthew Flatt 2011-03-28 15:15:57 -06:00
parent b0a3025c48
commit 0fda70b7ca
4 changed files with 126 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
collects/racket/draw/private/region.rkt
View File

@ -123,36 +123,43 @@
(cairo_identity_matrix cr) (cairo_identity_matrix cr)
(init-matrix cr) (init-matrix cr)
(cairo_transform cr (make-cairo_matrix_t 1 0 0 1 scroll-dx scroll-dy))) (cairo_transform cr (make-cairo_matrix_t 1 0 0 1 scroll-dx scroll-dy)))
(for/fold ([v init]) ([pr (in-list paths)]) (if (null? paths)
(cairo_new_path cr) (begin
(send (car pr) do-path cr values values) (cairo_new_path cr)
(cairo_set_fill_rule cr (install cr init))
(case (cdr pr) (for/fold ([v init]) ([pr (in-list paths)])
[(odd-even) CAIRO_FILL_RULE_EVEN_ODD] (cairo_new_path cr)
[(winding) CAIRO_FILL_RULE_WINDING] (send (car pr) do-path cr values values)
[else default-fill-rule])) (cairo_set_fill_rule cr
(install cr v)) (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)))) (when old-matrix (cairo_set_matrix cr old-matrix))))
(def/public (is-empty?) (def/public (is-empty?)
(really-is-empty?)) (really-is-empty?))
(define/private (with-clipping proc) (define/private (with-clipping who proc)
(send (unless dc
dc (raise-mismatch-error (method-name 'region% who)
in-cairo-context "not allowed for a region without a drawing context: "
(lambda (cr) this))
(cairo_save cr) (send dc in-cairo-context
(install-region cr 0 0 values values) (lambda (cr)
(begin0 (cairo_save cr)
(proc cr) (install-region cr 0 0 values values)
(cairo_restore cr))))) (begin0
(proc cr)
(cairo_restore cr)))))
(define/private (really-is-empty?) (define/private (really-is-empty?)
(or (null? paths) (or (null? paths)
(if empty-known? (if empty-known?
known-empty? known-empty?
(let ([v (with-clipping (let ([v (with-clipping
'is-empty?
(lambda (cr) (lambda (cr)
(let-values ([(x1 y1 x2 y2) (cairo_clip_extents cr)]) (let-values ([(x1 y1 x2 y2) (cairo_clip_extents cr)])
(or (= x1 x2) (= y1 y2)))))]) (or (= x1 x2) (= y1 y2)))))])
@ -160,18 +167,29 @@
(set! empty-known? #t) (set! empty-known? #t)
v)))) v))))
(def/public (in-region? [real? x] (define/private (with-temp-cr proc)
[real? y])
(let ([cr (call-as-atomic (let ([cr (call-as-atomic
(lambda () (lambda ()
(cond (cond
[temp-cr [temp-cr
(begin0 temp-cr (set! temp-cr #f))] (begin0 temp-cr (set! temp-cr #f))]
[else [else
(let ([s (cairo_image_surface_create CAIRO_FORMAT_A8 1 1)]) (let ([s (cairo_image_surface_create CAIRO_FORMAT_A8 100 100)])
(begin0 (begin0
(cairo_create s) (cairo_create s)
(cairo_surface_destroy 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) (let-values ([(x y)
(if matrix (if matrix
;; need to use the DC's current transformation ;; need to use the DC's current transformation
@ -184,12 +202,7 @@
(vector-ref m 5)))) (vector-ref m 5))))
;; no transformation needed ;; no transformation needed
(values x y))]) (values x y))])
(begin0 (install-region cr #t values values (lambda (cr v) (and v (cairo_in_fill cr x y))))))))
(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)]))))))
(def/public (set-arc [real? x] (def/public (set-arc [real? x]
[real? y] [real? y]

10
collects/racket/draw/unsafe/cairo.rkt
View File

@ -127,7 +127,15 @@
(x2 : (_ptr o _double)) (x2 : (_ptr o _double))
(y2 : (_ptr o _double)) (y2 : (_ptr o _double))
-> _void -> _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 ;; Transforms
(define-cairo cairo_translate (_fun _cairo_t _double* _double* -> _void)) (define-cairo cairo_translate (_fun _cairo_t _double* _double* -> _void))

4
collects/scribblings/draw/region-class.scrbl
View File

@ -90,7 +90,9 @@ An intersect corresponds to clipping with this region's path, and then
boolean?]{ boolean?]{
Returns @scheme[#t] if the region is approximately empty, @scheme[#f] 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.
} }

136
collects/tests/gracket/draw.rkt
View File

@ -1053,70 +1053,71 @@
;(send dc set-clipping-region #f) ;(send dc set-clipping-region #f)
(send dc clear) (send dc clear)
(if clock-clip? (let ([clip-dc dc])
(let ([r (make-object region% dc)]) (if clock-clip?
(send r set-arc 0. 60. 180. 180. clock-start clock-end) (let ([r (make-object region% clip-dc)])
(send dc set-clipping-region r)) (send r set-arc 0. 60. 180. 180. clock-start clock-end)
(let ([mk-poly (lambda (mode) (send dc set-clipping-region r))
(let ([r (make-object region% dc)]) (let ([mk-poly (lambda (mode)
(send r set-polygon octagon 0 0 mode) r))] (let ([r (make-object region% clip-dc)])
[mk-circle (lambda () (send r set-polygon octagon 0 0 mode) r))]
(let ([r (make-object region% dc)]) [mk-circle (lambda ()
(send r set-ellipse 0. 60. 180. 180.) r))] (let ([r (make-object region% clip-dc)])
[mk-rect (lambda () (send r set-ellipse 0. 60. 180. 180.) r))]
(let ([r (make-object region% dc)]) [mk-rect (lambda ()
(send r set-rectangle 100 -25 10 400) r))]) (let ([r (make-object region% clip-dc)])
(case clip (send r set-rectangle 100 -25 10 400) r))])
[(none) (void)] (case clip
[(rect) (send dc set-clipping-rect 100 -25 10 400)] [(none) (void)]
[(rect2) (send dc set-clipping-rect 50 -25 10 400)] [(rect) (send dc set-clipping-rect 100 -25 10 400)]
[(poly) (send dc set-clipping-region (mk-poly 'odd-even))] [(rect2) (send dc set-clipping-rect 50 -25 10 400)]
[(circle) (send dc set-clipping-region (mk-circle))] [(poly) (send dc set-clipping-region (mk-poly 'odd-even))]
[(wedge) (let ([r (make-object region% dc)]) [(circle) (send dc set-clipping-region (mk-circle))]
(send r set-arc 0. 60. 180. 180. (* 1/4 pi) (* 3/4 pi)) [(wedge) (let ([r (make-object region% clip-dc)])
(send dc set-clipping-region r))] (send r set-arc 0. 60. 180. 180. (* 1/4 pi) (* 3/4 pi))
[(lam) (let ([r (make-object region% dc)]) (send dc set-clipping-region r))]
(send r set-path lambda-path) [(lam) (let ([r (make-object region% clip-dc)])
(send dc set-clipping-region r))] (send r set-path lambda-path)
[(rect+poly) (let ([r (mk-poly 'winding)]) (send dc set-clipping-region r))]
(send r union (mk-rect)) [(rect+poly) (let ([r (mk-poly 'winding)])
(send dc set-clipping-region r))] (send r union (mk-rect))
[(rect+circle) (let ([r (mk-circle)]) (send dc set-clipping-region r))]
(send r union (mk-rect)) [(rect+circle) (let ([r (mk-circle)])
(send dc set-clipping-region r))] (send r union (mk-rect))
[(poly-rect) (let ([r (mk-poly 'odd-even)]) (send dc set-clipping-region r))]
(send r subtract (mk-rect)) [(poly-rect) (let ([r (mk-poly 'odd-even)])
(send dc set-clipping-region r))] (send r subtract (mk-rect))
[(poly&rect) (let ([r (mk-poly 'odd-even)]) (send dc set-clipping-region r))]
(send r intersect (mk-rect)) [(poly&rect) (let ([r (mk-poly 'odd-even)])
(send dc set-clipping-region r))] (send r intersect (mk-rect))
[(poly^rect) (let ([r (mk-poly 'odd-even)]) (send dc set-clipping-region r))]
(send r xor (mk-rect)) [(poly^rect) (let ([r (mk-poly 'odd-even)])
(send dc set-clipping-region r))] (send r xor (mk-rect))
[(roundrect) (let ([r (make-object region% dc)]) (send dc set-clipping-region r))]
(send r set-rounded-rectangle 80 200 125 40 -0.25) [(roundrect) (let ([r (make-object region% clip-dc)])
(send dc set-clipping-region r))] (send r set-rounded-rectangle 80 200 125 40 -0.25)
[(empty) (let ([r (make-object region% dc)]) (send dc set-clipping-region r))]
(send dc set-clipping-region r))] [(empty) (let ([r (make-object region% clip-dc)])
[(polka) (send dc set-clipping-region r))]
(let ([c (send dc get-background)]) [(polka)
(send dc set-background (send the-color-database find-color "PURPLE")) (let ([c (send dc get-background)])
(send dc clear) (send dc set-background (send the-color-database find-color "PURPLE"))
(send dc set-background c)) (send dc clear)
(let ([r (make-object region% dc)] (send dc set-background c))
[w 30] (let ([r (make-object region% clip-dc)]
[s 10]) [w 30]
(let xloop ([x 0]) [s 10])
(if (> x 300) (let xloop ([x 0])
(send dc set-clipping-region r) (if (> x 300)
(let yloop ([y 0]) (send dc set-clipping-region r)
(if (> y 500) (let yloop ([y 0])
(xloop (+ x w s)) (if (> y 500)
(let ([r2 (make-object region% dc)]) (xloop (+ x w s))
(send r2 set-ellipse x y w w) (let ([r2 (make-object region% clip-dc)])
(send r union r2) (send r2 set-ellipse x y w w)
(yloop (+ y w s)))))))) (send r union r2)
(send dc clear)]))) (yloop (+ y w s))))))))
(send dc clear)]))))
(when clip-pre-scale? (when clip-pre-scale?
(send dc set-scale xscale yscale) (send dc set-scale xscale yscale)
@ -1132,6 +1133,13 @@
(send dc set-clipping-region r2)) (send dc set-clipping-region r2))
(send dc set-clipping-region #f)))) (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: ;; check default pen/brush:
(send dc draw-rectangle 0 0 5 5) (send dc draw-rectangle 0 0 5 5)
(send dc draw-line 0 0 20 6) (send dc draw-line 0 0 20 6)