fix region% problems
- 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
parent
b0a3025c48
commit
0fda70b7ca
|
|
@ -123,36 +123,43 @@
|
|||
(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)))))])
|
||||
|
|
@ -160,18 +167,29 @@
|
|||
(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]
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -1132,6 +1133,13 @@
|
|||
(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)
|
||||
(send dc draw-line 0 0 20 6)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user