applied Ian's patch to the bitmap rotation code
svn: r17513
This commit is contained in:
Robby Findler
parent
ccacf5a651
commit
b5e54fe2eb
|
|
@ -16,8 +16,8 @@
|
|||
[f (new frame% [label ""])]
|
||||
[c (new canvas%
|
||||
[parent f]
|
||||
[min-width (+ extra-space (inexact->exact (floor (image-right g))))]
|
||||
[min-height (+ extra-space (inexact->exact (floor (image-bottom g))))]
|
||||
[min-width (+ extra-space (image-width g))]
|
||||
[min-height (+ extra-space (image-height g))]
|
||||
[paint-callback
|
||||
(λ (c dc)
|
||||
(send dc set-smoothing 'aligned)
|
||||
|
|
@ -27,8 +27,8 @@
|
|||
(render-image
|
||||
g
|
||||
dc
|
||||
(inexact->exact (floor (- (/ w 2 scale) (/ (image-right g) 2))))
|
||||
(inexact->exact (floor (- (/ h 2 scale) (/ (image-bottom g) 2))))))))])]
|
||||
(inexact->exact (floor (- (/ w 2 scale) (/ (get-right g) 2))))
|
||||
(inexact->exact (floor (- (/ h 2 scale) (/ (get-bottom g) 2))))))))])]
|
||||
[min-scale 1]
|
||||
[max-scale 10]
|
||||
[sl (new slider%
|
||||
|
|
@ -59,8 +59,8 @@
|
|||
(define (save-image pre-image filename)
|
||||
(let* ([image (to-img pre-image)]
|
||||
[bm (make-object bitmap%
|
||||
(inexact->exact (ceiling (+ 1 (image-width image))))
|
||||
(inexact->exact (ceiling (+ 1 (image-height image)))))]
|
||||
(inexact->exact (ceiling (+ 1 (get-right image))))
|
||||
(inexact->exact (ceiling (+ 1 (get-bottom image)))))]
|
||||
[bdc (make-object bitmap-dc% bm)])
|
||||
(send bdc set-smoothing 'aligned)
|
||||
(send bdc clear)
|
||||
|
|
@ -69,6 +69,10 @@
|
|||
(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)
|
||||
(make-image (make-scale x-factor y-factor (image-shape image))
|
||||
(make-bb (* x-factor (image-right image))
|
||||
(* y-factor (image-bottom image))
|
||||
(* y-factor (image-baseline image)))
|
||||
(make-bb (* x-factor (get-right image))
|
||||
(* y-factor (get-bottom image))
|
||||
(* y-factor (get-baseline image)))
|
||||
#f))
|
||||
|
||||
;; overlay : image image image ... -> image
|
||||
|
|
@ -155,16 +159,16 @@
|
|||
(define (find-x-spot x-place image)
|
||||
(case x-place
|
||||
[(left) 0]
|
||||
[(middle) (/ (image-right image) 2)]
|
||||
[(right) (image-right image)]
|
||||
[(middle) (/ (get-right image) 2)]
|
||||
[(right) (get-right image)]
|
||||
[else (error 'find-x-spot "~s" x-place)]))
|
||||
|
||||
(define (find-y-spot y-place image)
|
||||
(case y-place
|
||||
[(top) 0]
|
||||
[(middle) (/ (image-bottom image) 2)]
|
||||
[(bottom) (image-bottom image)]
|
||||
[(baseline) (image-baseline image)]
|
||||
[(middle) (/ (get-bottom image) 2)]
|
||||
[(bottom) (get-bottom image)]
|
||||
[(baseline) (get-baseline image)]
|
||||
[else (error 'find-y-spot "~s" y-place)]))
|
||||
|
||||
;; overlay/xy : image number number image -> image
|
||||
|
|
@ -189,12 +193,12 @@
|
|||
(define (overlay/δ image1 dx1 dy1 image2 dx2 dy2)
|
||||
(make-image (make-overlay (make-translate dx1 dy1 (image-shape image1))
|
||||
(make-translate dx2 dy2 (image-shape image2)))
|
||||
(make-bb (max (+ (image-right image1) dx1)
|
||||
(+ (image-right image2) dx2))
|
||||
(max (+ (image-bottom image1) dy1)
|
||||
(+ (image-bottom image2) dy2))
|
||||
(max (+ (image-baseline image1) dy1)
|
||||
(+ (image-baseline image2) dy2)))
|
||||
(make-bb (max (+ (get-right image1) dx1)
|
||||
(+ (get-right image2) dx2))
|
||||
(max (+ (get-bottom image1) dy1)
|
||||
(+ (get-bottom image2) dy2))
|
||||
(max (+ (get-baseline image1) dy1)
|
||||
(+ (get-baseline image2) dy2)))
|
||||
#f))
|
||||
|
||||
;; beside : image image image ... -> image
|
||||
|
|
@ -222,7 +226,7 @@
|
|||
0
|
||||
(if (< dy 0) (- dy) 0)
|
||||
(car rst)
|
||||
(image-right fst)
|
||||
(get-right fst)
|
||||
(if (< dy 0) 0 dy))
|
||||
(cdr rst)))])))
|
||||
|
||||
|
|
@ -252,7 +256,7 @@
|
|||
0
|
||||
(car rst)
|
||||
(if (< dx 0) 0 dx)
|
||||
(image-bottom fst))
|
||||
(get-bottom fst))
|
||||
(cdr rst)))])))
|
||||
|
||||
|
||||
|
|
@ -275,13 +279,13 @@
|
|||
(crop/internal x1 y1 width height image))
|
||||
|
||||
(define (crop/internal x1 y1 width height image)
|
||||
(let ([iw (min width (image-width image))]
|
||||
[ih (min height (image-height image))])
|
||||
(let ([iw (min width (get-right image))]
|
||||
[ih (min height (get-bottom image))])
|
||||
(make-image (make-crop (rectangle-points iw ih)
|
||||
(make-translate (- x1) (- y1) (image-shape image)))
|
||||
(make-bb iw
|
||||
ih
|
||||
(min ih (image-baseline image)))
|
||||
(min ih (get-baseline image)))
|
||||
#f)))
|
||||
|
||||
;; place-image : image x y scene -> scene
|
||||
|
|
@ -296,8 +300,8 @@
|
|||
(crop/internal
|
||||
(if (< dx 0) (- dx) 0)
|
||||
(if (< dy 0) (- dy) 0)
|
||||
(image-right scene)
|
||||
(image-bottom scene)
|
||||
(get-right scene)
|
||||
(get-bottom scene)
|
||||
(overlay/δ image
|
||||
(if (< dx 0) 0 dx)
|
||||
(if (< dy 0) 0 dy)
|
||||
|
|
@ -312,13 +316,13 @@
|
|||
(define/chk (frame image)
|
||||
(make-image (make-overlay (image-shape image)
|
||||
(image-shape
|
||||
(rectangle (image-right image)
|
||||
(image-bottom image)
|
||||
(rectangle (get-right image)
|
||||
(get-bottom image)
|
||||
'outline
|
||||
'black)))
|
||||
(make-bb (image-right image)
|
||||
(image-bottom image)
|
||||
(image-baseline image))
|
||||
(make-bb (get-right image)
|
||||
(get-bottom image)
|
||||
(get-baseline image))
|
||||
#f))
|
||||
|
||||
;; scale : I number -> I
|
||||
|
|
@ -471,9 +475,11 @@
|
|||
(rotated-rectangular-bounding-box w h (text-angle atomic-shape)))]
|
||||
[(bitmap? atomic-shape)
|
||||
(let ([bb (bitmap-raw-bitmap atomic-shape)])
|
||||
(rotated-rectangular-bounding-box (* (send bb get-width) (bitmap-x-scale atomic-shape))
|
||||
(* (send bb get-height) (bitmap-y-scale atomic-shape))
|
||||
(bitmap-angle atomic-shape)))]
|
||||
(let-values ([(l t r b)
|
||||
(rotated-rectangular-bounding-box (* (send bb get-width) (bitmap-x-scale atomic-shape))
|
||||
(* (send bb get-height) (bitmap-y-scale atomic-shape))
|
||||
(bitmap-angle atomic-shape))])
|
||||
(values l t r b)))]
|
||||
[else
|
||||
(fprintf (current-error-port) "using bad bounding box for ~s\n" atomic-shape)
|
||||
(values 0 0 100 100)]))
|
||||
|
|
@ -667,11 +673,11 @@
|
|||
[dy (abs (min 0 y1 y2))]
|
||||
[bottom (max (+ y1 dy)
|
||||
(+ y2 dy)
|
||||
(+ dy (image-bottom image)))]
|
||||
(+ dy (get-bottom image)))]
|
||||
[right (max (+ x1 dx)
|
||||
(+ x2 dx)
|
||||
(+ dx (image-right image)))]
|
||||
[baseline (+ dy (image-baseline image))])
|
||||
(+ dx (get-right image)))]
|
||||
[baseline (+ dy (get-baseline image))])
|
||||
(make-image (make-translate
|
||||
dx dy
|
||||
(make-overlay
|
||||
|
|
@ -806,8 +812,10 @@
|
|||
(make-bb w/h w/h w/h)
|
||||
#f)))
|
||||
|
||||
(define/chk (image-width image) (inexact->exact (ceiling (image-right image))))
|
||||
(define/chk (image-height image) (inexact->exact (ceiling (image-bottom image))))
|
||||
(define/chk (image-width image) (bb-select/round/exact bb-right 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)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -880,6 +888,7 @@
|
|||
|
||||
image-width
|
||||
image-height
|
||||
image-baseline
|
||||
|
||||
circle
|
||||
ellipse
|
||||
|
|
|
|||
|
|
@ -759,49 +759,6 @@
|
|||
(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
|
||||
|
|
@ -965,7 +922,7 @@
|
|||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; bitmaps
|
||||
;; bitmap tests
|
||||
;;
|
||||
|
||||
(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? (bytes->list (interpolate checker2x2 2 2 1 0))
|
||||
'(255 0 255 0))
|
||||
#;
|
||||
(check-equal? (bytes->list (interpolate checker3x3 3 3 0 0))
|
||||
'(255 0 0 255))
|
||||
#;
|
||||
(check-equal? (bytes->list (interpolate checker3x3 3 3 0 1))
|
||||
'(255 0 255 0))
|
||||
#;
|
||||
(check-equal? (bytes->list (interpolate checker3x3 3 3 0 2))
|
||||
'(255 0 0 255))
|
||||
#;
|
||||
(check-equal? (bytes->list (interpolate checker3x3 3 3 0.5 0))
|
||||
'(255 0 128 128))
|
||||
|
||||
|
|
@ -1043,6 +1005,42 @@
|
|||
(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)
|
||||
|
|
|
|||
|
|
@ -90,9 +90,6 @@ has been moved out).
|
|||
(define (image-normalized? p) (send p get-normalized?))
|
||||
(define (set-image-shape! p s) (send p set-shape s))
|
||||
(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)
|
||||
(or (is-a? p image%)
|
||||
(is-a? p image-snip%)
|
||||
|
|
@ -242,11 +239,10 @@ has been moved out).
|
|||
(init-field shape bb normalized?)
|
||||
(define/public (equal-to? that eq-recur)
|
||||
(or (eq? this that)
|
||||
(and (eq-recur bb (send that get-bb))
|
||||
(let* ([w (ceiling (max (inexact->exact (bb-right bb))
|
||||
(inexact->exact (bb-right (send that get-bb)))))]
|
||||
[h (ceiling (max (inexact->exact (bb-bottom bb))
|
||||
(inexact->exact (bb-bottom (send that get-bb)))))]
|
||||
(and (is-a? that image%)
|
||||
(same-bb? bb (send that get-bb))
|
||||
(let* ([w (round (inexact->exact (bb-right bb)))]
|
||||
[h (round (inexact->exact (bb-bottom bb)))]
|
||||
[bm1 (make-object bitmap% w h)]
|
||||
[bm2 (make-object bitmap% w h)]
|
||||
[bytes1 (make-bytes (* w h 4) 0)]
|
||||
|
|
@ -341,6 +337,10 @@ has been moved out).
|
|||
(inherit set-snipclass)
|
||||
(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 image-snipclass%
|
||||
|
|
@ -808,9 +808,6 @@ the mask bitmap and the original bitmap are all together in a single bytes!
|
|||
ellipse-rotated-size
|
||||
|
||||
image?
|
||||
image-right
|
||||
image-bottom
|
||||
image-baseline
|
||||
|
||||
text->font
|
||||
compare-all-rotations
|
||||
|
|
|
|||
|
|
@ -97,7 +97,7 @@ instead of this scaling code, we use the dc<%>'s scaling code.
|
|||
(values (build-bmbytes new-w
|
||||
new-h
|
||||
(λ (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)]
|
||||
}
|
||||
(interpolate bmbytes w h
|
||||
|
|
@ -105,6 +105,16 @@ instead of this scaling code, we use the dc<%>'s scaling code.
|
|||
(- (imag-part pre-image))))))
|
||||
new-w
|
||||
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
|
||||
|
|
@ -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).
|
||||
;
|
||||
(define (interpolate bmbytes w h x y)
|
||||
(let* {[x0 (floor/e x)]
|
||||
[y0 (floor/e y)]
|
||||
[dx (- x x0)]
|
||||
[dy (- y y0)]
|
||||
(let* {[x0 (floor/e (- x 1/2))]
|
||||
[y0 (floor/e (- y 1/2))]
|
||||
[dx (- (- x 1/2) x0)]
|
||||
[dy (- (- y 1/2) y0)]
|
||||
[1-dx (- 1 dx)]
|
||||
[1-dy (- 1 dy)]
|
||||
[nw (bmbytes-ref/safe bmbytes w h x0 y0 )]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user