added 'line'

svn: r16699

collects/2htdp/image.ss

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

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

@@ -158,7 +158,7 @@
                 'non-negative-real-number
                 i arg)
      arg]
-    [(dx dy factor x-factor y-factor)
+    [(dx dy x1 y1 x2 y2 factor x-factor y-factor)
      (check-arg fn-name
                 (real? arg)
                 'real\ number
@@ -449,6 +449,15 @@
 ;; (only called for rotated shapes, so bottom=baseline)
 (define (simple-bb simple-shape)
   (cond
+    [(line-segment? simple-shape)
+     (let ([x1 (point-x (line-segment-start simple-shape))]
+           [y1 (point-y (line-segment-start simple-shape))]
+           [x2 (point-x (line-segment-end simple-shape))]
+           [y2 (point-y (line-segment-end simple-shape))])
+       (values (min x1 x2)
+               (min y1 y2)
+               (max x1 x2)
+               (max y1 y2)))]
     [(polygon? simple-shape)
      (let ([points (polygon-points simple-shape)])
        (let* ([fx (point-x (car points))]
@@ -492,10 +501,10 @@
      (let*-values ([(w h a d) (send text-sizing-bm get-text-extent 
                                     (text-string atomic-shape) 
                                     (text->font atomic-shape))]
-                   [(ax ay) (rotate-point (- (/ w 2)) (- (/ h 2)) (text-angle atomic-shape))]
-                   [(bx by) (rotate-point (- (/ w 2)) (/ h 2) (text-angle atomic-shape))]
-                   [(cx cy) (rotate-point (/ w 2) (- (/ h 2)) (text-angle atomic-shape))]
-                   [(dx dy) (rotate-point (/ w 2) (/ h 2) (text-angle atomic-shape))])
+                   [(ax ay) (rotate-xy (- (/ w 2)) (- (/ h 2)) (text-angle atomic-shape))]
+                   [(bx by) (rotate-xy (- (/ w 2)) (/ h 2) (text-angle atomic-shape))]
+                   [(cx cy) (rotate-xy (/ w 2) (- (/ h 2)) (text-angle atomic-shape))]
+                   [(dx dy) (rotate-xy (/ w 2) (/ h 2) (text-angle atomic-shape))])
        (values (min ax bx cx dx)
                (min ay by cy dy)
                (max ax bx cx dx)
@@ -507,10 +516,14 @@
 ;; rotate-simple : angle simple-shape -> simple-shape
 (define (rotate-simple θ simple-shape)
   (cond
+    [(line-segment? simple-shape)
+     (make-line-segment (rotate-point (line-segment-start simple-shape)
+                                       θ)
+                        (rotate-point (line-segment-end simple-shape)
+                                      θ)
+                        (line-segment-color simple-shape))]
     [(polygon? simple-shape)
-     (make-polygon (map (λ (p)
-                          (let-values ([(xn yn) (rotate-point (point-x p) (point-y p) θ)])
-                            (make-point xn yn)))
+     (make-polygon (map (λ (p) (rotate-point p θ))
                         (polygon-points simple-shape))
                    (polygon-mode simple-shape)
                    (polygon-color simple-shape))]
@@ -569,8 +582,13 @@
                   (bitmap-scale atomic-shape)
                   #f)]))
 
-;; rotate-point : x,y angle -> x,y
-(define (rotate-point x y θ)
+;; rotate-point : point angle -> point
+(define (rotate-point p θ)
+  (let-values ([(x y) (rotate-xy (point-x p) (point-y p) θ)])
+    (make-point x y)))
+
+;; rotate-xy : x,y angle -> x,y
+(define (rotate-xy x y θ)
   (c->xy (* (make-polar 1 (degrees->radians θ)) 
             (xy->c x y))))
 
@@ -634,8 +652,35 @@
         (make-point 0 height)))
   
 
+(define/chk (line x1 y1 color)
+  (let-values ([(shape w h) (line-shape x1 y1 color)])
+    (make-image shape
+                (make-bb w h h)
+                #f)))
+
+(define (line-shape x1 y1 color)
+  (let ([dx (- (min x1 0))]
+        [dy (- (min y1 0))]
+        [w (+ (abs x1) 1)]
+        [h (+ (abs y1) 1)])
+    (values (make-translate
+             dx dy
+             (make-line-segment (make-point 0 0)
+                                (make-point x1 y1)
+                                color))
+            w h)))
+  #|
+(define/chk (add-line image x1 y1 x2 y2 color)
+  (make-image (make-overlay
+               (make-translate 
+                x1 y1
+                (make-line-segment (make-point 0 0)
+                                   (make-point x2 y2)
+                                   color))
+               (make-bb w h h)
+               #f))
+|#
 ;;       line
-;;       text
 
 ;; this is just so that 'text' objects can be sized.
 (define text-sizing-bm (make-object bitmap-dc% (make-object bitmap% 1 1)))
@@ -829,12 +874,14 @@
          star
          star-polygon
          
+         line
+         
          text
          text/font
          
          swizzle
          
-         rotate-point)
+         rotate-xy)
 
 (provide/contract
  [atomic-bb (-> atomic-shape? (values real? real? real? real?))]

collects/mrlib/image-core.ss

@@ -118,6 +118,7 @@ has been moved out).
 
 ;; an atomic-shape is either:
 ;;  - polygon
+;;  - line-segment
 ;;  - np-atomic-shape
 
 ;; a np-atomic-shape is:
@@ -142,6 +143,18 @@ has been moved out).
   #:property prop:equal+hash 
   (list (λ (a b rec) (polygon-equal? a b rec)) (λ (x y) 42) (λ (x y) 3)))
 
+;; a line-segment is
+;;
+;;  - (make-line-segment point point color)
+(define-struct/reg-mk line-segment (start end color) #:transparent #:omit-define-syntaxes
+  #:property prop:equal+hash 
+  (list (λ (a b rec) (and (or (and (rec (line-segment-start a) (line-segment-start b))
+                                   (rec (line-segment-end a) (line-segment-end b)))
+                              (and (rec (line-segment-start a) (line-segment-end b))
+                                   (rec (line-segment-end a) (line-segment-start b))))
+                          (rec (line-segment-color a) (line-segment-color b))))
+        (λ (x y) 42) 
+        (λ (x y) 3)))
 ;; a normalized-shape (subtype of shape) is either
 ;;  - (make-overlay normalized-shape simple-shape)
 ;;  - simple-shape
@@ -149,6 +162,7 @@ has been moved out).
 ;; a simple-shape (subtype of shape) is
 ;;  - (make-translate dx dy np-atomic-shape)
 ;;  - polygon
+;;  - line-segment
 
 ;; an angle is a number between 0 and 360 (degrees)
 
@@ -317,6 +331,9 @@ has been moved out).
              [x-scale 1]
              [y-scale 1]
              [bottom #f])
+    (define (scale-point p)
+      (make-point (+ dx (* x-scale (point-x p)))
+                  (+ dy (* y-scale (point-y p)))))
     (cond
       [(translate? shape)
        (loop (translate-shape shape)
@@ -338,18 +355,21 @@ has been moved out).
              (loop (overlay-top shape)
                    dx dy x-scale y-scale bottom))]
       [(polygon? shape)
-       (let* ([scaled-points
-               (map (λ (p)
-                      (make-point (+ dx (* x-scale (point-x p)))
-                                  (+ dy (* y-scale (point-y p)))))
-                    (polygon-points shape))]
-              [this-one 
-               (make-polygon scaled-points
+       (let* ([this-one 
+               (make-polygon (map scale-point (polygon-points shape))
                              (polygon-mode shape)
                              (polygon-color shape))])
          (if bottom
              (make-overlay bottom (f this-one))
              (f this-one)))]
+      [(line-segment? shape)
+       (let ([this-one 
+              (make-line-segment (scale-point (line-segment-start shape))
+                                 (scale-point (line-segment-end shape))
+                                 (line-segment-color shape))])
+         (if bottom
+             (make-overlay bottom (f this-one))
+             (f this-one)))]
       [(np-atomic-shape? shape)
        (let ([this-one (make-translate dx dy (scale-np-atomic x-scale y-scale shape))])
          (if bottom
@@ -361,10 +381,12 @@ has been moved out).
 (define (simple-shape? shape)
   (or (and (translate? shape)
            (np-atomic-shape? (translate-shape shape)))
-      (polygon? shape)))
+      (polygon? shape)
+      (line-segment? shape)))
 
 (define (atomic-shape? shape)
   (or (polygon? shape)
+      (line-segment? shape)
       (np-atomic-shape? shape)))
 
 (define (np-atomic-shape? shape)
@@ -460,6 +482,15 @@ has been moved out).
        (send dc set-pen (mode-color->pen (polygon-mode simple-shape) (polygon-color simple-shape)))
        (send dc set-brush (mode-color->brush (polygon-mode simple-shape) (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)]
+           [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))))]
     [else
      (let ([dx (+ dx (translate-dx simple-shape))]
            [dy (+ dy (translate-dy simple-shape))]
@@ -566,6 +597,8 @@ has been moved out).
          make-text text? text-string text-angle text-y-scale text-color
          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-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-scale bitmap-rendered-bitmap
          
          degrees->radians

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

@@ -46,7 +46,11 @@
     (read in)))
 
 (for-each handle-image expressions)
-(printf "\n")
+(cond
+  [(null? mapping)
+   (error 'image-gen "didn't find any images; probably this means that you need to delete .zo files and try again")]
+  [else
+   (printf "\n")])
 
 (call-with-output-file "image-toc.ss"
   (λ (port)

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

@@ -28,18 +28,18 @@
       (ellipse 20 30 "solid" "slateblue")
       (ellipse 20 10 "solid" "navy"))
     'image
-    "46.png")
-   (list '(frame (ellipse 20 20 "outline" "black")) 'image "45.png")
-   (list '(ellipse 60 60 "solid" "blue") 'image "44.png")
-   (list '(scale/xy 3 2 (ellipse 20 30 "solid" "blue")) 'image "43.png")
-   (list '(ellipse 40 60 "solid" "blue") 'image "42.png")
-   (list '(scale 2 (ellipse 20 30 "solid" "blue")) 'image "41.png")
-   (list '(rotate 5 (rectangle 50 50 "outline" "black")) 'image "40.png")
-   (list '(rotate 45 (ellipse 60 20 "solid" "olivedrab")) 'image "39.png")
+    "49.png")
+   (list '(frame (ellipse 20 20 "outline" "black")) 'image "48.png")
+   (list '(ellipse 60 60 "solid" "blue") 'image "47.png")
+   (list '(scale/xy 3 2 (ellipse 20 30 "solid" "blue")) 'image "46.png")
+   (list '(ellipse 40 60 "solid" "blue") 'image "45.png")
+   (list '(scale 2 (ellipse 20 30 "solid" "blue")) 'image "44.png")
+   (list '(rotate 5 (rectangle 50 50 "outline" "black")) 'image "43.png")
+   (list '(rotate 45 (ellipse 60 20 "solid" "olivedrab")) 'image "42.png")
    (list
     '(beside/places "baseline" (text "ijy" 18 "black") (text "ijy" 24 "black"))
     'image
-    "38.png")
+    "41.png")
    (list
     '(beside/places
       "center"
@@ -48,7 +48,7 @@
       (ellipse 20 30 "solid" "purple")
       (ellipse 20 10 "solid" "indigo"))
     'image
-    "37.png")
+    "40.png")
    (list
     '(beside/places
       "bottom"
@@ -57,7 +57,7 @@
       (ellipse 20 30 "solid" "slateblue")
       (ellipse 20 10 "solid" "navy"))
     'image
-    "36.png")
+    "39.png")
    (list
     '(beside
       (ellipse 20 70 "solid" "gray")
@@ -65,7 +65,7 @@
       (ellipse 20 30 "solid" "dimgray")
       (ellipse 20 10 "solid" "black"))
     'image
-    "35.png")
+    "38.png")
    (list
     '(overlay/xy
       (rectangle 10 10 "solid" "red")
@@ -73,7 +73,7 @@
       -10
       (rectangle 10 10 "solid" "black"))
     'image
-    "34.png")
+    "37.png")
    (list
     '(overlay/xy
       (rectangle 10 10 "solid" "red")
@@ -81,7 +81,7 @@
       10
       (rectangle 10 10 "solid" "black"))
     'image
-    "33.png")
+    "36.png")
    (list
     '(overlay/xy
       (rectangle 10 10 "outline" "red")
@@ -89,7 +89,7 @@
       0
       (rectangle 10 10 "outline" "black"))
     'image
-    "32.png")
+    "35.png")
    (list
     '(overlay/xy
       (ellipse 40 40 "outline" "black")
@@ -97,7 +97,7 @@
       25
       (ellipse 10 10 "solid" "forestgreen"))
     'image
-    "31.png")
+    "34.png")
    (list
     '(overlay/places
       "right"
@@ -107,7 +107,7 @@
       (rectangle 40 40 "solid" "red")
       (rectangle 50 50 "solid" "black"))
     'image
-    "30.png")
+    "33.png")
    (list
     '(overlay/places
       "middle"
@@ -115,7 +115,7 @@
       (rectangle 30 60 "solid" "orange")
       (ellipse 60 30 "solid" "purple"))
     'image
