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

fix clipping

Browse Source
This commit is contained in:
Matthew Flatt 2010-06-12 17:51:21 -06:00
parent d331ef6d98
commit 049e4dbdcb
3 changed files with 16 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/racket/draw/dc-path.rkt
View File

@ -269,7 +269,8 @@
(def/public (ellipse [real? x] [real? y] (def/public (ellipse [real? x] [real? y]
[nonnegative-real? w] [nonnegative-real? h]) [nonnegative-real? w] [nonnegative-real? h])
(when (open?) (close)) (when (open?) (close))
(do-arc x y w h 0 2pi #t)) (do-arc x y w h 0 2pi #f)
(close))
(def/public (scale [real? x][real? y]) (def/public (scale [real? x][real? y])
(unless (and (= x 1.0) (= y 1.0)) (unless (and (= x 1.0) (= y 1.0))

2
collects/racket/draw/region.rkt
View File

@ -128,7 +128,7 @@
[real? end-radians]) [real? end-radians])
(modifying 'set-arc) (modifying 'set-arc)
(let ([p (new dc-path%)]) (let ([p (new dc-path%)])
(send p move-to x y) (send p move-to (+ x (/ width 2)) (+ y (/ height 2)))
(send p arc x y width height start-radians end-radians) (send p arc x y width height start-radians end-radians)
(send p close) (send p close)
(set! paths (list (cons p 'any))))) (set! paths (list (cons p 'any)))))

11
collects/tests/gracket/draw.rkt
View File

@ -191,6 +191,11 @@
(send dc set-bitmap #f) (send dc set-bitmap #f)
bm)) bm))
(define (show-error . args)
(with-handlers ([exn? (lambda (exn)
(printf "~a\n" (exn-message exn)))])
(apply error args)))
(define DRAW-WIDTH 550) (define DRAW-WIDTH 550)
(define DRAW-HEIGHT 375) (define DRAW-HEIGHT 375)
@ -1073,7 +1078,7 @@
(let ([r (send dc get-clipping-region)]) (let ([r (send dc get-clipping-region)])
(if (eq? clip 'none) (if (eq? clip 'none)
(when r (when r
(error 'draw-test "shouldn't have been a clipping region")) (show-error 'draw-test "shouldn't have been a clipping region"))
(let*-values ([(x y w h) (send r get-bounding-box)] (let*-values ([(x y w h) (send r get-bounding-box)]
[(l) (list x y w h)] [(l) (list x y w h)]
[(=~) (lambda (x y) [(=~) (lambda (x y)
@ -1097,7 +1102,7 @@
(- (/ (caddr l) xscale) offset) (- (/ (caddr l) xscale) offset)
(- (/ (cadddr l) yscale) offset)) (- (/ (cadddr l) yscale) offset))
l))) l)))
(error 'draw-test "clipping region changed badly: ~a" l)))))) (show-error 'draw-test "clipping region changed badly: ~a" l))))))
(let-values ([(w h) (send dc get-size)]) (let-values ([(w h) (send dc get-size)])
(unless (cond (unless (cond
@ -1105,7 +1110,7 @@
[use-bad? #t] [use-bad? #t]
[use-bitmap? (and (= w (* xscale DRAW-WIDTH)) (= h (* yscale DRAW-HEIGHT)))] [use-bitmap? (and (= w (* xscale DRAW-WIDTH)) (= h (* yscale DRAW-HEIGHT)))]
[else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 DRAW-HEIGHT)))]) [else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 DRAW-HEIGHT)))])
(error 'x "wrong size reported by get-size: ~a ~a (not ~a)" w h (show-error 'x "wrong size reported by get-size: ~a ~a (not ~a)" w h
(if use-bitmap? (if use-bitmap?
(list (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT)) (list (* xscale DRAW-WIDTH) (* yscale DRAW-HEIGHT))
(list (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT)))))) (list (* 2 DRAW-WIDTH) (* 2 DRAW-HEIGHT))))))