diff --git a/collects/htdp/image.ss b/collects/htdp/image.ss index 6a0f95080c..03eb444389 100644 --- a/collects/htdp/image.ss +++ b/collects/htdp/image.ss @@ -391,48 +391,53 @@ plt/collects/tests/mzscheme/htdp-image.ss y2)))))) (define (text str size color-in) - (check 'text (lambda (x) (and (string? x) (not (equal? "" x)))) str "non-empty string" "first") + (check 'text string? str "string" "first") (check 'text (lambda (x) (and (integer? x) (<= 1 x 255))) size "integer between 1 and 255" "second") (check-image-color 'text color-in "third") - (let ([color (make-color% color-in)]) - (let-values ([(tw th) (get-text-size size str)]) - (let ([draw-proc - (lambda (txt-color mode dc dx dy) - (let ([old-mode (send dc get-text-mode)] - [old-fore (send dc get-text-foreground)] - [old-font (send dc get-font)]) - (send dc set-text-mode mode) - (send dc set-text-foreground txt-color) - (send dc set-font (get-font size)) - (send dc draw-text str dx dy) - (send dc set-text-mode old-mode) - (send dc set-text-foreground old-fore) - (send dc set-font old-font)))]) - (new cache-image-snip% - [dc-proc (lambda (dc dx dy) (draw-proc color 'transparent dc dx dy))] - [argb-proc - (lambda (argb dx dy) - (let ([bm-color - (build-bitmap - (lambda (dc) - (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) - (send dc set-brush (send the-brush-list find-or-create-brush color 'solid)) - (send dc draw-rectangle 0 0 tw th)) - tw - th)] - [bm-mask - (build-bitmap - (lambda (dc) - (draw-proc - (send the-color-database find-color "black") - 'solid dc 0 0)) - tw - th)]) - (overlay-bitmap argb dx dy bm-color bm-mask)))] - [width tw] - [height th] - [px 0] - [py 0]))))) + (cond + [(string=? str "") + (let-values ([(tw th) (get-text-size size "dummyX")]) + (rectangle 0 th 'solid 'black))] + [else + (let ([color (make-color% color-in)]) + (let-values ([(tw th) (get-text-size size str)]) + (let ([draw-proc + (lambda (txt-color mode dc dx dy) + (let ([old-mode (send dc get-text-mode)] + [old-fore (send dc get-text-foreground)] + [old-font (send dc get-font)]) + (send dc set-text-mode mode) + (send dc set-text-foreground txt-color) + (send dc set-font (get-font size)) + (send dc draw-text str dx dy) + (send dc set-text-mode old-mode) + (send dc set-text-foreground old-fore) + (send dc set-font old-font)))]) + (new cache-image-snip% + [dc-proc (lambda (dc dx dy) (draw-proc color 'transparent dc dx dy))] + [argb-proc + (lambda (argb dx dy) + (let ([bm-color + (build-bitmap + (lambda (dc) + (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) + (send dc set-brush (send the-brush-list find-or-create-brush color 'solid)) + (send dc draw-rectangle 0 0 tw th)) + tw + th)] + [bm-mask + (build-bitmap + (lambda (dc) + (draw-proc + (send the-color-database find-color "black") + 'solid dc 0 0)) + tw + th)]) + (overlay-bitmap argb dx dy bm-color bm-mask)))] + [width tw] + [height th] + [px 0] + [py 0]))))])) (define cached-bdc-for-text-size (make-thread-cell #f)) (define (get-text-size size string) @@ -452,41 +457,37 @@ plt/collects/tests/mzscheme/htdp-image.ss [(macosx) 'partly-smoothed] [else 'smoothed]))) -(define (a-rect/circ who do-draw w h color brush pen) - (check-sizes who w h) +(define (a-rect/circ do-draw w h color brush pen) (let* ([dc-proc (make-color-wrapper color brush pen do-draw)] [mask-proc (make-color-wrapper 'black brush pen do-draw)]) (make-simple-cache-image-snip w h (floor (/ w 2)) (floor (/ h 2)) dc-proc mask-proc))) (define (rectangle in-w in-h mode color) - (check-size 'rectangle in-w "first") - (check-size 'rectangle in-h "second") + (check-size/0 'rectangle in-w "first") + (check-size/0 'rectangle in-h "second") (check-mode 'rectangle mode "third") (check-image-color 'rectangle color "fourth") (let ([w (inexact->exact (floor in-w))] [h (inexact->exact (floor in-h))]) - (a-rect/circ 'rectangle - (lambda (dc dx dy) (send dc draw-rectangle dx dy w h)) + (a-rect/circ (lambda (dc dx dy) (send dc draw-rectangle dx dy w h)) w h color (mode->brush-symbol mode) (mode->pen-symbol mode)))) (define (ellipse in-w in-h mode color) - (check-size 'ellipse in-w "first") - (check-size 'ellipse in-h "second") + (check-size/0 'ellipse in-w "first") + (check-size/0 'ellipse in-h "second") (check-mode 'ellipse mode "third") (check-image-color 'ellipse color "fourth") (let ([w (inexact->exact (floor in-w))] [h (inexact->exact (floor in-h))]) - (a-rect/circ 'ellipse - (lambda (dc dx dy) (send dc draw-ellipse dx dy w h)) + (a-rect/circ (lambda (dc dx dy) (send dc draw-ellipse dx dy w h)) w h color (mode->brush-symbol mode) (mode->pen-symbol mode)))) (define (circle in-r mode color) - (check-size 'circle in-r "first") + (check-size/0 'circle in-r "first") (check-mode 'circle mode "second") (check-image-color 'circle color "third") (let ([r (inexact->exact (floor in-r))]) - (a-rect/circ 'circle - (lambda (dc dx dy) (send dc draw-ellipse dx dy (* 2 r) (* 2 r))) + (a-rect/circ (lambda (dc dx dy) (send dc draw-ellipse dx dy (* 2 r) (* 2 r))) (* 2 r) (* 2 r) color (mode->brush-symbol mode) (mode->pen-symbol mode)))) (define (triangle in-size mode color) @@ -629,10 +630,12 @@ plt/collects/tests/mzscheme/htdp-image.ss (let ([w (inexact->exact (ceiling w))] [h (inexact->exact (ceiling h))]) (let ([argb-proc - (lambda (argb-vector dx dy) - (let ([c-bm (build-bitmap (lambda (dc) (dc-proc dc 0 0)) w h)] - [m-bm (build-bitmap (lambda (dc) (mask-proc dc 0 0)) w h)]) - (overlay-bitmap argb-vector dx dy c-bm m-bm)))]) + (if (or (zero? w) (zero? h)) + void + (lambda (argb-vector dx dy) + (let ([c-bm (build-bitmap (lambda (dc) (dc-proc dc 0 0)) w h)] + [m-bm (build-bitmap (lambda (dc) (mask-proc dc 0 0)) w h)]) + (overlay-bitmap argb-vector dx dy c-bm m-bm))))]) (new cache-image-snip% [dc-proc dc-proc] [argb-proc argb-proc] @@ -986,7 +989,7 @@ converting from the computer's coordinates, we get: "given width times given height is ~a, but the given color list has ~a items" (* w h) (length cl))) (let ([index-list (alpha-colors->ent-list cl)]) - (argb->cache-image-snip (make-argb (list->vector index-list) w) px py)))) + (argb->cache-image-snip (make-argb (list->vector index-list) w h) px py)))) ;; alpha-colors->ent-list : (listof alpha-color) -> (listof number) (define (alpha-colors->ent-list cl) diff --git a/collects/mrlib/cache-image-snip.ss b/collects/mrlib/cache-image-snip.ss index 683505bae2..363bdc356f 100644 --- a/collects/mrlib/cache-image-snip.ss +++ b/collects/mrlib/cache-image-snip.ss @@ -9,8 +9,8 @@ cache-image-snip-class% snip-class) - ;; type argb = (make-argb (vectorof rational[between 0 & 255]) int) - (define-struct argb (vector width)) + ;; type argb = (make-argb (vectorof rational[between 0 & 255]) int int) + (define-struct argb (vector width height)) #| @@ -64,7 +64,6 @@ ;; argb : (union #f argb) (init-field [argb #f]) - ;; bitmap : (union #f (is-a?/c bitmap%)) ;; the way that this image is be drawn, on its own (define bitmap #f) @@ -79,18 +78,22 @@ (px px) (py py))) - ;; get-bitmap : -> bitmap + ;; get-bitmap : -> bitmap or false ;; returns a bitmap showing what the image would look like, ;; if it were drawn (define/public (get-bitmap) - (unless bitmap - (set! bitmap (argb->bitmap (get-argb)))) - bitmap) + (cond + [(or (zero? width) (zero? height)) + #f] + [else + (unless bitmap + (set! bitmap (argb->bitmap (get-argb)))) + bitmap])) ;; get-argb : -> argb (define/public (get-argb) (unless argb - (set! argb (make-argb (make-vector (* 4 width height) 255) width)) + (set! argb (make-argb (make-vector (* 4 width height) 255) width height)) (argb-proc argb 0 0)) argb) @@ -108,10 +111,12 @@ (define/override (draw dc x y left top right bottom dx dy draw-caret) (cond - [argb (let ([bitmap (get-bitmap)]) - (send dc draw-bitmap bitmap x y 'solid - (send the-color-database find-color "black") - (send bitmap get-loaded-mask)))] + [argb + (let ([bitmap (get-bitmap)]) + (when bitmap + (send dc draw-bitmap bitmap x y 'solid + (send the-color-database find-color "black") + (send bitmap get-loaded-mask))))] [dc-proc (let ([smoothing (send dc get-smoothing)]) (send dc set-smoothing 'aligned) @@ -124,6 +129,7 @@ (format "~s" (list (argb-vector (get-argb)) width + height px py)))]) (send f put str))) @@ -146,11 +152,31 @@ (define/override (read f) (data->snip (read-from-string (send f get-bytes) (lambda () #f)))) (define/public (data->snip data) - (if data - (argb->cache-image-snip (make-argb (first data) (second data)) - (third data) - (fourth data)) - (make-null-cache-image-snip))) + (cond + [(not (list? data)) (make-null-cache-image-snip)] + [(= (length data 4)) + ;; this is the case for old save files + ;; if the width is zero, the height + ;; will automatically also be zero + (let ([argb-vec (list-ref data 0)] + [width (list-ref data 1)] + [px (list-ref data 2)] + [py (list-ref data 3)]) + (argb->cache-image-snip (make-argb argb-vec + width + (if (zero? width) + 0 + (/ (vector-length argb-vec) width 4))) + px + py))] + [(= (length data) 5) + ;; this is the new saved data and it has the width and the height separately. + (let ([argb-vec (list-ref data 0)] + [width (list-ref data 1)] + [height (list-ref data 2)] + [px (list-ref data 3)] + [py (list-ref data 4)]) + (argb->cache-image-snip (make-argb argb-vec width height) px py))])) (super-new))) (define snip-class (new cache-image-snip-class%)) @@ -236,8 +262,8 @@ ;; argb->cache-image-snip : argb number number -> cache-image-snip (define (argb->cache-image-snip argb px py) (let* ([width (argb-width argb)] + [height (argb-height argb)] [argb-vector (argb-vector argb)] - [height (quotient (vector-length argb-vector) (* 4 width))] [bitmap (argb->bitmap argb)] [mask (send bitmap get-loaded-mask)]) (new cache-image-snip% @@ -246,42 +272,47 @@ (argb argb) (px px) (py py) - (argb-proc - (lambda (argb dx dy) - (overlay-bitmap argb dx dy bitmap mask))) - (dc-proc (lambda (dc dx dy) - (send dc draw-bitmap bitmap dx dy 'solid - (send the-color-database find-color "black") - mask)))))) + (argb-proc (if (or (zero? width) (zero? height)) + void + (lambda (argb dx dy) (overlay-bitmap argb dx dy bitmap mask)))) + (dc-proc (if (or (zero? width) (zero? height)) + void + (lambda (dc dx dy) + (send dc draw-bitmap bitmap dx dy 'solid + (send the-color-database find-color "black") + mask))))))) - ;; argb-vector->bitmap : argb -> bitmap + ;; argb-vector->bitmap : argb -> bitmap or false ;; flattens the argb vector into a bitmap (define (argb->bitmap argb) (let* ([argb-vector (argb-vector argb)] [w (argb-width argb)] - [h (quotient (vector-length argb-vector) (* w 4))] - [bm (make-object bitmap% w h)] - [mask-bm (make-object bitmap% w h)] - [bdc (new bitmap-dc% (bitmap bm))] - [bytes (make-bytes (vector-length argb-vector) 255)] - [mask-bytes (make-bytes (vector-length argb-vector) 255)]) - (let loop ([i (- (vector-length argb-vector) 1)]) - (cond - [(zero? (modulo i 4)) - (let ([av (round (vector-ref argb-vector i))]) - (bytes-set! mask-bytes (+ i 1) av) - (bytes-set! mask-bytes (+ i 2) av) - (bytes-set! mask-bytes (+ i 3) av))] - [else - (bytes-set! bytes i (round (vector-ref argb-vector i)))]) - (unless (zero? i) - (loop (- i 1)))) - (send bdc set-argb-pixels 0 0 w h bytes) - (send bdc set-bitmap mask-bm) - (send bdc set-argb-pixels 0 0 w h mask-bytes) - (send bdc set-bitmap #f) - (send bm set-loaded-mask mask-bm) - bm)) + [h (argb-height argb)]) + (cond + [(or (zero? w) (zero? h)) #f] + [else + (let* ([bm (make-object bitmap% w h)] + [mask-bm (make-object bitmap% w h)] + [bdc (new bitmap-dc% (bitmap bm))] + [bytes (make-bytes (vector-length argb-vector) 255)] + [mask-bytes (make-bytes (vector-length argb-vector) 255)]) + (let loop ([i (- (vector-length argb-vector) 1)]) + (cond + [(zero? (modulo i 4)) + (let ([av (round (vector-ref argb-vector i))]) + (bytes-set! mask-bytes (+ i 1) av) + (bytes-set! mask-bytes (+ i 2) av) + (bytes-set! mask-bytes (+ i 3) av))] + [else + (bytes-set! bytes i (round (vector-ref argb-vector i)))]) + (unless (zero? i) + (loop (- i 1)))) + (send bdc set-argb-pixels 0 0 w h bytes) + (send bdc set-bitmap mask-bm) + (send bdc set-argb-pixels 0 0 w h mask-bytes) + (send bdc set-bitmap #f) + (send bm set-loaded-mask mask-bm) + bm)]))) ;; overlay-bitmap : argb int int bitmap bitmap -> void ;; assumes that the mask bitmap only has greyscale in it @@ -656,9 +687,10 @@ for b3, we have: [flatten-bitmap ((is-a?/c bitmap%) . -> . (is-a?/c bitmap%))] [argb->cache-image-snip (argb? number? number? . -> . (is-a?/c cache-image-snip%))] - [argb->bitmap (argb? . -> . (is-a?/c bitmap%))] + [argb->bitmap (argb? . -> . (or/c false/c (is-a?/c bitmap%)))] [argb? (any/c . -> . boolean?)] - [make-argb ((vectorof (integer-in 0 255)) integer? . -> . argb?)] + [make-argb ((vectorof (integer-in 0 255)) exact-nonnegative-integer? exact-nonnegative-integer? . -> . argb?)] [argb-vector (argb? . -> . (vectorof (integer-in 0 255)))] - [argb-width (argb? . -> . integer?)])) + [argb-width (argb? . -> . exact-nonnegative-integer?)] + [argb-height (argb? . -> . exact-nonnegative-integer?)])) diff --git a/collects/mrlib/scribblings/cache-image-snip.scrbl b/collects/mrlib/scribblings/cache-image-snip.scrbl index e1bb976ba5..6013f3c297 100644 --- a/collects/mrlib/scribblings/cache-image-snip.scrbl +++ b/collects/mrlib/scribblings/cache-image-snip.scrbl @@ -44,13 +44,13 @@ predicate. } -@defmethod[(get-bitmap) - (is-a?/c bitmap%)]{ +@defmethod[(get-bitmap) (or/c false/c (is-a?/c bitmap%))]{ Builds (if not yet built) a bitmap corresponding to this snip and returns it. - + If the width or the height of the snip is @scheme[0], + this method return @scheme[#f]. } @defmethod[(get-dc-proc) @@ -83,7 +83,9 @@ predicate. This snipclass is used for saved cache image snips.} -@defproc[(make-argb [vectorof (integer-in 0 255)] [width exact-nonnegative-integer?]) +@defproc[(make-argb [vectorof (integer-in 0 255)] + [width exact-nonnegative-integer?] + [height exact-nonnegative-integer?]) argb?]{ Constructs a new argb value. The vector has four entries @@ -99,6 +101,10 @@ This snipclass is used for saved cache image snips.} Extracts the width from @scheme[argb].} +@defproc[(argb-height [argb argb?]) exact-nonnegative-integer?]{ + + Extracts the height from @scheme[argb].} + @defproc[(argb? [v any/c]) boolean?]{ @@ -142,9 +148,13 @@ procedure @scheme[draw] to render the bitmap content into the given @scheme[argb], using @scheme[dx] and @scheme[dy] as the pinhole.} -@defproc[(argb->bitmap [argb argb?]) (is-a?/c bitmap%)]{ +@defproc[(argb->bitmap [argb argb?]) (or/c false/c (is-a?/c bitmap%))]{ Builds a bitmap that draws the same way as @scheme[argb]; the alpha pixels are put into the bitmap's @method[bitmap% get-loaded-mask] - bitmap.} + bitmap. + + If the width or height of @scheme[argb] is @scheme[0], + this returns @scheme[#f]. +} diff --git a/collects/teachpack/htdp/scribblings/image.scrbl b/collects/teachpack/htdp/scribblings/image.scrbl index 7d629859a0..b9ff0c5e68 100644 --- a/collects/teachpack/htdp/scribblings/image.scrbl +++ b/collects/teachpack/htdp/scribblings/image.scrbl @@ -91,11 +91,9 @@ angle. See @scheme[add-line] below. } -@defproc[(text [s (and/c string? (lambda (s) (not (string=? s ""))))] [f (and/c number? positive?)] [c (unsyntax @tech{Color})]) Image]{ +@defproc[(text [s string?] [f (and/c number? positive?)] [c (unsyntax @tech{Color})]) Image]{ Creates an image of the text @scheme[s] at point size @scheme[f] - and painted in color @scheme[c]. - - The string @scheme[s] must have at least one character.} + and painted in color @scheme[c].} @;----------------------------------------------------------------------------- @section[#:tag "properties"]{Basic Image Properties} diff --git a/collects/tests/mzscheme/htdp-image.ss b/collects/tests/mzscheme/htdp-image.ss index 3ea4b20921..618f3a4173 100644 --- a/collects/tests/mzscheme/htdp-image.ss +++ b/collects/tests/mzscheme/htdp-image.ss @@ -49,10 +49,15 @@ (let ([bdc (make-object bitmap-dc%)] [max-difference (lambda (s1 s2) - (apply max - (map (lambda (x y) (abs (- x y))) - (bytes->list s1) - (bytes->list s1))))]) + (cond + [(and (zero? (bytes-length s1)) + (zero? (bytes-length s2))) + 0] + [else + (apply max + (map (lambda (x y) (abs (- x y))) + (bytes->list s1) + (bytes->list s1)))]))]) ;; test that no drawing is outside the snip's drawing claimed drawing area (let* ([extra-space 100] @@ -89,8 +94,8 @@ (test (list 'bmtrunc name #t) (lambda () (list 'bmtrunc name (equal? s-noclip s-trunc))))) - (let ([bm-normal (make-object bitmap% width height)] - [bm-bitmap (make-object bitmap% width height)] + (let ([bm-normal (make-object bitmap% (max 1 width) (max 1 height))] + [bm-bitmap (make-object bitmap% (max 1 width) (max 1 height))] [s-normal (make-bytes (* width height 4))] [s-bitmap (make-bytes (* width height 4))]) @@ -393,6 +398,19 @@ 1 0 (p00 (rectangle 1 2 'solid 'blue))))) +(test #t + 'image=?-zero1 + (image=? (rectangle 0 10 'solid 'red) + (rectangle 0 10 'solid 'red))) +(test #t + 'image=?-zero2 + (image=? (rectangle 0 10 'solid 'red) + (rectangle 0 10 'solid 'blue))) +(test #f + 'image=?-zero3 + (image=? (rectangle 0 5 'solid 'red) + (rectangle 0 4'solid 'blue))) + (test #t 'image-inside?1 (image-inside? (overlay/xy (p00 (rectangle 3 2 'solid 'red)) @@ -485,6 +503,14 @@ 'image-height (image-height (rectangle 5 7 'solid 'red))) +(test 10 image-width (rectangle 10 0 'solid 'red)) +(test 0 image-height (rectangle 10 0 'solid 'red)) +(test 0 image-width (rectangle 0 10 'solid 'red)) +(test 10 image-height (rectangle 0 10 'solid 'red)) + +(test 0 image-width (text "" 12 'black)) +(test #t 'not-zero-empty-string-height (not (zero? (image-height (text "" 12 'black))))) + (test 1 'color-red (color-red (make-color 1 2 3))) (test 2 'color-green (color-green (make-color 1 2 3))) (test 3 'color-blue (color-blue (make-color 1 2 3))) @@ -797,8 +823,20 @@ (check-on-bitmap 'outline-rect (rectangle 2 2 'outline 'red)) (check-on-bitmap 'solid-ellipse (ellipse 2 4 'solid 'red)) (check-on-bitmap 'outline-ellipse (ellipse 2 4 'outline 'red)) -(check-on-bitmap 'solid-ellipse (circle 4 'solid 'red)) -(check-on-bitmap 'outline-ellipse (circle 4 'outline 'red)) +(check-on-bitmap 'solid-circle (circle 4 'solid 'red)) +(check-on-bitmap 'outline-circle (circle 4 'outline 'red)) + +(check-on-bitmap '0solid-rect1 (rectangle 0 2 'solid 'red)) +(check-on-bitmap '0solid-rect2 (rectangle 2 0 'solid 'red)) +(check-on-bitmap '0outline-rect1 (rectangle 2 0 'outline 'red)) +(check-on-bitmap '0outline-rect2 (rectangle 0 0 'outline 'red)) +(check-on-bitmap '0solid-ellipse1 (ellipse 0 3 'solid 'red)) +(check-on-bitmap '0solid-ellipse2 (ellipse 3 0 'solid 'red)) +(check-on-bitmap '0outline-ellipse1 (ellipse 0 4 'outline 'red)) +(check-on-bitmap '0outline-ellipse2 (ellipse 2 0 'outline 'red)) +(check-on-bitmap '0solid-circle (circle 0 'solid 'red)) +(check-on-bitmap '0outline-circle (circle 0 'outline 'red)) + (check-on-bitmap 'solid-triangle (triangle 10 'solid 'red)) (check-on-bitmap 'outline-triangle (triangle 10 'outline 'red)) (check-on-bitmap 'solid-star (star 4 10 20 'solid 'red)) @@ -1158,7 +1196,6 @@ (err/rt-name-test (add-line image-snip1 10 10 #f #f #f) "fourth") (err/rt-name-test (add-line image-snip1 10 10 11 #f #f) "fifth") (err/rt-name-test (add-line image-snip1 10 10 11 11 #f) "sixth") -(err/rt-name-test (text "" 12 'red) "first") (err/rt-name-test (text #f #f #f) "first") (err/rt-name-test (text "abc" #f #f) "second") (err/rt-name-test (text "abc" 10 #f) "third")