-    "29.png")
+    "32.png")
    (list
     '(overlay
       (ellipse 10 10 "solid" "red")
@@ -125,32 +125,35 @@
       (ellipse 50 50 "solid" "red")
       (ellipse 60 60 "solid" "black"))
     'image
-    "28.png")
+    "31.png")
    (list
     '(overlay
       (ellipse 60 30 "solid" "purple")
       (rectangle 30 60 "solid" "orange"))
     'image
-    "27.png")
+    "30.png")
    (list
     '(text/font "not really a link" 18 "blue" #f 'roman 'normal 'normal #t)
     'image
-    "26.png")
+    "29.png")
    (list
     '(text/font "Goodbye" 18 "indigo" #f 'modern 'italic 'normal #f)
     'image
-    "25.png")
+    "28.png")
    (list
     '(text/font "Hello" 24 "olive" "Gill Sans" 'swiss 'normal 'bold #f)
     'image
-    "24.png")
-   (list '(text "Goodbye" 36 "indigo") 'image "23.png")
-   (list '(text "Hello" 24 "olive") 'image "22.png")
+    "27.png")
+   (list '(text "Goodbye" 36 "indigo") 'image "26.png")
+   (list '(text "Hello" 24 "olive") 'image "25.png")
+   (list '(line 30 -20 "red") 'image "24.png")
+   (list '(line -30 20 "red") 'image "23.png")
+   (list '(line 30 30 "black") 'image "22.png")
    (list '(star-polygon 20 10 3 "solid" "cornflowerblue") 'image "21.png")
    (list '(star-polygon 40 7 3 "outline" "darkred") 'image "20.png")
    (list '(star-polygon 40 5 2 "solid" "seagreen") 'image "19.png")
    (list '(star 40 "solid" "gray") 'image "18.png")
