diff --git a/collects/mred/mred-sig.ss b/collects/mred/mred-sig.ss index c7bb4f5d..5498a605 100644 --- a/collects/mred/mred-sig.ss +++ b/collects/mred/mred-sig.ss @@ -46,6 +46,7 @@ current-text-keymap-initializer cursor% dc<%> + dc-path% dialog% editor-admin% editor-canvas% diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss index d2874180..864473ef 100644 --- a/collects/mred/mred.ss +++ b/collects/mred/mred.ss @@ -8075,6 +8075,7 @@ current-ps-setup cursor% dc<%> + dc-path% get-display-depth end-busy-cursor event% diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss index 9d8b710e..00767b4f 100644 --- a/collects/mred/private/kernel.ss +++ b/collects/mred/private/kernel.ss @@ -404,6 +404,7 @@ set-clipping-rect draw-polygon draw-lines + draw-path draw-ellipse draw-arc draw-text @@ -579,17 +580,33 @@ (define-class cursor% object% #f ok?) (define-class region% object% (dc) + in-region? is-empty? get-bounding-box + xor subtract intersect union + set-path set-arc set-polygon set-ellipse set-rounded-rectangle set-rectangle get-dc) + (define-class dc-path% object% #f + append + reverse + rotate + scale + translate + curve-to + arc + line-to + move-to + open? + close + reset) (define-private-class font-name-directory% font-name-directory<%> object% #f find-family-default-font-id find-or-create-font-id diff --git a/collects/tests/mred/draw.ss b/collects/tests/mred/draw.ss index a2034fb9..19aab154 100644 --- a/collects/tests/mred/draw.ss +++ b/collects/tests/mred/draw.ss @@ -95,6 +95,25 @@ (list->bytes '(#xcc #x33 #xcc #x33 #xcc #x33 #xcc #x33)) 8 8)) +(define fancy-path + (let ([p (new dc-path%)] + [p2 (new dc-path%)]) + (send p2 move-to 10 80) + (send p2 line-to 80 80) + (send p2 line-to 80 10) + (send p2 line-to 10 10) + (send p2 close) + + (send p move-to 1 1) + (send p line-to 90 1) + (send p line-to 90 90) + (send p line-to 1 90) + (send p close) + (send p append p2) + (send p arc 50 50 100 120 0 (* pi 1/2) #f) + + p)) + (let* ([f (make-object frame% "Graphics Test" #f 600 550)] [vp (make-object vertical-panel% f)] [hp0 (make-object horizontal-panel% vp)] @@ -129,7 +148,7 @@ (let ([canvas (make-object (class100 canvas% args - (inherit get-dc) + (inherit get-dc refresh) (private-field [no-bitmaps? #f] [no-stipples? #f] @@ -141,14 +160,14 @@ [yscale 1] [offset 0]) (public - [set-bitmaps (lambda (on?) (set! no-bitmaps? (not on?)) (on-paint))] - [set-stipples (lambda (on?) (set! no-stipples? (not on?)) (on-paint))] - [set-pixel-copy (lambda (on?) (set! pixel-copy? on?) (on-paint))] - [set-kern (lambda (on?) (set! kern? on?) (on-paint))] - [set-clip-pre-scale (lambda (on?) (set! clip-pre-scale? on?) (on-paint))] - [set-mask-ex-mode (lambda (mode) (set! mask-ex-mode mode) (on-paint))] - [set-scale (lambda (xs ys) (set! xscale xs) (set! yscale ys) (on-paint))] - [set-offset (lambda (o) (set! offset o) (on-paint))]) + [set-bitmaps (lambda (on?) (set! no-bitmaps? (not on?)) (refresh))] + [set-stipples (lambda (on?) (set! no-stipples? (not on?)) (refresh))] + [set-pixel-copy (lambda (on?) (set! pixel-copy? on?) (refresh))] + [set-kern (lambda (on?) (set! kern? on?) (refresh))] + [set-clip-pre-scale (lambda (on?) (set! clip-pre-scale? on?) (refresh))] + [set-mask-ex-mode (lambda (mode) (set! mask-ex-mode mode) (refresh))] + [set-scale (lambda (xs ys) (set! xscale xs) (set! yscale ys) (refresh))] + [set-offset (lambda (o) (set! offset o) (refresh))]) (override [on-paint (case-lambda @@ -762,7 +781,15 @@ (send dc draw-polygon star 480 80) (pen 'butt 'bevel) (send dc draw-lines star 410 150) - (send dc draw-polygon star 480 150))) + (send dc draw-polygon star 480 150)) + + (send dc set-pen (make-object pen% "green" 3 'solid)) + (send dc set-brush (make-object brush% "yellow" 'solid)) + (send dc draw-path (let ([p (new dc-path%)]) + (send p append fancy-path) + (send p scale 0.5 0.5) + (send p translate 410 230) + p))) (when (and last? (not (or ps? (eq? dc can-dc))) (send mem-dc get-bitmap)) @@ -808,9 +835,9 @@ (let ([r (make-object region% dc)]) (send r set-arc 0. 60. 180. 180. clock-start clock-end) (send dc set-clipping-region r)) - (let ([mk-poly (lambda () + (let ([mk-poly (lambda (mode) (let ([r (make-object region% dc)]) - (send r set-polygon octagon) r))] + (send r set-polygon octagon 0 0 mode) r))] [mk-circle (lambda () (let ([r (make-object region% dc)]) (send r set-ellipse 0. 60. 180. 180.) r))] @@ -821,20 +848,23 @@ [(none) (void)] [(rect) (send dc set-clipping-rect 100 -25 10 400)] [(rect2) (send dc set-clipping-rect 50 -25 10 400)] - [(poly) (send dc set-clipping-region (mk-poly))] + [(poly) (send dc set-clipping-region (mk-poly 'odd-even))] [(circle) (send dc set-clipping-region (mk-circle))] - [(rect+poly) (let ([r (mk-poly)]) + [(rect+poly) (let ([r (mk-poly 'winding)]) (send r union (mk-rect)) (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)]) + (send dc set-clipping-region r))] + [(poly-rect) (let ([r (mk-poly 'odd-even)]) (send r subtract (mk-rect)) - (send dc set-clipping-region r))] - [(poly&rect) (let ([r (mk-poly)]) + (send dc set-clipping-region r))] + [(poly&rect) (let ([r (mk-poly 'odd-even)]) (send r intersect (mk-rect)) (send dc set-clipping-region r))] + [(poly^rect) (let ([r (mk-poly 'odd-even)]) + (send r xor (mk-rect)) + (send dc set-clipping-region r))] [(roundrect) (let ([r (make-object region% dc)]) (send r set-rounded-rectangle 80 200 125 40 -0.25) (send dc set-clipping-region r))] @@ -864,9 +894,15 @@ (let ([r (send dc get-clipping-region)]) (send dc set-clipping-rect 0 0 20 20) - (send dc set-clipping-region r))) + (if r + (let ([r2 (make-object region% dc)]) + (send r2 set-rectangle 0 0 10 10) + (send r xor r2) + (send r2 xor r) + (send dc set-clipping-region r2)) + (send dc set-clipping-region #f)))) - ; check default pen/brush: + ;; check default pen/brush: (send dc draw-rectangle 0 0 5 5) (send dc draw-line 0 0 20 6) @@ -891,7 +927,7 @@ [(rect) '(100. -25. 10. 400.)] [(rect2) '(50. -25. 10. 400.)] [(poly circle poly-rect) '(0. 60. 180. 180.)] - [(rect+poly rect+circle) '(0. -25. 180. 400.)] + [(rect+poly rect+circle poly^rect) '(0. -25. 180. 400.)] [(poly&rect) '(100. 60. 10. 180.)] [(roundrect) '(80. 200. 125. 40.)] [(polka) '(0. 0. 310. 510.)])]) @@ -929,7 +965,7 @@ (set! use-bitmap? (< 0 (send self get-selection))) (set! depth-one? (< 1 (send self get-selection))) (set! use-bad? (< 2 (send self get-selection))) - (send canvas on-paint)) + (send canvas refresh)) '(horizontal)) (make-object button% "Save" hp0 (lambda (b e) @@ -946,7 +982,7 @@ [else (error 'save-file "unknown suffix: ~e" f)])]) (set! save-filename f) (set! save-file-format format) - (send canvas on-paint)))))) + (send canvas refresh)))))) (make-object button% "PS" hp (lambda (self event) (send canvas on-paint #t))) @@ -964,7 +1000,7 @@ (make-object check-box% "Cyan" hp (lambda (self event) (set! cyan? (send self get-value)) - (send canvas on-paint))) + (send canvas refresh))) (send (make-object check-box% "Icons" hp2 (lambda (self event) (send canvas set-bitmaps (send self get-value)))) @@ -980,7 +1016,7 @@ (lambda (self event) (set! smoothing (list-ref '(unsmoothed smoothed compatible) (send self get-selection))) - (send canvas on-paint))) + (send canvas refresh))) (make-object button% "Clock" hp2.5 (lambda (b e) (clock #f))) (make-object choice% #f '("MrEd XOR" "PLT Middle" "PLT ^ MrEd" "MrEd ^ PLT" "MrEd ^ MrEd" @@ -999,13 +1035,13 @@ (make-object choice% "Clip" '("None" "Rectangle" "Rectangle2" "Octagon" "Circle" "Round Rectangle" "Rectangle + Octagon" "Rectangle + Circle" - "Octagon - Rectangle" "Rectangle & Octagon" "Polka") + "Octagon - Rectangle" "Rectangle & Octagon" "Rectangle ^ Octagon" "Polka") hp3 (lambda (self event) (set! clip (list-ref - '(none rect rect2 poly circle roundrect rect+poly rect+circle poly-rect poly&rect polka) + '(none rect rect2 poly circle roundrect rect+poly rect+circle poly-rect poly&rect poly^rect polka) (send self get-selection))) - (send canvas on-paint))) + (send canvas refresh))) (make-object check-box% "Clip Pre-Scale" hp3 (lambda (self event) (send canvas set-clip-pre-scale (send self get-value)))) @@ -1026,7 +1062,7 @@ (set! clock-clip? #f) (set! clock-start #f) (set! clock-end #f) - (send canvas on-paint))))]) + (send canvas refresh))))]) (make-object button% "Clip Clock" hp3 (lambda (b e) (clock #t))))) (send f show #t))