diff --git a/collects/2htdp/image.rkt b/collects/2htdp/image.rkt index 69360bc621..47dce5b3b7 100644 --- a/collects/2htdp/image.rkt +++ b/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? diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt index e775238d79..ce7f3fd3d8 100644 --- a/collects/2htdp/private/image-more.rkt +++ b/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 diff --git a/collects/2htdp/private/img-err.rkt b/collects/2htdp/private/img-err.rkt index 3ed6288a44..cfb2f9a680 100644 --- a/collects/2htdp/private/img-err.rkt +++ b/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] diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt index 603346ce7c..2c10bbb77f 100644 --- a/collects/2htdp/tests/test-image.rkt +++ b/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 as first argument, given: 0 + +|# \ No newline at end of file diff --git a/collects/scribblings/drracket/interface-essentials.scrbl b/collects/scribblings/drracket/interface-essentials.scrbl index 1c6872ed37..04ece79c06 100644 --- a/collects/scribblings/drracket/interface-essentials.scrbl +++ b/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, diff --git a/collects/teachpack/2htdp/scribblings/image-gen.rkt b/collects/teachpack/2htdp/scribblings/image-gen.rkt index 862a87fcdb..373b024549 100644 --- a/collects/teachpack/2htdp/scribblings/image-gen.rkt +++ b/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]) diff --git a/collects/teachpack/2htdp/scribblings/image-toc.rkt b/collects/teachpack/2htdp/scribblings/image-toc.rkt index 05fe0227c1..7f865eac14 100644 --- a/collects/teachpack/2htdp/scribblings/image-toc.rkt +++ b/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 diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl index d3c1f7f0a2..48463837a6 100644 --- a/collects/teachpack/2htdp/scribblings/image.scrbl +++ b/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?)]{ diff --git a/collects/teachpack/2htdp/scribblings/img/19e57826953.png b/collects/teachpack/2htdp/scribblings/img/19e57826953.png new file mode 100644 index 0000000000..0705890a9f Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/19e57826953.png differ diff --git a/collects/teachpack/2htdp/scribblings/img/26e407a14a2.png b/collects/teachpack/2htdp/scribblings/img/26e407a14a2.png new file mode 100644 index 0000000000..ff9cb5b754 Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/26e407a14a2.png differ diff --git a/collects/teachpack/2htdp/scribblings/img/2e45632f5de.png b/collects/teachpack/2htdp/scribblings/img/2e45632f5de.png new file mode 100644 index 0000000000..0bda86a29e Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/2e45632f5de.png differ