(hopefully) sorted out polygons; added a few other polygon-based primitives

svn: r16570

collects/2htdp/image.ss

@@ -66,12 +66,16 @@ and they all have good sample contracts. (It is amazing what we can do with kids
          
          ellipse
          rectangle
+         regular-polygon
+         star
+         triangle
          
          x-place?
          y-place?
          image?
          mode?
          angle?
+         side-count?
          
          image-width
          image-height)

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

@@ -1,6 +1,6 @@
 #lang scheme/base
 
-(require mrlib/image-core
+(require "../../mrlib/image-core.ss"
          scheme/class
          scheme/gui/base
          htdp/error
@@ -34,9 +34,16 @@
          y-place?
          mode?
          angle?
+         side-count?
          
          image-width
-         image-height)
+         image-height
+         
+         regular-polygon
+         triangle 
+         star
+         
+         swizzle)
 
 
 (define (show-image g [extra-space 0])
@@ -168,26 +175,26 @@
                 'mode
                 i
                 arg)
-     (let ([sym (if (string? arg)
+     (if (string? arg)
          (string->symbol arg)
-                    arg)])
+         arg)]
-       sym
-       #;
-       (if (eq? sym 'outline)
-           1
-           sym))]
     [(width height)
      (check-arg fn-name
-                (and (number? arg)
+                (and (real? arg)
                      (not (negative? arg)))
-                'non-negative-number
+                'non-negative-real-number
                 i arg)
      arg]
-    [(dx dy factor x-factor y-factor)
+    [(dx dy factor x-factor y-factor side-length)
      (check-arg fn-name
-                (and (number? arg)
+                (real? arg)
-                     (real? arg))
+                'real\ number
-                'number
+                i arg)
+     arg]
+    [(side-count)
+     (check-arg fn-name
+                (side-count? arg)
+                'side-count
                 i arg)
      arg]
     [(angle)
@@ -220,9 +227,11 @@
 (define (mode? arg)
   (member arg '(solid outline "solid" "outline")))
 (define (angle? arg)
-  (and (number? arg)
+  (and (real? arg)
-       (real? arg)
        (< -360 arg 360)))
+(define (side-count? i)
+  (and (integer? i)
+       (3 . <= .  i)))
 
 (define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
   (make-image (make-bitmap bm mask-bm 0 1 #f)
@@ -464,15 +473,15 @@
                  (+ r dx)
                  (+ b dy))))]))
 
+
 (define (atomic-bb atomic-shape)
   (cond
     [(ellipse? atomic-shape)
      (let-values ([(w h) (ellipse-rotated-size (ellipse-width atomic-shape)
                                                (ellipse-height atomic-shape)
-                                               (ellipse-angle atomic-shape))])
+                                               (degrees->radians (ellipse-angle atomic-shape)))])
        (values 0 0 w h))]
     [else
-     (fprintf (current-error-port) "BAD BOUNDING BOX\n")
      (values 0 0 100 100)]))
   
 ;; rotate-simple : angle simple-shape -> simple-shape
@@ -588,13 +597,7 @@
   (list (make-point 0 0)
         (make-point width 0)
         (make-point width height)
-        (make-point 0 height))
+        (make-point 0 height)))
-  
-  #;
-  (list (make-point 0 0)
-        (make-point (- width 1) 0)
-        (make-point (- width 1) (- height 1))
-        (make-point 0 (- height 1))))
   
 
 ;;       circle
@@ -603,7 +606,48 @@
 ;;       line
 ;;       star
 ;;       text
