From d6aad1a33e894c8ad0d0b604ac9c2fd64fd06149 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 19 Aug 1998 19:43:02 +0000 Subject: [PATCH] . original commit: 02adcbef72f96491292277a572aff1dbef6b9bc1 --- collects/tests/mred/draw.ss | 236 +++++++++++++++++------------------- collects/tests/mred/item.ss | 4 +- src/mred/wrap/mred.ss | 9 +- 3 files changed, 119 insertions(+), 130 deletions(-) diff --git a/collects/tests/mred/draw.ss b/collects/tests/mred/draw.ss index 581a4a7e..dd6f6dce 100644 --- a/collects/tests/mred/draw.ss +++ b/collects/tests/mred/draw.ss @@ -8,36 +8,34 @@ (lambda (f) (build-path d f)))) -(let* ([f (make-object mred:frame% () - "Graphics Test" - -1 -1 300 450)] - [vp (make-object mred:vertical-panel% f)] - [hp0 (make-object mred:horizontal-panel% vp)] - [hp (make-object mred:horizontal-panel% vp)] +(define (get-icon) + (make-object icon% (sys-path "mred.xbm") 'xbm)) + +(let* ([f (make-object frame% "Graphics Test" #f 300 450)] + [vp (make-object vertical-panel% f)] + [hp0 (make-object horizontal-panel% vp)] + [hp (make-object horizontal-panel% vp)] [hp2 hp] - [bb (make-object wx:bitmap% (sys-path "bb.gif") - wx:const-bitmap-type-gif)] - [return (let ([bm (make-object wx:bitmap% (sys-path "return.xbm") - wx:const-bitmap-type-xbm)] - [dc (make-object wx:memory-dc%)]) + [bb (make-object bitmap% (sys-path "bb.gif") 'gif)] + [return (let ([bm (make-object bitmap% (sys-path "return.xbm") 'xbm)] + [dc (make-object memory-dc%)]) (send dc select-object bm) (send dc draw-line 0 3 20 3) - (send dc select-object null) + (send dc select-object #f) bm)] - [tmp-mdc (make-object wx:memory-dc%)] + [tmp-mdc (make-object memory-dc%)] [use-bitmap? #f] [depth-one? #f] [cyan? #f] [clip? #f]) - (send hp0 stretchable-in-y #f) - (send hp stretchable-in-y #f) - (make-object mred:button% hp0 + (send hp0 stretchable-height #f) + (send hp stretchable-height #f) + (make-object button% "What Should I See?" hp0 (lambda (b e) - (send (send (mred:edit-file (local-path "draw-info.txt")) get-edit) lock #t)) - "What Should I See?") + (send (send (edit-file (local-path "draw-info.txt")) get-edit) lock #t))) (let ([canvas (make-object - (make-class mred:canvas% + (class canvas% args (inherit get-dc) (public [no-bitmaps? #f] @@ -47,27 +45,28 @@ [scale 1] [set-scale (lambda (s) (set! scale s) (on-paint))] [offset 0] - [set-offset (lambda (o) (set! offset o) (on-paint))] + [set-offset (lambda (o) (set! offset o) (on-paint))]) + (override [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)] + [pen0s (make-object pen% "BLACK" 0 'solid)] + [pen1s (make-object pen% "BLACK" 1 'solid)] + [pen2s (make-object pen% "BLACK" 2 'solid)] + [pen0t (make-object pen% "BLACK" 0 'transparent)] + [pen1t (make-object pen% "BLACK" 1 'transparent)] + [pen2t (make-object pen% "BLACK" 2 'transparent)] + [brushs (make-object brush% "BLACK" 'solid)] + [brusht (make-object brush% "BLACK" 'transparent)] + [penr (make-object pen% "RED" 1 'solid)] + [brushb (make-object brush% "BLUE" 'solid)] [mem-dc (if use-bitmap? - (make-object wx:memory-dc%) + (make-object memory-dc%) #f)] [bm (if use-bitmap? - (make-object wx:bitmap% (* scale 350) (* scale 300) + (make-object bitmap% (* scale 350) (* scale 300) (if depth-one? 1 -1)) #f)] [draw-series @@ -78,12 +77,12 @@ [obm (send dc get-background-mode)]) (if (positive? flevel) (send dc set-font - (make-object wx:font% - 10 wx:const-decorative - wx:const-normal + (make-object font% + 10 'decorative + 'normal (if (> flevel 1) - wx:const-bold - wx:const-normal) + 'bold + 'normal) #t))) (send dc set-pen pens) (send dc set-brush brusht) @@ -93,10 +92,10 @@ (+ x 3) (+ y 12) (+ x 40) (+ y 12)) - (send dc set-text-background (make-object wx:colour% "YELLOW")) + (send dc set-text-background (make-object color% "YELLOW")) (when (= flevel 2) - (send dc set-text-foreground (make-object wx:colour% "RED")) - (send dc set-background-mode wx:const-solid)) + (send dc set-text-foreground (make-object color% "RED")) + (send dc set-background-mode 'solid)) (send dc draw-text (string-append size " Pen") (+ x 5) (+ y 8)) @@ -174,14 +173,14 @@ (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 set-logical-function 'clear) (send dc draw-rectangle (+ x 18) (+ y 96) 8 8) - (send dc set-logical-function wx:const-copy) + (send dc set-logical-function 'copy) (send dc draw-rectangle (+ x 29) (+ y 95) 10 10) - (send dc set-logical-function wx:const-clear) + (send dc set-logical-function 'clear) (send dc set-pen pent) (send dc draw-rectangle (+ x 30) (+ y 96) 8 8) @@ -189,10 +188,10 @@ (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 set-logical-function 'xor) (send dc draw-rectangle (+ x 5) (+ y 95) 10 10) - (send dc set-logical-function wx:const-copy) + (send dc set-logical-function 'copy) (send dc draw-line (+ x 5) (+ y 110) (+ x 8) (+ y 110)) @@ -213,15 +212,15 @@ (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)) + (make-object point% 5 95) + (make-object point% 8 95) + (make-object point% 11 98) + (make-object point% 11 101) + (make-object point% 8 104) + (make-object point% 5 104) + (make-object point% 2 101) + (make-object point% 2 98) + (make-object point% 5 95)) (+ x 12) (+ y 15)) (send dc draw-point (+ x 35) (+ y 115)) @@ -261,28 +260,28 @@ (+ dx 240) (+ dy 30))) (send dc set-pen pen0s) (draw-ess 0 0) - (send dc set-pen (make-object wx:pen% "RED" 0 wx:const-solid)) + (send dc set-pen (make-object pen% "RED" 0 '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)] + (let ([pat-list (list 'bdiagonal-hatch + 'crossdiag-hatch + 'fdiagonal-hatch + 'cross-hatch + 'horizontal-hatch + 'vertical-hatch)] + [b (make-object brush% "BLACK" 'solid)] [ob (send dc get-brush)] [obg (send dc get-background)] - [blue (make-object wx:brush% "BLUE" wx:const-solid)]) + [blue (make-object brush% "BLUE" 'solid)]) (let loop ([x 245][y 10][l pat-list]) (unless (null? l) - (send b set-colour "BLACK") + (send b set-color "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 b set-color "GREEN") (send dc set-brush b) (send dc draw-rectangle (+ x 25) y 20 20) (send dc set-background blue) @@ -296,9 +295,8 @@ (when (and (not no-bitmaps?) last?) (let ([x 5] [y 165]) - (send dc draw-icon - (mred:get-icon) x y) - (set! x (+ x (send (mred:get-icon) get-width))) + (send dc draw-icon (get-icon) x y) + (set! x (+ x (send (get-icon) get-width))) (let ([do-one (lambda (bm mode) (if (send bm ok?) @@ -311,17 +309,17 @@ tmp-mdc 0 0 mode) (set! x (+ x w 10))) - (send tmp-mdc select-object null)) + (send tmp-mdc select-object #f)) (printf "bad bitmap~n")))]) - (do-one bb wx:const-copy) - (do-one return wx:const-copy) + (do-one bb 'copy) + (do-one return 'copy) (send dc set-pen penr) - (do-one return wx:const-copy) - (do-one return wx:const-colour) - (do-one bb wx:const-colour) + (do-one return 'copy) + (do-one return 'color) + (do-one bb 'color) (let ([bg (send dc get-background)]) (send dc set-background brushs) - (do-one return wx:const-colour) + (do-one return 'color) (send dc set-background bg)) (send dc set-pen pens)))) @@ -330,13 +328,13 @@ (send dc set-brush brushb) (send dc draw-rectangle 80 200 125 40) (when (send return ok?) - (let ([b (make-object wx:brush% "GREEN" wx:const-stipple)]) + (let ([b (make-object brush% "GREEN" 'stipple)]) (send b set-stipple return) (send dc set-brush b) ; First stipple (transparent background) (send dc draw-rectangle 85 205 30 30) (send dc set-brush brushs) - (send b set-style wx:const-opaque-stipple) + (send b set-style 'opaque-stipple) (send dc set-brush b) ; Second stipple (opaque) (send dc draw-rectangle 120 205 30 30) @@ -346,23 +344,23 @@ ; Third stipple (BB logo) (send dc draw-rectangle 155 205 20 30) (send dc set-brush brushs) - (send b set-stipple null) - (send b set-style wx:const-cross-hatch) + (send b set-stipple #f) + (send b set-style 'cross-hatch) (send dc set-brush b) ; Green cross hatch (white BG) on blue field (send dc draw-rectangle 180 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)] + (let ([styles (list 'solid + 'dot + 'long-dash + 'short-dash + 'dot-dash)] [obg (send dc get-background)] - [red (make-object wx:brush% "RED" wx:const-solid)]) + [red (make-object brush% "RED" 'solid)]) (let loop ([s styles][y 250]) (unless (null? s) - (let ([p (make-object wx:pen% "GREEN" flevel (car s))]) + (let ([p (make-object 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) @@ -375,13 +373,13 @@ (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) + (send pens set-style 'solid) (loop (cdr s) (+ y 8)))))) (if (not (or ps? (eq? dc can-dc))) (send can-dc blit 0 0 (* scale 350) (* scale 300) - mem-dc 0 0 wx:const-copy))) + mem-dc 0 0 'copy))) 'done)]) @@ -389,7 +387,7 @@ (send (get-dc) set-device-origin 0 0) (let ([dc (if ps? - (let ([dc (make-object wx:post-script-dc% null #t)]) + (let ([dc (make-object post-script-dc% #f #t)]) (and (send dc ok?) dc)) (if (and use-bitmap? (send bm ok?)) (begin @@ -405,8 +403,8 @@ (send dc set-background (if cyan? - (make-object wx:brush% "CYAN" wx:const-solid) - (make-object wx:brush% "WHITE" wx:const-solid))) + (make-object brush% "CYAN" 'solid) + (make-object brush% "WHITE" 'solid))) (send dc destroy-clipping-region) (send dc clear) @@ -450,51 +448,41 @@ (send dc end-page) (send dc end-doc))) - 'done)])])) - vp 0 50 300 300)]) - (make-object mred:radio-box% hp0 + 'done)])]) + (sequence (apply super-init args))) + vp)]) + (make-object radio-box% #f '("Canvas" "Pixmap" "Bitmap") hp0 (lambda (self event) - (set! use-bitmap? (< 0 (send event get-command-int))) - (set! depth-one? (< 1 (send event get-command-int))) + (set! use-bitmap? (< 0 (send self get-selection))) + (set! depth-one? (< 1 (send self get-selection))) (send canvas on-paint)) - null - -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 + '(horizontal)) + (make-object button% "Hide" hp0 + (lambda (self event) (send vp change-children (lambda (l) (list canvas))))) + (make-object button% "PostScript" hp (lambda (self event) - (send canvas on-paint #t)) - "PostScript") - (make-object mred:check-box% hp + (send canvas on-paint #t))) + (make-object check-box% "*2" hp (lambda (self event) - (send canvas set-scale (if (send event checked?) 2 1))) - "*2") - (make-object mred:check-box% hp + (send canvas set-scale (if (send self get-value) 2 1)))) + (make-object check-box% "+10" hp (lambda (self event) - (send canvas set-offset (if (send event checked?) 10 0))) - "+10") - (make-object mred:check-box% hp + (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)) - "Clip") - (make-object mred:check-box% hp + (send canvas on-paint))) + (make-object check-box% "Cyan" hp (lambda (self event) (set! cyan? (send self get-value)) - (send canvas on-paint)) - "Cyan") - (send (make-object mred:check-box% hp2 + (send canvas on-paint))) + (send (make-object check-box% "Icons" hp2 (lambda (self event) - (send canvas set-bitmaps (send event checked?))) - "Icons") + (send canvas set-bitmaps (send self get-value)))) set-value #t) - (send (make-object mred:check-box% hp2 + (send (make-object check-box% "Stipples" hp2 (lambda (self event) - (send canvas set-stipples (send event checked?))) - "Stipples") + (send canvas set-stipples (send self get-value)))) set-value #t)) (send f show #t)) diff --git a/collects/tests/mred/item.ss b/collects/tests/mred/item.ss index e7c1f7bb..d3472274 100644 --- a/collects/tests/mred/item.ss +++ b/collects/tests/mred/item.ss @@ -175,8 +175,8 @@ (define active-frame% (class-asi frame% (private (pre-on void)) - (override [pre-on-event (lambda args (apply pre-on args))] - [pre-on-char pre-on-event]) + (override [on-subwindow-event (lambda args (apply pre-on args))] + [on-subwindow-char on-subwindow-event]) (public [set-info (lambda (ep) (set! pre-on (add-pre-note this ep)))]))) diff --git a/src/mred/wrap/mred.ss b/src/mred/wrap/mred.ss index af094a11..8b866590 100644 --- a/src/mred/wrap/mred.ss +++ b/src/mred/wrap/mred.ss @@ -2941,11 +2941,12 @@ (define get-ps-setup-from-user (case-lambda - [() (get-ps-setup-from-user #f #f null)] - [(message) (get-ps-setup-from-user message #f (wx:current-ps-setup) null)] - [(message parent) (get-ps-setup-from-user message parent (wx:current-ps-setup) null)] + [() (get-ps-setup-from-user #f #f #f null)] + [(message) (get-ps-setup-from-user message #f #f null)] + [(message parent) (get-ps-setup-from-user message parent #f null)] [(message parent pss) (get-ps-setup-from-user message parent pss null)] - [(message parent pss style) + [(message parent pss-in style) + (define pss (or pss-in (wx:current-ps-setup))) (define f (make-object dialog% "PostScript Setup" parent)) (define papers '("A4 210 x 297 mm" "A3 297 x 420 mm" "Letter 8 1/2 x 11 in" "Legal 8 1/2 x 14 in"))