suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

generalize the color structs to have an alpha field and then use that in the bitmap conversion functions

Browse Source
This commit is contained in:
Robby Findler 2010-12-27 20:07:23 -06:00
parent 0b1f1a4f4e
commit 835f7753dc
6 changed files with 85 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/2htdp/image.rkt
View File

@ -107,7 +107,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids
pen-cap?
pen-join?
real-valued-posn?
color-red color-blue color-green color? color
color-red color-blue color-green color-alpha color? color
pen-color pen-width pen-style pen-cap pen-join
image-width

47
collects/2htdp/private/image-more.rkt
View File

@ -1269,40 +1269,55 @@
(define/chk (image->color-list image)
(let* ([w (image-width image)]
[h (image-height image)]
[bm (make-object bitmap% w h)]
[bm (make-bitmap w h)]
[bdc (make-object bitmap-dc% bm)]
[c (make-object color%)])
[c (make-object color%)]
[bytes (make-bytes (* w h 4))])
(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)))))
(send bdc get-argb-pixels 0 0 w h bytes)
(for/list ([i (in-range 0 (* w h 4) 4)])
(color (bytes-ref bytes (+ i 1))
(bytes-ref bytes (+ i 2))
(bytes-ref bytes (+ i 3))
(bytes-ref bytes i)))))
(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)]
(let* ([bmp (make-bitmap width height)]
[bytes (make-bytes (* width height 4) 0)]
[o (make-object color%)])
(for ([c (in-list color-list)]
[i (in-naturals)])
(define j (* i 4))
(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)]
(bytes-set! bytes j (color-alpha c))
(bytes-set! bytes (+ j 1) (color-red c))
(bytes-set! bytes (+ j 2) (color-green c))
(bytes-set! bytes (+ j 3) (color-blue c))]
[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))]))
(bytes-set! bytes j 255) ;; this should probably (send clr alpha) when that's possible
(bytes-set! bytes (+ j 1) (send clr red))
(bytes-set! bytes (+ j 2) (send clr green))
(bytes-set! bytes (+ j 3) (send clr blue)))]))
(send bmp set-argb-pixels 0 0 width height bytes)
(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)
(orig-make-color int0-255-1 int0-255-2 int0-255-3))
(define/chk make-color
(case-lambda
[(int0-255-1 int0-255-2 int0-255-3)
(orig-make-color int0-255-1 int0-255-2 int0-255-3)]
[(int0-255-1 int0-255-2 int0-255-3 int0-255-4)
(orig-make-color int0-255-1 int0-255-2 int0-255-3 int0-255-4)]))
make-color))
(define/chk (pinhole-x image) (let ([ph (send image get-pinhole)]) (and ph (point-x ph))))
@ -1319,8 +1334,12 @@
(define build-color/color
(let ([orig-make-color make-color])
(define/chk (color int0-255-1 int0-255-2 int0-255-3)
(orig-make-color int0-255-1 int0-255-2 int0-255-3))
(define/chk color
(case-lambda
[(int0-255-1 int0-255-2 int0-255-3)
(orig-make-color int0-255-1 int0-255-2 int0-255-3)]
[(int0-255-1 int0-255-2 int0-255-3 int0-255-4)
(orig-make-color int0-255-1 int0-255-2 int0-255-3 int0-255-4)]))
color))
(define build-pen/make-pen

2
collects/2htdp/private/img-err.rkt
View File

@ -241,7 +241,7 @@
'list-of-at-least-three-posns
i arg)
arg]
[(int0-255-1 int0-255-2 int0-255-3)
[(int0-255-1 int0-255-2 int0-255-3 int0-255-4)
(check-arg fn-name (and (integer? arg) (<= 0 arg 255))
'integer\ between\ 0\ and\ 255 i arg)
arg]

13
collects/2htdp/tests/test-image.rkt
View File

@ -1624,6 +1624,19 @@
=>
#t))
(test (image->color-list
(overlay
(color-list->bitmap
(list (color 0 0 0 0)
(color 0 0 255 255))
1 2)
(color-list->bitmap
(list (color 255 0 0 255)
(color 0 0 0 0))
1 2)))
=>
(list (color 255 0 0 255)
(color 0 0 255 255)))
(let ([i
(overlay (circle 20 'solid 'red)

20
collects/mrlib/image-core.rkt
View File

@ -178,8 +178,13 @@ has been moved out).
;; an color is
;; - (make-color (<=/c 0 255) (<=/c 0 255) (<=/c 0 255))
;; - string
(define-struct/reg-mk color (red green blue) #:transparent)
(define-struct/reg-mk color (red green blue alpha) #:transparent)
(define -make-color
;; this let is here just for the name
(let ([make-color
(λ (r g b [a 255])
(make-color r g b a))])
make-color))
;
;
;
@ -396,6 +401,14 @@ has been moved out).
(list-ref parsed-args 3)
(list-ref parsed-args 4)
(make-hash))]
[(and (eq? tag 'struct:color)
(= arg-count 3))
;; we changed the arity of the color constructor from old versions,
;; so fix it up here.
(make-color (list-ref parsed-args 0)
(list-ref parsed-args 1)
(list-ref parsed-args 2)
255)]
[else
(k #f)]))]))]
[else sexp]))))
@ -1154,7 +1167,8 @@ the mask bitmap and the original bitmap are all together in a single bytes!
make-flip flip? flip-flipped? flip-shape
(struct-out color)
(except-out (struct-out color) make-color)
(rename-out [-make-color make-color])
degrees->radians
normalize-shape

23
collects/teachpack/2htdp/scribblings/image.scrbl
View File

@ -1205,9 +1205,26 @@ This section lists predicates for the basic structures provided by the image lib
@defstruct[color ([red (and/c natural-number/c (<=/c 255))]
[green (and/c natural-number/c (<=/c 255))]
[blue (and/c natural-number/c (<=/c 255))])]{
The @racket[color] struct defines a color with red, green, and blue components
that range from @racket[0] to @racket[255].
[blue (and/c natural-number/c (<=/c 255))]
[alpha (and/c natural-number/c (<=/c 255))])]{
The @racket[color] struct defines a color with @racket[red],
@racket[green], @racket[blue], and @racket[alpha] components
that range from @racket[0] to @racket[255].
The @racket[red], @racket[green], and @racket[blue] fields
combine to make a color, with the higher values meaning more of the given color.
For example, @racket[(make-color 255 0 0)] makes a
bright red color and @racket[(make-color 255 0 255)] makes a bright purple.
The @racket[alpha] field controls the transparency of the color. A value of @racket[255] means
that the color is opaque and @racket[0] means the color is fully transparent.
The constructor, @racket[make-color], also accepts only three arguments, in which case
the three arguments are used for the @racket[red], @racket[green], and @racket[blue] fields, and the
@racket[alpha] field defaults to @racket[255].
Unfortunately, not all of the primitives that accept or produce @racket[color] structs use the @racket[alpha]
field; only @racket[image->color-list] and @racket[color-list->bitmap] do.
}
@defproc[(y-place? [x any/c]) boolean?]{