-;;       regular-polygon
+
+(define/chk (triangle side-length mode color)
+  (make-polygon/star side-length 3 mode color values))
+(define/chk (regular-polygon side-length side-count mode color)
+  (make-polygon/star side-length side-count mode color values))
+(define/chk (star side-length mode color)
+  (make-polygon/star side-length 5 mode color swizzle))
+
+(define (make-polygon/star side-length side-count mode color adjust)
+  (let ([poly (make-polygon 
+               (adjust (regular-polygon-points side-length side-count))
+               mode
+               color)])
+    (let-values ([(l t r b) (simple-bb poly)])
+      (printf "l ~s t ~s r ~s b ~s\n" l t r b)
+      (make-image (make-translate (- l) (- t) poly)
+                  (make-bb (- r l) (- b t) (- b t))
+                  #f))))
+
+;; swizzle : (listof X)[odd-length] -> (listof X)
+;; returns a list with the same elements, 
+;; but reordered so the even elements come first 
+;; and then the odd elements afterwards
+(define (swizzle l)
+  (let ([v (list->vector l)])
+    (let loop ([i 0])
+      (cond
+        [(= i (vector-length v)) '()]
+        [else
+         (cons (vector-ref v (modulo (* i 2) (vector-length v)))
+               (loop (+ i 1)))]))))
+
+;; regular-polygon-points : number number -> (listof point)
+(define (regular-polygon-points side-length side-count)
+  (let loop ([p (make-rectangular 0 0)]
+             [i 0])
+    (cond
+      [(= i side-count) '()]
+      [else (cons (make-point (real-part p) (imag-part p)) 
+                  (loop (+ p (make-polar side-length
+                                         (* -1 (* 2 pi) (/ i side-count))))
+                        (+ i 1)))])))
 
 (define/chk (ellipse width height mode color)
   (make-image (make-ellipse width height 

collects/mrlib/image-core.ss

@@ -7,7 +7,7 @@ teachpack that has to be shared between drscheme
 and the user's program to make copy and paste
 work right.
 
-Most of the exports are jsut for use in 2htdp/image
+Most of the exports are just for use in 2htdp/image
 (technically, 2htdp/private/image-more). The main
 use of this library is the snip class addition it
 does (and any code that that does not depend on
@@ -125,7 +125,7 @@ has been moved out).
 
 ;; a polygon is:
 ;;
-;;  - (make-polygon (listof points) angle pen brush)
+;;  - (make-polygon (listof vector) mode color)
 (define-struct/reg-mk polygon (points mode color) #:transparent #:omit-define-syntaxes
   #:property prop:equal+hash 
   (list (λ (a b rec) (polygon-equal? a b rec)) (λ (x y) 42) (λ (x y) 3)))
@@ -140,6 +140,8 @@ has been moved out).
 
 ;; an angle is a number between 0 and 360 (degrees)
 
+;; a mode is either 'solid or 'outline (indicating a pen width for outline mode)
+
 (define (polygon-equal? p1 p2 eq-recur)
   (and (eq-recur (polygon-mode p1) (polygon-mode p2))
        (eq-recur (polygon-color p1) (polygon-color p2))
@@ -312,10 +314,13 @@ has been moved out).
              (loop (overlay-top shape)
                    dx dy x-scale y-scale bottom))]
       [(polygon? shape)
-       (let ([this-one (make-polygon (map (λ (p)
+       (let* ([scaled-points
+               (map (λ (p)
                       (make-point (+ dx (* x-scale (point-x p)))
                                   (+ dy (* y-scale (point-y p)))))
-                                          (polygon-points shape))
+                    (polygon-points shape))]
+              [this-one 
+               (make-polygon scaled-points
                              (polygon-mode shape)
                              (polygon-color shape))])
          (if bottom
@@ -330,16 +335,14 @@ has been moved out).
        (error 'normalize-shape "unknown shape ~s\n" shape)])))
 
 (define (atomic-shape? shape)
-  (or (ellipse? shape)
+  (or (polygon? shape)
-      (text? shape)
+      (np-atomic-shape? shape)))
-      (polygon? shape)
-      (bitmap? shape)))
 
 (define (np-atomic-shape? shape)
   (or (ellipse? shape)
       (text? shape)
-      (bitmap? shape)))
+      (bitmap? shape)
-
+      (point? shape)))
 
 (define (scale-np-atomic x-scale y-scale shape)
   (cond
@@ -396,10 +399,16 @@ has been moved out).
      (let ([path (new dc-path%)]
            [points (polygon-points simple-shape)])
        (send path move-to (point-x (car points)) (point-y (car points)))
-       (let loop ([points (cdr points)])
+       (let loop ([point (make-rectangular (point-x (car points)) (point-y (car points)))]
+                  [points (cdr points)])
          (unless (null? points)
-           (send path line-to (point-x (car points)) (point-y (car points)))
+           (let* ([vec (make-rectangular (- (point-x (car points))
-           (loop (cdr points))))
+                                            (real-part point))
+                                         (- (point-y (car points))
+                                            (imag-part point)))]
+                  [endpoint (+ point vec (make-polar -1 (angle vec)))])
+           (send path line-to (real-part endpoint) (imag-part endpoint))
+           (loop endpoint (cdr points)))))
        (send path line-to (point-x (car points)) (point-y (car points)))
        (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)))
@@ -413,7 +422,7 @@ has been moved out).
           (let* ([path (new dc-path%)]
                  [ew (ellipse-width atomic-shape)]
                  [eh (ellipse-height atomic-shape)]
-                 [θ (ellipse-angle atomic-shape)])
+                 [θ (degrees->radians (ellipse-angle atomic-shape))])
             (let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)])
               (send path ellipse 0 0 ew eh)
               (send path translate (- (/ ew 2)) (- (/ eh 2)))
@@ -435,26 +444,40 @@ has been moved out).
             (send dc draw-text (text-string atomic-shape) dx dy #f 0 angle))]))]))
 
 (define (ellipse-rotated-size ew eh θ)
+  (cond
+    [(and (zero? ew) (zero? eh))
+     (values 0 0)]
+    [(zero? eh)
+     (values (* (cos θ) ew)
+             (* (sin θ) ew))]
+    [(zero? ew)
+     (values (* (sin θ) eh)
+             (* (cos θ) eh))]
+    [else
      (let* ([t1 (atan (/ eh ew (exact->inexact (tan θ))))]
             ; a*cos(t1),b*sin(t1) is the point on *original* ellipse which gets rotated to top.
             [t2 (atan (/ (* (- eh) (tan θ)) ew))] ; the original point rotated to right side.
             [rotated-height (+ (* ew (sin θ) (cos t1)) (* eh (cos θ) (sin t1)))]
             [rotated-width  (- (* ew (cos θ) (cos t2)) (* eh (sin θ) (sin t2)))])
        (values (abs rotated-width)
-            (abs rotated-height))))
+               (abs rotated-height)))]))
 
 (define (degrees->radians θ)
   (* θ 2 pi (/ 360)))
 
 (define (mode-color->pen mode color)
-  (case mode
+  (cond
-    [(outline) (send the-pen-list find-or-create-pen color 1 'solid)]
+    [(eq? mode 'solid)
-    [(solid) (send the-pen-list find-or-create-pen color 1 'solid)]))
+     (send the-pen-list find-or-create-pen "black" 1 'transparent)]
+    [else
+     (send the-pen-list find-or-create-pen color 1 'solid)]))
 
 (define (mode-color->brush mode color)
-  (case mode
+  (cond
-    [(outline) (send the-brush-list find-or-create-brush "black" 'transparent)]
+    [(eq? mode 'solid)
-    [(solid) (send the-brush-list find-or-create-brush color 'solid)]))
+     (send the-brush-list find-or-create-brush color 'solid)]
+    [else
+     (send the-brush-list find-or-create-brush "black" 'transparent)]))
 
 (provide make-image image-shape image-bb image-normalized? image%
          
@@ -478,3 +501,6 @@ has been moved out).
          image-baseline
          
          render-image)
+
+;; method names
+(provide get-shape get-bb get-normalized?)

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

@@ -30,6 +30,33 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
   Constructs a rectangle with the given width, height, mode, and color.
 }
 
+@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.
+}
+
+@defproc[(star [side-length (and/c positive? real?)] 
+               [mode mode?]
+               [color (or/c symbol? string?)])
+         image?]{
+  Constructs a star with five points. The @scheme[side-length] argument 
+  determines the side length of the enclosing pentagon.
+}
+
+@defproc[(triangle [side-length (and/c positive? real?)] 
+                   [mode mode?]
+                   [color (or/c symbol? string?)])
+         image?]{
+  Constructs a upward-pointing equilateral triangle. 
+  The @scheme[side-length] argument 
+  determines the 
+  length of the side of the triangle.
+}
+
+                
 @section{Overlaying Images}
 
 @defproc[(overlay [i1 image?] [i2 image?] [is image?] ...) image?]{
@@ -96,6 +123,16 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
   certain sub-images appear within some larger image.
 }
 
+@section{Image Properties}
+
+@defproc[(image-width [i image?]) (and/c number? positive?)]{
+  Returns the width of @scheme[i].
+}
+
+@defproc[(image-height [i image?]) (and/c number? positive?)]{
+  Returns the height of @scheme[i].
+}
+
 @section{Image Predicates}
 
 This section lists predicates for the basic structures provided by the image library.
@@ -152,6 +189,11 @@ This section lists predicates for the basic structures provided by the image lib
   and @scheme[360] (exclusive).
 }
 
+@defproc[(side-count? [x any/c]) boolean?]{
+  Determines if @scheme[x] is an integer 
+  greater than or equal to @scheme[3].
+}
+
 @section{Equality Testing of Images}
 
 Image equality testing is done structurally, i.e., based on 

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

@@ -4,14 +4,19 @@
          scheme/math
          scheme/class
          scheme/gui/base
-         tests/eli-tester)
+         schemeunit)
 
-;(define-syntax-rule (test a => b) (begin a b))
+(define-syntax-rule (test a => b) (check-equal? a b))
 
 ;; test case: (beside (text "a"...) (text "b" ...)) vs (text "ab")
 
 ;(show-image (frame (rotate 30 (ellipse 200 400 'solid 'purple))))
 
+(define-simple-check (check-close a b)
+  (and (number? a)
+       (number? b)
+       (< (abs (- a b)) 0.001)))
+
 #;
 (show-image
  (overlay/xy (rectangle 100 10 'solid 'red)
@@ -63,6 +68,84 @@
           (map loop (cdr (vector->list (struct->vector x))))))]
       [else x])))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; width and height
+;;
+
+(test (image-width (rectangle 10 20 'solid 'blue))
+      =>
+      10)
+(test (image-height (rectangle 10 20 'solid 'blue))
+      =>
+      20)
+(test (image-width (rectangle 0 100 'solid 'blue))
+      =>
+      0)
+(test (image-height (rectangle 0 100 'solid 'blue))
+      =>
+      100)
+(test (image-width (rectangle 100 0 'solid 'blue))
+      =>
+      100)
+(test (image-height (rectangle 100 0 'solid 'blue))
+      =>
+      0)
+
+(check-close (image-width (rotate 45 (rectangle 100 0 'solid 'blue)))
+             (* (sin (* pi 1/4)) 100))
+(check-close (image-height (rotate 45 (rectangle 100 0 'solid 'blue)))
+             (* (sin (* pi 1/4)) 100))
+(check-close (image-width (rotate 45 (rectangle 0 100 'solid 'blue)))
+             (* (sin (* pi 1/4)) 100))
+(check-close (image-height (rotate 45 (rectangle 0 100 'solid 'blue)))
+             (* (sin (* pi 1/4)) 100))
+
+(test (image-width (scale 4 (rectangle 10 10 'outline 'black)))
+      =>
+      40)
+(test (image-width (rotate 90 (scale 4 (rectangle 10 10 'outline 'black))))
+      =>
+      40.0)
+
+(test (image-width (scale 4 (rectangle 10 10 'solid 'black)))
+      =>
+      40)
+(test (image-width (rotate 90 (scale 4 (rectangle 10 10 'solid 'black))))
+      =>
+      40.0)
+
+
+(test (image-width (ellipse 10 20 'solid 'blue))
+      =>
+      10)
+(test (image-height (ellipse 10 20 'solid 'blue))
+      =>
+      20)
+(test (image-width (ellipse 0 100 'solid 'blue))
+      =>
+      0)
+(test (image-height (ellipse 0 100 'solid 'blue))
+      =>
+      100)
+(test (image-width (ellipse 100 0 'solid 'blue))
+      =>
+      100)
+(test (image-height (ellipse 100 0 'solid 'blue))
+      =>
+      0)
+
+(test (image-width (rotate 30 (ellipse 100 0 'solid 'blue)))
+      =>
+      (* (cos (* pi 1/6)) 100))
+(test (image-height (rotate 30 (ellipse 100 0 'solid 'blue)))
+      =>
+      (* (sin (* pi 1/6)) 100))
+(check-close (image-width (rotate 30 (ellipse 0 100 'solid 'blue)))
+             (* (sin (* pi 1/6)) 100))
+(check-close (image-height (rotate 30 (ellipse 0 100 'solid 'blue)))
+             (* (cos (* pi 1/6)) 100))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;;  testing overlays
@@ -446,3 +529,15 @@
       =>
       (image-snip->image (make-object image-snip% blue-20x10-bitmap)))
 |#
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  regular polygon
+;;
+
+(check-equal? (round-numbers (regular-polygon 100 4 'outline 'green))
+              (round-numbers (rectangle 100 100 'outline 'green)))
+
+(check-equal? (swizzle (list 0 1 2 3 4))
+              (list 0 2 4 1 3))