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

added zero size rectangles, ellipses, circles, and strings

Browse Source 
svn: r10610
This commit is contained in:
Robby Findler 2008-07-05 01:58:36 +00:00
parent 39f14130e9
commit 7be05fcf8b
5 changed files with 209 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/htdp/image.ss
View File

@ -391,9 +391,14 @@ 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")
(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
@ -432,7 +437,7 @@ plt/collects/tests/mzscheme/htdp-image.ss
[width tw]
[height th]
[px 0]
[py 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
(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)))])
(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)

84
collects/mrlib/cache-image-snip.ss
View File

@ -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)
(cond
[(or (zero? width) (zero? height))
#f]
[else
(unless bitmap
(set! bitmap (argb->bitmap (get-argb))))
bitmap)
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)])
[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)))]
(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,21 +272,26 @@
(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)
(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))))))
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)]
[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)]
@ -281,7 +312,7 @@
(send bdc set-argb-pixels 0 0 w h mask-bytes)
(send bdc set-bitmap #f)
(send bm set-loaded-mask mask-bm)
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?)]))

22
collects/mrlib/scribblings/cache-image-snip.scrbl
View File

@ -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].
}

6
collects/teachpack/htdp/scribblings/image.scrbl
View File

@ -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}

49
collects/tests/mzscheme/htdp-image.ss
View File

@ -49,10 +49,15 @@
(let ([bdc (make-object bitmap-dc%)]
[max-difference
(lambda (s1 s2)
(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))))])
(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")