added image->color-list and color-list->bitmap
This commit is contained in:
parent
a2b11a0329
commit
1fa6be75b5
|
@ -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?
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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
|
||||
|
||||
|#
|
|
@ -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,
|
||||
|
|
|
@ -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])
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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?)]{
|
||||
|
|
BIN
collects/teachpack/2htdp/scribblings/img/19e57826953.png
Normal file
BIN
collects/teachpack/2htdp/scribblings/img/19e57826953.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 1.7 KiB |
BIN
collects/teachpack/2htdp/scribblings/img/26e407a14a2.png
Normal file
BIN
collects/teachpack/2htdp/scribblings/img/26e407a14a2.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 2.1 KiB |
BIN
collects/teachpack/2htdp/scribblings/img/2e45632f5de.png
Normal file
BIN
collects/teachpack/2htdp/scribblings/img/2e45632f5de.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 184 B |
Loading…
Reference in New Issue
Block a user