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

first (broken) attempt at bounding boxes for ellipses

Browse Source 
svn: r16145
This commit is contained in:
Robby Findler 2009-09-28 16:26:03 +00:00
parent ce6c12daf8
commit 53a796d7af
3 changed files with 68 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
collects/2htdp/private/image-core.ss
View File

@ -371,40 +371,6 @@ and they all have good sample contracts. (It is amazing what we can do with kids
;
;
(define (show-image g [extra-space 0])
(letrec ([f (new frame% [label ""])]
[c (new canvas%
[parent f]
[min-width (+ extra-space (inexact->exact (floor (image-right g))))]
[min-height (+ extra-space (inexact->exact (floor (image-bottom g))))]
[paint-callback
(λ (c dc)
(send dc set-smoothing 'aligned)
(let-values ([(w h) (send c get-client-size)])
(let ([scale (send sl get-value)])
(send dc set-scale scale scale)
(render-image
g
dc
(inexact->exact (floor (- (/ w 2 scale) (/ (image-right g) 2))))
(inexact->exact (floor (- (/ h 2 scale) (/ (image-bottom g) 2))))))))])]
[min-scale 1]
[max-scale 10]
[sl (new slider%
[label "Scale factor"]
[parent f]
[min-value min-scale]
[max-value max-scale]
[callback (λ ignore (send c refresh))])]
[bp (new horizontal-panel% [parent f] [alignment '(center center)] [stretchable-height #f])]
[scale-adjust
(λ (f)
(send sl set-value (max min-scale (min max-scale (f (send sl get-value)))))
(send c refresh))])
(send (new button% [label "√"] [callback (λ x (scale-adjust sub1))] [parent bp]) min-width 100)
(send (new button% [label "2"] [callback (λ x (scale-adjust add1))] [parent bp]) min-width 100)
(send f show #t)))
;; render-image : normalized-shape dc dx dy -> void
(define (render-image image dc dx dy)
(let loop ([shape (send image get-normalized-shape)])
@ -484,4 +450,4 @@ and they all have good sample contracts. (It is amazing what we can do with kids
image-bottom
image-baseline
show-image)
render-image)

65
collects/2htdp/private/image-more.ss
View File

@ -21,9 +21,44 @@
ellipse
rectangle
show-image
bring-between)
(define (show-image g [extra-space 0])
(letrec ([f (new frame% [label ""])]
[c (new canvas%
[parent f]
[min-width (+ extra-space (inexact->exact (floor (image-right g))))]
[min-height (+ extra-space (inexact->exact (floor (image-bottom g))))]
[paint-callback
(λ (c dc)
(send dc set-smoothing 'aligned)
(let-values ([(w h) (send c get-client-size)])
(let ([scale (send sl get-value)])
(send dc set-scale scale scale)
(render-image
g
dc
(inexact->exact (floor (- (/ w 2 scale) (/ (image-right g) 2))))
(inexact->exact (floor (- (/ h 2 scale) (/ (image-bottom g) 2))))))))])]
[min-scale 1]
[max-scale 10]
[sl (new slider%
[label "Scale factor"]
[parent f]
[min-value min-scale]
[max-value max-scale]
[callback (λ ignore (send c refresh))])]
[bp (new horizontal-panel% [parent f] [alignment '(center center)] [stretchable-height #f])]
[scale-adjust
(λ (f)
(send sl set-value (max min-scale (min max-scale (f (send sl get-value)))))
(send c refresh))])
(send (new button% [label "√"] [callback (λ x (scale-adjust sub1))] [parent bp]) min-width 100)
(send (new button% [label "2"] [callback (λ x (scale-adjust add1))] [parent bp]) min-width 100)
(send f show #t)))
;
;
@ -364,12 +399,36 @@
(cdr points))
(values left top right bottom)))]
[else
#|
>> (rotate theta (ellipse w h _ _))
>> is
>> (let* {[cos2 (sqr (cos theta))]
>> [sin2 (sqr (sin theta))]
>> }
>> (make-bbox (+ (* w cos2) (* h sin2))
>> (+ (* w sin2) (* h cos2)))
>> ... ;; baseline is same as y, for non-text, right?
>> )
>>
|#
(let ([dx (translate-dx simple-shape)]
[dy (translate-dy simple-shape)]
[atomic-shape (translate-shape simple-shape)])
(fprintf (current-error-port) "BAD bounding box\n")
(values 0 0 100 100))]))
(cond
[(ellipse? atomic-shape)
(let* ([theta (degrees->radians (ellipse-angle atomic-shape))]
[w (ellipse-width atomic-shape)]
[h (ellipse-height atomic-shape)]
[cos2 (sqr (cos theta))]
[sin2 (sqr (sin theta))])
(values dx
dy
(+ dx (* w cos2) (* h sin2))
(+ dy (* w sin2) (* h cos2))))]
[else
(fprintf (current-error-port) "BAD BOUNDING BOX\n")
(values 0 0 100 100)]))]))
;; rotate-simple : angle simple-shape -> simple-shape
(define (rotate-simple θ simple-shape)

5
collects/tests/2htdp/test-image.ss
View File

@ -2,10 +2,15 @@
(require "../../2htdp/private/image-core.ss"
"../../2htdp/private/image-more.ss"
scheme/math
scheme/class
scheme/gui/base
tests/eli-tester)
;(define-syntax-rule (test a => b) (begin a b))
#;
(show-image
(overlay/xy (rectangle 100 10 'solid 'red)
0