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

small bug fix in world, needs more inspection

Browse Source 
svn: r12221
This commit is contained in:
Matthias Felleisen 2008-11-03 01:43:11 +00:00
parent a3ce8a9b85
commit d2248f6ff6
1 changed files with 8 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/htdp/world.ss
View File

@ -460,23 +460,24 @@ Matthew
(define w (image-width img)) (define w (image-width img))
(define h (image-height img)) (define h (image-height img))
(cond (cond
[(and (<= 0 x0) (< x0 w) (<= 0 x1) (< x1 w) (<= 0 y0) (< y0 w) (<= 0 y1) (< y1 w)) [(and (<= 0 x0 w) (<= 0 x1 w) (<= 0 y0 w) (<= 0 y1 w))
(add-line img x0 y0 x1 y1 c)] (shrink (add-line img x0 y0 x1 y1 c) 0 0 (- w 1) (- h 1))]
[(= x0 x1) ;; vertical [(= x0 x1) ;; vertical that leaves bounds
(if (<= 0 x0 w) (add-line img x0 (app y0 h) x0 (app y1 h) c) img)] (if (<= 0 x0 w) (add-line img x0 (app y0 h) x0 (app y1 h) c) img)]
[(= y0 y1) ;; horizontal [(= y0 y1) ;; horizontal that leaves bounds
(if (<= 0 y0 h) (add-line img (app x0 w) y0 (app x1 w) y0 c) img)] (if (<= 0 y0 h) (add-line img (app x0 w) y0 (app x1 w) y0 c) img)]
[else [else
(local ((define lin (points->line x0 y0 x1 y1)) (local ((define lin (points->line x0 y0 x1 y1))
(define dir (direction x0 y0 x1 y1)) (define dir (direction x0 y0 x1 y1))
(define-values (upp low lft rgt) (intersections lin w h)) (define-values (upp low lft rgt) (intersections lin w h))
(define (add x y) (add-line img x0 y0 x y c))) (define (add x y) (add-line img x0 y0 x y c)))
(printf "up/low: ~s x ~s ~s\n" upp low dir)
(cond (cond
[(and (< 0 x0 w) (< 0 y0 h)) ;; (x0,y0) is in the interior [(and (< 0 x0 w) (< 0 y0 h)) ;; (x0,y0) is in the interior
(case dir (case dir
[(upper-left) (if (number? upp) (add upp 0) (add 0 lft))] [(upper-left) (if (number? upp) (add upp 0) (add 0 lft))]
[(lower-left) (if (number? low) (add low h) (add 0 lft))] [(lower-left) (if (number? low) (add low h) (add 0 lft))]
[(upper-right) (if (number? upp) (add upp 0) (add h rgt))] [(upper-right) (if (number? upp) (add upp 0) (add w rgt))]
[(lower-right) (if (number? low) (add low h) (add w rgt))] [(lower-right) (if (number? low) (add low h) (add w rgt))]
[else (error 'dir "contract violation: ~e" dir)])] [else (error 'dir "contract violation: ~e" dir)])]
[(and (< 0 x1 w) (< 0 y1 h)) ;; (x1,y1) in interior; symmetry! [(and (< 0 x1 w) (< 0 y1 h)) ;; (x1,y1) in interior; symmetry!
@ -657,8 +658,8 @@ Matthew
(new (class frame% (new (class frame%
(super-new) (super-new)
(define/augment (on-close) (define/augment (on-close)
(custodian-shutdown-all the-play-back-custodian) (callback-stop!)
(callback-stop!))) (custodian-shutdown-all the-play-back-custodian)))
(label "DrScheme") (label "DrScheme")
(stretchable-width #f) (stretchable-width #f)
(stretchable-height #f) (stretchable-height #f)