suzanne.soy/gui
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)

original commit: 0fda70b7ca4a833d1ac347e711e717af1c0fefc6
This commit is contained in:
Matthew Flatt 2011-03-28 15:15:57 -06:00
parent 50b854a332
commit 576d4d60f6
1 changed files with 72 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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)