added 'bitmap'

svn: r16857

collects/2htdp/image.ss

@@ -81,6 +81,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids
          add-line
          text
          text/font
+         bitmap
          
          x-place?
          y-place?

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

@@ -6,8 +6,9 @@
          scheme/gui/base
          htdp/error
          scheme/math
-         lang/posn
+         (for-syntax scheme/base
-         (for-syntax scheme/base))
+                     scheme/list)
+         lang/posn)
 
 (define (show-image g [extra-space 0])
   (letrec ([f (new frame% [label ""])]
@@ -43,8 +44,9 @@
     (send (new button% [label "2"] [callback (λ x (scale-adjust add1))] [parent bp]) min-width 100)
     (send f show #t)))
 
-(define (save-image image filename)
+(define (save-image pre-image filename)
-  (let* ([bm (make-object bitmap% 
+  (let* ([image (to-img pre-image)]
+         [bm (make-object bitmap% 
                (inexact->exact (ceiling (+ 1 (image-width image)))) 
                (inexact->exact (ceiling (+ 1 (image-height image)))))]
          [bdc (make-object bitmap-dc% bm)])
@@ -139,10 +141,7 @@
                 'image
                 i
                 arg)
-     (cond
+     (to-img arg)]
-       [(is-a? arg image-snip%) (image-snip->image arg)]
-       [(is-a? arg bitmap%) (bitmap->image arg)]
-       [else arg])]
     [(mode)
      (check-arg fn-name
                 (mode? arg)
@@ -248,6 +247,12 @@
        (1 . <= .  i)))
 (define (color? c) (or (symbol? c) (string? c)))
 
+(define (to-img arg)
+  (cond
+    [(is-a? arg image-snip%) (image-snip->image arg)]
+    [(is-a? arg bitmap%) (bitmap->image arg)]
+    [else arg]))
+
 (define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
   (let ([w (send bm get-width)]
         [h (send bm get-height)])
@@ -884,6 +889,46 @@
 (define/chk (image-width image) (image-right image))
 (define/chk (image-height image) (image-bottom image))
 
+(define-syntax (bitmap stx)
+  (syntax-case stx ()
+    [(_ arg)
+     (let* ([arg (syntax->datum #'arg)]
+            [path
+             (cond
+               [(and (pair? arg)
+                     (eq? (car arg) 'planet))
+                (raise-syntax-error 'bitmap "planet paths not yet supported" stx)]
+               [(symbol? arg)
+                (let ([pieces (regexp-split #rx"/" (symbol->string arg))])
+                  (cond
+                    [(null? pieces)
+                     (raise-syntax-error 'bitmap "expected a path with a / in it" stx)]
+                    [else
+                     (let loop ([cps (current-library-collection-paths)])
+                       (cond
+                         [(null? cps)
+                          (raise-syntax-error 'bitmap
+                                              (format "could not find the ~a collection" (car pieces))
+                                              stx)]
+                         [else
+                          (if (and (directory-exists? (car cps))
+                                   (member (build-path (car pieces))
+                                           (directory-list (car cps))))
+                              (let ([candidate (apply build-path (car cps) pieces)])
+                                (if (file-exists? candidate)
+                                    candidate
+                                    (raise-syntax-error 'bitmap 
+                                                        (format "could not find ~a in the ~a collection"
+                                                                (apply string-append (add-between (cdr pieces) "/"))
+                                                                (car pieces))
+                                                        stx)))
+                              (loop (cdr cps)))]))]))]
+               [(string? arg)
+                (path->complete-path 
+                 arg
+                 (or (current-load-relative-directory)
+                     (current-directory)))])])
+       #`(make-object image-snip% (make-object bitmap% #,path 'unknown/mask)))]))
 
 (provide overlay
          overlay/places
@@ -937,6 +982,8 @@
          text
          text/font
          
+         bitmap
+         
          swizzle
          
          rotate-xy)

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

@@ -774,3 +774,14 @@
        [bl (image-baseline txt)])
   (check-equal? (image-baseline (add-line txt 0 -10 100 100 'red))
                 (+ bl 10)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  bitmaps
+;;
+
+(check-equal? (image-width (bitmap icons/stop-16x16.png))
+              16)
+(check-equal? (image-height (bitmap icons/stop-16x16.png))
+              16)

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

@@ -184,6 +184,8 @@
       (ellipse 60 30 "solid" "purple"))
     'image
     "4e85791a5.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

@@ -247,6 +247,17 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
                              #f 'roman 'normal 'normal #t)]
 }
 
+@defform/subs[(bitmap bitmap-spec)
+              ([bitmap-spec rel-string
+                            id])]{
+                                  
+  Loads the bitmap specified by @scheme[bitmap-spec]. If @scheme[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{Overlaying Images}