From 3159a06389f212f6a44c202eb5b42a179d7320e4 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 6 Nov 2009 14:34:25 +0000
Subject: [PATCH] (hopefully) sorted out polygons; added a few other
 polygon-based primitives

svn: r16570
---
 collects/2htdp/image.ss                       |   4 +
 collects/2htdp/private/image-more.ss          | 100 ++++++++++++-----
 collects/mrlib/image-core.ss                  |  92 ++++++++++------
 .../teachpack/2htdp/scribblings/image.scrbl   |  42 ++++++++
 collects/tests/2htdp/test-image.ss            | 101 +++++++++++++++++-
 5 files changed, 275 insertions(+), 64 deletions(-)

diff --git a/collects/2htdp/image.ss b/collects/2htdp/image.ss
index 6c82637439..3e1fe09bfc 100644
--- a/collects/2htdp/image.ss
+++ b/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)
\ No newline at end of file
diff --git a/collects/2htdp/private/image-more.ss b/collects/2htdp/private/image-more.ss
index eb45ed09f1..de1a6be7af 100644
--- a/collects/2htdp/private/image-more.ss
+++ b/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)
-                    (string->symbol arg)
-                    arg)])
-       sym
-       #;
-       (if (eq? sym 'outline)
-           1
-           sym))]
+     (if (string? arg)
+         (string->symbol arg)
+         arg)]
     [(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))
-                'number
+                (real? arg)
+                'real\ 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)
-       (real? arg)
+  (and (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))
-  
-  #;
-  (list (make-point 0 0)
-        (make-point (- width 1) 0)
-        (make-point (- width 1) (- height 1))
-        (make-point 0 (- height 1))))
+        (make-point 0 height)))
   
 
 ;;       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 
diff --git a/collects/mrlib/image-core.ss b/collects/mrlib/image-core.ss
index 45bfe0277d..20bbcedb4b 100644
--- a/collects/mrlib/image-core.ss
+++ b/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,12 +314,15 @@ has been moved out).
              (loop (overlay-top shape)
                    dx dy x-scale y-scale bottom))]
       [(polygon? shape)
-       (let ([this-one (make-polygon (map (λ (p)
-                                            (make-point (+ dx (* x-scale (point-x p)))
-                                                        (+ dy (* y-scale (point-y p)))))
-                                          (polygon-points shape))
-                                     (polygon-mode shape)
-                                     (polygon-color 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
+                             (polygon-mode shape)
+                             (polygon-color shape))])
          (if bottom
              (make-overlay bottom (f this-one))
              (f this-one)))]
@@ -330,16 +335,14 @@ has been moved out).
        (error 'normalize-shape "unknown shape ~s\n" shape)])))
 
 (define (atomic-shape? shape)
-  (or (ellipse? shape)
-      (text? shape)
-      (polygon? shape)
-      (bitmap? shape)))
+  (or (polygon? shape)
+      (np-atomic-shape? 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)))
-           (loop (cdr points))))
+           (let* ([vec (make-rectangular (- (point-x (car 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 θ)
-  (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))))
+  (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)))]))
 
 (define (degrees->radians θ)
   (* θ 2 pi (/ 360)))
 
 (define (mode-color->pen mode color)
-  (case mode
-    [(outline) (send the-pen-list find-or-create-pen color 1 'solid)]
-    [(solid) (send the-pen-list find-or-create-pen color 1 'solid)]))
+  (cond
+    [(eq? mode '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
-    [(outline) (send the-brush-list find-or-create-brush "black" 'transparent)]
-    [(solid) (send the-brush-list find-or-create-brush color 'solid)]))
+  (cond
+    [(eq? mode '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%
          
@@ -467,7 +490,7 @@ has been moved out).
          make-text text? text-string text-angle text-font
          make-polygon polygon? polygon-points polygon-mode polygon-color
          make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-scale bitmap-rendered-bitmap
-          
+         
          degrees->radians
          normalize-shape
          ellipse-rotated-size
@@ -477,4 +500,7 @@ has been moved out).
          image-bottom
          image-baseline
          
-         render-image)
\ No newline at end of file
+         render-image)
+
+;; method names
+(provide get-shape get-bb get-normalized?)
diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl
index 1882a46502..062521b264 100644
--- a/collects/teachpack/2htdp/scribblings/image.scrbl
+++ b/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 
diff --git a/collects/tests/2htdp/test-image.ss b/collects/tests/2htdp/test-image.ss
index cfe6b7667c..292f045db1 100644
--- a/collects/tests/2htdp/test-image.ss
+++ b/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
@@ -445,4 +528,16 @@
 (test (rotate 90 (make-object image-snip% blue-10x20-bitmap))
       =>
       (image-snip->image (make-object image-snip% blue-20x10-bitmap)))
-|#
\ No newline at end of file
+|#
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  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))