added place-image and fixed a bunch of bugs related to equality, rotating and other things

svn: r17491

collects/2htdp/image.ss

@@ -46,9 +46,10 @@ and they all have good sample contracts. (It is amazing what we can do with kids
 |#
 
 
-(require mrlib/image-core
+(require "../mrlib/image-core.ss"
          "private/image-more.ss"
-         "private/img-err.ss")
+         "private/img-err.ss"
+         htdp/error)
 
 (provide overlay
          overlay/align
@@ -66,6 +67,8 @@ and they all have good sample contracts. (It is amazing what we can do with kids
 	 crop
          rotate
          frame
+         place-image
+         place-image/align
          
          scale
          scale/xy
@@ -94,8 +97,22 @@ and they all have good sample contracts. (It is amazing what we can do with kids
          mode?
          angle?
          side-count?
-         color?
+         image-color?
-         
+         (rename-out [build-color make-color])
+         color-red color-blue color-green color? color
          image-width
          image-height
          image-baseline)
+
+(define build-color
+  (let ([orig-make-color make-color])
+    (let ([make-color 
+           (λ (a b c)
+             (check-arg 'make-color (and (integer? a) (<= 0 a 255)) 
+                        'integer\ between\ 0\ and\ 255 1 a)
+             (check-arg 'make-color (and (integer? b) (<= 0 b 255)) 
+                        'integer\ between\ 0\ and\ 255 2 b)
+             (check-arg 'make-color (and (integer? c) (<= 0 c 255)) 
+                        'integer\ between\ 0\ and\ 255 3 c)
+             (make-color a b c))])
+      make-color)))

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

@@ -37,13 +37,23 @@
                     [min-value min-scale]
                     [max-value max-scale]
                     [callback (λ ignore (send c refresh))])]
-           [bp (new horizontal-panel% [parent f] [alignment '(center center)] [stretchable-height #f])]
+           [bp (new horizontal-panel% 
+                    [parent f]
+                    [alignment '(center center)]
+                    [stretchable-height #f])]
            [scale-adjust
             (λ (f)
-              (send sl set-value (max min-scale (min max-scale (f (send sl get-value)))))
+              (send sl set-value 
+                    (max min-scale (min max-scale (f (send sl get-value)))))
               (send c refresh))])
-    (send (new button% [label "√"] [callback (λ x (scale-adjust sub1))] [parent bp]) min-width 100)
+    (send (new button% 
-    (send (new button% [label "2"] [callback (λ x (scale-adjust add1))] [parent bp]) min-width 100)
+               [label "√"] 
+               [callback (λ x (scale-adjust sub1))] 
+               [parent bp]) min-width 100)
+    (send (new button% 
+               [label "2"]
+               [callback (λ x (scale-adjust add1))]
+               [parent bp]) min-width 100)
     (send f show #t)))
 
 (define (save-image pre-image filename)
@@ -97,7 +107,8 @@
               #f))
 
 ;; overlay : image image image ... -> image
-;; places images on top of each other with their upper left corners aligned. last one goes on the bottom
+;; places images on top of each other with their upper left corners aligned. 
+;; last one goes on the bottom
 (define/chk (overlay image image2 . image3)
   (overlay/internal 'left 'top image (cons image2 image3)))
 
@@ -261,6 +272,9 @@
 ;; crop : number number number number image -> image
 ;; crops an image to be w x h from (x,y)
 (define/chk (crop x1 y1 width height image)
+  (crop/internal x1 y1 width height image))
+
+(define (crop/internal x1 y1 width height image)
   (let ([iw (min width (image-width image))]
         [ih (min height (image-height image))])
     (make-image (make-crop (rectangle-points iw ih)
@@ -270,6 +284,27 @@
                          (min ih (image-baseline image)))
                 #f)))
 
+;; place-image : image x y scene -> scene
+(define/chk (place-image image1 x1 y1 image2) 
+  (place-image/internal image1 x1 y1 image2 'left 'top))
+(define/chk (place-image/align image1 x1 y1 x-place y-place image2)
+  (place-image/internal image1 x1 y1 image2 x-place y-place))
+
+(define (place-image/internal image orig-dx orig-dy scene x-place y-place)
+  (let ([dx (- orig-dx (find-x-spot x-place image))]
+        [dy (- orig-dy (find-y-spot y-place image))])
+    (crop/internal
+     (if (< dx 0) (- dx) 0)
+     (if (< dy 0) (- dy) 0)
+     (image-right scene)
+     (image-bottom scene)
+     (overlay/δ image
+                (if (< dx 0) 0 dx)
+                (if (< dy 0) 0 dy)
+                scene
+                (if (< dx 0) (- dx) 0)
+                (if (< dy 0) (- dy) 0)))))
+
 ;; frame : image -> image
 ;; draws a black frame around a image where the bounding box is
 ;; (useful for debugging images)
@@ -290,47 +325,35 @@
 ;; scales the I by the given factor
 
 ;; rotate : I number -> I
-;; rotates the I around the top-left corner by the given angle
+;; rotates the I around the top-left corner by the given angle (in degrees)
-;; (in degrees)
-;; LINEAR TIME OPERATION (sigh)
 (define/chk (rotate angle image)
-  (let-values ([(rotated-shape ltrb)
+  (let* ([rotated-shape (rotate-normalized-shape 
-                (rotate-normalized-shape/bb angle 
+                         angle
-                                            (normalize-shape (image-shape image)))])
+                         (send image get-normalized-shape))]
-    
+        [ltrb (normalized-shape-bb rotated-shape)])
     (make-image (make-translate (- (ltrb-left ltrb)) (- (ltrb-top ltrb)) rotated-shape)
                 (make-bb (- (ltrb-right ltrb) (ltrb-left ltrb))
                          (- (ltrb-bottom ltrb) (ltrb-top ltrb))
                          (- (ltrb-bottom ltrb) (ltrb-top ltrb)))
                 #f)))
 
-;; rotate-normalized-shape/bb : angle normalized-shape -> (values normalized-shape ltrb)
+(define (rotate-normalized-shape angle shape)
-(define (rotate-normalized-shape/bb angle shape)
   (cond
     [(overlay? shape)
-     (let-values ([(top-shape top-ltrb) (rotate-normalized-shape/bb angle (overlay-top shape))]
+     (let ([top-shape (rotate-normalized-shape angle (overlay-top shape))]
-                  [(bottom-shape bottom-ltrb) (rotate-simple/bb angle (overlay-bottom shape))])
+           [bottom-shape (rotate-simple angle (overlay-bottom shape))])
-       (values (make-overlay top-shape bottom-shape)
+       (make-overlay top-shape bottom-shape))]
-               (union-ltrb top-ltrb bottom-ltrb)))]
     [else 
-     (rotate-cropped-simple/bb angle shape)]))
+     (rotate-cropped-simple angle shape)]))
 
-;; rotate-cropped-shape/bb : angle cropped-simple-shape -> (values cropped-simple-shape ltrb)
+;; rotate-cropped-simple : angle cropped-simple-shape -> cropped-simple-shape
-(define (rotate-cropped-simple/bb angle shape)
+(define (rotate-cropped-simple angle shape)
   (cond
     [(crop? shape)
-     (let-values ([(rotated-shape ltrb) (rotate-cropped-simple/bb angle (crop-shape shape))])
+     (make-crop (rotate-points angle (crop-points shape))
-       (let* ([rotated-points (rotate-points angle (crop-points shape))]
+                (rotate-cropped-simple angle (crop-shape shape)))]
-              [crop-ltrb (points->ltrb rotated-points)])
-         (values (make-crop rotated-points rotated-shape)
-                 (intersect-ltrb crop-ltrb ltrb))))]
     [else 
-     (rotate-simple/bb angle shape)]))
+     (rotate-simple angle shape)]))
-
-;; rotate-simple/bb : angle simple-shape -> (values simple-shape ltrb)
-(define (rotate-simple/bb angle shape)
-  (let ([rotated-shape (rotate-simple angle shape)])
-    (values rotated-shape (simple-bb rotated-shape))))
 
 ;; rotate-simple : angle simple-shape -> simple-shape
 (define (rotate-simple θ simple-shape)
@@ -366,6 +389,26 @@
              (min (ltrb-right ltrb1) (ltrb-right ltrb2))
              (min (ltrb-bottom ltrb1) (ltrb-bottom ltrb2))))
 
+;; normalized-shape-bb : normalized-shape -> ltrb
+(define (normalized-shape-bb shape)
+  (cond
+    [(overlay? shape)
+     (let ([top-ltrb (normalized-shape-bb (overlay-top shape))]
+           [bottom-ltrb (simple-bb (overlay-bottom shape))])
+       (union-ltrb top-ltrb bottom-ltrb))]
+    [else 
+     (cropped-simple-bb shape)]))
+
+;; cropped-simple-bb : cropped-simple-shape -> ltrb
+(define (cropped-simple-bb shape)
+  (cond
+    [(crop? shape)
+     (let ([ltrb (cropped-simple-bb (crop-shape shape))]
+           [crop-ltrb (points->ltrb (crop-points shape))])
+       (intersect-ltrb crop-ltrb ltrb))]
+    [else
+     (simple-bb shape)]))
+
 ;; simple-bb : simple-shape -> ltrb
 ;; returns the bounding box of 'shape' 
 ;; (only called for rotated shapes, so bottom=baseline)
@@ -445,7 +488,31 @@
             (max ax bx cx dx)
             (max ay by cy dy))))
 
-(define (rotate-points θ points) (map (λ (p) (rotate-point p θ)) points))
+(define (rotate-points θ in-points)
+  (let* ([cs (map point->c in-points)]
+         [vectors (points->vectors cs)]
+         [rotated-vectors (map (λ (c) (rotate-c c θ)) vectors)]
+         [points (vectors->points rotated-vectors)])
+    points))
+
+(define (points->vectors orig-points)
+  (let loop ([points (cons 0 orig-points)])
+    (cond
+      [(null? (cdr points)) '()]
+      [else
+       (cons (- (cadr points) (car points))
+             (loop (cdr points)))])))
+
+(define (vectors->points vecs)
+  (let loop ([vecs vecs]
+             [p 0])
+    (cond
+      [(null? vecs) '()]
+      [else 
+       (let ([next-p (+ (car vecs) p)])
+         (cons (c->point next-p)
+               (loop (cdr vecs)
+                     next-p)))])))
 
 (define (center-point np-atomic-shape)
   (let-values ([(l t r b) (np-atomic-bb np-atomic-shape)])
@@ -500,15 +567,22 @@
   (let-values ([(x y) (rotate-xy (point-x p) (point-y p) θ)])
     (make-point x y)))
 
+(define (rotate-c c θ)
+  (* (make-polar 1 (degrees->radians θ)) 
+     c))
+
 ;; rotate-xy : x,y angle -> x,y
 (define (rotate-xy x y θ)
-  (c->xy (* (make-polar 1 (degrees->radians θ)) 
+  (c->xy (rotate-c (xy->c x y) θ)))
-            (xy->c x y))))
 
 (define (xy->c x y) (make-rectangular x (- y)))
 (define (c->xy c) 
   (values (real-part c)
           (- (imag-part c))))
+(define (point->c p) (xy->c (point-x p) (point-y p)))
+(define (c->point c) 
+  (let-values ([(x y) (c->xy c)])
+    (make-point x y)))
 
 
 ;; bring-between : number number -> number
@@ -732,30 +806,6 @@
                 (make-bb w/h w/h w/h)
                 #f)))
 
-(define (mode-color->pen mode color)
-  (send the-pen-list find-or-create-pen color 1 
-        (case mode
-          [(outline) 'solid]
-          [(solid) 'transparent])))
-
-(define (mode-color->brush mode color)
-  (send the-brush-list find-or-create-brush color 
-        (case mode
-          [(outline) 'transparent]
-          [(solid) 'solid])))
-
-;; add-line : I number number number number -> I
-;; add-line : string string I number number number number -> I
-;; like add-line, but adapted to use coordinates relative the top-left of the I,
-;; or to the user-specified spot
-
-;; add-curve : I posn number number posn number number -> I
-;; add-curve : string string I posn number number posn number number -> I
-;; the posns are the start and end points of the curve
-;; the pair of numbers following each posn are the angle and "pull" of the curve
-;; see pin-line in slideshow
-;; the initial strings in the second instance of add-curve are like the strings in add-line
-
 (define/chk (image-width image) (inexact->exact (ceiling (image-right image))))
 (define/chk (image-height image) (inexact->exact (ceiling (image-bottom image))))
 
@@ -814,9 +864,12 @@
          
          rotate
          crop
-
          frame
 
+         place-image
+         place-image/align
+         
+         
          show-image
          save-image
          bring-between

collects/2htdp/private/img-err.ss

@@ -7,7 +7,7 @@
          mode?
          angle?
          side-count?
-         color?
+         image-color?
          image-snip->image
          bitmap->image)
 
@@ -147,15 +147,20 @@
          (+ arg 360)
          arg)]
     [(color)
-     (check-color fn-name i arg)
+     (check-arg fn-name (image-color? arg) 'color i arg)
-     (let ([color-str 
+     ;; return either a string or a color object;
-            (cond
+     ;; since there may be saved files that have 
-              [(symbol? arg)
+     ;; strings in the color positions we leave them
-               (symbol->string arg)]
+     ;; here too.
-              [else arg])])
+     (if (color? arg)
-       (if (send the-color-database find-color color-str)
+         arg
-           color-str
+         (let* ([color-str
-           "black"))]
+                 (if (symbol? arg)
+                     (symbol->string arg)
+                     arg)])
+           (if (send the-color-database find-color color-str)
+               color-str
+               "black")))]
     [(string)
      (check-arg fn-name (string? arg) 'string i arg)
      arg]
@@ -207,7 +212,7 @@
 (define (step-count? i)
   (and (integer? i)
        (1 . <= .  i)))
-(define (color? c) (or (symbol? c) (string? c)))
+(define (image-color? c) (or (symbol? c) (string? c) (color? c)))
 
 (define (to-img arg)
   (cond

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

@@ -1,9 +1,16 @@
 #lang scheme/base
 #|
 ;; snippet of code for experimentation
+#lang scheme/gui
+(require 2htdp/private/image-more
+         mrlib/image-core
+         mrlib/private/image-core-bitmap
+         2htdp/private/img-err
+         (only-in lang/htdp-advanced equal~?))
+
 (define images
-  (list (round-numbers (rotate 180 (line 20 30 "red")))
+  (list (rhombus 10 90 'solid 'black)
-        (round-numbers (line 20 30 "red"))))
+        (rotate 45 (square 10 'solid 'black))))
 
 (define t (new text%))
 (define f (new frame% [label ""] [width 600] [height 400]))
@@ -20,15 +27,17 @@
          scheme/math
          scheme/class
          scheme/gui/base
-         schemeunit)
+         schemeunit
+         (only-in lang/htdp-advanced equal~?))
 
 (require (for-syntax scheme/base))
 (define-syntax (test stx)
   (syntax-case stx ()
     [(test a => b)
-     #`(begin
+     (with-syntax ([check-equal? (datum->syntax #'here 'check-equal? stx)])
-         ;(printf "running line ~a\n" #,(syntax-line stx))
+       #`(begin
-         (check-equal? a b))]))
+           ;(printf "running line ~a\n" #,(syntax-line stx))
+           #,(quasisyntax/loc stx (check-equal? a b))))]))
 
 ;; test case: (beside (text "a"...) (text "b" ...)) vs (text "ab")
 
@@ -39,26 +48,6 @@
        (number? b)
        (< (abs (- a b)) 0.001)))
 
-#;
-(show-image
- (overlay/xy (rectangle 100 10 'solid 'red)
-             0
-             10
-             (rectangle 100 10 'solid 'red)))
-
-
-#;
-(show-image
- (let loop ([image (rectangle 400 8 'solid 'red)]
-            [n 2])
-   (cond
-     [(= n 7) image]
-     [else
-      (loop (overlay/align 'center 'center
-                            image
-                            (rotate (* 180 (/ 1 n)) image))
-            (+ n 1))])))
-
 (define-syntax-rule 
   (round-numbers e)
   (call-with-values (λ () e) round-numbers/values))
@@ -222,6 +211,17 @@
                        "solid" "plum")
               (rectangle 10 10 "solid" "plum"))
 
+;; make sure equality isn't equating everything
+(check-equal? (equal? (rectangle 10 10 'solid 'blue)
+                      (rectangle 10 10 'solid 'red))
+              #f)
+
+;; make sure 'white and black match up with color structs
+(check-equal? (rectangle 10 10 'solid (make-color 255 255 255))
+              (rectangle 10 10 'solid 'white))
+(check-equal? (rectangle 10 10 'solid (make-color 0 0 0))
+              (rectangle 10 10 'solid 'black))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;;  testing overlays
@@ -650,9 +650,11 @@
 (test (bring-between 720 360) => 0)
 (test (bring-between 720.5 360) => .5)
 
-(test (round-numbers (rotate 90 (rectangle 100 100 'solid 'blue)))
+(test (equal~? (rotate 90 (rectangle 100 100 'solid 'blue))
+               (rectangle 100 100 'solid 'blue)
+               .1)
       =>
-      (round-numbers (rectangle 100 100 'solid 'blue)))
+      #t)
 
 (test (round-numbers
        (normalize-shape (image-shape (rotate 90 (rotate 90 (rectangle 50 100 'solid 'purple))))
@@ -678,8 +680,6 @@
       =>
       (round-numbers (rotate 90 (ellipse 200 400 'solid 'purple))))
 
-(require (only-in lang/htdp-advanced equal~?))
-
 (test (equal~? (rectangle 100 10 'solid 'red)
                (rotate 90 (rectangle 10 100 'solid 'red))
                0.1)
@@ -787,14 +787,16 @@
 (test (image-baseline (image-snip->image (make-object image-snip% blue-10x20-bitmap)))
       => 
       20)
-#|
 (test (scale 2 (make-object image-snip% blue-10x20-bitmap))
       =>
       (image-snip->image (make-object image-snip% blue-20x40-bitmap)))
+
+;; this test fails; sent email to Ian about it.
+#;
 (test (rotate 90 (make-object image-snip% blue-10x20-bitmap))
       =>
       (image-snip->image (make-object image-snip% blue-20x10-bitmap)))
-|#
+
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1040,7 +1042,7 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
-;; cropping
+;; cropping (and place-image)
 ;;
 
 (test (crop 0 0 10 10 (rectangle 20 20 'solid 'black))
@@ -1058,3 +1060,55 @@
       =>
       (beside (rectangle 10 10 'solid 'black)
               (rectangle 10 10 'solid 'green)))
+
+(test (place-image (circle 4 'solid 'black)
+                   10 10
+                   (rectangle 40 40 'solid 'orange))
+      =>
+      (underlay/xy (rectangle 40 40 'solid 'orange)
+                   10 10
+                   (circle 4 'solid 'black)))
+
+(test (place-image (circle 4 'solid 'black)
+                   50 50
+                   (rectangle 40 40 'solid 'orange))
+      =>
+      (rectangle 40 40 'solid 'orange))
+
+(test (place-image (circle 4 'solid 'black)
+                   36 36
+                   (rectangle 40 40 'solid 'orange))
+      =>
+      (underlay/xy (rectangle 40 40 'solid 'orange)
+                   36 36
+                   (crop 0 0 4 4 (circle 4 'solid 'black))))
+
+(test (place-image (circle 8 'solid 'black)
+                   -4 -4
+                   (rectangle 40 40 'solid 'orange))
+      =>
+      (overlay (crop 4 4 16 16 (circle 8 'solid 'black))
+               (rectangle 40 40 'solid 'orange)))
+
+(check-equal? (place-image (circle 4 'solid 'black)
+                           -4 0
+                           (rectangle 40 40 'solid 'orange))
+              (overlay (crop 4 0 4 8 (circle 4 'solid 'black))
+                       (rectangle 40 40 'solid 'orange)))
+
+(test (place-image/align (circle 4 'solid 'black)
+                         5 10 'center 'center
+                         (rectangle 40 40 'solid 'orange))
+      =>
+      (underlay/xy (rectangle 40 40 'solid 'orange)
+                   1 6
+                   (circle 4 'solid 'black)))
+
+
+(test (place-image/align (circle 4 'solid 'black)
+                         10 15 'right 'bottom
+                         (rectangle 40 40 'solid 'orange))
+      =>
+      (underlay/xy (rectangle 40 40 'solid 'orange)
+                   2 7
+                   (circle 4 'solid 'black)))

collects/mrlib/image-core.ss

@@ -233,7 +233,9 @@ has been moved out).
 ;                        ;;   ;                     
 ;                         ;;;;                      
 
-(define-local-member-name get-shape set-shape get-bb get-normalized? set-normalized get-normalized-shape)
+(define-local-member-name
+  get-shape set-shape get-bb 
+  get-normalized? set-normalized get-normalized-shape)
 
 (define image%
   (class* snip% (equal<%>)
@@ -250,13 +252,8 @@ has been moved out).
                       [bytes1 (make-bytes (* w h 4) 0)]
                       [bytes2 (make-bytes (* w h 4) 0)]
                       [bdc (make-object bitmap-dc%)])
-                 (send bdc set-smoothing 'aligned)
                  (and (check-same? bm1 bm2 bytes1 bytes2 bdc "red" that)
-                      (check-same? bm1 bm2 bytes1 bytes2 bdc "green" that)))))
+                      (check-same? bm1 bm2 bytes1 bytes2 bdc "green" that))))))
-      
-      #;
-      (eq-recur (get-normalized-shape)
-                (send that get-normalized-shape)))
     
     (define/private (check-same? bm1 bm2 bytes1 bytes2 bdc color that)
       (clear-bitmap/draw/bytes bm1 bdc bytes1 this color)
@@ -268,8 +265,8 @@ has been moved out).
       (send bdc set-pen "black" 1 'transparent)
       (send bdc set-brush color 'solid)
       (send bdc draw-rectangle 0 0 (send bm get-width) (send bm get-height))
-      (render-image this bdc 0 0)
+      (render-image obj bdc 0 0)
-      (send bm get-argb-pixels 0 0 (send bm get-width) (send bm get-height) bytes))
+      (send bdc get-argb-pixels 0 0 (send bm get-width) (send bm get-height) bytes))
     
     (define/public (equal-hash-code-of y) 42)
     (define/public (equal-secondary-hash-code-of y) 3)
@@ -323,10 +320,12 @@ has been moved out).
         (send dc set-smoothing 'aligned)
         (render-image this dc x y)
         (send dc set-smoothing smoothing)))
+    
     (define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f])
       (send (get-the-snip-class-list) add snip-class)
-      (let ([bottom (round (bb-bottom bb))])
+      (let ([bottom (round (bb-bottom bb))]
-        (set-box/f! w (round (bb-right bb)))
+            [right (round (bb-right bb))])
+        (set-box/f! w right)
         (set-box/f! h bottom)
         (set-box/f! descent (- bottom (round (bb-baseline bb))))
         (set-box/f! space 0)
@@ -571,8 +570,10 @@ has been moved out).
   (cond
     [(polygon? simple-shape)
      (let ([path (polygon-points->path (polygon-points simple-shape))])
-       (send dc set-pen (mode-color->pen (polygon-mode simple-shape) (polygon-color simple-shape)))
+       (send dc set-pen (mode-color->pen (polygon-mode simple-shape)
-       (send dc set-brush (mode-color->brush (polygon-mode simple-shape) (polygon-color 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%)]
@@ -626,19 +627,14 @@ has been moved out).
 
 (define (polygon-points->path points)
   (let ([path (new dc-path%)])
-    (send path move-to (point-x (car points)) (point-y (car points)))
+    (send path move-to (round (point-x (car points))) (round (point-y (car points))))
-    (let loop ([point (make-rectangular (point-x (car points)) (point-y (car points)))]
+    (let loop ([points (cdr points)])
-               [last-point (car points)]
-               [points (cdr points)])
       (unless (null? points)
-        (let* ([vec (make-rectangular (- (point-x (car points))
+        (send path line-to 
-                                         (point-x last-point))
+              (round (point-x (car points)))
-                                      (- (point-y (car points))
+              (round (point-y (car points))))
-                                         (point-y last-point)))]
+        (loop (cdr points))))
-               [endpoint (+ point vec (make-polar -1 (angle vec)))])
+    (send path line-to (round (point-x (car points))) (round (point-y (car points))))
-          (send path line-to (real-part endpoint) (imag-part endpoint))
-          (loop endpoint (car points) (cdr points)))))
-    (send path line-to (point-x (car points)) (point-y (car points)))
     path))
 
 #|
@@ -680,15 +676,14 @@ the mask bitmap and the original bitmap are all together in a single bytes!
 
 (define (do-rotate bitmap)
   (let ([θ (degrees->radians (bitmap-angle bitmap))])
-    (let-values ([(bytes w h) (bitmap->bytes (bitmap-rendered-bitmap bitmap) (bitmap-rendered-mask bitmap))])
+    (let-values ([(bytes w h) (bitmap->bytes (bitmap-rendered-bitmap bitmap) 
+                                             (bitmap-rendered-mask bitmap))])
       (let-values ([(rotated-bytes rotated-w rotated-h)
                     (rotate-bytes bytes w h θ)])
-        (set-bitmap-rendered-bitmap!
+        (let* ([bm (bytes->bitmap rotated-bytes rotated-w rotated-h)]
-         bitmap
+               [mask (send bm get-loaded-mask)])
-         (bytes->bitmap rotated-bytes rotated-w rotated-h))
+          (set-bitmap-rendered-bitmap! bitmap bm)
-        (set-bitmap-rendered-mask!
+          (set-bitmap-rendered-mask! bitmap mask))))))
-         bitmap
-         (send (bitmap-rendered-bitmap bitmap) get-loaded-mask))))))
 
 (define (do-scale bitmap)
   (let* ([bdc (make-object bitmap-dc%)]
@@ -762,18 +757,29 @@ the mask bitmap and the original bitmap are all together in a single bytes!
   (* θ 2 pi (/ 360)))
 
 (define (mode-color->pen mode color)
-  (cond
+  (send the-pen-list find-or-create-pen 
-    [(eq? mode 'solid)
+        (get-color-arg color)
-     (send the-pen-list find-or-create-pen "black" 1 'transparent)]
+        1 
-    [else
+        (case mode
-     (send the-pen-list find-or-create-pen color 1 'solid)]))
+          [(outline) 'solid]
+          [(solid) 'transparent])))
 
 (define (mode-color->brush mode color)
-  (cond
+  (send the-brush-list find-or-create-brush 
-    [(eq? mode 'solid)
+        (get-color-arg color) 
-     (send the-brush-list find-or-create-brush color 'solid)]
+        (case mode
-    [else
+          [(outline) 'transparent]
-     (send the-brush-list find-or-create-brush "black" 'transparent)]))
+          [(solid) 'solid])))
+
+(define (get-color-arg color)
+  (if (string? color) 
+      color
+      (make-object color% 
+        (color-red color)
+        (color-green color)
+        (color-blue color))))
+
+(define-struct/reg-mk color (red green blue) #:transparent)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -795,6 +801,8 @@ the mask bitmap and the original bitmap are all together in a single bytes!
          make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale 
          bitmap-rendered-bitmap bitmap-rendered-mask
 
+         (struct-out color)
+         
          degrees->radians
          normalize-shape
          ellipse-rotated-size
@@ -806,7 +814,9 @@ the mask bitmap and the original bitmap are all together in a single bytes!
          
          text->font
          compare-all-rotations
-         render-image)
+         render-image
+         
+         scale-np-atomic)
 
 ;; method names
 (provide get-shape get-bb get-normalized? get-normalized-shape)

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

@@ -8,8 +8,8 @@
   (list
    (list '(image-height (rectangle 100 100 "solid" "black")) 'val 100)
    (list '(image-baseline (rectangle 100 100 "solid" "black")) 'val 100)
-   (list '(image-height (text "Hello" 24 "black")) 'val 24)
+   (list '(image-height (text "Hello" 24 "black")) 'val 41)
-   (list '(image-baseline (text "Hello" 24 "black")) 'val 18)
+   (list '(image-baseline (text "Hello" 24 "black")) 'val 31.0)
    (list
     '(image-height
       (overlay (circle 20 "solid" "orange") (circle 30 "solid" "purple")))
@@ -76,6 +76,91 @@
     '(rotate 45 (ellipse 60 20 "solid" "olivedrab"))
     'image
     "28daec71a64.png")
+   (list
+    '(beside
+      (place-image/align
+       (circle 8 "solid" "tomato")
+       0
+       0
+       "center"
+       "center"
+       (rectangle 32 32 "outline" "black"))
+      (place-image/align
+       (circle 8 "solid" "tomato")
+       8
+       8
+       "center"
+       "center"
+       (rectangle 32 32 "outline" "black"))
+      (place-image/align
+       (circle 8 "solid" "tomato")
+       16
+       16
+       "center"
+       "center"
+       (rectangle 32 32 "outline" "black"))
+      (place-image/align
+       (circle 8 "solid" "tomato")
+       24
+       24
+       "center"
+       "center"
+       (rectangle 32 32 "outline" "black"))
+      (place-image/align
+       (circle 8 "solid" "tomato")
+       32
+       32
+       "center"
+       "center"
+       (rectangle 32 32 "outline" "black")))
+    'image
+    "cf131e14ad.png")
+   (list
+    '(place-image/align
+      (triangle 16 "solid" "yellowgreen")
+      32
+      32
+      "right"
+      "bottom"
+      (rectangle 32 32 "solid" "mediumgoldenrod"))
+    'image
+    "f4c4d435a6.png")
+   (list
+    '(place-image
+      (circle 4 "solid" "white")
+      16
+      18
+      (place-image
+       (circle 4 "solid" "white")
+       -2
+       4
+       (place-image
+        (circle 4 "solid" "white")
+        12
+        0
+        (place-image
+         (circle 4 "solid" "white")
+         6
+         12
+         (rectangle 24 24 "solid" "goldenrod")))))
+    'image
+    "1178fdd1294.png")
+   (list
+    '(place-image
+      (triangle 64 "solid" "red")
+      -8
+      -8
+      (rectangle 48 48 "solid" "gray"))
+    'image
+    "2875b40781.png")
+   (list
+    '(place-image
+      (triangle 32 "solid" "red")
+      8
+      8
+      (rectangle 48 48 "solid" "gray"))
+    'image
+    "2bea495d1f.png")
    (list
     '(above/align
       "center"
@@ -256,6 +341,15 @@
       (ellipse 60 30 "solid" "purple"))
     'image
     "bf08c71801.png")
+   (list
+    '(overlay
+      (regular-polygon 20 5 "solid" (make-color 50 50 255))
+      (regular-polygon 25 5 "solid" (make-color 100 100 255))
+      (regular-polygon 30 5 "solid" (make-color 150 150 255))
+      (regular-polygon 35 5 "solid" (make-color 200 200 255))
+      (regular-polygon 40 5 "solid" (make-color 250 250 255)))
+    'image
+    "1aea411192a.png")
    (list
     '(overlay
       (ellipse 10 10 "solid" "red")

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

@@ -24,7 +24,7 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
 
 @defproc[(circle [radius (and/c real? (not/c negative?))]
                  [mode mode?]
-                 [color color?])
+                 [color image-color?])
          image?]{
   Constructs a circle with the given radius, height, mode, and color.
   
@@ -33,11 +33,10 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
   
 }
 
-
 @defproc[(ellipse [width (and/c real? (not/c negative?))]
                   [height (and/c real? (not/c negative?))]
                   [mode mode?] 
-                  [color color?]) image?]{
+                  [color image-color?]) image?]{
   Constructs an ellipsis with the given width, height, mode, and color.
   
   @image-examples[(ellipse 40 20 "outline" "black")
@@ -47,7 +46,7 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
 
 @defproc[(triangle [side-length (and/c real? (not/c negative?))] 
                    [mode mode?]
-                   [color color?])
+                   [color image-color?])
          image?]{
   Constructs a upward-pointing equilateral triangle. 
   The @scheme[side-length] argument 
@@ -60,7 +59,7 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
 @defproc[(right-triangle [side-length1 (and/c real? (not/c negative?))]
                          [side-length2 (and/c real? (not/c negative?))]
                          [mode mode?]
-                         [color color?])
+                         [color image-color?])
          image?]{
                  
   Constructs a triangle with a right angle where the two sides adjacent
@@ -72,7 +71,7 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
 @defproc[(isosceles-triangle [side-length (and/c real? (not/c negative?))] 
                              [angle angle?]
                              [mode mode?]
-                             [color color?])
+                             [color image-color?])
          image?]{
 
  Creates a triangle with two equal-length sides, of length @scheme[side-length]
@@ -89,7 +88,7 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
 
 @defproc[(square [side-length (and/c real? (not/c negative?))]
                  [mode mode?]
-                 [color color?])
+                 [color image-color?])
          image?]{
 
  Constructs a square.
@@ -99,7 +98,7 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
 
 }
 
-@defproc[(rectangle [width real?] [height real?] [mode mode?] [color color?]) image?]{
+@defproc[(rectangle [width real?] [height real?] [mode mode?] [color image-color?]) image?]{
   Constructs a rectangle with the given width, height, mode, and color.
   @image-examples[(rectangle 40 20 "outline" "black")
                   (rectangle 20 40 "solid" "blue")]
@@ -108,7 +107,7 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
 @defproc[(rhombus [side-length (and/c real? (not/c negative?))]
                   [angle angle?]
                   [mode mode?]
-                  [color color?])
+                  [color image-color?])
          image?]{
                  
 Constructs a four sided polygon with all equal sides and thus where opposite angles are equal to each
@@ -121,7 +120,7 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
 @defproc[(regular-polygon [side-length (and/c real? (not/c negative?))] 
                           [side-count side-count?]
                           [mode mode?]
-                          [color color?])
+                          [color image-color?])
          image?]{
   Constructs a regular polygon with @scheme[side-count] sides.
 
@@ -132,7 +131,7 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
 
 @defproc[(star [side-length (and/c real? (not/c negative?))] 
                [mode mode?]
-               [color color?])
+               [color image-color?])
          image?]{
   Constructs a star with five points. The @scheme[side-length] argument 
   determines the side length of the enclosing pentagon.
@@ -145,7 +144,7 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
                        [side-count side-count?]
                        [step-count step-count?]
                        [mode mode?]
-                       [color color?])
+                       [color image-color?])
          image?]{
  
   Constructs an arbitrary regular star polygon (a generalization of the regular polygons). 
@@ -164,7 +163,7 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
                 
 @defproc[(polygon [verticies (listof posn?)] 
                   [mode mode?]
-                  [color color?])
+                  [color image-color?])
          image?]{
   Constructs a polygon connecting the given verticies.
   
@@ -184,7 +183,7 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
                            "solid" "plum")]
 }
 
-@defproc[(line [x1 real?] [y1 real?] [color color?]) image?]{
+@defproc[(line [x1 real?] [y1 real?] [color image-color?]) image?]{
   Constructs an image representing a line segment that connects the points
   (0,0) to (x1,y1).
   
@@ -196,7 +195,7 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
 @defproc[(add-line [image image?]
                    [x1 real?] [y1 real?]
                    [x2 real?] [y2 real?]
-                   [color color?])
+                   [color image-color?])
          image?]{
 
   Adds a line to the image @scheme[image], starting from the point (@scheme[x1],@scheme[y1])
@@ -212,7 +211,7 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
                             "darkolivegreen")]
 }
 
-@defproc[(text [string string?] [font-size (and/c integer? (<=/c 1 255))] [color color?])
+@defproc[(text [string string?] [font-size (and/c integer? (<=/c 1 255))] [color image-color?])
          image?]{
                 
   Constructs an image that draws the given string, using the font size and color.
@@ -221,7 +220,7 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
                   (text "Goodbye" 36 "indigo")]
 }
 
-@defproc[(text/font [string string?] [font-size (and/c integer? (<=/c 1 255))] [color color?]
+@defproc[(text/font [string string?] [font-size (and/c integer? (<=/c 1 255))] [color image-color?]
                     [face (or/c string? #f)]
                     [family (or/c 'default 'decorative 'roman 'script 'swiss 'modern 'symbol 'system)]
                     [style (or/c 'normal 'italic 'slant)]
@@ -273,7 +272,12 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
                            (ellipse 30 30 "solid" "red")
                            (ellipse 40 40 "solid" "black")
                            (ellipse 50 50 "solid" "red")
-                           (ellipse 60 60 "solid" "black"))]
+                           (ellipse 60 60 "solid" "black"))
+                  (overlay (regular-polygon 20 5 "solid" (make-color  50  50 255))
+                           (regular-polygon 25 5 "solid" (make-color 100 100 255))
+                           (regular-polygon 30 5 "solid" (make-color 150 150 255))
+                           (regular-polygon 35 5 "solid" (make-color 200 200 255))
+                           (regular-polygon 40 5 "solid" (make-color 250 250 255)))]
   
   }
 
@@ -453,6 +457,70 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
   
   }
 
+@section{Placing Images}
+
+Placing images into scenes is particularly useful when building worlds
+and universes using @scheme[2htdp/universe].
+
+@defproc[(place-image [image image?] [x real?] [y real?] [scene image?]) image?]{
+
+ Places @scheme[image] onto @scheme[scene] with its upper left corner at the coordinates 
+ (@scheme[x],@scheme[y]) and crops the resulting image so that it has the 
+ same size as @scheme[scene].
+  
+ @image-examples[(place-image 
+                  (triangle 32 "solid" "red")
+                  8 8
+                  (rectangle 48 48 "solid" "gray"))
+                 
+                 (place-image 
+                  (triangle 64 "solid" "red")
+                  -8 -8
+                  (rectangle 48 48 "solid" "gray"))
+                 
+                 (place-image
+                  (circle 4 "solid" "white")
+                  16 18
+                  (place-image
+                   (circle 4 "solid" "white")
+                   -2 4
+                   (place-image
+                    (circle 4 "solid" "white")
+                    12 0
+                    (place-image
+                     (circle 4 "solid" "white")
+                     6 12
+                     (rectangle 24 24 "solid" "goldenrod")))))]
+}
+@defproc[(place-image/align [image image?] [x real?] [y real?] [scene image?] [x-place x-place?] [y-place y-place?])
+         image?]{
+
+ Places @scheme[image] onto @scheme[scene] with its @scheme[x-place] and @scheme[y-place]
+ at the coordinates 
+ (@scheme[x],@scheme[y]) and crops the resulting image so that it has the 
+ same size as @scheme[scene].
+  
+ @image-examples[(place-image/align (triangle 16 "solid" "yellowgreen")
+                                    32 32 "right" "bottom"
+                                    (rectangle 32 32 "solid" "mediumgoldenrod"))
+                 (beside 
+                  (place-image/align (circle 8 "solid" "tomato")
+                                     0 0 "center" "center"
+                                     (rectangle 32 32 "outline" "black"))
+                  (place-image/align (circle 8 "solid" "tomato")
+                                     8 8 "center" "center"
+                                     (rectangle 32 32 "outline" "black"))
+                  (place-image/align (circle 8 "solid" "tomato")
+                                     16 16 "center" "center"
+                                     (rectangle 32 32 "outline" "black"))
+                  (place-image/align (circle 8 "solid" "tomato")
+                                     24 24 "center" "center"
+                                     (rectangle 32 32 "outline" "black"))
+                  (place-image/align (circle 8 "solid" "tomato")
+                                     32 32 "center" "center"
+                                     (rectangle 32 32 "outline" "black")))]
+}
+
 @section{Rotating, Scaling, Cropping, and Framing Images}
 
 @defproc[(rotate [angle angle?] [image image?]) image?]{
@@ -577,22 +645,30 @@ This section lists predicates for the basic structures provided by the image lib
  filled in or not.
 }
 
-@defproc[(color? [x any/c]) boolean?]{
+@defproc[(image-color? [x any/c]) boolean?]{
+
+  Determines if @scheme[x] represents a color. Strings, symbols,
+  and @scheme[color] structs are allowed as colors.
 
-  Determines if @scheme[x] represents a color. Both strings and symbols are allowed as colors.
   For example,
   @scheme["magenta"], @scheme["black"], @scheme['orange], and @scheme['purple]
   are allowed. Colors are not case-sensitive, so 
   @scheme["Magenta"], @scheme["Black"], @scheme['Orange], and @scheme['Purple]
   are also allowed, and are the same colors as in the previous sentence.
-
+  If a string or symbol color name is not recognized, black is used in its place.
-  If a color is not recognized, black is used in its place.
   
   The complete list of colors is available in the documentation for
   @scheme[color-database<%>].
                                       
 }
 
+@defstruct[color ([red (and/c natural-number/c (<=/c 255))]
+                  [green (and/c natural-number/c (<=/c 255))]
+                  [blue (and/c natural-number/c (<=/c 255))])]{
+  The @scheme[color] struct defines a color with red, green, and blue components
+      that range from @scheme[0] to @scheme[255].
+}
+
 @defproc[(y-place? [x any/c]) boolean?]{
   Determines if @scheme[x] is a placement option
   for the vertical direction. It can be one