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

.

Browse Source 
original commit: 4d4c429517b9aa63a3315e246c26b7b6dfc44dce
This commit is contained in:
Matthew Flatt 1998-09-23 00:15:05 +00:00
parent ac2dd91a78
commit 6d700d6c8a
1 changed files with 55 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -23,11 +23,25 @@
(send c set-editor e) (send c set-editor e)
(send f show #t))) (send f show #t)))
(define pi (atan 0 -1))
(define octagon
(list (make-object point% 60 60)
(make-object point% 120 60)
(make-object point% 180 120)
(make-object point% 180 180)
(make-object point% 120 240)
(make-object point% 60 240)
(make-object point% 0 180)
(make-object point% 0 120)
(make-object point% 60 60)))
(let* ([f (make-object frame% "Graphics Test" #f 300 450)] (let* ([f (make-object frame% "Graphics Test" #f 300 450)]
[vp (make-object vertical-panel% f)] [vp (make-object vertical-panel% f)]
[hp0 (make-object horizontal-panel% vp)] [hp0 (make-object horizontal-panel% vp)]
[hp (make-object horizontal-panel% vp)] [hp (make-object horizontal-panel% vp)]
[hp2 hp] [hp2 hp]
[hp3 (make-object horizontal-pane% vp)]
[bb (make-object bitmap% (sys-path "bb.gif") 'gif)] [bb (make-object bitmap% (sys-path "bb.gif") 'gif)]
[return (let ([bm (make-object bitmap% (sys-path "return.xbm") 'xbm)] [return (let ([bm (make-object bitmap% (sys-path "return.xbm") 'xbm)]
[dc (make-object bitmap-dc%)]) [dc (make-object bitmap-dc%)])
@ -38,9 +52,10 @@
[use-bitmap? #f] [use-bitmap? #f]
[depth-one? #f] [depth-one? #f]
[cyan? #f] [cyan? #f]
[clip? #f]) [clip 'none])
(send hp0 stretchable-height #f) (send hp0 stretchable-height #f)
(send hp stretchable-height #f) (send hp stretchable-height #f)
(send hp3 stretchable-height #f)
(make-object button% "What Should I See?" hp0 (make-object button% "What Should I See?" hp0
(lambda (b e) (lambda (b e)
(show-instructions (local-path "draw-info.txt")))) (show-instructions (local-path "draw-info.txt"))))
@ -241,20 +256,25 @@
(send dc set-brush brusht) (send dc set-brush brusht)
(send dc draw-arc (send dc draw-arc
(+ x 20) (+ y 135) (+ x 5) (+ y 135)
(+ x 5) (+ y 150) 30 40
(+ x 20) (+ y 150)) 0 (/ pi 2))
(send dc draw-arc (send dc draw-arc
(+ x 35) (+ y 150) (+ x 5) (+ y 135)
(+ x 20) (+ y 135) 30 40
(+ x 20) (+ y 150)) (/ pi 2) pi)
(send dc set-brush brushs) (send dc set-brush brushs)
(send dc draw-arc (send dc draw-arc
(+ x 60) (+ y 135) (+ x 45) (+ y 135)
(+ x 36) (+ y 150) 30 40
(+ x 60) (+ y 150)) (/ pi 2) pi)
(send dc set-brush brusht) (send dc set-brush brusht)
(when last?
(send dc set-pen pen0s)
(send dc draw-polygon octagon))
(when last? (when last?
; Splines ; Splines
(define op (send dc get-pen)) (define op (send dc get-pen))
@ -412,11 +432,15 @@
(send the-color-database find-color "CYAN") (send the-color-database find-color "CYAN")
(send the-color-database find-color "WHITE"))) (send the-color-database find-color "WHITE")))
(send dc destroy-clipping-region) (send dc set-clipping-region #f)
(send dc clear) (send dc clear)
(when clip? (case clip
(send dc set-clipping-region 100 -25 10 400)) [(none) (void)]
[(rect) (send dc set-clipping-rect 100 -25 10 400)]
[(poly) (let ([r (make-object region% dc)])
(send r set-polygon octagon)
(send dc set-clipping-region r))])
; check default pen/brush: ; check default pen/brush:
(send dc draw-rectangle 0 0 5 5) (send dc draw-rectangle 0 0 5 5)
@ -428,16 +452,16 @@
(draw-series dc pen2s pen2t "2 x 2" 135 0 2 #t) (draw-series dc pen2s pen2t "2 x 2" 135 0 2 #t)
(let ([x (box 0)] (let ([r (send dc get-clipping-region)])
[y (box 0)] (if (eq? clip 'none)
[w (box 0)] (when r
[h (box 0)]) (error 'draw-test "shouldn't have been a clipping region"))
(send dc get-clipping-region x y w h) (let*-values ([(x y w h) (send r get-bounding-box)]
(unless (equal? (map unbox (list x y w h)) [(l) (list x y w h)])
(if clip? (unless (equal? l (case clip
'(100. -25. 10. 400.) [(rect) '(100. -25. 10. 400.)]
'(0. 0. -1. -1.))) [(poly) '(0. 60. 180. 180.)]))
(error 'draw-test "clipping region changed badly: ~a" (list x y w h)))) (error 'draw-test "clipping region changed badly: ~a" l)))))
(let ([w (box 0)] (let ([w (box 0)]
[h (box 0)]) [h (box 0)])
@ -474,10 +498,6 @@
(make-object check-box% "+10" hp (make-object check-box% "+10" hp
(lambda (self event) (lambda (self event)
(send canvas set-offset (if (send self get-value) 10 0)))) (send canvas set-offset (if (send self get-value) 10 0))))
(make-object check-box% "Clip" hp
(lambda (self event)
(set! clip? (send self get-value))
(send canvas on-paint)))
(make-object check-box% "Cyan" hp (make-object check-box% "Cyan" hp
(lambda (self event) (lambda (self event)
(set! cyan? (send self get-value)) (set! cyan? (send self get-value))
@ -489,8 +509,14 @@
(send (make-object check-box% "Stipples" hp2 (send (make-object check-box% "Stipples" hp2
(lambda (self event) (lambda (self event)
(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" '("None" "Rectangle" "Octagon") hp3
(lambda (self event)
(set! clip (case (send self get-selection)
[(0) 'none]
[(1) 'rect]
[(2) 'poly]))
(send canvas on-paint))))
(send f show #t)) (send f show #t))
; Canvas, Pixmaps, and Bitmaps: ; Canvas, Pixmaps, and Bitmaps: