added image->color-list and color-list->bitmap

collects/2htdp/image.rkt

@@ -105,6 +105,8 @@ and they all have good sample contracts. (It is amazing what we can do with kids
          scene+curve
          text
          text/font
+         image->color-list
+         color-list->bitmap
          
          x-place?
          y-place?

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

@@ -1159,7 +1159,39 @@
                      (current-directory)))])])
        #`(make-object image-snip% (make-object bitmap% #,path 'unknown/mask)))]))
 
+(define/chk (image->color-list image)
+  (let* ([w (image-width image)]
+         [h (image-height image)]
+         [bm (make-object bitmap% w h)]
+         [bdc (make-object bitmap-dc% bm)]
+         [c (make-object color%)])
+    (send bdc clear)
+    (render-image image bdc 0 0)
+    (for/list ([i (in-range 0 (* w h))])
+      (send bdc get-pixel (remainder i w) (quotient i w) c)
+      (color (send c red) (send c green) (send c blue)))))
 
+(define/chk (color-list->bitmap color-list width height)
+  (check-dependencies 'color-list->bitmap
+                      (= (* width height) (length color-list))
+                      "the length of the color list to match the product of the width and the height, but the list has ~a elements and the width and height are ~a and ~a respectively"
+                      (length color-list) width height)
+  (let* ([bmp (make-object bitmap% width height)]
+         [bdc (make-object bitmap-dc% bmp)]
+         [o (make-object color%)])
+    (for ([c (in-list color-list)]
+          [i (in-naturals)])
+      (cond
+        [(color? c)
+         (send o set (color-red c) (color-green c) (color-blue c))
+         (send bdc set-pixel (remainder i width) (quotient i width) o)]
+        [else
+         (let* ([str (if (string? c) c (symbol->string c))]
+                [clr (or (send the-color-database find-color str)
+                         (send the-color-database find-color "black"))])
+           (send bdc set-pixel (remainder i width) (quotient i width) clr))]))
+    (bitmap->image bmp)))
+      
 (define build-color/make-color
   (let ([orig-make-color make-color])
     (define/chk (make-color int0-255-1 int0-255-2 int0-255-3) 
@@ -1249,6 +1281,8 @@
          scene+curve
          text
          text/font
+         image->color-list
+         color-list->bitmap
          
          bitmap
          

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

@@ -182,6 +182,9 @@
           (if (send the-color-database find-color color-str)
               color-str
               "black"))])]
+    [(color-list)
+     (check-arg fn-name (and (list? arg) (andmap image-color? arg)) 'color-list i arg)
+     arg]
     [(string)
      (check-arg fn-name (string? arg) 'string i arg)
      arg]

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

@@ -644,9 +644,9 @@
 
 (test (empty-scene 185 100)
       =>
-      (overlay/align "left" "top"
-                     (rectangle 184 99 'outline 'solid)
-                     (rectangle 185 100 'solid 'white)))
+      (crop 0 0 185 100
+            (overlay (rectangle 185 100 'outline (pen "black" 2 'solid 'round 'round))
+                     (rectangle 185 100 'solid 'white))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -1555,6 +1555,29 @@
        160 160 0 1/2
        (make-pen "black" 12 "solid" "round" "round")))
 
