From 7b742e7c655efb845211aae428fa29e149d7eac2 Mon Sep 17 00:00:00 2001
From: Stephen Bloch <sbloch@adelphi.edu>
Date: Tue, 31 Dec 2013 13:41:42 -0500
Subject: [PATCH] Added add-polygon and scene+polygon functions.

---
 .../teachpack/2htdp/scribblings/image.scrbl   |  78 +++++++++++
 pkgs/htdp-pkgs/htdp-lib/2htdp/image.rkt       |   2 +
 .../htdp-lib/2htdp/private/image-more.rkt     |  24 ++++
 .../htdp-test/2htdp/tests/test-image.rkt      | 121 ++++++++++++++++++
 4 files changed, 225 insertions(+)

diff --git a/pkgs/htdp-pkgs/htdp-doc/teachpack/2htdp/scribblings/image.scrbl b/pkgs/htdp-pkgs/htdp-doc/teachpack/2htdp/scribblings/image.scrbl
index 34779a4ad4..d930d91215 100644
--- a/pkgs/htdp-pkgs/htdp-doc/teachpack/2htdp/scribblings/image.scrbl
+++ b/pkgs/htdp-pkgs/htdp-doc/teachpack/2htdp/scribblings/image.scrbl
@@ -689,6 +689,83 @@ the @racket[point-count] argument determines how many points the star has.
                     (make-pen "darkslategray" 10 "solid" "projecting" "miter")))]
 }
 
+@defproc[(add-polygon [image image?]
+                   [posns (listof posn?)]
+                   [mode mode?]
+                   [color image-color?])
+         image?]{
+  Adds a closed polygon to the image @racket[image], with vertices as specified in @racket[posns] (relative to the top-left corner of @racket[image]).  Unlike @racket[scene+polygon], if the polygon goes outside the bounds of @racket[image], the result is enlarged to accommodate both.
+
+@mode/color-and-nitty-text
+
+@image-examples[(add-polygon (rectangle 55 34 "solid" "light blue")
+                          (list (make-posn 50 10)
+                                (make-posn 20 15)
+                                (make-posn 50 20)
+                                (make-posn 10 25)
+                                (make-posn 35 30))
+                          "outline" "red")
+                (add-polygon (square 65 "solid" "light blue")
+                          (list (make-posn 30 -20)
+                                (make-posn 50 50)
+                                (make-posn -20 30))
+                          "solid" "forest green")
+                (add-polygon (square 180 "solid" "yellow")
+                          (list
+                           (make-posn 109 160)
+                           (make-posn 26 148)
+                           (make-posn 46 36)
+                           (make-posn 93 44)
+                           (make-posn 89 68)
+                           (make-posn 122 72))
+                          "outline" "dark blue")
+                (add-polygon (square 50 "solid" "light blue")
+                          (list (make-posn 25 -10)
+                                (make-posn 60 25)
+                                (make-posn 25 60)
+                                (make-posn -10 25))
+                          "solid" "pink")]
+                                     }
+
+@defproc[(scene+polygon [image image?]
+                     [posns (listof posn?)]
+                     [mode mode?]
+                     [color image-color?])
+         image?]{
+  Adds a closed polygon to the image @racket[image], with vertices as specified in @racket[posns] (relative to the top-left corner of @racket[image]).  Unlike @racket[add-polygon], if the polygon goes outside the bounds of @racket[image], the result is clipped to @racket[image].
+                                     
+@crop-warning
+
+@image-examples[(scene+polygon (rectangle 55 34 "solid" "light blue")
+                          (list (make-posn 50 10)
+                                (make-posn 20 15)
+                                (make-posn 50 20)
+                                (make-posn 10 25)
+                                (make-posn 35 30))
+                          "outline" "red")
+                (scene+polygon (square 65 "solid" "light blue")
+                          (list (make-posn 30 -20)
+                                (make-posn 50 50)
+                                (make-posn -20 30))
+                          "solid" "forest green")
+                (scene+polygon (square 180 "solid" "yellow")
+                          (list
+                           (make-posn 109 160)
+                           (make-posn 26 148)
+                           (make-posn 46 36)
+                           (make-posn 93 44)
+                           (make-posn 89 68)
+                           (make-posn 122 72))
+                          "outline" "dark blue")
+                (scene+polygon (square 50 "solid" "light blue")
+                          (list (make-posn 25 -10)
+                                (make-posn 60 25)
+                                (make-posn 25 60)
+                                (make-posn -10 25))
+                          "solid" "pink")]
+                                     }
+
+
 @section{Overlaying Images}
 
 @defproc[(overlay [i1 image?] [i2 image?] [is image?] ...) image?]{
@@ -1164,6 +1241,7 @@ a black outline.
                    (make-pen "goldenrod" 30 "solid" "round" "round"))]
 }
 
