fixed rotation of bitmaps

svn: r16861

collects/2htdp/private/image-more.ss

@@ -10,8 +10,9 @@
                      scheme/list)
          lang/posn)
 
-(define (show-image g [extra-space 0])
+(define (show-image arg [extra-space 0])
-  (letrec ([f (new frame% [label ""])]
+  (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,20 +544,28 @@
                  (/ w 2)
                  (/ h 2))))]
     [(text? atomic-shape)
-     (let*-values ([(w h a d) (send text-sizing-bm get-text-extent 
+     (let-values ([(w h a d) (send text-sizing-bm get-text-extent 
                                    (text-string atomic-shape) 
-                                    (text->font atomic-shape))]
+                                   (text->font atomic-shape))])
-                   [(ax ay) (rotate-xy (- (/ w 2)) (- (/ h 2)) (text-angle atomic-shape))]
+       (rotated-rectangular-bounding-box w h (text-angle atomic-shape)))]
-                   [(bx by) (rotate-xy (- (/ w 2)) (/ h 2) (text-angle atomic-shape))]
+    [(bitmap? atomic-shape)
-                   [(cx cy) (rotate-xy (/ w 2) (- (/ h 2)) (text-angle atomic-shape))]
+     (let ([bb (bitmap-raw-bitmap atomic-shape)])
-                   [(dx dy) (rotate-xy (/ w 2) (/ h 2) (text-angle 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" 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)))]
+            (max ay by cy dy))))
-    [else
-     (fprintf (current-error-port) "using bad bounding box for ~s\n" (image-shape atomic-shape))
-     (values 0 0 100 100)]))
 
 ;; rotate-simple : angle simple-shape -> simple-shape
 (define (rotate-simple θ simple-shape)
@@ -582,8 +590,8 @@
                                       (translate-dy simple-shape))))])
          (make-translate dx dy rotated)))]))
 
-(define (center-point atomic-shape)
+(define (center-point np-atomic-shape)
-  (let-values ([(l t r b) (atomic-bb 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?)])

collects/2htdp/tests/test-image.ss

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

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)
+     (make-bitmap (bitmap-raw-bitmap shape)
-                  (= 1 y-scale))
+                  (bitmap-raw-mask shape)
-       (fprintf (current-error-port) "scaling a bitmap, ignoring\n"))
+                  (bitmap-angle shape)
-     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

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