added a bunch more polygons

svn: r16681

collects/2htdp/image.ss

@@ -67,11 +67,14 @@ and they all have good sample contracts. (It is amazing what we can do with kids
          circle
          ellipse
          rectangle
+         square
+         rhombus
          regular-polygon
          star
          star-polygon
          triangle
          isosceles-triangle
+         right-triangle
          text
          text/font
          

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

@@ -151,14 +151,14 @@
      (if (string? arg)
          (string->symbol arg)
          arg)]
-    [(width height radius)
+    [(width height radius side-length side-length1 side-length2)
      (check-arg fn-name
                 (and (real? arg)
                      (not (negative? arg)))
                 'non-negative-real-number
                 i arg)
      arg]
-    [(dx dy factor x-factor y-factor side-length)
+    [(dx dy factor x-factor y-factor)
      (check-arg fn-name
                 (real? arg)
                 'real\ number
@@ -611,13 +611,21 @@
 ;;       rectangle
 
 (define/chk (rectangle width height mode color)
-  (make-image (make-polygon (rectangle-points width height)
-                            mode
-                            color)
-              (make-bb width
-                       height
-                       height)
-              #f))
+  (make-a-polygon (rectangle-points width height) mode color))
+
+(define/chk (square side-length mode color)
+  (make-a-polygon (rectangle-points side-length side-length) mode color))
+
+(define/chk (rhombus side-length angle mode color)
+  (let* ([left-corner (make-polar side-length (+ (* pi 1/2) (/ (degrees->radians angle) 2)))]
+         [right-corner (make-polar side-length (- (* pi 1/2) (/ (degrees->radians angle) 2)))]
+         [bottom-corner (+ left-corner right-corner)])
+    (make-a-polygon (list (make-point 0 0)
+                          (make-point (real-part right-corner) (imag-part right-corner))
+                          (make-point (real-part bottom-corner) (imag-part bottom-corner))
+                          (make-point (real-part left-corner) (imag-part left-corner)))
+                    mode
+                    color)))
 
 (define (rectangle-points width height)
   (list (make-point 0 0)
@@ -667,6 +675,13 @@
                     mode
                     color)))
 
+(define/chk (right-triangle side-length1 side-length2 mode color)
+  (make-a-polygon (list (make-point 0 (- side-length2))
+                        (make-point 0 0)
+                        (make-point side-length1 0))
+                  mode
+                  color))
+
 (define/chk (triangle side-length mode color)
   (make-polygon/star side-length 3 mode color values))
 
@@ -804,10 +819,13 @@
          circle
          ellipse
          rectangle
+         square
+         rhombus
          
          regular-polygon
          triangle 
          isosceles-triangle
+         right-triangle
          star
          star-polygon
          

collects/mrlib/image-core.ss

@@ -163,25 +163,34 @@ has been moved out).
                   (null? p2-points))
              (and (not (or (null? p1-points)
                            (null? p2-points)))
-                  (or (eq-recur (rotate-to-zero (closest-to-zero p1-points) p1-points)
-                                (rotate-to-zero (closest-to-zero p2-points) p2-points))
-                      (let ([p1-rev (reverse p1-points)])
-                        (eq-recur (rotate-to-zero (closest-to-zero p1-rev) p1-rev)
-                                  (rotate-to-zero (closest-to-zero p2-points) p2-points)))))))))
+                  (or (compare-all-rotations p1-points p2-points eq-recur)
+                      (compare-all-rotations p1-points (reverse p2-points) eq-recur)))))))
 
