From 835f7753dcb98d508d86c653dd6fc2d7c3f21b1e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 27 Dec 2010 20:07:23 -0600 Subject: [PATCH] generalize the color structs to have an alpha field and then use that in the bitmap conversion functions --- collects/2htdp/image.rkt | 2 +- collects/2htdp/private/image-more.rkt | 47 +++++++++++++------ collects/2htdp/private/img-err.rkt | 2 +- collects/2htdp/tests/test-image.rkt | 13 +++++ collects/mrlib/image-core.rkt | 20 ++++++-- .../teachpack/2htdp/scribblings/image.scrbl | 23 +++++++-- 6 files changed, 85 insertions(+), 22 deletions(-) diff --git a/collects/2htdp/image.rkt b/collects/2htdp/image.rkt index 21593414c6..a8ca6e81ab 100644 --- a/collects/2htdp/image.rkt +++ b/collects/2htdp/image.rkt @@ -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 diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt index dc9cace9fe..35437f9d15 100644 --- a/collects/2htdp/private/image-more.rkt +++ b/collects/2htdp/private/image-more.rkt @@ -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 diff --git a/collects/2htdp/private/img-err.rkt b/collects/2htdp/private/img-err.rkt index 698bfcc213..079e59d004 100644 --- a/collects/2htdp/private/img-err.rkt +++ b/collects/2htdp/private/img-err.rkt @@ -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] diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt index 644155295f..5fe37ce479 100644 --- a/collects/2htdp/tests/test-image.rkt +++ b/collects/2htdp/tests/test-image.rkt @@ -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) diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index b0c3c16c83..3b491eeb71 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -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 diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl index 1a7bb918fd..ba2d64ebea 100644 --- a/collects/teachpack/2htdp/scribblings/image.scrbl +++ b/collects/teachpack/2htdp/scribblings/image.scrbl @@ -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?]{