+
 @defproc[(scene+curve [scene image?] 
                       [x1 real?] [y1 real?] [angle1 angle?] [pull1 real?]
                       [x2 real?] [y2 real?] [angle2 angle?] [pull2 real?]
diff --git a/pkgs/htdp-pkgs/htdp-lib/2htdp/image.rkt b/pkgs/htdp-pkgs/htdp-lib/2htdp/image.rkt
index c4c310cb0d..a0cfe27c50 100644
--- a/pkgs/htdp-pkgs/htdp-lib/2htdp/image.rkt
+++ b/pkgs/htdp-pkgs/htdp-lib/2htdp/image.rkt
@@ -95,8 +95,10 @@ and they all have good sample contracts. (It is amazing what we can do with kids
          right-triangle
          line
          add-line
+         add-polygon
          add-curve
          scene+line
+         scene+polygon
          scene+curve
          text
          text/font
diff --git a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt
index 2d5b381f14..7937f5f1c4 100644
--- a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt
+++ b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt
@@ -472,6 +472,19 @@
                 #f
                 (send image get-pinhole))))
 
+(define/chk (scene+polygon image posns mode color)
+  (check-mode/color-combination 'scene+polygon 4 mode color)
+  (when (null? posns) (error 'scene+polygon "must have at least one posn"))
+  (make-image (make-overlay
+               (make-crop (rectangle-points (get-right image) (get-bottom image))
+                          (make-polygon (map (lambda (p) (make-point (posn-x p) (posn-y p))) posns)
+                                        mode color))
+               (image-shape image))
+              (image-bb image)
+              #f
+              (send image get-pinhole)))
+    
+
 (define/chk (scene+curve image x1 y1 angle1 pull1 x2 y2 angle2 pull2 color)
   (let* ([dx (abs (min 0 x1 x2))]
          [dy (abs (min 0 y1 y2))])
@@ -995,6 +1008,15 @@
                 #f
                 (send image get-pinhole))))
 
+(define/chk (add-polygon image posns mode color)
+  (if (null? posns)
+      (error 'add-polygon "must have at least one posn")
+      (let ((left (apply min (map posn-x posns)))
+            (top (apply min (map posn-y posns)))
+            (poly (polygon posns mode color)))
+        (overlay/xy poly (- left) (- top) image)
+        )))
+
 (define/chk (add-curve image x1 y1 angle1 pull1 x2 y2 angle2 pull2 color)
   (define cs (make-curve-segment (make-point x1 y1) angle1 pull1
                                  (make-point x2 y2) angle2 pull2
@@ -1533,8 +1555,10 @@
          
          line
          add-line
+         add-polygon
          add-curve
          scene+line
+         scene+polygon
          scene+curve
          text
          text/font
diff --git a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/test-image.rkt b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/test-image.rkt
index 1859eacb6e..6b0d1bd668 100644
--- a/pkgs/htdp-pkgs/htdp-test/2htdp/tests/test-image.rkt
+++ b/pkgs/htdp-pkgs/htdp-test/2htdp/tests/test-image.rkt
@@ -1220,6 +1220,127 @@
       =>
       100)
 
+(test (add-polygon (rectangle 60 50 'solid 'black)
+                (list (make-posn -10 0)
+                      (make-posn 60 -10)
+                      (make-posn 70 50)
+                      (make-posn 0 60))
+                'outline 'red)
+      =>
+      (overlay/xy 
+       (polygon (list (make-posn 0 10)
+                      (make-posn 70 0)
+                      (make-posn 80 60)
+                      (make-posn 10 70))
+                'outline 'red)
+       10 10
+       (rectangle 60 50 'solid 'black)))
+
+(test (scene+polygon (rectangle 60 50 'solid 'black)
+                  (list (make-posn -10 0)
+                        (make-posn 60 -10)
+                        (make-posn 70 50)
+                        (make-posn 0 60))
+                  'outline 'red)
+      =>
+      (rectangle 60 50 'solid 'black))
+
+(test (add-polygon (rectangle 60 60 'solid 'black)
+                (list (make-posn -10 0)
+                      (make-posn 60 -10)
+                      (make-posn 70 60)
+                      (make-posn 0 70))
+                'solid 'red)
+      =>
+             (polygon (list (make-posn 0 10)
+                      (make-posn 70 0)
+                      (make-posn 80 70)
+                      (make-posn 10 80))
+                'solid 'red)
+             )
+
+(test (add-polygon (rectangle 100 60 'solid 'green)
+                (list (make-posn 70 20)
+                      (make-posn 40 40)
+                      (make-posn 60 60)
+                      (make-posn 5 70)
+                      (make-posn 2 40))
+                'outline 'red)
+      =>
+      (overlay/xy (polygon (list (make-posn 100 50)
+                                 (make-posn 70 70)
+                                 (make-posn 90 90)
+                                 (make-posn 35 100)
+                                 (make-posn 32 70))
+                           'outline 'red)
+                  -2 -20
+                  (rectangle 100 60 'solid 'green)))
+
+(test (scene+polygon (rectangle 60 50 'solid 'black)
+                  (list (make-posn -10 0)
+                        (make-posn 60 -10)
+                        (make-posn 70 60)
+                        (make-posn 0 70))
+                  'solid 'red)
+      =>
+      (rectangle 60 50 'solid 'red))
+
+(test (scene+polygon (rectangle 120 100 'solid 'black)
+                  (list (make-posn 50 40)
+                        (make-posn 70 40)
+                        (make-posn 70 60)
+                        (make-posn 50 60))
+                  'outline 'red)
+      =>
+               (overlay (square 20 'outline 'red) (rectangle 120 100 'solid 'black)))
+
+(test (scene+polygon (rectangle 90 100 'solid 'black)
+                  (list (make-posn 30 10)
+                        (make-posn 100 20)
+                        (make-posn 50 30)
+                        (make-posn 100 40)
+                        (make-posn 30 50))
+                  'solid 'red)
+      =>
+      (place-image/align (polygon (list (make-posn 30 50)
+                                        (make-posn 100 40)
+                                        (make-posn 50 30)
+                                        (make-posn 100 20)
+                                        (make-posn 30 10))
+                                  'solid 'red)
+                         30 10 'left 'top (rectangle 90 100 'solid 'black)))
+
+(test (image-width (scene+polygon (rectangle 90 100 'solid 'black)
+                               (list (make-posn 30 10)
+                                     (make-posn 100 20)
+                                     (make-posn 50 30)
+                                     (make-posn 100 40)
+                                     (make-posn 30 50))
+                               'outline 'orange))
+      => 90)
+(test (image-height (scene+polygon (rectangle 90 100 'solid 'black)
+                               (list (make-posn 30 10)
+                                     (make-posn 100 20)
+                                     (make-posn 50 30)
+                                     (make-posn 100 40)
+                                     (make-posn 30 50))
+                               'outline 'orange))
+      => 100)
+(test (scene+polygon (rectangle 100 100 'solid 'blue)
+                  (list (make-posn 20 10)
+                        (make-posn -10 -20)
+                        (make-posn -20 -10)
+                        (make-posn 10 20))
+                  'outline 'orange)
+      =>
+      (place-image/align (polygon (list (make-posn -20 -10)
+                                        (make-posn 10 20)
+                                        (make-posn 20 10)
+                                        (make-posn -10 -20))
+                                  'outline 'orange)
+                         -20 -20 'left 'top
+                         (rectangle 100 100 'solid 'blue)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;;  curves