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

.

Browse Source 
original commit: cb9c8cae3248e58df8aad25608630baa0b722452
This commit is contained in:
Matthew Flatt 1998-08-01 23:20:49 +00:00
parent ef16decaba
commit a0f33f05a7
2 changed files with 57 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/tests/mred/draw-info.txt
View File

@ -19,9 +19,11 @@ The drawing area should have the following features:
A little bit of a black line should appear before "Pen 2 x 2",
but the yellow background should have covered up the line
At the far right, a black and red pair of splines should form
a squashed "S", twice as wide as high. The "S" is formed
by two splines.
To the right of the Pen text, a black and red pair of splines should
form a squashed "S", twice as wide as high. The "S" is formed by
two splines.
To the far right should be three columns of boxes...
The drawings under 0x0 and 1x1 should look nearly the same:
TopLeft: h-line should be left-aligned with box below it,
@ -45,9 +47,11 @@ The drawing area should have the following features:
Arcs: The leftmost should be the top half of a circle (it's
form via two arcs); the rightmost should be a filled
wedge from 90 degrees to 180 degress
Bottom section:
Images: MrEd logo (b & w)
BB logo (color)
Down-left arrow (b & w)
Down-left arrow with a thin horizontal line (b & w)
Down-left arrow - B & W, *not* red
Down-left arrow - red with white background
BB logo, possibly reddened
@ -60,12 +64,10 @@ The drawing area should have the following features:
Black and white stippled arrow
[Click "cyan" => replace "white" with "cyan"]
BB stippled
Green cross-hatch on {white,cyan}/blue
Outside of blue box:
Green cross-hatch on {white,cyan}
Black cross-hatch on {white,cyan}
Green cross-hatch on {white,cyan}
Dashed lines: each half green, half black:
Dashed lines: each half green, half black, first
with a {white,cyan} background, then a red background:
Solid line
Dot line
Long Dash line

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

@ -67,7 +67,7 @@
(make-object wx:memory-dc%)
#f)]
[bm (if use-bitmap?
(make-object wx:bitmap% (* scale 300) (* scale 300)
(make-object wx:bitmap% (* scale 350) (* scale 300)
(if depth-one? 1 -1))
#f)]
[draw-series
@ -263,8 +263,37 @@
(draw-ess 0 0)
(send dc set-pen (make-object wx:pen% "RED" 0 wx:const-solid))
(draw-ess -2 2)
; Brush patterns:
(let ([pat-list (list wx:const-bdiagonal-hatch
wx:const-crossdiag-hatch
wx:const-fdiagonal-hatch
wx:const-cross-hatch
wx:const-horizontal-hatch
wx:const-vertical-hatch)]
[b (make-object wx:brush% "BLACK" wx:const-solid)]
[ob (send dc get-brush)]
[obg (send dc get-background)]
[blue (make-object wx:brush% "BLUE" wx:const-solid)])
(let loop ([x 245][y 10][l pat-list])
(unless (null? l)
(send b set-colour "BLACK")
(send b set-style (car l))
(send dc set-brush b)
(send dc draw-rectangle x y 20 20)
(send dc set-brush ob)
(send b set-colour "GREEN")
(send dc set-brush b)
(send dc draw-rectangle (+ x 25) y 20 20)
(send dc set-background blue)
(send dc draw-rectangle (+ x 50) y 20 20)
(send dc set-background obg)
(send dc set-brush ob)
(loop x (+ y 25) (cdr l)))))
(send dc set-pen op))
(when (and (not no-bitmaps?) last?)
(let ([x 5] [y 165])
(send dc draw-icon
@ -320,37 +349,38 @@
(send b set-stipple null)
(send b set-style wx:const-cross-hatch)
(send dc set-brush b)
; Green cross hatch on blue (white BG)
; Green cross hatch (white BG) on blue field
(send dc draw-rectangle 180 205 20 20)
; Green cross hatch on while
(send dc draw-rectangle 210 205 20 20)
(send dc set-brush brushs)
(send b set-colour "BLACK")
(send dc set-brush b)
; Black cross hatch
(send dc draw-rectangle 235 205 20 20)
(send dc set-brush brushs))))
(let ([styles (list wx:const-solid
wx:const-dot
wx:const-long-dash
wx:const-short-dash
wx:const-dot-dash)])
wx:const-dot-dash)]
[obg (send dc get-background)]
[red (make-object wx:brush% "RED" wx:const-solid)])
(let loop ([s styles][y 250])
(unless (null? s)
(let ([p (make-object wx:pen% "GREEN" flevel (car s))])
(send dc set-pen p)
(send dc draw-line (+ x 5) y (+ x 30) y)
(send dc set-background red)
(send dc draw-line (+ x 5) (+ 4 y) (+ x 30) (+ y 4))
(send dc set-background obg)
(send pens set-style (car s))
(send dc set-pen pens)
(send dc draw-line (+ x 30) y (+ x 55) y)
(send dc set-background red)
(send dc draw-line (+ x 30) (+ y 4) (+ x 55) (+ y 4))
(send dc set-background obg)
(send dc set-pen pent)
(send pens set-style wx:const-solid)
(loop (cdr s) (+ y 5 ))))))
(loop (cdr s) (+ y 8))))))
(if (not (or ps? (eq? dc can-dc)))
(send can-dc blit 0 0
(* scale 300) (* scale 300)
(* scale 350) (* scale 300)
mem-dc 0 0 wx:const-copy)))
'done)])
@ -412,7 +442,7 @@
[h (unbox h)])
(unless (cond
[ps? #t]
[use-bitmap? (and (= w (* scale 300)) (= h (* scale 300)))]
[use-bitmap? (and (= w (* scale 350)) (= h (* scale 300)))]
[else (= w (send this get-width)) (= h (send this get-height))])
(error "wrong size reported by get-size: ~a ~a" w h))))
@ -430,6 +460,9 @@
-1 -1 -1 -1
'("Canvas" "Pixmap" "Bitmap")
0 wx:const-horizontal)
(make-object mred:button% hp0
(lambda (self event) (send vp change-children (lambda (l) (list canvas))))
"Hide")
(make-object mred:button% hp
(lambda (self event)
(send canvas on-paint #t))