From 6bcf979d9017cd6fa499d7c130c0921b81309804 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 18 Nov 2009 14:58:15 +0000
Subject: [PATCH] fixed rotation of bitmaps

svn: r16861

original commit: cc60cdc02bbccdd2f0336a3858edb037d04a430f
---
 collects/mrlib/image-core.ss                |  61 +++++-
 collects/mrlib/private/image-core-bitmap.ss | 202 ++++++++++++++++++++
 2 files changed, 255 insertions(+), 8 deletions(-)
 create mode 100644 collects/mrlib/private/image-core-bitmap.ss

diff --git a/collects/mrlib/image-core.ss b/collects/mrlib/image-core.ss
index 415cdae9..5a0ee444 100644
--- a/collects/mrlib/image-core.ss
+++ b/collects/mrlib/image-core.ss
@@ -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
diff --git a/collects/mrlib/private/image-core-bitmap.ss b/collects/mrlib/private/image-core-bitmap.ss
new file mode 100644
index 00000000..7491cb4f
--- /dev/null
+++ b/collects/mrlib/private/image-core-bitmap.ss
@@ -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))
+