image-core-bitmap.rkt
1 #lang scheme/base 2 (require racket/draw 3 scheme/class) 4 5 6 (provide rotate-bytes ;; : bytes int[width] int[height] radians[radians] -> bytes 7 flip-bytes ;; : bytes int[width] int[height] -> bytes 8 bitmap->bytes 9 bytes->bitmap 10 bitmap->png-bytes 11 png-bytes->bitmap 12 linear-transform) 13 ;; rotate-bitmap : (-> bytes? natural-number/c natural-number/c real? bytes?) 14 ;; avoid a dependency on scheme/contract, which pulls in too much 15 16 ;; for the test suite: 17 (provide clamp-1 build-bytes bmbytes-ref/safe interpolate) 18 19 (define pi (atan 0 -1)) 20 (define i 0+1i) 21 22 #| 23 24 instead of this scaling code, we use the dc<%>'s scaling code. 25 26 (provide/contract [scale-bitmap 27 (-> bytes? natural-number/c natural-number/c (and/c real? (not/c negative?)) 28 bytes?)]) 29 30 31 ; bmbytes: a bytes which represents an image -- 32 ; its size is a multiple of 4, and each 33 ; four consecutive bytes represent alpha,r,g,b. 34 35 36 ; scale: given a bmbytes, 37 ; return a new bmbytes scaled by k in each direction. 38 ; 39 ; TODO: this code is meant for scaling by (>= k 1); 40 ; if (< k 1) then the result will ignore ~ (1-k) of the original's pixels. 41 ; We should really do a proper averaging for that case. 42 ; 43 (define (scale-bitmap bmbytes w h k) 44 (let* {[new-w (round/e (* w k))] 45 [new-h (round/e (* h k))] 46 } 47 (values (build-bmbytes new-w 48 new-h 49 (λ (x y) (interpolate bmbytes w h 50 ; You'd think x would map to (x/(kw))*w, 51 ; but we actually use (x/(kw-1))*(w-1). 52 ; It's because the distance between left- and right-most samples 53 ; is one less than the number of samples, 54 ; and we want the end-samples at the far ends of the new bitmap. 55 (* (/ x (sub1 (* k w))) (sub1 w)) 56 (* (/ y (sub1 (* k h))) (sub1 h))))) 57 new-w 58 new-h))) 59 |# 60 61 (define (bitmap->bytes bm [mask (send bm get-loaded-mask)]) 62 (let* ([w (send bm get-width)] 63 [h (send bm get-height)] 64 [bytes (make-bytes (* w h NUM-CHANNELS) 0)]) 65 (send bm get-argb-pixels 0 0 w h bytes #f) 66 (when mask 67 (send mask get-argb-pixels 0 0 w h bytes #t)) 68 (values bytes w h))) 69 70 (define (bytes->bitmap bytes w h) 71 (unless (= (bytes-length bytes) (* w h NUM-CHANNELS)) 72 (error 'bytes->bitmap "wrong sizes, got ~a bytes, w ~a h ~a (which should be ~a bytes)" 73 (bytes-length bytes) 74 w 75 h 76 (* w h NUM-CHANNELS))) 77 (let* ([bm (make-bitmap w h)]) 78 (send bm set-argb-pixels 0 0 w h bytes) 79 bm)) 80 81 (define (png-bytes->bitmap bytes backing-scale) 82 (read-bitmap (open-input-bytes bytes) 83 'png/alpha 84 #:backing-scale backing-scale)) 85 86 (define (bitmap->png-bytes bitmap) 87 (define bp (open-output-bytes)) 88 (send bitmap save-file bp 'png #:unscaled? #t) 89 (values (get-output-bytes bp) (send bitmap get-backing-scale))) 90 91 (define (flip-bytes bmbytes w h) 92 (build-bmbytes 93 w h 94 (λ (x y) 95 (let ([new-x x] 96 [new-y (- h y 1)]) 97 (bmbytes-ref/safe bmbytes w h new-x new-y))))) 98 99 #; 100 (define (rotate-bytes bmbytes w h theta) 101 (let* {[theta-rotation (exp (* i theta))] 102 [theta-unrotation (make-rectangular (real-part theta-rotation) 103 (- (imag-part theta-rotation)))] 104 [ne (* theta-rotation w)] 105 [sw (* theta-rotation (* i (- h)))] 106 [se (* theta-rotation (make-rectangular w (- h)))] 107 [nw 0] 108 [pts (list ne sw se nw)] 109 [longitudes (map real-part pts)] 110 [latitudes (map imag-part pts)] 111 [east (apply max longitudes)] 112 [west (apply min longitudes)] 113 [nrth (apply max latitudes)] 114 [sth (apply min latitudes)] 115 [new-w (round/e (- east west))] 116 [new-h (round/e (- nrth sth))] 117 } 118 (values (build-bmbytes new-w 119 new-h 120 (λ (x y) 121 (let* {[pre-image (* (make-rectangular (+ west x 1/2) (- nrth y 1/2)) 122 theta-unrotation)] 123 } 124 (interpolate bmbytes w h 125 (real-part pre-image) 126 (- (imag-part pre-image)))))) 127 new-w 128 new-h))) 129 130 ;; linear transform: bytes width height <matrix coodinates> -> (values bytes width height) 131 ;; The matrix is read like this: 132 ;; +- -+ 133 ;; | a b | 134 ;; | c d | 135 ;; +- -+ 136 ;; The ai, bi, ci, and di are the coordinates of the inverse matrix 137 (define (linear-transform bmbytes w h a b c d) 138 (let-values ([(ai bi ci di) 139 (let ([k (/ (- (* a d) (* b c)))]) 140 (values (* k d) (* k (- b)) 141 (* k (- c)) (* k a)))]) 142 ;; mapp : <matrix> complex -> complex 143 ;; applies the matrix represented by abcd(as in the picture above) to p 144 (define (mapp a b c d p) 145 (let ([x (real-part p)] 146 [y (imag-part p)]) 147 (make-rectangular (+ (* a x) (* b y)) 148 (+ (* c x) (* d y))))) 149 (let* {[f-rotation (λ (p) (mapp a b c d p))] 150 [f-unrotation (λ (p) (mapp ai bi ci di p))] 151 [ne (f-rotation w)] 152 [sw (f-rotation (* i (- h)))] 153 [se (f-rotation (make-rectangular w (- h)))] 154 [nw 0] 155 [pts (list ne sw se nw)] 156 [longitudes (map real-part pts)] 157 [latitudes (map imag-part pts)] 158 [east (apply max longitudes)] 159 [west (apply min longitudes)] 160 [nrth (apply max latitudes)] 161 [sth (apply min latitudes)] 162 [new-w (round/e (- east west))] 163 [new-h (round/e (- nrth sth))]} 164 (values (build-bmbytes new-w 165 new-h 166 (λ (x y) 167 (let* {[pre-image (f-unrotation (make-rectangular (+ west x 1/2) (- nrth y 1/2)))]} 168 (interpolate bmbytes w h 169 (real-part pre-image) 170 (- (imag-part pre-image)))))) 171 new-w 172 new-h)))) 173 174 (define (rotate-bytes bmbytes w h theta) 175 (let* ([theta-rotation (exp (* i theta -1))] 176 [x (real-part theta-rotation)] 177 [y (imag-part theta-rotation)]) 178 (linear-transform 179 bmbytes w h 180 x (- y) y x))) 181 182 #; 183 (define (rotate-bytes bmbytes w h theta) 184 (let* {[theta-rotation (exp (* i theta))] 185 [theta-unrotation (make-rectangular (real-part theta-rotation) 186 (- (imag-part theta-rotation)))] 187 [f-rotation (λ (p) (* theta-rotation p))] 188 [f-unrotation (λ (p) (* theta-unrotation p))] 189 [ne (f-rotation w)] 190 [sw (f-rotation (* i (- h)))] 191 [se (f-rotation (make-rectangular w (- h)))] 192 [nw 0] 193 [pts (list ne sw se nw)] 194 [longitudes (map real-part pts)] 195 [latitudes (map imag-part pts)] 196 [east (apply max longitudes)] 197 [west (apply min longitudes)] 198 [nrth (apply max latitudes)] 199 [sth (apply min latitudes)] 200 [new-w (round/e (- east west))] 201 [new-h (round/e (- nrth sth))]} 202 (values (build-bmbytes new-w 203 new-h 204 (λ (x y) 205 (let* {[pre-image (f-unrotation (make-rectangular (+ west x 1/2) (- nrth y 1/2)))]} 206 (interpolate bmbytes w h 207 (real-part pre-image) 208 (- (imag-part pre-image)))))) 209 new-w 210 new-h))) 211 212 ;; Why the offsets of 1/2 in `rotate-bytes` and `interpolate`? 213 ;; We consider a pixel's RGB as a point-sample taken from the 'true' image, 214 ;; where the RGB is the sample at the *center* of the square covered by the pixel. 215 ;; (When we assume the sample had been from the NW corner instead of the center, 216 ;; we got weird artifacts upon rotation: 217 ;; Consider a 1x1 bitmap rotated by 90 degrees. 218 ;; The NW corner of our new value would be derived from the *NE* corner of 219 ;; the original bitmap, which is a full pixel-width away from the original sample. 220 ;; So a 1x1 bitmap being rotated would counterintuitively give a different bitmap.) 221 222 223 224 ; interpolate: bytes natnum natum real real -> bytes 225 ; 226 ; Given a bitmap (bytes of size (* w h NUM-CHANNELS)), return a pixel (bytes of size NUM-CHANNELS) 227 ; corresponding to the interpolated color at x,y 228 ; where x,y are *real-valued* coordinates in [0,w), [0,h). 229 ; 230 (define (interpolate bmbytes w h x y) 231 (let* {[x0 (floor/e (- x 1/2))] 232 [y0 (floor/e (- y 1/2))] 233 [dx (- (- x 1/2) x0)] 234 [dy (- (- y 1/2) y0)] 235 [1-dx (- 1 dx)] 236 [1-dy (- 1 dy)] 237 [nw (bmbytes-ref/safe bmbytes w h x0 y0 )] 238 [ne (bmbytes-ref/safe bmbytes w h (add1 x0) y0 )] 239 [sw (bmbytes-ref/safe bmbytes w h x0 (add1 y0))] 240 [se (bmbytes-ref/safe bmbytes w h (add1 x0) (add1 y0))] 241 } 242 (build-bytes 243 NUM-CHANNELS 244 (λ (i) (inexact->exact (round/e (+ (* (bytes-ref nw i) 1-dx 1-dy) 245 (* (bytes-ref ne i) dx 1-dy) 246 (* (bytes-ref sw i) 1-dx dy) 247 (* (bytes-ref se i) dx dy)))))))) 248 249 250 251 252 253 ; Return pixel (i,j) from a bytes representation. 254 ; However, if i,j refers to an off-board location, 255 ; return the nearest board location where alpha has been set to 0. 256 ; (That is, conceptually extend the picture's edge colors 257 ; infinitely, but make them transparent.) 258 ; This is helpful when trying to interpolate just beyond 259 ; an edge pixel. 260 ; 261 (define (bmbytes-ref/safe bytes w h i j) 262 (let* {[i/safe (clamp-1 0 i w)] 263 [j/safe (clamp-1 0 j h)] 264 [offset (flatten-bm-coord w h i/safe j/safe)] 265 [pixel (subbytes bytes offset (+ offset NUM-CHANNELS))] 266 } 267 (if (and (= i i/safe) (= j j/safe)) 268 pixel 269 (let {[new-pixel (bytes-copy pixel)]} 270 (begin (bytes-set! new-pixel 0 0) 271 new-pixel))))) 272 273 ; Create a bytes representation from 274 ; a function f mapping locations to pixels. 275 ; 276 ; f : [0,w), [0,h) -> (bytes a r g b) 277 ; 278 (define (build-bmbytes w h f) 279 (do {[bm (make-bytes (* NUM-CHANNELS w h))] 280 [y 0 (add1 y)] 281 } 282 [(>= y h) bm] 283 (do {[x 0 (add1 x)] 284 } 285 [(>= x w)] 286 (bytes-copy! bm (flatten-bm-coord w h x y) (f x y))))) 287 288 ; build-bytes, analogous to build-list. 289 ; 290 (define (build-bytes sz f) 291 (do {[b (make-bytes sz)] 292 [i 0 (add1 i)] 293 } 294 [(>= i sz) b] 295 (bytes-set! b i (f i)))) 296 297 ;;;; Some utility functions 298 299 300 (define round/e (compose inexact->exact round)) 301 (define floor/e (compose inexact->exact floor)) 302 (define ceiling/e (compose inexact->exact ceiling)) 303 304 (define NUM-CHANNELS 4) ; alpha, r, g, b 305 306 ; Return n, clamped to the range [a,b). 307 ; (note the open interval; for integers.) 308 ; 309 (define (clamp-1 a n b) 310 (min (max a n) (sub1 b))) 311 312 313 ; Convert an x,y pixel coordinate into its offset into a bytes. 314 ; 315 (define (flatten-bm-coord w h x y) (* (+ (* y w) x) NUM-CHANNELS)) 316