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

fixed rotation of bitmaps

Browse Source 
svn: r16861

original commit: cc60cdc02bbccdd2f0336a3858edb037d04a430f
This commit is contained in:
Robby Findler 2009-11-18 14:58:15 +00:00
parent 4327752408
commit 6bcf979d90
2 changed files with 255 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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))