added add-curve

svn: r17523

collects/2htdp/image.ss

@@ -87,6 +87,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids
          right-triangle
          line
          add-line
+         add-curve
          text
          text/font
          bitmap

collects/2htdp/private/image-more.ss

@@ -368,6 +368,16 @@
                         (rotate-point (line-segment-end simple-shape)
                                       θ)
                         (line-segment-color simple-shape))]
+    [(curve-segment? simple-shape)
+     (make-curve-segment (rotate-point (curve-segment-start simple-shape)
+                                       θ)
+                         (bring-between (+ (curve-segment-s-angle simple-shape) θ) 360)
+                         (curve-segment-s-pull simple-shape)
+                         (rotate-point (curve-segment-end simple-shape)
+                                       θ)
+                         (bring-between (+ (curve-segment-e-angle simple-shape) θ) 360)
+                         (curve-segment-e-pull simple-shape)
+                         (curve-segment-color simple-shape))]
     [(polygon? simple-shape)
      (make-polygon (rotate-points θ (polygon-points simple-shape))
                    (polygon-mode simple-shape)
@@ -427,6 +437,15 @@
                   (min y1 y2)
                   (+ (max x1 x2) 1)
                   (+ (max y1 y2) 1)))]
+    [(curve-segment? simple-shape)
+     (let ([x1 (point-x (curve-segment-start simple-shape))]
+           [y1 (point-y (curve-segment-start simple-shape))]
+           [x2 (point-x (curve-segment-end simple-shape))]
+           [y2 (point-y (curve-segment-end simple-shape))])
+       (make-ltrb (min x1 x2)
+                  (min y1 y2)
+                  (+ (max x1 x2) 1)
+                  (+ (max y1 y2) 1)))]
     [(polygon? simple-shape)
      (points->ltrb (polygon-points simple-shape))]
     [else
@@ -686,6 +705,25 @@
                 (make-bb right bottom baseline)
                 #f)))
 
+(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)))
 
 ;; this is just so that 'text' objects can be sized.
 (define text-sizing-bm (make-object bitmap-dc% (make-object bitmap% 1 1)))
@@ -906,6 +944,7 @@
          
          line
          add-line
+         add-curve
          
          text
          text/font

collects/2htdp/private/img-err.ss

@@ -120,7 +120,7 @@
                 'non-negative-real-number
                 i arg)
      arg]
