adjust 2htdp/image's add-curve and scene+curve so they accurately

compute the bounding box

using the new get-path-bounding-box method

pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt

@@ -885,30 +885,35 @@ has been moved out).
        (send dc set-smoothing 'smoothed)
        (send dc draw-path path dx dy))]
     [(curve-segment? simple-shape)
-     (let* ([path (new dc-path%)]
-            [start (curve-segment-start simple-shape)]
-            [end (curve-segment-end simple-shape)]
-            [sx (point-x start)]
-            [sy (point-y start)]
-            [ex (point-x end)]
-            [ey (point-y end)]
-            [sa (degrees->radians (curve-segment-s-angle simple-shape))]
-            [ea (degrees->radians (curve-segment-e-angle simple-shape))]
-            [d (sqrt (+ (sqr (- ey sy)) (sqr (- ex sx))))]
-            [sp (* (curve-segment-s-pull simple-shape) d)]
-            [ep (* (curve-segment-e-pull simple-shape) d)])
-       (send path move-to sx sy)
-       (send path curve-to
-             (+ sx (* sp (cos sa)))
-             (- sy (* sp (sin sa)))
-             (- ex (* ep (cos ea)))
-             (+ ey (* ep (sin ea)))
-             ex
-             ey)
-       (send dc set-pen (mode-color->pen 'outline (curve-segment-color simple-shape)))
-       (send dc set-brush "black" 'transparent)
-       (send dc set-smoothing 'smoothed)
-       (send dc draw-path path dx dy))]))
+     (define path (curve-segment->path simple-shape))
+     (send dc set-pen (mode-color->pen 'outline (curve-segment-color simple-shape)))
+     (send dc set-brush "black" 'transparent)
+     (send dc set-smoothing 'smoothed)
+     (send dc draw-path path dx dy)]))
+
+(define (curve-segment->path simple-shape)
+  (define start (curve-segment-start simple-shape))
+  (define end (curve-segment-end simple-shape))
+  (define sx (point-x start))
+  (define sy (point-y start))
+  (define ex (point-x end))
+  (define ey (point-y end))
+  (define sa (degrees->radians (curve-segment-s-angle simple-shape)))
+  (define ea (degrees->radians (curve-segment-e-angle simple-shape)))
+
+  (define path (new dc-path%))
+  (define d (sqrt (+ (sqr (- ey sy)) (sqr (- ex sx)))))
+  (define sp (* (curve-segment-s-pull simple-shape) d))
+  (define ep (* (curve-segment-e-pull simple-shape) d))
+  (send path move-to sx sy)
+  (send path curve-to
+        (+ sx (* sp (cos sa)))
+        (- sy (* sp (sin sa)))
+        (- ex (* ep (cos ea)))
+        (+ ey (* ep (sin ea)))
+        ex
+        ey)
+  path)
 
 (define (render-np-atomic-shape np-atomic-shape dc dx dy)
   (cond
@@ -1350,7 +1355,10 @@ the mask bitmap and the original bitmap are all together in a single bytes!
          to-img
          bitmap->image
          image-snip->image
-         image-snip%)
+         image-snip%
+         
+         curve-segment->path
+         mode-color->pen)
 
 ;; method names
 (provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape)

pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt

@@ -977,25 +977,28 @@
                 (send image get-pinhole))))
 
 (define/chk (add-curve image x1 y1 angle1 pull1 x2 y2 angle2 pull2 color)
-  (let* ([dx (abs (min 0 x1 x2))]
-         [dy (abs (min 0 y1 y2))]
-         [bottom (max (+ y1 dy)
-                      (+ y2 dy)
-                      (+ dy (get-bottom image)))]
-         [right (max (+ x1 dx)
-                     (+ x2 dx)
-                     (+ dx (get-right image)))]
-         [baseline (+ dy (get-baseline image))])
-    (make-image (make-translate
-                 dx dy
-                 (make-overlay
-                  (make-curve-segment (make-point x1 y1) angle1 pull1
-                                      (make-point x2 y2) angle2 pull2
-                                      color)
-                  (image-shape image)))
-                (make-bb right bottom baseline)
-                #f
-                (send image get-pinhole))))
+  (define cs (make-curve-segment (make-point x1 y1) angle1 pull1
+                                 (make-point x2 y2) angle2 pull2
+                                 color))
+  (define path (curve-segment->path cs))
+  (define rdc (new record-dc%))
+  (send rdc set-pen (mode-color->pen 'outline color))
+  (send rdc set-brush "black" 'transparent)
+  (send rdc set-smoothing 'smoothed)
+  (define-values (path-l path-t path-w path-h) (send rdc get-path-bounding-box path 'stroke))
+  (define dx (abs (min 0 path-l)))
+  (define dy (abs (min 0 path-t)))
+  (define bottom (max (+ dy path-t path-h) (+ dy (get-bottom image))))
+  (define right (max (+ dx path-l path-w) (+ dx (get-right image))))
+  (define baseline (+ dy (get-baseline image)))
+  (make-image (make-translate
+               dx dy
+               (make-overlay
+                cs
+                (image-shape image)))
+              (make-bb right bottom baseline)
+              #f
+              (send image get-pinhole)))
 
 ;; this is just so that 'text' objects can be sized.
 (define text-sizing-bm (make-object bitmap-dc% (make-object bitmap% 1 1)))

pkgs/htdp-pkgs/htdp-lib/teachpack/HISTORY.txt

@@ -1,3 +1,12 @@
+------------------------------------------------------------------------
+Version 6.0
+
+* 2htdp/image: changed scene+curve and add-curve to more accurately
+  compute the bounding box of the curve (previously the argument
+  points were used as the bounding box for the entire curve; now the
+  bounding box is calculated properly in the case that the curve goes
+  outside that rectangle)
+
 ------------------------------------------------------------------------
 Version 5.3.4				  [Wed Apr 24 16:20:03 EDT 2013]