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

mflatt

Browse Source 
original commit: 4d2876223ed5f8e4ab28c5b56795d464a879c2cd
This commit is contained in:
Robby Findler 1998-09-23 13:28:26 +00:00
parent e59299ddc8
commit 0024f4ee20
1 changed files with 16 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/tests/mred/draw.ss
View File

@ -377,7 +377,7 @@
(send b set-style 'opaque) (send b set-style 'opaque)
(send dc set-brush b) (send dc set-brush b)
; Second stipple (opaque) ; Second stipple (opaque)
(send dc draw-rectangle 120 205 30 30) (send dc draw-ellipse 120 205 30 30)
(send dc set-brush brushs) (send dc set-brush brushs)
(send b set-stipple bb) (send b set-stipple bb)
(send dc set-brush b) (send dc set-brush b)
@ -450,6 +450,9 @@
(let ([mk-poly (lambda () (let ([mk-poly (lambda ()
(let ([r (make-object region% dc)]) (let ([r (make-object region% dc)])
(send r set-polygon octagon) r))] (send r set-polygon octagon) r))]
[mk-circle (lambda ()
(let ([r (make-object region% dc)])
(send r set-ellipse 0. 60. 180. 180.) r))]
[mk-rect (lambda () [mk-rect (lambda ()
(let ([r (make-object region% dc)]) (let ([r (make-object region% dc)])
(send r set-rectangle 100 -25 10 400) r))]) (send r set-rectangle 100 -25 10 400) r))])
@ -457,9 +460,13 @@
[(none) (void)] [(none) (void)]
[(rect) (send dc set-clipping-rect 100 -25 10 400)] [(rect) (send dc set-clipping-rect 100 -25 10 400)]
[(poly) (send dc set-clipping-region (mk-poly))] [(poly) (send dc set-clipping-region (mk-poly))]
[(circle) (send dc set-clipping-region (mk-circle))]
[(rect+poly) (let ([r (mk-poly)]) [(rect+poly) (let ([r (mk-poly)])
(send r union (mk-rect)) (send r union (mk-rect))
(send dc set-clipping-region r))] (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)]) [(poly-rect) (let ([r (mk-poly)])
(send r subtract (mk-rect)) (send r subtract (mk-rect))
(send dc set-clipping-region r))] (send dc set-clipping-region r))]
@ -486,8 +493,8 @@
(unless (equal? l (unless (equal? l
(case clip (case clip
[(rect) '(100. -25. 10. 400.)] [(rect) '(100. -25. 10. 400.)]
[(poly poly-rect) '(0. 60. 180. 180.)] [(poly circle poly-rect) '(0. 60. 180. 180.)]
[(rect+poly) '(0. -25. 180. 400.)] [(rect+poly rect+circle) '(0. -25. 180. 400.)]
[(poly&rect) '(100. 60. 10. 180.)])) [(poly&rect) '(100. 60. 10. 180.)]))
(error 'draw-test "clipping region changed badly: ~a" l))))) (error 'draw-test "clipping region changed badly: ~a" l)))))
@ -539,17 +546,14 @@
(send canvas set-stipples (send self get-value)))) (send canvas set-stipples (send self get-value))))
set-value #t) set-value #t)
(make-object choice% "Clip" (make-object choice% "Clip"
'("None" "Rectangle" "Octagon" '("None" "Rectangle" "Octagon" "Circle"
"Rectangle + Octagon" "Octagon - Rectangle" "Rectangle & Octagon") "Rectangle + Octagon" "Rectangle + Circle"
"Octagon - Rectangle" "Rectangle & Octagon")
hp3 hp3
(lambda (self event) (lambda (self event)
(set! clip (case (send self get-selection) (set! clip (list-ref
[(0) 'none] '(none rect poly circle rect+poly rect+circle poly-rect poly&rect)
[(1) 'rect] (send self get-selection)))
[(2) 'poly]
[(3) 'rect+poly]
[(4) 'poly-rect]
[(5) 'poly&rect]))
(send canvas on-paint)))) (send canvas on-paint))))
(send f show #t)) (send f show #t))