-   (list '(regular-polygon 20 6 "solid" "red") 'image "17.png")
+   (list '(regular-polygon 20 8 "solid" "red") 'image "17.png")
    (list '(regular-polygon 20 4 "outline" "blue") 'image "16.png")
    (list '(regular-polygon 30 3 "outline" "red") 'image "15.png")
    (list '(rhombus 80 150 "solid" "mediumpurple") 'image "14.png")

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

@@ -128,7 +128,7 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
 
   @image-examples[(regular-polygon 30 3 "outline" "red")
                   (regular-polygon 20 4 "outline" "blue")
-                  (regular-polygon 20 6 "solid" "red")]
+                  (regular-polygon 20 8 "solid" "red")]
 }
 
 @defproc[(star [side-length (and/c real? (not/c negative?))] 
@@ -163,6 +163,15 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
  
 }
 
+@defproc[(line [x1 real?] [y1 real?] [color (or/c symbol? string?)]) image?]{
+  Constructs an image representing a line segment that connects the points
+  (0,0) to (x1,y1).
+  
+  @image-examples[(line 30 30 "black")
+                  (line -30 20 "red")
+                  (line 30 -20 "red")]
+}
+                
 @defproc[(text [string string?] [font-size (and/c integer? (<=/c 1 255))] [color (or/c symbol? string?)])
          image?]{
                 
@@ -459,6 +468,10 @@ Equality testing may contain a few nuances, though:
          
          To combat this problem, use @scheme[equal~?] to compare the images,
          or @scheme[check-within] for test suites involving images.}
+   
+   @item{Combining a series of line segments to form a polygon produces
+         an image that is different than the polygon.}
+   
    @item{In order to make equality on images created with 
          @scheme[text] and @scheme[text/font]
          work well, each string passed to either of those functions results
@@ -476,7 +489,7 @@ Equality testing may contain a few nuances, though:
          For example, the letter combinations ``ff'' and ``fi'' and ``fl'' are
          generally drawn intertwined when they appear together, and thus an ``f''
          drawn separately from an ``i'' looks different than the ligature ``fi''.
-         For example, here is how 24 point Times font looks when the word ``difficult''
+         For example, here is how 24 point Times font looks when the word ``refill''
          is drawn, first with ligatures and then without:
          @centerline{@image["2htdp/scribblings/ligature.png"]}.
          }

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

@@ -633,3 +633,21 @@
                        0.01)
               #t)
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; lines
+;;
+
+(check-equal? (image-width (line 10 20 'black))
+              11)
+(check-equal? (image-height (line 10 20 'black))
+              21)
+
+(check-equal? (round-numbers (rotate 90 (line 10 20 'black)))
+              (round-numbers (line 20 -10 'black)))
+
+(check-equal? (round-numbers (line 20 30 "red"))
+              (round-numbers (rotate 180 (line 20 30 "red"))))
+
+(check-equal? (round-numbers (line -30 20 "red"))
+              (round-numbers (line 30 -20 "red")))