You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
347 lines
10 KiB
Scheme
347 lines
10 KiB
Scheme
27 years ago
|
|
||
|
|
(define sys-path
|
||
|
|
(lambda (f)
|
||
|
|
(build-path (collection-path "icons") f)))
|
||
|
|
|
||
|
|
(let* ([f (make-object mred:frame% ()
|
||
|
|
"Graphics Test"
|
||
|
|
-1 -1 300 350)]
|
||
|
|
[vp (make-object mred:vertical-panel% f)]
|
||
|
|
[hp0 (make-object mred:horizontal-panel% vp)]
|
||
|
|
[hp (make-object mred:horizontal-panel% vp)]
|
||
|
|
[hp2 (make-object mred:horizontal-panel% vp)]
|
||
|
|
[bb (make-object wx:bitmap% (sys-path "bb.gif")
|
||
|
|
wx:const-bitmap-type-gif)]
|
||
|
|
[return (make-object wx:bitmap% (sys-path "return.xbm")
|
||
|
|
wx:const-bitmap-type-xbm)]
|
||
|
|
[tmp-mdc (make-object wx:memory-dc%)]
|
||
|
|
[use-bitmap? #f]
|
||
|
|
[depth-one? #f])
|
||
|
|
(send hp0 stretchable-in-y #f)
|
||
|
|
(send hp stretchable-in-y #f)
|
||
|
|
(send hp2 stretchable-in-y #f)
|
||
|
|
(let ([canvas
|
||
|
|
(make-object
|
||
|
|
(make-class mred:canvas%
|
||
|
|
(inherit get-dc)
|
||
|
|
(public
|
||
|
|
[no-bitmaps? #f]
|
||
|
|
[set-bitmaps (lambda (on?) (set! no-bitmaps? (not on?)) (on-paint))]
|
||
|
|
[no-stipples? #f]
|
||
|
|
[set-stipples (lambda (on?) (set! no-stipples? (not on?)) (on-paint))]
|
||
|
|
[scale 1]
|
||
|
|
[set-scale (lambda (s) (set! scale s) (on-paint))]
|
||
|
|
[offset 0]
|
||
|
|
[set-offset (lambda (o) (set! offset o) (on-paint))]
|
||
|
|
[on-paint
|
||
|
|
(case-lambda
|
||
|
|
[() (on-paint #f)]
|
||
|
|
[(ps?)
|
||
|
|
(let* ([can-dc (get-dc)]
|
||
|
|
[pen0s (make-object wx:pen% "BLACK" 0 wx:const-solid)]
|
||
|
|
[pen1s (make-object wx:pen% "BLACK" 1 wx:const-solid)]
|
||
|
|
[pen2s (make-object wx:pen% "BLACK" 2 wx:const-solid)]
|
||
|
|
[pen0t (make-object wx:pen% "BLACK" 0 wx:const-transparent)]
|
||
|
|
[pen1t (make-object wx:pen% "BLACK" 1 wx:const-transparent)]
|
||
|
|
[pen2t (make-object wx:pen% "BLACK" 2 wx:const-transparent)]
|
||
|
|
[brushs (make-object wx:brush% "BLACK" wx:const-solid)]
|
||
|
|
[brusht (make-object wx:brush% "BLACK" wx:const-transparent)]
|
||
|
|
[penr (make-object wx:pen% "RED" 1 wx:const-solid)]
|
||
|
|
[brushb (make-object wx:brush% "BLUE" wx:const-solid)]
|
||
|
|
[mem-dc (if use-bitmap?
|
||
|
|
(make-object wx:memory-dc%)
|
||
|
|
#f)]
|
||
|
|
[bm (if use-bitmap?
|
||
|
|
(make-object wx:bitmap% (* scale 300) (* scale 300)
|
||
|
|
(if depth-one? 1 -1))
|
||
|
|
#f)]
|
||
|
|
[draw-series
|
||
|
|
(lambda (dc pens pent size x y flevel last?)
|
||
|
|
(let* ([ofont (send dc get-font)])
|
||
|
|
(if (positive? flevel)
|
||
|
|
(send dc set-font
|
||
|
|
(make-object wx:font%
|
||
|
|
10 wx:const-decorative
|
||
|
|
wx:const-normal
|
||
|
|
(if (> flevel 1)
|
||
|
|
wx:const-bold
|
||
|
|
wx:const-normal)
|
||
|
|
#t)))
|
||
|
|
|
||
|
|
(send dc set-pen pens)
|
||
|
|
(send dc set-brush brusht)
|
||
|
|
|
||
|
|
; Test should overlay this line:
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 3) (+ y 12)
|
||
|
|
(+ x 40) (+ y 12))
|
||
|
|
|
||
|
|
(send dc draw-text (string-append size " Pen")
|
||
|
|
(+ x 5) (+ y 8))
|
||
|
|
(send dc set-font ofont)
|
||
|
|
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 5) (+ y 27) (+ x 10) (+ 27 y))
|
||
|
|
(send dc draw-rectangle
|
||
|
|
(+ x 5) (+ y 30) 5 5)
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 12) (+ y 30) (+ x 12) (+ y 35))
|
||
|
|
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 5) (+ y 40) (+ x 10) (+ 40 y))
|
||
|
|
(send dc draw-rectangle
|
||
|
|
(+ x 5) (+ y 41) 5 5)
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 10) (+ y 41) (+ x 10) (+ 46 y))
|
||
|
|
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 15) (+ y 25) (+ x 20) (+ 25 y))
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 20) (+ y 30) (+ x 20) (+ 25 y))
|
||
|
|
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 30) (+ y 25) (+ x 25) (+ 25 y))
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 25) (+ y 30) (+ x 25) (+ 25 y))
|
||
|
|
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 35) (+ y 30) (+ x 40) (+ 30 y))
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 40) (+ y 25) (+ x 40) (+ 30 y))
|
||
|
|
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 50) (+ y 30) (+ x 45) (+ 30 y))
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 45) (+ y 25) (+ x 45) (+ 30 y))
|
||
|
|
|
||
|
|
; Check line thickness with "X"
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 20) (+ y 45) (+ x 40) (+ 39 y))
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 20) (+ y 39) (+ x 40) (+ 45 y))
|
||
|
|
|
||
|
|
(send dc draw-rectangle
|
||
|
|
(+ x 5) (+ y 50) 10 10)
|
||
|
|
(send dc draw-rounded-rectangle
|
||
|
|
(+ x 5) (+ y 65) 10 10 3)
|
||
|
|
(send dc draw-ellipse
|
||
|
|
(+ x 5) (+ y 80) 10 10)
|
||
|
|
|
||
|
|
(send dc set-brush brushs)
|
||
|
|
(send dc draw-rectangle
|
||
|
|
(+ x 17) (+ y 50) 10 10)
|
||
|
|
(send dc draw-rounded-rectangle
|
||
|
|
(+ x 17) (+ y 65) 10 10 3)
|
||
|
|
(send dc draw-ellipse
|
||
|
|
(+ x 17) (+ y 80) 10 10)
|
||
|
|
|
||
|
|
(send dc set-pen pent)
|
||
|
|
(send dc draw-rectangle
|
||
|
|
(+ x 29) (+ y 50) 10 10)
|
||
|
|
(send dc draw-rounded-rectangle
|
||
|
|
(+ x 29) (+ y 65) 10 10 3)
|
||
|
|
(send dc draw-ellipse
|
||
|
|
(+ x 29) (+ y 80) 10 10)
|
||
|
|
|
||
|
|
|
||
|
|
(send dc set-pen pens)
|
||
|
|
(send dc draw-rectangle
|
||
|
|
(+ x 17) (+ y 95) 10 10)
|
||
|
|
(send dc set-logical-function wx:const-clear)
|
||
|
|
(send dc draw-rectangle
|
||
|
|
(+ x 18) (+ y 96) 8 8)
|
||
|
|
(send dc set-logical-function wx:const-copy)
|
||
|
|
|
||
|
|
(send dc draw-rectangle
|
||
|
|
(+ x 29) (+ y 95) 10 10)
|
||
|
|
(send dc set-logical-function wx:const-clear)
|
||
|
|
(send dc set-pen pent)
|
||
|
|
(send dc draw-rectangle
|
||
|
|
(+ x 30) (+ y 96) 8 8)
|
||
|
|
|
||
|
|
(send dc set-pen pens)
|
||
|
|
(send dc draw-rectangle
|
||
|
|
(+ x 5) (+ y 95) 10 10)
|
||
|
|
(send dc set-logical-function wx:const-xor)
|
||
|
|
(send dc draw-rectangle
|
||
|
|
(+ x 5) (+ y 95) 10 10)
|
||
|
|
(send dc set-logical-function wx:const-copy)
|
||
|
|
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 5) (+ y 110) (+ x 8) (+ y 110))
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 8) (+ y 110) (+ x 11) (+ y 113))
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 11) (+ y 113) (+ x 11) (+ y 116))
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 11) (+ y 116) (+ x 8) (+ y 119))
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 8) (+ y 119) (+ x 5) (+ y 119))
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 5) (+ y 119) (+ x 2) (+ y 116))
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 2) (+ y 116) (+ x 2) (+ y 113))
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 2) (+ y 113) (+ x 5) (+ y 110))
|
||
|
|
|
||
|
|
(send dc draw-lines
|
||
|
|
(list
|
||
|
|
(make-object wx:point% 5 95)
|
||
|
|
(make-object wx:point% 8 95)
|
||
|
|
(make-object wx:point% 11 98)
|
||
|
|
(make-object wx:point% 11 101)
|
||
|
|
(make-object wx:point% 8 104)
|
||
|
|
(make-object wx:point% 5 104)
|
||
|
|
(make-object wx:point% 2 101)
|
||
|
|
(make-object wx:point% 2 98)
|
||
|
|
(make-object wx:point% 5 95))
|
||
|
|
(+ x 12) (+ y 15))
|
||
|
|
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 5) (+ y 125) (+ x 10) (+ y 125))
|
||
|
|
(send dc draw-line
|
||
|
|
(+ x 11) (+ y 125) (+ x 16) (+ y 125))
|
||
|
|
|
||
|
|
(send dc set-brush brusht)
|
||
|
|
(send dc draw-arc
|
||
|
|
(+ x 20) (+ y 135)
|
||
|
|
(+ x 5) (+ y 150)
|
||
|
|
(+ x 20) (+ y 150))
|
||
|
|
(send dc draw-arc
|
||
|
|
(+ x 35) (+ y 150)
|
||
|
|
(+ x 20) (+ y 135)
|
||
|
|
(+ x 20) (+ y 150))
|
||
|
|
(send dc set-brush brushs)
|
||
|
|
(send dc draw-arc
|
||
|
|
(+ x 60) (+ y 135)
|
||
|
|
(+ x 36) (+ y 150)
|
||
|
|
(+ x 60) (+ y 150))
|
||
|
|
(send dc set-brush brusht)
|
||
|
|
|
||
|
|
(unless (or no-bitmaps? (not last?))
|
||
|
|
(let ([x 5] [y 165])
|
||
|
|
(send dc draw-icon
|
||
|
|
(mred:get-icon) x y)
|
||
|
|
(set! x (+ x (send (mred:get-icon) get-width)))
|
||
|
|
(let ([do-one
|
||
|
|
(lambda (bm mode)
|
||
|
|
(if (send bm ok?)
|
||
|
|
(begin
|
||
|
|
(send tmp-mdc select-object bm)
|
||
|
|
(let ([h (send bm get-height)]
|
||
|
|
[w (send bm get-width)])
|
||
|
|
(send dc blit x y
|
||
|
|
w h
|
||
|
|
tmp-mdc 0 0
|
||
|
|
mode)
|
||
|
|
(set! x (+ x w 10)))
|
||
|
|
(send tmp-mdc select-object null))
|
||
|
|
(printf "bad bitmap~n")))])
|
||
|
|
(do-one bb wx:const-copy)
|
||
|
|
(do-one return wx:const-copy)
|
||
|
|
(send dc set-pen penr)
|
||
|
|
(do-one return wx:const-copy)
|
||
|
|
(do-one return wx:const-colour)
|
||
|
|
(do-one bb wx:const-colour)
|
||
|
|
(let ([bg (send dc get-background)])
|
||
|
|
(send dc set-background brushs)
|
||
|
|
(do-one return wx:const-colour)
|
||
|
|
(send dc set-background bg))
|
||
|
|
(send dc set-pen pens))))
|
||
|
|
|
||
|
|
(unless (or no-stipples? (not last?))
|
||
|
|
(send dc set-brush brushb)
|
||
|
|
(send dc draw-rectangle 80 200 100 40)
|
||
|
|
(when (send return ok?)
|
||
|
|
(let ([b (make-object wx:brush% "GREEN" wx:const-stipple)])
|
||
|
|
(send b set-stipple return)
|
||
|
|
(send dc set-brush b)
|
||
|
|
(send dc draw-rectangle 85 205 30 30)
|
||
|
|
(send dc set-brush brushs)
|
||
|
|
(send b set-style wx:const-opaque-stipple)
|
||
|
|
(send dc set-brush b)
|
||
|
|
(send dc draw-rectangle 120 205 30 30)
|
||
|
|
(send dc set-brush brushs)
|
||
|
|
(send b set-stipple bb)
|
||
|
|
(send dc set-brush b)
|
||
|
|
(send dc draw-rectangle 155 205 20 30)
|
||
|
|
(send dc set-brush brushs)
|
||
|
|
(send b set-stipple null))))
|
||
|
|
|
||
|
|
(if (not (or ps? (eq? dc can-dc)))
|
||
|
|
(send can-dc blit 0 0
|
||
|
|
(* scale 300) (* scale 300)
|
||
|
|
mem-dc 0 0 wx:const-copy)))
|
||
|
|
|
||
|
|
'done)])
|
||
|
|
|
||
|
|
(send (get-dc) set-user-scale 1 1)
|
||
|
|
(send (get-dc) set-device-origin 0 0)
|
||
|
|
|
||
|
|
(let ([dc (if ps?
|
||
|
|
(let ([dc (make-object wx:post-script-dc% null #t)])
|
||
|
|
(and (send dc ok?) dc))
|
||
|
|
(if (and use-bitmap? (send bm ok?))
|
||
|
|
(begin
|
||
|
|
(send mem-dc select-object bm)
|
||
|
|
mem-dc)
|
||
|
|
(get-dc)))])
|
||
|
|
(when dc
|
||
|
|
(when ps?
|
||
|
|
(send dc start-doc "Draw Test")
|
||
|
|
(send dc start-page))
|
||
|
|
|
||
|
|
(send dc set-user-scale scale scale)
|
||
|
|
(send dc set-device-origin offset offset)
|
||
|
|
|
||
|
|
(send dc clear)
|
||
|
|
; check default pen/brush:
|
||
|
|
(send dc draw-rectangle 0 0 5 5)
|
||
|
|
(send dc draw-line 0 0 20 6)
|
||
|
|
|
||
|
|
(draw-series dc pen0s pen0t "0 x 0" 5 0 0 #f)
|
||
|
|
|
||
|
|
(draw-series dc pen1s pen1t "1 x 1" 70 0 1 #f)
|
||
|
|
|
||
|
|
(draw-series dc pen2s pen2t "2 x 2" 135 0 2 #t)
|
||
|
|
|
||
|
|
(when ps?
|
||
|
|
(send dc end-page)
|
||
|
|
(send dc end-doc))))
|
||
|
|
|
||
|
|
'done)])]))
|
||
|
|
vp 0 50 300 300)])
|
||
|
|
(make-object mred:radio-box% hp0
|
||
|
|
(lambda (self event)
|
||
|
|
(set! use-bitmap? (< 0 (send event get-command-int)))
|
||
|
|
(set! depth-one? (< 1 (send event get-command-int)))
|
||
|
|
(send canvas on-paint))
|
||
|
|
null
|
||
|
|
-1 -1 -1 -1
|
||
|
|
'("Canvas" "Pixmap" "Bitmap")
|
||
|
|
0 wx:const-horizontal)
|
||
|
|
(make-object mred:button% hp
|
||
|
|
(lambda (self event)
|
||
|
|
(send canvas on-paint #t))
|
||
|
|
"PostScript")
|
||
|
|
(make-object mred:check-box% hp
|
||
|
|
(lambda (self event)
|
||
|
|
(send canvas set-scale (if (send event checked?) 2 1)))
|
||
|
|
"*2")
|
||
|
|
(make-object mred:check-box% hp
|
||
|
|
(lambda (self event)
|
||
|
|
(send canvas set-offset (if (send event checked?) 10 0)))
|
||
|
|
"+10")
|
||
|
|
(send (make-object mred:check-box% hp2
|
||
|
|
(lambda (self event)
|
||
|
|
(send canvas set-bitmaps (send event checked?)))
|
||
|
|
"Icons")
|
||
|
|
set-value #t)
|
||
|
|
(send (make-object mred:check-box% hp2
|
||
|
|
(lambda (self event)
|
||
|
|
(send canvas set-stipples (send event checked?)))
|
||
|
|
"Stipples")
|
||
|
|
set-value #t))
|
||
|
|
|
||
|
|
(send f show #t))
|