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

fixed a bug in the saving of bitmaps (and along the way added some randomized tests that found a few other things)

Browse Source 
Please merge to release branch.
This commit is contained in:
Robby Findler 2010-07-20 22:59:03 -05:00
parent 5cfd52d224
commit 6cd277a36f
5 changed files with 84 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/2htdp/private/image-core.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang racket/base
;; this is here as a backwards compatibility file to provide the snipclass
(require mrlib/image-core)
(provide snip-class)

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

@ -427,6 +427,8 @@
(min (ltrb-top ltrb1) (ltrb-top ltrb2))
(max (ltrb-right ltrb1) (ltrb-right ltrb2))
(max (ltrb-bottom ltrb1) (ltrb-bottom ltrb2))))
;; only intersection if they already overlap.
(define (intersect-ltrb ltrb1 ltrb2)
(make-ltrb (max (ltrb-left ltrb1) (ltrb-left ltrb2))
(max (ltrb-top ltrb1) (ltrb-top ltrb2))

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

@ -45,6 +45,7 @@
lang/posn
racket/math
racket/class
racket/file
racket/gui/base
rackunit
(prefix-in 1: htdp/image)
@ -1611,7 +1612,13 @@
(crop coord coord size size image)
(scale/xy factor factor image)
(scale factor image)
(rotate angle image))
(rotate angle image)
(flip-vertical image)
(flip-horizontal image)
(bitmap bmp-spec))
(bmp-spec icons/b-run.png
icons/stop-16x16.png)
(factor (+ 1 big-nat) 1/2 1/3 1/4) ;; scaling factors
(size big-nat)
@ -1632,7 +1639,7 @@
(let loop ([obj obj])
(when (struct? obj)
(let ([stuff (vector->list (struct->vector obj))])
(unless (member (car stuff) '(struct:translate struct:scale)) ;; skip these becuase normalization eliminates them
(unless (member (car stuff) '(struct:flip struct:translate struct:scale)) ;; skip these becuase normalization eliminates them
(hash-set! counts (car stuff) (+ 1 (hash-ref counts (car stuff) 0))))
(for-each loop (cdr stuff)))))
(sort (hash-map counts list) string<=? #:key (λ (x) (symbol->string (car x))))))
@ -1640,20 +1647,44 @@
(define (check-image-properties img-sexp img)
(let* ([raw-size (image-struct-count (image-shape img))]
[normalized (normalize-shape (image-shape img) values)]
[norm-size (image-struct-count normalized)])
[norm-size (image-struct-count normalized)])
(unless (normalized-shape? normalized)
(error 'test-image.ss "found a non-normalized shape after normalization:\n~s"
img-sexp))
(unless (equal? norm-size raw-size)
(error 'test-image.ss "found differing sizes for ~s:\n ~s\n ~s"
img-sexp raw-size norm-size))))
img-sexp raw-size norm-size))))
(define (test-save/load img fn)
(let ([t1 (new text%)]
[t2 (new text%)])
(send t1 insert img)
(send t1 save-file fn)
(send t2 load-file fn)
(let ([s1 (send t1 find-first-snip)]
[s2 (send t2 find-first-snip)])
(equal? s1 s2))))
(time
(redex-check
2htdp/image
image
(check-image-properties
(term image)
(eval (term image) (namespace-anchor->namespace anchor)))
(to-img (eval (term image) (namespace-anchor->namespace anchor))))
#:attempts 1000))
;; this one is commented out because it catches
;; a bug where cropping a shape outside of its
;; bounding box leads to strange, bad behavior.
#;
(time
(let ([fn (make-temporary-file "test-image~a")])
(redex-check
2htdp/image
image
(let ([img (to-img (eval (term image) (namespace-anchor->namespace anchor)))])
(unless (test-save/load img fn)
(error 'test-image.rkt "saving and loading this image fails:\n ~s" (term image))))
#:attempts 1000)))

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

@ -150,7 +150,8 @@ has been moved out).
;; - (make-bitmap (is-a?/c bitmap%) angle positive-real (or/c #f (is-a?/c bitmap%)))
;; NOTE: bitmap copying needs to happen in 'write' and 'read' methods
(define-struct/reg-mk bitmap (raw-bitmap raw-mask angle x-scale y-scale [rendered-bitmap #:mutable] [rendered-mask #:mutable])
#:omit-define-syntaxes #:transparent)
#:omit-define-syntaxes #:transparent
#:property prop:custom-write (λ (x y z) (bitmap-write x y z)))
;; a flip is:
;; - (make-flip boolean bitmap)
@ -158,7 +159,7 @@ has been moved out).
;; * this struct is here to avoid adding a field to bitmaps, so that old save files
;; from when the library did not support flipping still load
;; (since normalization will add a flip structure if necessary)
(define-struct/reg-mk flip (flipped? shape))
(define-struct/reg-mk flip (flipped? shape) #:transparent)
;; a polygon is:
;;
@ -312,7 +313,7 @@ has been moved out).
(define/override (find-scroll-step y)
(calc-scroll-step)
(inexact->exact (ceiling (/ y scroll-step))))
(define/override (copy) (make-image shape bb normalized?))
(define/override (draw dc x y left top right bottom dx dy draw-caret?)
(let ([smoothing (send dc get-smoothing)])
@ -342,8 +343,8 @@ has been moved out).
(and (= (round (bb-right bb1)) (round (bb-right bb2)))
(= (round (bb-bottom bb1)) (round (bb-bottom bb2)))
(= (round (bb-baseline bb1)) (round (bb-baseline bb2)))))
(define racket/base:read read)
(define racket/base:read read)
(define image-snipclass%
(class snip-class%
(define/override (read f)
@ -370,7 +371,7 @@ has been moved out).
(provide snip-class)
(define snip-class (new image-snipclass%))
(send snip-class set-classname (format "~s" '(lib "image-core.ss" "2htdp" "private")))
(send snip-class set-classname (format "~s" '(lib "image-core.ss" "mrlib")))
(send snip-class set-version 1)
(send (get-the-snip-class-list) add snip-class)
@ -384,12 +385,17 @@ has been moved out).
[(vector? sexp)
(if (= (vector-length sexp) 0)
(k #f)
(let ([constructor (id->constructor (vector-ref sexp 0))]
[args (cdr (vector->list sexp))])
(if (and constructor
(procedure-arity-includes? constructor (length args)))
(apply constructor (map loop args))
(k #f))))]
(cond
[(bytes? (vector-ref sexp 0))
;; bitmaps are vectors with a bytes in the first field
(apply bytes->bitmap (vector->list sexp))]
[else
(let ([constructor (id->constructor (vector-ref sexp 0))]
[args (cdr (vector->list sexp))])
(if (and constructor
(procedure-arity-includes? constructor (length args)))
(apply constructor (map loop args))
(k #f)))]))]
[else sexp]))))
(define-id->constructor id->constructor)
@ -829,7 +835,7 @@ the mask bitmap and the original bitmap are all together in a single bytes!
(let-values ([(rotated-bytes rotated-w rotated-h)
(rotate-bytes bytes w h θ)])
(let* ([flipped-bytes (if flip?
(flip-bytes rotated-bytes w h)
(flip-bytes rotated-bytes rotated-w rotated-h)
rotated-bytes)]
[bm (bytes->bitmap flipped-bytes rotated-w rotated-h)]
[mask (send bm get-loaded-mask)])
@ -1005,6 +1011,24 @@ the mask bitmap and the original bitmap are all together in a single bytes!
(make-bb w h h)
#f)))
(define (bitmap-write bitmap port mode)
(let* ([v (struct->vector bitmap)]
[recur (case mode
[(#t) write]
[(#f) display]
[else (lambda (p port) (print p port mode))])]
[update
(λ (i)
(let ([o (vector-ref v i)])
(let ([nv (call-with-values (λ () (bitmap->bytes o)) vector)])
(vector-set! v i nv))))])
(update 1)
(update 2)
;; don't save the rendered bitmap (if it is there)
(vector-set! v 6 #f)
(vector-set! v 7 #f)
(recur v port)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

6
collects/mrlib/private/image-core-bitmap.rkt
View File

@ -67,7 +67,11 @@ instead of this scaling code, we use the dc<%>'s scaling code.
(define (bytes->bitmap bytes w h)
(unless (= (bytes-length bytes) (* w h NUM-CHANNELS))
(error 'bytes->bitmap "wrong sizes"))
(error 'bytes->bitmap "wrong sizes, got ~a bytes, w ~a h ~a (which should be ~a bytes)"
(bytes-length bytes)
w
h
(* w h NUM-CHANNELS)))
(let* ([bm (make-object bitmap% w h)]
[mask (make-object bitmap% w h)]
[bdc (make-object bitmap-dc% bm)])