From 53a796d7af5fb7befa0d490da46ab4d5959b0722 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 28 Sep 2009 16:26:03 +0000 Subject: [PATCH] first (broken) attempt at bounding boxes for ellipses svn: r16145 --- collects/2htdp/private/image-core.ss | 36 +-------------- collects/2htdp/private/image-more.ss | 65 ++++++++++++++++++++++++++-- collects/tests/2htdp/test-image.ss | 5 +++ 3 files changed, 68 insertions(+), 38 deletions(-) diff --git a/collects/2htdp/private/image-core.ss b/collects/2htdp/private/image-core.ss index ba07dbeb4e..eefb4c86c9 100644 --- a/collects/2htdp/private/image-core.ss +++ b/collects/2htdp/private/image-core.ss @@ -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) \ No newline at end of file + render-image) \ No newline at end of file diff --git a/collects/2htdp/private/image-more.ss b/collects/2htdp/private/image-more.ss index ec79840693..6855332c9a 100644 --- a/collects/2htdp/private/image-more.ss +++ b/collects/2htdp/private/image-more.ss @@ -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) diff --git a/collects/tests/2htdp/test-image.ss b/collects/tests/2htdp/test-image.ss index e29bd68a14..b67209ee96 100644 --- a/collects/tests/2htdp/test-image.ss +++ b/collects/tests/2htdp/test-image.ss @@ -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