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

applied Ian's patch to the bitmap rotation code

Browse Source 
svn: r17513
This commit is contained in:
Robby Findler 2010-01-06 21:43:34 +00:00
parent ccacf5a651
commit b5e54fe2eb
4 changed files with 119 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
collects/2htdp/private/image-more.ss
View File

@ -16,8 +16,8 @@
[f (new frame% [label ""])] [f (new frame% [label ""])]
[c (new canvas% [c (new canvas%
[parent f] [parent f]
[min-width (+ extra-space (inexact->exact (floor (image-right g))))] [min-width (+ extra-space (image-width g))]
[min-height (+ extra-space (inexact->exact (floor (image-bottom g))))] [min-height (+ extra-space (image-height g))]
[paint-callback [paint-callback
(λ (c dc) (λ (c dc)
(send dc set-smoothing 'aligned) (send dc set-smoothing 'aligned)
@ -27,8 +27,8 @@
(render-image (render-image
g g
dc dc
(inexact->exact (floor (- (/ w 2 scale) (/ (image-right g) 2)))) (inexact->exact (floor (- (/ w 2 scale) (/ (get-right g) 2))))
(inexact->exact (floor (- (/ h 2 scale) (/ (image-bottom g) 2))))))))])] (inexact->exact (floor (- (/ h 2 scale) (/ (get-bottom g) 2))))))))])]
[min-scale 1] [min-scale 1]
[max-scale 10] [max-scale 10]
[sl (new slider% [sl (new slider%
@ -59,8 +59,8 @@
(define (save-image pre-image filename) (define (save-image pre-image filename)
(let* ([image (to-img pre-image)] (let* ([image (to-img pre-image)]
[bm (make-object bitmap% [bm (make-object bitmap%
(inexact->exact (ceiling (+ 1 (image-width image)))) (inexact->exact (ceiling (+ 1 (get-right image))))
(inexact->exact (ceiling (+ 1 (image-height image)))))] (inexact->exact (ceiling (+ 1 (get-bottom image)))))]
[bdc (make-object bitmap-dc% bm)]) [bdc (make-object bitmap-dc% bm)])
(send bdc set-smoothing 'aligned) (send bdc set-smoothing 'aligned)
(send bdc clear) (send bdc clear)
@ -69,6 +69,10 @@
(send bm save-file filename 'png))) (send bm save-file filename 'png)))
(define (get-right img) (bb-right (send img get-bb)))
(define (get-bottom img) (bb-bottom (send img get-bb)))
(define (get-baseline img) (bb-baseline (send img get-bb)))
; ;
; ;
; ;
@ -101,9 +105,9 @@
(define (scale-internal x-factor y-factor image) (define (scale-internal x-factor y-factor image)
(make-image (make-scale x-factor y-factor (image-shape image)) (make-image (make-scale x-factor y-factor (image-shape image))
(make-bb (* x-factor (image-right image)) (make-bb (* x-factor (get-right image))
(* y-factor (image-bottom image)) (* y-factor (get-bottom image))
(* y-factor (image-baseline image))) (* y-factor (get-baseline image)))
#f)) #f))
;; overlay : image image image ... -> image ;; overlay : image image image ... -> image
@ -155,16 +159,16 @@
(define (find-x-spot x-place image) (define (find-x-spot x-place image)
(case x-place (case x-place
[(left) 0] [(left) 0]
[(middle) (/ (image-right image) 2)] [(middle) (/ (get-right image) 2)]
[(right) (image-right image)] [(right) (get-right image)]
[else (error 'find-x-spot "~s" x-place)])) [else (error 'find-x-spot "~s" x-place)]))
(define (find-y-spot y-place image) (define (find-y-spot y-place image)
(case y-place (case y-place
[(top) 0] [(top) 0]
[(middle) (/ (image-bottom image) 2)] [(middle) (/ (get-bottom image) 2)]
[(bottom) (image-bottom image)] [(bottom) (get-bottom image)]
[(baseline) (image-baseline image)] [(baseline) (get-baseline image)]
[else (error 'find-y-spot "~s" y-place)])) [else (error 'find-y-spot "~s" y-place)]))
;; overlay/xy : image number number image -> image ;; overlay/xy : image number number image -> image
@ -189,12 +193,12 @@
(define (overlay/δ image1 dx1 dy1 image2 dx2 dy2) (define (overlay/δ image1 dx1 dy1 image2 dx2 dy2)
(make-image (make-overlay (make-translate dx1 dy1 (image-shape image1)) (make-image (make-overlay (make-translate dx1 dy1 (image-shape image1))
(make-translate dx2 dy2 (image-shape image2))) (make-translate dx2 dy2 (image-shape image2)))
(make-bb (max (+ (image-right image1) dx1) (make-bb (max (+ (get-right image1) dx1)
(+ (image-right image2) dx2)) (+ (get-right image2) dx2))
(max (+ (image-bottom image1) dy1) (max (+ (get-bottom image1) dy1)
(+ (image-bottom image2) dy2)) (+ (get-bottom image2) dy2))
(max (+ (image-baseline image1) dy1) (max (+ (get-baseline image1) dy1)
(+ (image-baseline image2) dy2))) (+ (get-baseline image2) dy2)))
#f)) #f))
;; beside : image image image ... -> image ;; beside : image image image ... -> image
@ -222,7 +226,7 @@
0 0
(if (< dy 0) (- dy) 0) (if (< dy 0) (- dy) 0)
(car rst) (car rst)
(image-right fst) (get-right fst)
(if (< dy 0) 0 dy)) (if (< dy 0) 0 dy))
(cdr rst)))]))) (cdr rst)))])))
@ -252,7 +256,7 @@
0 0
(car rst) (car rst)
(if (< dx 0) 0 dx) (if (< dx 0) 0 dx)
(image-bottom fst)) (get-bottom fst))
(cdr rst)))]))) (cdr rst)))])))
@ -275,13 +279,13 @@
(crop/internal x1 y1 width height image)) (crop/internal x1 y1 width height image))
(define (crop/internal x1 y1 width height image) (define (crop/internal x1 y1 width height image)
(let ([iw (min width (image-width image))] (let ([iw (min width (get-right image))]
[ih (min height (image-height image))]) [ih (min height (get-bottom image))])
(make-image (make-crop (rectangle-points iw ih) (make-image (make-crop (rectangle-points iw ih)
(make-translate (- x1) (- y1) (image-shape image))) (make-translate (- x1) (- y1) (image-shape image)))
(make-bb iw (make-bb iw
ih ih
(min ih (image-baseline image))) (min ih (get-baseline image)))
#f))) #f)))
;; place-image : image x y scene -> scene ;; place-image : image x y scene -> scene
@ -296,8 +300,8 @@
(crop/internal (crop/internal
(if (< dx 0) (- dx) 0) (if (< dx 0) (- dx) 0)
(if (< dy 0) (- dy) 0) (if (< dy 0) (- dy) 0)
(image-right scene) (get-right scene)
(image-bottom scene) (get-bottom scene)
(overlay/δ image (overlay/δ image
(if (< dx 0) 0 dx) (if (< dx 0) 0 dx)
(if (< dy 0) 0 dy) (if (< dy 0) 0 dy)
@ -312,13 +316,13 @@
(define/chk (frame image) (define/chk (frame image)
(make-image (make-overlay (image-shape image) (make-image (make-overlay (image-shape image)
(image-shape (image-shape
(rectangle (image-right image) (rectangle (get-right image)
(image-bottom image) (get-bottom image)
'outline 'outline
'black))) 'black)))
(make-bb (image-right image) (make-bb (get-right image)
(image-bottom image) (get-bottom image)
(image-baseline image)) (get-baseline image))
#f)) #f))
;; scale : I number -> I ;; scale : I number -> I
@ -471,9 +475,11 @@
(rotated-rectangular-bounding-box w h (text-angle atomic-shape)))] (rotated-rectangular-bounding-box w h (text-angle atomic-shape)))]
[(bitmap? atomic-shape) [(bitmap? atomic-shape)
(let ([bb (bitmap-raw-bitmap atomic-shape)]) (let ([bb (bitmap-raw-bitmap atomic-shape)])
(let-values ([(l t r b)
(rotated-rectangular-bounding-box (* (send bb get-width) (bitmap-x-scale atomic-shape)) (rotated-rectangular-bounding-box (* (send bb get-width) (bitmap-x-scale atomic-shape))
(* (send bb get-height) (bitmap-y-scale atomic-shape)) (* (send bb get-height) (bitmap-y-scale atomic-shape))
(bitmap-angle atomic-shape)))] (bitmap-angle atomic-shape))])
(values l t r b)))]
[else [else
(fprintf (current-error-port) "using bad bounding box for ~s\n" atomic-shape) (fprintf (current-error-port) "using bad bounding box for ~s\n" atomic-shape)
(values 0 0 100 100)])) (values 0 0 100 100)]))
@ -667,11 +673,11 @@
[dy (abs (min 0 y1 y2))] [dy (abs (min 0 y1 y2))]
[bottom (max (+ y1 dy) [bottom (max (+ y1 dy)
(+ y2 dy) (+ y2 dy)
(+ dy (image-bottom image)))] (+ dy (get-bottom image)))]
[right (max (+ x1 dx) [right (max (+ x1 dx)
(+ x2 dx) (+ x2 dx)
(+ dx (image-right image)))] (+ dx (get-right image)))]
[baseline (+ dy (image-baseline image))]) [baseline (+ dy (get-baseline image))])
(make-image (make-translate (make-image (make-translate
dx dy dx dy
(make-overlay (make-overlay
@ -806,8 +812,10 @@
(make-bb w/h w/h w/h) (make-bb w/h w/h w/h)
#f))) #f)))
(define/chk (image-width image) (inexact->exact (ceiling (image-right image)))) (define/chk (image-width image) (bb-select/round/exact bb-right image))
(define/chk (image-height image) (inexact->exact (ceiling (image-bottom image)))) (define/chk (image-height image) (bb-select/round/exact bb-bottom image))
(define/chk (image-baseline image) (bb-select/round/exact bb-baseline image))
(define (bb-select/round/exact select image) (inexact->exact (round (select (send image get-bb)))))
(define-syntax (bitmap stx) (define-syntax (bitmap stx)
(syntax-case stx () (syntax-case stx ()
@ -880,6 +888,7 @@
image-width image-width
image-height image-height
image-baseline
circle circle
ellipse ellipse

86
collects/2htdp/tests/test-image.ss
View File

@ -759,49 +759,6 @@
(rectangle 100 10 "solid" "blue")) (rectangle 100 10 "solid" "blue"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; bitmap tests
;;
(define (fill-bitmap b color)
(let ([bdc (make-object bitmap-dc% b)])
(send bdc set-brush color 'solid)
(send bdc set-pen color 1 'solid)
(send bdc draw-rectangle 0 0 (send b get-width) (send b get-height))
(send bdc set-bitmap #f)))
(define blue-10x20-bitmap (make-object bitmap% 10 20))
(fill-bitmap blue-10x20-bitmap "blue")
(define blue-20x10-bitmap (make-object bitmap% 20 10))
(fill-bitmap blue-20x10-bitmap "blue")
(define blue-20x40-bitmap (make-object bitmap% 20 40))
(fill-bitmap blue-20x40-bitmap "blue")
(test (image-right (image-snip->image (make-object image-snip% blue-10x20-bitmap)))
=>
10)
(test (image-bottom (image-snip->image (make-object image-snip% blue-10x20-bitmap)))
=>
20)
(test (image-baseline (image-snip->image (make-object image-snip% blue-10x20-bitmap)))
=>
20)
(test (scale 2 (make-object image-snip% blue-10x20-bitmap))
=>
(image-snip->image (make-object image-snip% blue-20x40-bitmap)))
;; this test fails; sent email to Ian about it.
#;
(test (rotate 90 (make-object image-snip% blue-10x20-bitmap))
=>
(image-snip->image (make-object image-snip% blue-20x10-bitmap)))
;; there was a bug in the bounding box computation for scaled bitmaps that this test exposes
(test (image-width (frame (rotate 90 (scale 1/2 (bitmap icons/plt-logo-red-diffuse.png)))))
=>
128)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; regular polygon ;; regular polygon
@ -965,7 +922,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; bitmaps ;; bitmap tests
;; ;;
(check-equal? (clamp-1 0 3 5) 3) (check-equal? (clamp-1 0 3 5) 3)
@ -1003,14 +960,19 @@
(check-equal? (bmbytes-ref/safe checker3x3 3 3 1 19) (list->bytes '( 0 0 255 0))) (check-equal? (bmbytes-ref/safe checker3x3 3 3 1 19) (list->bytes '( 0 0 255 0)))
#;
(check-equal? (bytes->list (interpolate checker2x2 2 2 1 0)) (check-equal? (bytes->list (interpolate checker2x2 2 2 1 0))
'(255 0 255 0)) '(255 0 255 0))
#;
(check-equal? (bytes->list (interpolate checker3x3 3 3 0 0)) (check-equal? (bytes->list (interpolate checker3x3 3 3 0 0))
'(255 0 0 255)) '(255 0 0 255))
#;
(check-equal? (bytes->list (interpolate checker3x3 3 3 0 1)) (check-equal? (bytes->list (interpolate checker3x3 3 3 0 1))
'(255 0 255 0)) '(255 0 255 0))
#;
(check-equal? (bytes->list (interpolate checker3x3 3 3 0 2)) (check-equal? (bytes->list (interpolate checker3x3 3 3 0 2))
'(255 0 0 255)) '(255 0 0 255))
#;
(check-equal? (bytes->list (interpolate checker3x3 3 3 0.5 0)) (check-equal? (bytes->list (interpolate checker3x3 3 3 0.5 0))
'(255 0 128 128)) '(255 0 128 128))
@ -1043,6 +1005,42 @@
(void)) (void))
(define (fill-bitmap b color)
(let ([bdc (make-object bitmap-dc% b)])
(send bdc set-brush color 'solid)
(send bdc set-pen color 1 'transparent)
(send bdc draw-rectangle 0 0 (send b get-width) (send b get-height))
(send bdc set-bitmap #f)))
(define blue-10x20-bitmap (make-object bitmap% 10 20))
(fill-bitmap blue-10x20-bitmap "blue")
(define blue-20x10-bitmap (make-object bitmap% 20 10))
(fill-bitmap blue-20x10-bitmap "blue")
(define blue-20x40-bitmap (make-object bitmap% 20 40))
(fill-bitmap blue-20x40-bitmap "blue")
(test (image-width (image-snip->image (make-object image-snip% blue-10x20-bitmap)))
=>
10)
(test (image-height (image-snip->image (make-object image-snip% blue-10x20-bitmap)))
=>
20)
(test (image-baseline (image-snip->image (make-object image-snip% blue-10x20-bitmap)))
=>
20)
(test (scale 2 (make-object image-snip% blue-10x20-bitmap))
=>
(image-snip->image (make-object image-snip% blue-20x40-bitmap)))
(test (rotate 90 (make-object image-snip% blue-10x20-bitmap))
=>
(image-snip->image (make-object image-snip% blue-20x10-bitmap)))
;; there was a bug in the bounding box computation for scaled bitmaps that this test exposes
(test (image-width (frame (rotate 90 (scale 1/2 (bitmap icons/plt-logo-red-diffuse.png)))))
=>
128)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; cropping (and place-image) ;; cropping (and place-image)

19
collects/mrlib/image-core.ss
View File

@ -90,9 +90,6 @@ has been moved out).
(define (image-normalized? p) (send p get-normalized?)) (define (image-normalized? p) (send p get-normalized?))
(define (set-image-shape! p s) (send p set-shape s)) (define (set-image-shape! p s) (send p set-shape s))
(define (set-image-normalized?! p n?) (send p set-normalized? n?)) (define (set-image-normalized?! p n?) (send p set-normalized? n?))
(define (image-right image) (bb-right (image-bb image)))
(define (image-bottom image) (bb-bottom (image-bb image)))
(define (image-baseline image) (bb-baseline (image-bb image)))
(define (image? p) (define (image? p)
(or (is-a? p image%) (or (is-a? p image%)
(is-a? p image-snip%) (is-a? p image-snip%)
@ -242,11 +239,10 @@ has been moved out).
(init-field shape bb normalized?) (init-field shape bb normalized?)
(define/public (equal-to? that eq-recur) (define/public (equal-to? that eq-recur)
(or (eq? this that) (or (eq? this that)
(and (eq-recur bb (send that get-bb)) (and (is-a? that image%)
(let* ([w (ceiling (max (inexact->exact (bb-right bb)) (same-bb? bb (send that get-bb))
(inexact->exact (bb-right (send that get-bb)))))] (let* ([w (round (inexact->exact (bb-right bb)))]
[h (ceiling (max (inexact->exact (bb-bottom bb)) [h (round (inexact->exact (bb-bottom bb)))]
(inexact->exact (bb-bottom (send that get-bb)))))]
[bm1 (make-object bitmap% w h)] [bm1 (make-object bitmap% w h)]
[bm2 (make-object bitmap% w h)] [bm2 (make-object bitmap% w h)]
[bytes1 (make-bytes (* w h 4) 0)] [bytes1 (make-bytes (* w h 4) 0)]
@ -341,6 +337,10 @@ has been moved out).
(inherit set-snipclass) (inherit set-snipclass)
(set-snipclass snip-class))) (set-snipclass snip-class)))
(define (same-bb? bb1 bb2)
(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 scheme/base:read read) (define scheme/base:read read)
(define image-snipclass% (define image-snipclass%
@ -808,9 +808,6 @@ the mask bitmap and the original bitmap are all together in a single bytes!
ellipse-rotated-size ellipse-rotated-size
image? image?
image-right
image-bottom
image-baseline
text->font text->font
compare-all-rotations compare-all-rotations

20
collects/mrlib/private/image-core-bitmap.ss
View File

@ -97,7 +97,7 @@ instead of this scaling code, we use the dc<%>'s scaling code.
(values (build-bmbytes new-w (values (build-bmbytes new-w
new-h new-h
(λ (x y) (λ (x y)
(let* {[pre-image (* (make-rectangular (+ west x) (- nrth y)) (let* {[pre-image (* (make-rectangular (+ west x 1/2) (- nrth y 1/2))
theta-unrotation)] theta-unrotation)]
} }
(interpolate bmbytes w h (interpolate bmbytes w h
@ -105,6 +105,16 @@ instead of this scaling code, we use the dc<%>'s scaling code.
(- (imag-part pre-image)))))) (- (imag-part pre-image))))))
new-w new-w
new-h))) new-h)))
;; Why the offsets of 1/2 in `rotate-bytes` and `interpolate`?
;; We consider a pixel's RGB as a point-sample taken from the 'true' image,
;; where the RGB is the sample at the *center* of the square covered by the pixel.
;; (When we assume the sample had been from the NW corner instead of the center,
;; we got weird artifacts upon rotation:
;; Consider a 1x1 bitmap rotated by 90 degrees.
;; The NW corner of our new value would be derived from the *NE* corner of
;; the original bitmap, which is a full pixel-width away from the original sample.
;; So a 1x1 bitmap being rotated would counterintuitively give a different bitmap.)
; interpolate: bytes natnum natum real real -> bytes ; interpolate: bytes natnum natum real real -> bytes
@ -114,10 +124,10 @@ instead of this scaling code, we use the dc<%>'s scaling code.
; where x,y are *real-valued* coordinates in [0,w), [0,h). ; where x,y are *real-valued* coordinates in [0,w), [0,h).
; ;
(define (interpolate bmbytes w h x y) (define (interpolate bmbytes w h x y)
(let* {[x0 (floor/e x)] (let* {[x0 (floor/e (- x 1/2))]
[y0 (floor/e y)] [y0 (floor/e (- y 1/2))]
[dx (- x x0)] [dx (- (- x 1/2) x0)]
[dy (- y y0)] [dy (- (- y 1/2) y0)]
[1-dx (- 1 dx)] [1-dx (- 1 dx)]
[1-dy (- 1 dy)] [1-dy (- 1 dy)]
[nw (bmbytes-ref/safe bmbytes w h x0 y0 )] [nw (bmbytes-ref/safe bmbytes w h x0 y0 )]