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

fixed rotation of bitmaps

Browse Source 
svn: r16861
This commit is contained in:
Robby Findler 2009-11-18 14:58:15 +00:00
parent 5d79713481
commit cc60cdc02b
4 changed files with 342 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -10,8 +10,9 @@
scheme/list)
lang/posn)
(define (show-image g [extra-space 0])
(letrec ([f (new frame% [label ""])]
(define (show-image arg [extra-space 0])
(letrec ([g (to-img arg)]
[f (new frame% [label ""])]
[c (new canvas%
[parent f]
[min-width (+ extra-space (inexact->exact (floor (image-right g))))]
@ -253,21 +254,20 @@
[(is-a? arg bitmap%) (bitmap->image arg)]
[else arg]))
(define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
(let ([w (send bm get-width)]
[h (send bm get-height)])
(make-image (make-translate
(/ w 2)
(/ h 2)
(make-bitmap bm mask-bm 0 1 #f))
(make-bb w h h)
#f)))
(define (image-snip->image is)
(bitmap->image (send is get-bitmap)
(or (send is get-bitmap-mask)
(send (send is get-bitmap) get-loaded-mask))))
(define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
(let ([w (send bm get-width)]
[h (send bm get-height)])
(make-image (make-translate (/ w 2)
(/ h 2)
(make-bitmap bm mask-bm 0 1 1 #f #f))
(make-bb w h h)
#f)))
;
;
;
@ -524,14 +524,14 @@
[else
(let ([dx (translate-dx simple-shape)]
[dy (translate-dy simple-shape)])
(let-values ([(l t r b) (atomic-bb (translate-shape simple-shape))])
(let-values ([(l t r b) (np-atomic-bb (translate-shape simple-shape))])
(values (+ l dx)
(+ t dy)
(+ r dx)
(+ b dy))))]))
(define (atomic-bb atomic-shape)
(define (np-atomic-bb atomic-shape)
(cond
[(ellipse? atomic-shape)
(let ([θ (ellipse-angle atomic-shape)])
@ -544,21 +544,29 @@
(/ w 2)
(/ h 2))))]
[(text? atomic-shape)
(let*-values ([(w h a d) (send text-sizing-bm get-text-extent
(text-string atomic-shape)
(text->font atomic-shape))]
[(ax ay) (rotate-xy (- (/ w 2)) (- (/ h 2)) (text-angle atomic-shape))]
[(bx by) (rotate-xy (- (/ w 2)) (/ h 2) (text-angle atomic-shape))]
[(cx cy) (rotate-xy (/ w 2) (- (/ h 2)) (text-angle atomic-shape))]
[(dx dy) (rotate-xy (/ w 2) (/ h 2) (text-angle atomic-shape))])
(values (min ax bx cx dx)
(min ay by cy dy)
(max ax bx cx dx)
(max ay by cy dy)))]
(let-values ([(w h a d) (send text-sizing-bm get-text-extent
(text-string atomic-shape)
(text->font atomic-shape))])
(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)
(send bb get-height)
(bitmap-angle atomic-shape)))]
[else
(fprintf (current-error-port) "using bad bounding box for ~s\n" (image-shape atomic-shape))
(fprintf (current-error-port) "using bad bounding box for ~s\n" atomic-shape)
(values 0 0 100 100)]))
(define (rotated-rectangular-bounding-box w h θ)
(let*-values ([(ax ay) (rotate-xy (- (/ w 2)) (- (/ h 2)) θ)]
[(bx by) (rotate-xy (- (/ w 2)) (/ h 2) θ)]
[(cx cy) (rotate-xy (/ w 2) (- (/ h 2)) θ)]
[(dx dy) (rotate-xy (/ w 2) (/ h 2) θ)])
(values (min ax bx cx dx)
(min ay by cy dy)
(max ax bx cx dx)
(max ay by cy dy))))
;; rotate-simple : angle simple-shape -> simple-shape
(define (rotate-simple θ simple-shape)
(cond
@ -582,8 +590,8 @@
(translate-dy simple-shape))))])
(make-translate dx dy rotated)))]))
(define (center-point atomic-shape)
(let-values ([(l t r b) (atomic-bb atomic-shape)])
(define (center-point np-atomic-shape)
(let-values ([(l t r b) (np-atomic-bb np-atomic-shape)])
(xy->c (/ (- r l) 2)
(/ (- b t) 2))))
@ -625,7 +633,9 @@
(make-bitmap (bitmap-raw-bitmap atomic-shape)
(bitmap-raw-mask atomic-shape)
(bring-between (+ θ (bitmap-angle atomic-shape)) 360)
(bitmap-scale atomic-shape)
(bitmap-x-scale atomic-shape)
(bitmap-y-scale atomic-shape)
#f
#f)]))
;; rotate-point : point angle -> point
@ -989,5 +999,5 @@
rotate-xy)
(provide/contract
[atomic-bb (-> atomic-shape? (values real? real? real? real?))]
[np-atomic-bb (-> np-atomic-shape? (values real? real? real? real?))]
[center-point (-> np-atomic-shape? number?)])

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

@ -1,6 +1,7 @@
#lang scheme/base
(require "../../mrlib/image-core.ss"
"../private/image-more.ss"
"../../mrlib/private/image-core-bitmap.ss"
lang/posn
scheme/math
scheme/class
@ -775,12 +776,57 @@
(check-equal? (image-baseline (add-line txt 0 -10 100 100 'red))
(+ bl 10)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; bitmaps
;;
(check-equal? (clamp-1 0 3 5) 3)
(check-equal? (clamp-1 0 0 5) 0)
(check-equal? (clamp-1 0 -2 5) 0)
(check-equal? (clamp-1 0 4 5) 4)
(check-equal? (clamp-1 0 7 5) 4)
(check-equal? (build-bytes 5 sqr) (list->bytes '(0 1 4 9 16)))
(define onePixel (list->bytes '(255 0 0 255)))
;(call-with-values (λ () (scale onePixel 1 1 100)) show-bitmap)
(define blue2x1 (list->bytes '(255 0 0 255 255 0 255 0)))
;(call-with-values (λ () (scale blue2x1 2 1 20)) show-bitmap)
(define blue2x2 (list->bytes '(255 0 0 255 255 0 0 255 255 0 0 255 255 0 0 255)))
(define gray2x2 (list->bytes '(255 100 100 100 255 100 100 100 255 100 100 100 255 100 100 100)))
;; Some blue x green checkerboards:
(define checker2x2 (list->bytes '(255 0 0 255 255 0 255 0
255 0 255 0 255 0 0 255)))
(define checker3x3 (list->bytes '(255 0 0 255 255 0 255 0 255 0 0 255
255 0 255 0 255 0 0 255 255 0 255 0
255 0 0 255 255 0 255 0 255 0 0 255 )))
(check-equal? (bmbytes-ref/safe checker3x3 3 3 0 0) (list->bytes '(255 0 0 255)))
(check-equal? (bmbytes-ref/safe checker3x3 3 3 1 1) (list->bytes '(255 0 0 255)))
(check-equal? (bmbytes-ref/safe checker3x3 3 3 2 2) (list->bytes '(255 0 0 255)))
(check-equal? (bmbytes-ref/safe checker3x3 3 3 1 2) (list->bytes '(255 0 255 0)))
(check-equal? (bmbytes-ref/safe checker3x3 3 3 0 3) (list->bytes '( 0 0 0 255)))
(check-equal? (bmbytes-ref/safe checker3x3 3 3 -1 -1) (list->bytes '( 0 0 0 255)))
(check-equal? (bmbytes-ref/safe checker3x3 3 3 -1 1) (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))
'(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))
(check-equal? (image-width (bitmap icons/stop-16x16.png))
16)
(check-equal? (image-height (bitmap icons/stop-16x16.png))

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

@ -23,11 +23,14 @@ has been moved out).
(beside/places "baseline"
(text "ijy" 12 'black)
(text "ijy" 24 'black))
- /places => /align
|#
(require scheme/class
scheme/gui/base
scheme/math
"private/image-core-bitmap.ss"
(for-syntax scheme/base))
(define-for-syntax id-constructor-pairs '())
@ -134,7 +137,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 scale rendered-bitmap) #:omit-define-syntaxes #:transparent)
(define-struct/reg-mk bitmap (raw-bitmap raw-mask angle x-scale y-scale [rendered-bitmap #:mutable] [rendered-mask #:mutable])
#:omit-define-syntaxes #:transparent)
;; a polygon is:
;;
@ -449,10 +453,12 @@ has been moved out).
(text-weight shape)
(text-underline shape))]
[(bitmap? shape)
(unless (and (= 1 x-scale)
(= 1 y-scale))
(fprintf (current-error-port) "scaling a bitmap, ignoring\n"))
shape]))
(make-bitmap (bitmap-raw-bitmap shape)
(bitmap-raw-mask shape)
(bitmap-angle shape)
(* x-scale (bitmap-x-scale shape))
(* y-scale (bitmap-y-scale shape))
#f #f)]))
;
@ -540,14 +546,14 @@ has been moved out).
(send dc set-brush (mode-color->brush (ellipse-mode atomic-shape) (ellipse-color atomic-shape)))
(send dc draw-path path dx dy)))]
[(bitmap? atomic-shape)
(let ([bm (bitmap-raw-bitmap atomic-shape)])
(let ([bm (get-rendered-bitmap atomic-shape)])
(send dc draw-bitmap
bm
(- dx (/ (send bm get-width) 2))
(- dy (/ (send bm get-height) 2))
'solid
(send the-color-database find-color "black")
(bitmap-raw-mask atomic-shape)))]
(get-rendered-mask atomic-shape)))]
[(text? atomic-shape)
(let ([θ (degrees->radians (text-angle atomic-shape))]
[font (send dc get-font)])
@ -563,6 +569,41 @@ has been moved out).
(imag-part p)
#f 0 θ))))]))]))
#|
the mask bitmap and the original bitmap are all together in a single bytes!
|#
(define (get-rendered-bitmap bitmap)
(calc-renered-bitmap bitmap)
(bitmap-rendered-bitmap bitmap))
(define (get-rendered-mask bitmap)
(calc-renered-bitmap bitmap)
(bitmap-rendered-mask bitmap))
(define (calc-renered-bitmap bitmap)
(unless (bitmap-rendered-bitmap bitmap)
(cond
[(and (= 1 (bitmap-x-scale bitmap))
(= 1 (bitmap-y-scale bitmap))
(= 0 (bitmap-angle bitmap)))
(set-bitmap-rendered-bitmap! bitmap (bitmap-raw-bitmap bitmap))
(set-bitmap-rendered-mask! bitmap (bitmap-raw-mask bitmap))]
[else
(let ([θ (degrees->radians (bitmap-angle bitmap))])
(let-values ([(bytes w h) (bitmap->bytes (bitmap-raw-bitmap bitmap) (bitmap-raw-mask bitmap))])
(let-values ([(rotated-bytes rotated-w rotated-h)
(rotate-bytes bytes w h θ)])
(set-bitmap-rendered-bitmap!
bitmap
(bytes->bitmap rotated-bytes rotated-w rotated-h))
(set-bitmap-rendered-mask!
bitmap
(send (bitmap-rendered-bitmap bitmap) get-loaded-mask)))))])))
(define (text->font text)
(cond
[(text-face text)
@ -617,6 +658,9 @@ has been moved out).
[else
(send the-brush-list find-or-create-brush "black" 'transparent)]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide make-image image-shape image-bb image-normalized? image%
(struct-out bb)
@ -630,7 +674,8 @@ has been moved out).
make-polygon polygon? polygon-points polygon-mode polygon-color
make-line-segment line-segment? line-segment-start line-segment-end line-segment-color
make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-scale bitmap-rendered-bitmap
make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale
bitmap-rendered-bitmap bitmap-rendered-mask
degrees->radians
normalize-shape

202
collects/mrlib/private/image-core-bitmap.ss Normal file
View File

@ -0,0 +1,202 @@
#lang scheme/base
(require scheme/gui/base
scheme/class)
(provide rotate-bytes ;; : bytes int[width] int[height] radians[radians] -> bytes
bitmap->bytes
bytes->bitmap)
;; rotate-bitmap : (-> bytes? natural-number/c natural-number/c real? bytes?)
;; avoid a dependency on scheme/contract, which pulls in too much
;; for the test suite:
(provide clamp-1 build-bytes bmbytes-ref/safe interpolate)
(define pi (atan 0 -1))
(define i 0+1i)
#|
instead of this scaling code, we use the dc<%>'s scaling code.
(provide/contract [scale-bitmap
(-> bytes? natural-number/c natural-number/c (and/c real? (not/c negative?))
bytes?)])
; bmbytes: a bytes which represents an image --
; it's size is a multiple of 4, and each
; four consecutive bytes represent alpha,r,g,b.
; scale: given a bmbytes,
; return a new bmbytes scaled by k in each direction.
;
; TODO: this code is meant for scaling by (>= k 1);
; if (< k 1) then the result will ignore ~ (1-k) of the original's pixels.
; We should really do a proper averaging for that case.
;
(define (scale-bitmap bmbytes w h k)
(let* {[new-w (round/e (* w k))]
[new-h (round/e (* h k))]
}
(values (build-bmbytes new-w
new-h
(λ (x y) (interpolate bmbytes w h
; You'd think x would map to (x/(kw))*w,
; but we actually use (x/(kw-1))*(w-1).
; It's because the distance between left- and right-most samples
; is one less than the number of samples,
; and we want the end-samples at the far ends of the new bitmap.
(* (/ x (sub1 (* k w))) (sub1 w))
(* (/ y (sub1 (* k h))) (sub1 h)))))
new-w
new-h)))
|#
(define (bitmap->bytes bm [mask (send bm get-loaded-mask)])
(let* ([w (send bm get-width)]
[h (send bm get-height)]
[bytes (make-bytes (* w h NUM-CHANNELS) 0)])
(send bm get-argb-pixels 0 0 w h bytes #f)
(when (send bm get-loaded-mask)
(send (send bm get-loaded-mask) get-argb-pixels 0 0 w h bytes #t))
(values bytes w h)))
(define (bytes->bitmap bytes w h)
(unless (= (bytes-length bytes) (* w h NUM-CHANNELS))
(error 'bytes->bitmap "wrong sizes"))
(let* ([bm (make-object bitmap% w h)]
[mask (make-object bitmap% w h)]
[bdc (make-object bitmap-dc% bm)])
(send bdc set-argb-pixels 0 0 w h bytes #f)
(send bdc set-bitmap mask)
(send bdc set-argb-pixels 0 0 w h bytes #t)
(send bdc set-bitmap #f)
(send bm set-loaded-mask mask)
bm))
(define (rotate-bytes bmbytes w h theta)
(let* {[theta-rotation (exp (* i theta))]
[theta-unrotation (make-rectangular (real-part theta-rotation)
(- (imag-part theta-rotation)))]
[ne (* theta-rotation w)]
[sw (* theta-rotation (* i (- h)))]
[se (* theta-rotation (make-rectangular w (- h)))]
[nw 0]
[pts (list ne sw se nw)]
[longitudes (map real-part pts)]
[latitudes (map imag-part pts)]
[east (apply max longitudes)]
[west (apply min longitudes)]
[nrth (apply max latitudes)]
[sth (apply min latitudes)]
[new-w (round/e (- east west))]
[new-h (round/e (- nrth sth))]
}
(values (build-bmbytes new-w
new-h
(λ (x y)
(let* {[pre-image (* (make-rectangular (+ west x) (- nrth y))
theta-unrotation)]
}
(interpolate bmbytes w h
(real-part pre-image)
(- (imag-part pre-image))))))
new-w
new-h)))
; interpolate: bytes natnum natum real real -> bytes
;
; Given a bitmap (bytes of size (* w h NUM-CHANNELS)), return a pixel (bytes of size NUM-CHANNELS)
; corresponding to the interpolated color at x,y
; 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)]
[1-dx (- 1 dx)]
[1-dy (- 1 dy)]
[nw (bmbytes-ref/safe bmbytes w h x0 y0 )]
[ne (bmbytes-ref/safe bmbytes w h (add1 x0) y0 )]
[sw (bmbytes-ref/safe bmbytes w h x0 (add1 y0))]
[se (bmbytes-ref/safe bmbytes w h (add1 x0) (add1 y0))]
}
(build-bytes
NUM-CHANNELS
(λ (i) (inexact->exact (round/e (+ (* (bytes-ref nw i) 1-dx 1-dy)
(* (bytes-ref ne i) dx 1-dy)
(* (bytes-ref sw i) 1-dx dy)
(* (bytes-ref se i) dx dy))))))))
; Return pixel (i,j) from a bytes representation.
; However, if i,j refers to an off-board location,
; return the nearest board location where alpha has been set to 0.
; (That is, conceptually extend the picture's edge colors
; infinitely, but make them transparent.)
; This is helpful when trying to interpolate just beyond
; an edge pixel.
;
(define (bmbytes-ref/safe bytes w h i j)
(let* {[i/safe (clamp-1 0 i w)]
[j/safe (clamp-1 0 j h)]
[offset (flatten-bm-coord w h i/safe j/safe)]
[pixel (subbytes bytes offset (+ offset NUM-CHANNELS))]
}
(if (and (= i i/safe) (= j j/safe))
pixel
(let {[new-pixel (bytes-copy pixel)]}
(begin (bytes-set! new-pixel 0 0)
new-pixel)))))
; Create a bytes representation from
; a function f mapping locations to pixels.
;
; f : [0,w), [0,h) -> (bytes a r g b)
;
(define (build-bmbytes w h f)
(do {[bm (make-bytes (* NUM-CHANNELS w h))]
[y 0 (add1 y)]
}
[(>= y h) bm]
(do {[x 0 (add1 x)]
}
[(>= x w)]
(bytes-copy! bm (flatten-bm-coord w h x y) (f x y)))))
; build-bytes, analogous to build-list.
;
(define (build-bytes sz f)
(do {[b (make-bytes sz)]
[i 0 (add1 i)]
}
[(>= i sz) b]
(bytes-set! b i (f i))))
;;;; Some utility functions
(define round/e (compose inexact->exact round))
(define floor/e (compose inexact->exact floor))
(define ceiling/e (compose inexact->exact ceiling))
(define NUM-CHANNELS 4) ; alpha, r, g, b
; Return n, clamped to the range [a,b).
; (note the open interval; for integers.)
;
(define (clamp-1 a n b)
(min (max a n) (sub1 b)))
; Convert an x,y pixel coordinate into its offset into a bytes.
;
(define (flatten-bm-coord w h x y) (* (+ (* y w) x) NUM-CHANNELS))