-(define (rotate-to-zero zero-p points)
-  (let loop ([points points]
-             [acc null])
-    (cond
-      [(equal? (car points) zero-p)
-       (append points (reverse acc))]
-      [else
-       (loop (cdr points)
-             (cons (car points) acc))])))
-
-(define (closest-to-zero points)
-  (car (sort points < #:key (λ (p) (+ (point-x p) (point-y p))))))
 
+;; returns #t when there is some rotation of l1 that is equal to l2
+(define (compare-all-rotations l1 l2 compare)
+  (cond
+    [(and (null? l1) (null? l2)) #t]
+    [else
+     (let ([v1 (list->vector l1)]
+           [v2 (list->vector l2)])
+       (and (= (vector-length v1) 
+               (vector-length v2))
+            (let o-loop ([init 0])
+              (cond
+                [(= init (vector-length v1)) #f]
+                [else
+                 (or (let i-loop ([i 0])
+                       (cond
+                         [(= i (vector-length v2)) 
+                          #t]
+                         [else
+                          (let ([j (modulo (+ init i) (vector-length v1))])
+                            (and (compare (vector-ref v1 j)
+                                          (vector-ref v2 i))
+                                 (i-loop (+ i 1))))]))
+                     (o-loop (+ init 1)))]))))]))
+        
 
 ;                                                   
 ;                                                   
@@ -569,7 +578,7 @@ has been moved out).
          image-baseline
          
          text->font
-         
+         compare-all-rotations
          render-image)
 
 ;; method names

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

@@ -28,18 +28,18 @@
       (ellipse 20 30 "solid" "slateblue")
       (ellipse 20 10 "solid" "navy"))
     'image
-    "41.png")
-   (list '(frame (ellipse 20 20 "outline" "black")) 'image "40.png")
-   (list '(ellipse 60 60 "solid" "blue") 'image "39.png")
-   (list '(scale/xy 3 2 (ellipse 20 30 "solid" "blue")) 'image "38.png")
-   (list '(ellipse 40 60 "solid" "blue") 'image "37.png")
-   (list '(scale 2 (ellipse 20 30 "solid" "blue")) 'image "36.png")
-   (list '(rotate 5 (rectangle 50 50 "outline" "black")) 'image "35.png")
-   (list '(rotate 45 (ellipse 60 20 "solid" "olivedrab")) 'image "34.png")
+    "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")
    (list
     '(beside/places "baseline" (text "ijy" 18 "black") (text "ijy" 24 "black"))
     'image
-    "33.png")
+    "38.png")
    (list
     '(beside/places
       "center"
@@ -48,7 +48,7 @@
       (ellipse 20 30 "solid" "purple")
       (ellipse 20 10 "solid" "indigo"))
     'image
-    "32.png")
+    "37.png")
    (list
     '(beside/places
       "bottom"
@@ -57,7 +57,7 @@
       (ellipse 20 30 "solid" "slateblue")
       (ellipse 20 10 "solid" "navy"))
     'image
-    "31.png")
+    "36.png")
    (list
     '(beside
       (ellipse 20 70 "solid" "gray")
@@ -65,7 +65,7 @@
       (ellipse 20 30 "solid" "dimgray")
       (ellipse 20 10 "solid" "black"))
     'image
-    "30.png")
+    "35.png")
    (list
     '(overlay/xy
       (rectangle 10 10 "solid" "red")
@@ -73,7 +73,7 @@
       -10
       (rectangle 10 10 "solid" "black"))
     'image
-    "29.png")
+    "34.png")
    (list
     '(overlay/xy
       (rectangle 10 10 "solid" "red")
@@ -81,7 +81,7 @@
       10
       (rectangle 10 10 "solid" "black"))
     'image
-    "28.png")
+    "33.png")
    (list
     '(overlay/xy
       (rectangle 10 10 "outline" "red")
@@ -89,7 +89,7 @@
       0
       (rectangle 10 10 "outline" "black"))
     'image
-    "27.png")
+    "32.png")
    (list
     '(overlay/xy
       (ellipse 40 40 "outline" "black")
@@ -97,7 +97,7 @@
       25
       (ellipse 10 10 "solid" "forestgreen"))
     'image
-    "26.png")
+    "31.png")
    (list
     '(overlay/places
       "right"
@@ -107,7 +107,7 @@
       (rectangle 40 40 "solid" "red")
       (rectangle 50 50 "solid" "black"))
     'image
