diff --git a/collects/2htdp/image.ss b/collects/2htdp/image.ss index 67cf9f528f..4ca0e0dc52 100644 --- a/collects/2htdp/image.ss +++ b/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? diff --git a/collects/2htdp/private/image-more.ss b/collects/2htdp/private/image-more.ss index c13d49376a..830f5bc4fd 100644 --- a/collects/2htdp/private/image-more.ss +++ b/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) - (let* ([bm (make-object bitmap% +(define (save-image pre-image filename) + (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 - [(is-a? arg image-snip%) (image-snip->image arg)] - [(is-a? arg bitmap%) (bitmap->image arg)] - [else arg])] + (to-img 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) diff --git a/collects/2htdp/tests/test-image.ss b/collects/2htdp/tests/test-image.ss index 170d23f20a..03f252d421 100644 --- a/collects/2htdp/tests/test-image.ss +++ b/collects/2htdp/tests/test-image.ss @@ -773,4 +773,15 @@ (let* ([txt (text "H" 24 'black)] [bl (image-baseline txt)]) (check-equal? (image-baseline (add-line txt 0 -10 100 100 'red)) - (+ bl 10))) \ No newline at end of file + (+ bl 10))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; bitmaps +;; + +(check-equal? (image-width (bitmap icons/stop-16x16.png)) + 16) +(check-equal? (image-height (bitmap icons/stop-16x16.png)) + 16) diff --git a/collects/teachpack/2htdp/scribblings/image-toc.ss b/collects/teachpack/2htdp/scribblings/image-toc.ss index 51c34e61d5..4fca8bcadb 100644 --- a/collects/teachpack/2htdp/scribblings/image-toc.ss +++ b/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 diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl index ee1295ab6d..e91b85da11 100644 --- a/collects/teachpack/2htdp/scribblings/image.scrbl +++ b/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} diff --git a/collects/teachpack/2htdp/scribblings/img/13aef4074e9.png b/collects/teachpack/2htdp/scribblings/img/13aef4074e9.png new file mode 100644 index 0000000000..7220d4363c Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/13aef4074e9.png differ diff --git a/collects/teachpack/2htdp/scribblings/img/72aef3dc67.png b/collects/teachpack/2htdp/scribblings/img/72aef3dc67.png new file mode 100644 index 0000000000..f23e71fde1 Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/72aef3dc67.png differ