-    [(dx dy x1 y1 x2 y2 factor x-factor y-factor)
+    [(dx dy x1 y1 x2 y2 factor x-factor y-factor pull1 pull2)
      (check-arg fn-name
                 (real? arg)
                 'real\ number
@@ -138,7 +138,7 @@
                 'step-count
                 i arg)
      arg]
-    [(angle)
+    [(angle angle1 angle2)
      (check-arg fn-name
                 (angle? arg)
                 'angle\ in\ degrees

collects/2htdp/tests/test-image.ss

@@ -920,6 +920,40 @@
   (check-equal? (image-baseline (add-line txt 0 -10 100 100 'red))
                 (+ bl 10)))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  curves
+;;
+
+(test (add-curve (rectangle 100 20 'solid 'black)
+                 10 10 0 1/4
+                 90 10 0 1/4 
+                 'white)
+      =>
+      (add-line (rectangle 100 20 'solid 'black)
+                10 10
+                90 10
+                'white))
+
+(test (scale 2
+             (add-curve 
+              (rectangle 100 100 'solid 'black)
+              20 20 0 1/3 80 80 0 1/3 'white))
+      =>
+      (add-curve 
+       (rectangle 200 200 'solid 'black)
+       40 40 0 1/3 160 160 0 1/3 'white))
+
+(test (rotate 
+       90
+       (add-curve 
+        (rectangle 100 100 'solid 'black)
+        20 20 0 1/3 80 80 0 1/3 'white))
+      =>
+      (add-curve 
+       (rectangle 100 100 'solid 'black)
+       20 80 90 1/3 80 20 90 1/3 'white))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;;  bitmap tests

collects/mrlib/image-core.ss

@@ -122,6 +122,7 @@ has been moved out).
 ;; an atomic-shape is either:
 ;;  - polygon
 ;;  - line-segment
+;;  - curve-segment
 ;;  - np-atomic-shape
 
 ;; a np-atomic-shape is:
@@ -159,6 +160,12 @@ has been moved out).
                           (rec (line-segment-color a) (line-segment-color b))))
         (λ (x y) 42) 
         (λ (x y) 3)))
+
+;; a curve-segment is
+;;
+;;  - (make-curve-segment point real real point real real color)
+(define-struct/reg-mk curve-segment (start s-angle s-pull end e-angle e-pull color) #:transparent #:omit-define-syntaxes)
+
 ;; a normalized-shape (subtype of shape) is either
 ;;  - (make-overlay normalized-shape cropped-simple-shape)
 ;;  - cropped-simple-shape
@@ -171,6 +178,7 @@ has been moved out).
 ;;  - (make-translate dx dy np-atomic-shape))
 ;;  - polygon
 ;;  - line-segment
+;;  - curve-segment
 
 ;; an angle is a number between 0 and 360 (degrees)
 
@@ -457,6 +465,22 @@ has been moved out).
          (if bottom
              (make-overlay bottom (f this-one))
              (f this-one)))]
+      [(curve-segment? shape)
+       ;; the pull is multiplied by the distance 
+       ;; between the two points when it is drawn,
+       ;; so we don't need to scale it here
+       (let ([this-one 
+              (add-crops
+               (make-curve-segment (scale-point (curve-segment-start shape))
+                                   (curve-segment-s-angle shape)
+                                   (curve-segment-s-pull shape)
+                                   (scale-point (curve-segment-end shape))
+                                   (curve-segment-e-angle shape)
+                                   (curve-segment-e-pull shape)
+                                   (curve-segment-color shape)))])
+         (if bottom
+             (make-overlay bottom (f this-one))
+             (f this-one)))]
       [(np-atomic-shape? shape)
        (let ([this-one 
               (add-crops
@@ -471,11 +495,13 @@ has been moved out).
   (or (and (translate? shape)
            (np-atomic-shape? (translate-shape shape)))
       (polygon? shape)
-      (line-segment? shape)))
+      (line-segment? shape)
+      (curve-segment? shape)))
 
 (define (atomic-shape? shape)
   (or (polygon? shape)
       (line-segment? shape)
+      (curve-segment? shape)
       (np-atomic-shape? shape)))
 
 (define (np-atomic-shape? shape)
@@ -576,14 +602,37 @@ has been moved out).
                                              (polygon-color simple-shape)))
        (send dc draw-path path dx dy 'winding))]
     [(line-segment? simple-shape)
-     (let ([path (new dc-path%)]
-           [start (line-segment-start simple-shape)]
+     (let ([start (line-segment-start simple-shape)]
            [end (line-segment-end simple-shape)])
        (send dc set-pen (line-segment-color simple-shape) 1 'solid)
        (send dc set-brush "black" 'transparent)
        (send dc draw-line
              (+ dx (point-x start)) (+ dy (point-y start))
              (+ dx (point-x end)) (+ dy (point-y end))))]
+    [(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 (curve-segment-color simple-shape) 1 'solid)
+       (send dc set-brush "black" 'transparent)
+       (send dc draw-path path dx dy))]
     [else
      (let ([dx (+ dx (translate-dx simple-shape))]
            [dy (+ dy (translate-dy simple-shape))]
@@ -797,6 +846,10 @@ the mask bitmap and the original bitmap are all together in a single bytes!
          text-angle text-size text-face text-family text-style text-weight text-underline
          make-polygon polygon? polygon-points polygon-mode polygon-color
          make-line-segment line-segment? line-segment-start line-segment-end line-segment-color
+         make-curve-segment curve-segment? 
+         curve-segment-start curve-segment-s-angle curve-segment-s-pull
+         curve-segment-end curve-segment-e-angle curve-segment-e-pull 
+         curve-segment-color
 
          make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale 
          bitmap-rendered-bitmap bitmap-rendered-mask

collects/teachpack/2htdp/scribblings/image-toc.ss

@@ -9,7 +9,7 @@
    (list '(image-height (rectangle 100 100 "solid" "black")) 'val 100)
    (list '(image-baseline (rectangle 100 100 "solid" "black")) 'val 100)
    (list '(image-height (text "Hello" 24 "black")) 'val 41)
-   (list '(image-baseline (text "Hello" 24 "black")) 'val 31.0)
+   (list '(image-baseline (text "Hello" 24 "black")) 'val 31)
    (list
     '(image-height
       (overlay (circle 20 "solid" "orange") (circle 30 "solid" "purple")))
@@ -382,6 +382,48 @@
     "169f2ceb45c.png")
    (list '(text "Goodbye" 36 "indigo") 'image "169990a635e.png")
    (list '(text "Hello" 24 "olive") 'image "1bbeedc0d6.png")
+   (list
+    '(add-curve
+      (add-curve
+       (rectangle 40 100 'solid 'black)
+       20
+       10
+       180
+       1/2
+       20
+       90
+       180
+       1/2
+       'white)
+      20
+      10
+      0
+      1/2
+      20
+      90
+      0
+      1/2
+      'white)
+    'image
+    "13121248a3c.png")
+   (list
+    '(add-curve (rectangle 100 100 'solid 'black) 20 20 0 1 80 80 0 1 'white)
+    'image
+    "df251e846.png")
+   (list
+    '(add-curve
+      (rectangle 100 100 'solid 'black)
+      20
+      20
+      0
+      1/3
+      80
+      80
+      0
+      1/3
+      'white)
+    'image
+    "12472655f6c.png")
    (list
     '(add-line
       (ellipse 80 60 "outline" "darkolivegreen")

collects/teachpack/2htdp/scribblings/image.scrbl

@@ -211,6 +211,42 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
                             "darkolivegreen")]
 }
 
+@defproc[(add-curve [image image?] 
+                    [x1 real?] [y1 real?] [angle1 angle?] [pull1 real?]
+                    [x2 real?] [y2 real?] [angle2 angle?] [pull2 real?]
+                    [color image-color?])
+         image?]{
+
+Adds a curve to @scheme[image], starting at the point
+(@scheme[x1],@scheme[y1]), and ending at the point
+(@scheme[x2],@scheme[y2]).
+
+The @scheme[angle1] and @scheme[angle2] arguments specify the 
+angle that the curve has as it leaves the initial point and
+as it reaches the final point, respectively. 
+
+The @scheme[pull1] and @scheme[pull2] arguments control how
+long the curve tries to stay with that angle. Larger numbers
+mean that the curve stays with the angle longer.
+
+@image-examples[(add-curve (rectangle 100 100 'solid 'black)
+                           20 20 0 1/3
+                           80 80 0 1/3
+                           'white)
+                (add-curve (rectangle 100 100 'solid 'black)
+                           20 20 0 1 
+                           80 80 0 1
+                           'white)
+                (add-curve 
+                 (add-curve 
+                  (rectangle 40 100 'solid 'black)
+                  20 10 180 1/2
+                  20 90 180 1/2
+                  'white)
+                 20 10 0 1/2
+                 20 90 0 1/2
+                 'white)]
+}
 @defproc[(text [string string?] [font-size (and/c integer? (<=/c 1 255))] [color image-color?])
          image?]{