-    "25.png")
+    "30.png")
    (list
     '(overlay/places
       "middle"
@@ -115,7 +115,7 @@
       (rectangle 30 60 "solid" "orange")
       (ellipse 60 30 "solid" "purple"))
     'image
-    "24.png")
+    "29.png")
    (list
     '(overlay
       (ellipse 10 10 "solid" "red")
@@ -125,40 +125,45 @@
       (ellipse 50 50 "solid" "red")
       (ellipse 60 60 "solid" "black"))
     'image
-    "23.png")
+    "28.png")
    (list
     '(overlay
       (ellipse 60 30 "solid" "purple")
       (rectangle 30 60 "solid" "orange"))
     'image
-    "22.png")
+    "27.png")
    (list
     '(text/font "not really a link" 18 "blue" #f 'roman 'normal 'normal #t)
     'image
-    "21.png")
+    "26.png")
    (list
     '(text/font "Goodbye" 18 "indigo" #f 'modern 'italic 'normal #f)
     'image
-    "20.png")
+    "25.png")
    (list
     '(text/font "Hello" 24 "olive" "Gill Sans" 'swiss 'normal 'bold #f)
     'image
-    "19.png")
-   (list '(text "Goodbye" 36 "indigo") 'image "18.png")
-   (list '(text "Hello" 24 "olive") 'image "17.png")
-   (list '(star-polygon 20 10 3 "solid" "cornflowerblue") 'image "16.png")
-   (list '(star-polygon 40 7 3 "outline" "darkred") 'image "15.png")
-   (list '(star-polygon 40 5 2 "solid" "seagreen") 'image "14.png")
-   (list '(star 40 "solid" "gray") 'image "13.png")
-   (list '(isosceles-triangle 60 330 "solid" "lightseagreen") 'image "12.png")
-   (list '(isosceles-triangle 60 30 "solid" "aquamarine") 'image "11.png")
-   (list '(isosceles-triangle 200 170 "solid" "seagreen") 'image "10.png")
-   (list '(triangle 40 "solid" "tan") 'image "9.png")
-   (list '(regular-polygon 20 6 "solid" "red") 'image "8.png")
-   (list '(regular-polygon 20 4 "outline" "blue") 'image "7.png")
-   (list '(regular-polygon 30 3 "outline" "red") 'image "6.png")
-   (list '(rectangle 20 40 "solid" 'blue) 'image "5.png")
-   (list '(rectangle 40 20 "outline" 'black) 'image "4.png")
+    "24.png")
+   (list '(text "Goodbye" 36 "indigo") 'image "23.png")
+   (list '(text "Hello" 24 "olive") '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 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")
+   (list '(rhombus 40 45 "solid" "magenta") 'image "13.png")
+   (list '(rectangle 20 40 "solid" "blue") 'image "12.png")
+   (list '(rectangle 40 20 "outline" "black") 'image "11.png")
+   (list '(square 50 "outline" "darkmagenta") 'image "10.png")
+   (list '(square 40 "solid" "slateblue") 'image "9.png")
+   (list '(isosceles-triangle 60 330 "solid" "lightseagreen") 'image "8.png")
+   (list '(isosceles-triangle 60 30 "solid" "aquamarine") 'image "7.png")
+   (list '(isosceles-triangle 200 170 "solid" "seagreen") 'image "6.png")
+   (list '(right-triangle 36 48 "solid" "black") 'image "5.png")
+   (list '(triangle 40 "solid" "tan") 'image "4.png")
    (list '(ellipse 20 40 "solid" "blue") 'image "3.png")
    (list '(ellipse 40 20 "outline" "black") 'image "2.png")
    (list '(circle 20 "solid" "blue") 'image "1.png")

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

@@ -23,7 +23,7 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
 
 @section{Basic Images}
 
-@defproc[(circle [radius (and/c real? positive?)] 
+@defproc[(circle [radius (and/c real? (not/c negative?))] 
                  [mode mode?]
                  [color (or/c symbol? string?)])
          image?]{
@@ -35,7 +35,10 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
 }
 
 
-@defproc[(ellipse [width (and/c real? positive?)] [height (and/c real? positive?)] [mode mode?] [color (or/c symbol? string?)]) image?]{
+@defproc[(ellipse [width (and/c real? (not/c negative?))]
+                  [height (and/c real? (not/c negative?))]
+                  [mode mode?] 
+                  [color (or/c symbol? string?)]) image?]{
   Constructs an ellipsis with the given width, height, mode, and color.
   
   @image-examples[(ellipse 40 20 "outline" "black")
@@ -43,25 +46,7 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
   
 }
 
-@defproc[(rectangle [width real?] [height real?] [mode mode?] [color (or/c symbol? string?)]) image?]{
-  Constructs a rectangle with the given width, height, mode, and color.
-  @image-examples[(rectangle 40 20 "outline" 'black)
-                  (rectangle 20 40 "solid" 'blue)]
-}
-
-@defproc[(regular-polygon [side-length (and/c positive? real?)] 
-                          [side-count side-count?]
-                          [mode mode?]
-                          [color (or/c symbol? string?)])
-         image?]{
-  Constructs a regular polygon with @scheme[side-count] sides.
-
-  @image-examples[(regular-polygon 30 3 "outline" "red")
-                  (regular-polygon 20 4 "outline" "blue")
-                  (regular-polygon 20 6 "solid" "red")]
-}
-
-@defproc[(triangle [side-length (and/c positive? real?)] 
+@defproc[(triangle [side-length (and/c real? (not/c negative?))] 
                    [mode mode?]
                    [color (or/c symbol? string?)])
          image?]{
@@ -73,7 +58,19 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
 @image-examples[(triangle 40 "solid" "tan")]
 }
 
-@defproc[(isosceles-triangle [side-length (and/c positive? real?)] 
+@defproc[(right-triangle [side-length1 (and/c real? (not/c negative?))]
+                         [side-length2 (and/c real? (not/c negative?))]
+                         [mode mode?]
+                         [color (or/c symbol? string?)])
+         image?]{
+                 
+  Constructs a triangle with a right angle where the two sides adjacent
+  to the right angle have lengths @scheme[side-length1] and @scheme[side-length2].
+
+  @image-examples[(right-triangle 36 48 "solid" "black")]
+}
+                
+@defproc[(isosceles-triangle [side-length (and/c real? (not/c negative?))] 
                              [angle angle?]
                              [mode mode?]
                              [color (or/c symbol? string?)])
@@ -89,8 +86,52 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
                  (isosceles-triangle 60 30 "solid" "aquamarine")
                  (isosceles-triangle 60 330 "solid" "lightseagreen")]
 }
-                
-@defproc[(star [side-length (and/c real? positive?)] 
+
+
+@defproc[(square [side-length (and/c real? (not/c negative?))]
+                 [mode mode?]
+                 [color (or/c symbol? string?)])
+         image?]{
+
+ Constructs a square.
+ 
+ @image-examples[(square 40 "solid" "slateblue")
+                 (square 50 "outline" "darkmagenta")]
+
+}
+
+@defproc[(rectangle [width real?] [height real?] [mode mode?] [color (or/c symbol? string?)]) image?]{
+  Constructs a rectangle with the given width, height, mode, and color.
+  @image-examples[(rectangle 40 20 "outline" "black")
+                  (rectangle 20 40 "solid" "blue")]
+}
+
+@defproc[(rhombus [side-length (and/c real? (not/c negative?))]
+                  [angle angle?]
+                  [mode mode?]
+                  [color (or/c symbol? string?)])
+         image?]{
+                 
+Constructs a four sided polygon with all equal sides and thus where opposite angles are equal to each
+other. The top and bottom pair of angles is @scheme[angle] and the left and right are @scheme[(- 180 angle)].
+
+@image-examples[(rhombus 40 45 "solid" "magenta")
+                (rhombus 80 150 "solid" "mediumpurple")]
+}
+
+@defproc[(regular-polygon [side-length (and/c real? (not/c negative?))] 
+                          [side-count side-count?]
+                          [mode mode?]
+                          [color (or/c symbol? string?)])
+         image?]{
+  Constructs a regular polygon with @scheme[side-count] sides.
+
+  @image-examples[(regular-polygon 30 3 "outline" "red")
+                  (regular-polygon 20 4 "outline" "blue")
+                  (regular-polygon 20 6 "solid" "red")]
+}
+
+@defproc[(star [side-length (and/c real? (not/c negative?))] 
                [mode mode?]
                [color (or/c symbol? string?)])
          image?]{
@@ -101,7 +142,7 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
   
 }
 
-@defproc[(star-polygon [side-length (and/c real? positive?)]
+@defproc[(star-polygon [side-length (and/c real? (not/c negative?))]
                        [side-count side-count?]
                        [step-count step-count?]
                        [mode mode?]

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

@@ -68,6 +68,28 @@
           (map loop (cdr (vector->list (struct->vector x))))))]
       [else x])))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  compare-all-rotations
+;;
+
+(check-equal? (compare-all-rotations '() '() equal?)
+              #t)
+(check-equal? (compare-all-rotations '(1) '(1) equal?)
+              #t)
+(check-equal? (compare-all-rotations '(1) '(2) equal?)
+              #f)
+(check-equal? (compare-all-rotations '(1 2 3) '(1 2 3) equal?)
+              #t)
+(check-equal? (compare-all-rotations '(1 2 3) '(2 3 1) equal?)
+              #t)
+(check-equal? (compare-all-rotations '(1 2 3) '(3 1 2) equal?)
+              #t)
+(check-equal? (compare-all-rotations '(1 2 3 4) '(4 1 2 3) equal?)
+              #t)
+(check-equal? (compare-all-rotations '(1 2 3 5) '(4 1 2 3) equal?)
+              #f)
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;; circle vs ellipse
@@ -393,11 +415,9 @@
 (test (bring-between 720 360) => 0)
 (test (bring-between 720.5 360) => .5)
 
-(test (round-numbers
-       (normalize-shape (image-shape (rotate 90 (rectangle 100 100 'solid 'blue)))
-                        values))
+(test (round-numbers (rotate 90 (rectangle 100 100 'solid 'blue)))
       =>
-      (round-numbers (image-shape (rectangle 100 100 'solid 'blue))))
+      (round-numbers (rectangle 100 100 'solid 'blue)))
 
 (test (round-numbers
        (normalize-shape (image-shape (rotate 90 (rotate 90 (rectangle 50 100 'solid 'purple))))
@@ -572,3 +592,44 @@
                  (image-width (rotate 45 (rectangle (image-width t) 
                                                     (image-height t)
                                                     'solid 'black))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; triangle
+;;
+
+(check-equal? (round-numbers (rotate 180 (isosceles-triangle 60 330 "solid" "lightseagreen")))
+              (round-numbers (isosceles-triangle 60 30 "solid" "lightseagreen")))
+
+(check-equal? (triangle 40 'outline 'black)
+              (regular-polygon 40 3 'outline 'black))
+
+(check-equal? (equal~? (rotate (+ 180 45) (right-triangle 50 50 'solid 'black))
+                       (isosceles-triangle 50 90 'solid 'black)
+                       0.001)
+              #t)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; square
+;;
+
+(check-equal? (square 10 'solid 'black)
+              (rectangle 10 10 'solid 'black))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; rhombus
+;;
+
+(check-equal? (equal~? (rhombus 10 90 'solid 'black)
+                       (square 10 'solid 'black)
+                       0.01)
+              #t)
+
+(check-equal? (equal~? (rhombus 50 150 'solid 'black)
+                       (rotate 90 (rhombus 50 30 'solid 'black))
+                       0.01)
+              #t)
+