+(test (image->color-list
+       (above (beside (rectangle 1 1 'solid (color 1 1 1))
+                      (rectangle 1 1 'solid (color 2 2 2))
+                      (rectangle 1 1 'solid (color 3 3 3)))
+              (beside (rectangle 1 1 'solid (color 4 4 4))
+                      (rectangle 1 1 'solid (color 5 5 5))
+                      (rectangle 1 1 'solid (color 6 6 6)))))
+      =>
+      (list (color 1 1 1) (color 2 2 2) (color 3 3 3) 
+            (color 4 4 4) (color 5 5 5) (color 6 6 6)))
+
+(test (color-list->bitmap
+       (list (color 1 1 1) (color 2 2 2) (color 3 3 3) 
+             (color 4 4 4) (color 5 5 5) (color 6 6 6))
+       3 2)
+      =>
+      (above (beside (rectangle 1 1 'solid (color 1 1 1))
+                     (rectangle 1 1 'solid (color 2 2 2))
+                     (rectangle 1 1 'solid (color 3 3 3)))
+             (beside (rectangle 1 1 'solid (color 4 4 4))
+                     (rectangle 1 1 'solid (color 5 5 5))
+                     (rectangle 1 1 'solid (color 6 6 6)))))
+
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -1633,6 +1656,12 @@
 (test/exn (color #f #f #f)
           =>
           #rx"^color:")
+(test/exn (color-list->bitmap
+           (list (color 1 1 1) (color 2 2 2) (color 3 3 3) 
+                 (color 4 4 4) (color 5 5 5) (color 6 6 6))
+           3 3)
+          =>
+          #rx"^color-list->bitmap")
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -1760,7 +1789,7 @@
                (term image))))
     #:attempts 1000)))
 
-;;This expression was found by the below. Its problematic because it has a negative width.
+;;This expression was found by the above. Its problematic because it has a negative width.
 #;
 (begin
   (define i
@@ -1769,3 +1798,22 @@
      (rotate 30 (crop 54 30 20 10 i))))
   (image-width i) (image-height i) i)
 
+
+#|
+
+This was found by the first redex check above:
+
+(let ((i (flip-horizontal 
+          (let ((i (line (+ (* 10 1) -2) (+ (* 10 3) 4) "green")))
+            (crop (max 0 (min (image-width i) (+ (* 10 4) 13)))
+                  (max 0 (min (image-height i) (+ (* 10 2) 0)))
+                  (+ (* 10 3) 2)
+                  (+ (* 10 7) 0)
+                  i)))))
+  (crop (max 0 (min (image-width i) (+ (* 10 0) 2))) 
+        (max 0 (min (image-height i) (+ (* 10 2) 12))) 
+        (+ (* 10 1) 7) (+ (* 10 1) 2)
+        i))
+raises an exception crop: expected <number that is between 0 than the width (-1)> as first argument, given: 0
+
+|#

collects/scribblings/drracket/interface-essentials.scrbl

@@ -513,7 +513,7 @@ graphical elements as expressions within a program. Plug-in tools can
 extend the available graphical syntax, but this section describes some
 of the more commonly used elements.
 
-@subsection{Images}
+@subsection[#:tag "images"]{Images}
 
 DrRacket's @menuitem["Insert" "Insert Image..."] menu item lets you
 select an image file from disk (in various formats such as GIF, PNG,

collects/teachpack/2htdp/scribblings/image-gen.rkt

@@ -40,7 +40,8 @@
                             (printf "\nerror evaluating:\n")
                             (pretty-write exp)
                             (raise x))])
-           (parameterize ([current-namespace image-ns]) (eval exp)))])
+           (parameterize ([current-namespace image-ns])
+             (rewrite (eval exp))))])
     (cond
       [(image? result)
        (let ([fn (exp->filename exp)])
@@ -52,7 +53,18 @@
        (unless (equal? result (read/write result))
          (error 'handle-image "expression ~s produced ~s, which I can't write"
                 exp result))
-       (set! mapping (cons `(list ',exp 'val ,result) mapping))])))
+       (set! mapping (cons `(list ',exp 'val ',result) mapping))])))
+
+(define (rewrite exp)
+  (let loop ([exp exp])
+    (cond
+      [(list? exp)
+       `(list ,@(map loop exp))]
+      [(color? exp)
+       `(color ,(color-red exp)
+               ,(color-green exp)
+               ,(color-blue exp))]
+      [else exp])))
 
 (define (exp->filename exp)
   (let loop ([prev 0])

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

@@ -36,26 +36,47 @@
        (above r r r r r r))
     'image
     "245380940d6-1.png")
-   (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-baseline (text "Hello" 24 "black")) 'val 18)
-   (list '(image-height (rectangle 10 0 "solid" "purple")) 'val 0)
+   (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-baseline (text "Hello" 24 "black")) 'val '18)
+   (list '(image-height (rectangle 10 0 "solid" "purple")) 'val '0)
    (list
     '(image-height
       (overlay (circle 20 "solid" "orange") (circle 30 "solid" "purple")))
     'val
-    60)
-   (list '(image-height (circle 30 "solid" "orange")) 'val 60)
-   (list '(image-height (ellipse 30 40 "solid" "orange")) 'val 40)
-   (list '(image-width (rectangle 0 10 "solid" "purple")) 'val 0)
+    '60)
+   (list '(image-height (circle 30 "solid" "orange")) 'val '60)
+   (list '(image-height (ellipse 30 40 "solid" "orange")) 'val '40)
+   (list '(image-width (rectangle 0 10 "solid" "purple")) 'val '0)
    (list
     '(image-width
       (beside (circle 20 "solid" "orange") (circle 20 "solid" "purple")))
     'val
-    80)
-   (list '(image-width (circle 30 "solid" "orange")) 'val 60)
-   (list '(image-width (ellipse 30 40 "solid" "orange")) 'val 30)
+    '80)
+   (list '(image-width (circle 30 "solid" "orange")) 'val '60)
+   (list '(image-width (ellipse 30 40 "solid" "orange")) 'val '30)
+   (list
+    '(scale 40 (color-list->bitmap (list "red" "green" "blue") 3 1))
+    'image
+    "2e45632f5de.png")
+   (list
+    '(image->color-list
+      (above
+       (beside
+        (rectangle 1 1 "solid" (make-color 1 1 1))
+        (rectangle 1 1 "solid" (make-color 2 2 2)))
+       (beside
+        (rectangle 1 1 "solid" (make-color 3 3 3))
+        (rectangle 1 1 "solid" (make-color 4 4 4)))))
+    'val
+    '(list (color 1 1 1) (color 2 2 2) (color 3 3 3) (color 4 4 4)))
+   (list
+    '(image->color-list (rectangle 2 2 "solid" "black"))
+    'val
+    '(list (color 0 0 0) (color 0 0 0) (color 0 0 0) (color 0 0 0)))
+   (list '(bitmap icons/b-run.png) 'image "13aef4074e9.png")
+   (list '(bitmap icons/stop-16x16.png) 'image "72aef3dc67.png")
    (list
     '(beside
       (ellipse 20 70 "solid" "lightsteelblue")
@@ -641,8 +662,6 @@
     "2dde939d6dc.png")
    (list '(right-triangle 36 48 "solid" "black") 'image "1a0088e3819.png")
    (list '(triangle 40 "solid" "tan") 'image "aeddf66d5d.png")
-   (list '(bitmap icons/b-run.png) 'image "13aef4074e9.png")
-   (list '(bitmap icons/stop-16x16.png) 'image "72aef3dc67.png")
    (list
     '(text/font "not really a link" 18 "blue" #f 'roman 'normal 'normal #t)
     'image

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

@@ -177,18 +177,6 @@ Unlike @racket[scene+curve], if the line passes outside of @racket[image], the i
                              #f 'roman 'normal 'normal #t)]
 }
 
-@defform/subs[(bitmap bitmap-spec)
-              ([bitmap-spec rel-string
-                            id])]{
-                                  
-  Loads the bitmap specified by @racket[bitmap-spec]. If @racket[bitmap-spec] is a string, it is treated as a 
-  relative path. If it is an identifier, it is treated like a require spec and used to refer to a file
-  in a collection.
-  
-  @image-examples[(bitmap icons/stop-16x16.png)
-                  (bitmap icons/b-run.png)]
-}
-
 @section{Polygons}
                      
 @defproc*[([(triangle [side-length (and/c real? (not/c negative?))] 
@@ -1060,6 +1048,58 @@ the parts that fit onto @racket[scene].
                    (ellipse 20 10 "solid" "navy"))]
 }
 
+@section{Bitmaps}
+
+DrRacket's @seclink["images" #:doc '(lib "scribblings/drracket/drracket.scrbl")]{Insert Image ...} 
+menu item allows you to insert images into your program text, and those images are treated 
+as images for this library. 
+
+Unlike all of the other images in this library, those images (and the other images created
+by functions in this section of the documentation)
+are represented as bitmaps, i.e., a (potentially quite large) array of colors. 
+This means that scaling and rotating them loses fidelity in the image and is significantly
+more expensive than with the other shapes.
+
+@defform/subs[(bitmap bitmap-spec)
+              ([bitmap-spec rel-string
+                            id])]{
+                                  
+  Loads the bitmap specified by @racket[bitmap-spec]. If @racket[bitmap-spec] is a string, it is treated as a 
+  relative path. If it is an identifier, it is treated like a require spec and used to refer to a file
+  in a collection.
+  
+  @image-examples[(bitmap icons/stop-16x16.png)
+                  (bitmap icons/b-run.png)]
+}
+
+@defproc[(image->color-list [image image?]) (listof color?)]{
+  Returns a list of colors that correspond to the colors in the
+  image, reading from left to right, top to bottom.
+  
+  @image-examples[(image->color-list (rectangle 2 2 "solid" "black"))
+                  (image->color-list
+                   (above (beside (rectangle 1 1 "solid" (make-color 1 1 1))
+                                  (rectangle 1 1 "solid" (make-color 2 2 2)))
+                          (beside (rectangle 1 1 "solid" (make-color 3 3 3))
+                                  (rectangle 1 1 "solid" (make-color 4 4 4)))))]
+  
+}
+
+@defproc[(color-list->bitmap [colors (listof image-color?)] 
+                             [width (and/c real? (not/c negative?))]
+                             [height (and/c real? (not/c negative?))])
+         image?]{
+  Constructs a bitmap from the given @racket[colors], with the given @racket[width] and @racket[height].
+
+  @image-examples[(scale
+                   40
+                   (color-list->bitmap
+                    (list "red" "green" "blue")
+                    3 1))]
+  
+  }
+                             
+
 @section{Image Properties}
 
 @defproc[(image-width [i image?]) (and/c integer? (not/c negative?) exact?)]{