From 1fa6be75b5c48f850832a332ddd15587782e2242 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 4 Sep 2010 13:52:49 -0500 Subject: [PATCH] added image->color-list and color-list->bitmap --- collects/2htdp/image.rkt | 2 + collects/2htdp/private/image-more.rkt | 34 ++++++++++ collects/2htdp/private/img-err.rkt | 3 + collects/2htdp/tests/test-image.rkt | 56 +++++++++++++-- .../drracket/interface-essentials.scrbl | 2 +- .../teachpack/2htdp/scribblings/image-gen.rkt | 16 ++++- .../teachpack/2htdp/scribblings/image-toc.rkt | 47 +++++++++---- .../teachpack/2htdp/scribblings/image.scrbl | 64 ++++++++++++++---- .../2htdp/scribblings/img/19e57826953.png | Bin 0 -> 1726 bytes .../2htdp/scribblings/img/26e407a14a2.png | Bin 0 -> 2103 bytes .../2htdp/scribblings/img/2e45632f5de.png | Bin 0 -> 184 bytes 11 files changed, 191 insertions(+), 33 deletions(-) create mode 100644 collects/teachpack/2htdp/scribblings/img/19e57826953.png create mode 100644 collects/teachpack/2htdp/scribblings/img/26e407a14a2.png create mode 100644 collects/teachpack/2htdp/scribblings/img/2e45632f5de.png 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 0000000000000000000000000000000000000000..0705890a9f632cc7ea82df056f3fed8d7bc8ce37 GIT binary patch literal 1726 zcmV;v20{6WP) zJx>%}7=|BVf(0hRlu}6`*(pR4DV2I>@ejx^aLFzvG-4rOBQ}^Y=<*A&(Gqs8wRt-b z6P5@iHYBqaQb2ar`z^+gU6`GZGiS~@v%7bm3UNNJ3=h{C&e?Mf0QC|jhljMVK!pP3 za_k4W*5e*NwHm#6L8THo4rMa*^($!_ISE|E-;!$S3Ocncs1(yi#HLzYI>< z`@KrF8a;VJckVDkCnl%t>gU~YXmgWRR;X5sdnjF}qoXKJ$-PCUC2XzSrwWA#XYWSt z)hbMrCvmql4F?Bduc5oR+cxIsp=tb~M|H|>;a;!9vLaYHbCt`XuBR)wm&=@6xld&> zsMmupsl&M+93;}p{cC+a_`*7tyKSRbOt6*vl&-_J11_%vxeIIMK2%`@Pv19vZc!LwBp4Q>K!;4SNoA{pfFZ zztdj|(uup(&M8yIy@AFiHg)L!_uKzV8=X0j4&5zJr%V&~&-grv$&mMZ?=&l&xLcl1 znGWvX@qHGvQEz!_X-7JAx30dYRGs?;E?(i)4cuV3UzMFwY3@7N8OL~>`&Gv&4Wq>= z73F?}qZ!P^zu%#Tu8vb$*1sE6j{6zT7P06KKDm^dPN^36Eo@yHe8w*|ol+I_8R zJYnwP=9d4``ezPCrE{m)PN``q7DKi2#JERX@p+oPCmlM)bIM4qJQ?mx%Y@SFlnkw$ zH}@FJgwp7g%&nXscOJ`x6miPYb0g3xW43Z0-1*HdZ|Fm+IOTiG=bz)Z^4Q#YulQ8l zDGh^9E04iFnH8VPI;F0|vbeQ!ChiHZ_*Bg)lW64;xr{ivFNq;Ss8;2y z;`gfLobo>I?_yUr?SCNvn4gzU+^r;>@)mAwVM{jW%OL=;ZOI>_&{Q0qasUHQ@$@Ht z%7*NbKOVWUA)UBeyqq$J+&6ra%GNJ`xYz3{SdCjTol^YZlOavxrb7 zSQS6`WJv3Kf;2njEM{d5J{i)=J)KTDiAlMGPljB1FQ$%D8l!4i5>I>XiZ~^&35klucOHjar@XY{v$NvMU6xaZUnZ2= z1kGErEYZ*tnvkeig1C!x$_{Pio(VBOQh-zPom-xUgqxR|oKto|EB8$3`M^myWp}i4 z&xHFN@=S*2=6HNQchdpOWvWz|wsP!*gx;^LR-^H8J{x;2FVox{`xeQakqAEz8QBA=n_Te){4|Ad5h%I>rB@QJ<; zXthcc6T#a~=kv6(!noOb7bN@e-$r0cY@a``KkMf>|b=pnH#MocEQlX6vT3hQ0B15`*Uvr81A1CC% U2C907*qoM6N<$f^r99;s5{u literal 0 HcmV?d00001 diff --git a/collects/teachpack/2htdp/scribblings/img/26e407a14a2.png b/collects/teachpack/2htdp/scribblings/img/26e407a14a2.png new file mode 100644 index 0000000000000000000000000000000000000000..ff9cb5b754bfbe94b621593245a3e90c900e7243 GIT binary patch literal 2103 zcmV-72*~$|P)NMt1((?Nhan>3?y2TN-5!Bu9;+(qB;2X-9H}o#>>5zd+t5wJm+5c&i4=Gp7T4u z=ffGUbM7Cs13(TWD2U3-iHKf%jZ7x;@^WO6R-E>ZoRpPSkIrBF`B8SZihF7eX{Y#p zuc;wFKdP;5`u)&QGMOkMLam*-ca-1n>FE~GiKw)cA|oj_mQJ5`ep~JzC`w5Qh+6LJ zujBS@Wh=L`D0GjAu*;nYy?P-xSDQV%LzK9`_ny7z=05Wb4j$BO^DZ1E?*9IY-MKHm zh;!#O8^I-G_xox_hU0ITIXTp~FD+i|;OTA|yM8*=)$s6e@Mdq=#~#Dhts37+t`Ym( zr%h7<-Q4G%!{Ngk&t>%3;eOzNn&{@vo{dYFv>(u*vBQ1XFiqTv@W2CDzFhkmjhL3) z-+4zXbaNkn93OtD%diHDP4~Jw`1)$@&W(w|@#A_;Egzfi3l`{vZf2aJARwu zbLL>qWn7kHRGk02XJ(3Xb9evM!85y{%Sx;i#Z(XifD0GUv7@*+H@M8H^Met*8@r`d zTMhw0LV`FqcjZ6SS!g`QpTtRNTU#L%7mIUqFL$9Xm(^TxKIY%R4QXM^A&eX;F3z2^ zLj6U3;Ikg+mo_59$s8Ji8@&iUjMgoWvkzI2|HvaiPQimHd?%bE~(vSGj0PX;;T|;uRK7-F#CyCCzANOY>(*W+AufIl2 zjHV+O{Y4(VzL&iJ6m}&)-w5uU4?aLpkVeCf*e}g(ZsIEb>iOsK)mKJv=PX~2&Yjhr zbkk&MYjY2WH2K!txwvx02<`xW`U$gVt2OD}cGTyLG`G1?dzydup@*<~wGrGoUwnbc zNarUtrAb?x`|k-hUVidPeEhKy+&NpfqJMvfC;hIkv~|M}h+;YZIic&Hc|%CzqHu4QJ09!5zS@ zTUfZz+D@-`q#hTfxy>D3==>_4p2)~Bf;;EbDNLHwe4ELc($?l~oT}n-{{Gmq#R%@4 zy?Zfuuz7dK1EsCaz3oB0s#RY%A_AqQMsVk>S%a=!K@^iO&24V#BJEb6H48O0MsNpk z_3DY7SLM06r~7Gr4KFWbWf{R80B{V)#$b%Rdu*OQR~j@3J9iquowEZw24bKXdci22 zFFAHB%F7Ml&RK?KozO|ZJ+wsR2cDFK+FAp+1GtEbGci-w@v~=&pmV!*Lw2?S+&LvE z8HG`L3|`xbx?L1>=Z1!&puhm`oIK?9LqBatPFg08&YeEJerkDl&LS-GfQKf-mJbx? z=6ZVm{z%6t?f|M$Jrz^cpLgsIadB?LhdBmv=M~OxVTTIY)7HG)7w;cFQDjZf;PJ)e&6Mo%2544@97adHqj`i*s!} zf_Gte&RclvKHT^Fuo(-*xw+%U+1j?ty94+EKO`W5KyCK`{m>!B7j1K|&$ev{2yg^FKHibb zDgXQ0Zk;7dC_SC(>g+xK-g~L4ihO(&U#K;{ui8jT3RP86e7wEKn@ox5ZwWd(u+}z4ilbGl1 YnIRnBx_qZ3fKFlXboFyt=akR{04w)W&Hw-a literal 0 HcmV?d00001