speed up bitmap rotation (could probably revisit this to

speed up flipping (and also to do all three in one pass)

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

@@ -1360,13 +1360,37 @@
       => 
       20)
 
-(test (rotate 90 (make-object image-snip% blue-10x20-bitmap))
+(define (close-enough i1 i2)
-      =>
+  (define w (image-width i1))
-      (image-snip->image (make-object image-snip% blue-20x10-bitmap)))
+  (define h (image-height i1))
+  (cond
+    [(and (= w (image-width i2))
+          (= h (image-height i2)))
+     (define b1 (make-bytes (* w h 4)))
+     (define b2 (make-bytes (* w h 4)))
+     (define bm (make-bitmap w h))
+     (define bdc (make-object bitmap-dc% bm))
+     (render-image i1 bdc 0 0)
+     (send bdc get-argb-pixels 0 0 w h b1)
+     (send bdc erase)
+     (render-image i2 bdc 0 0)
+     (send bdc get-argb-pixels 0 0 w h b2)
+     (define diff 0)
+     (for ([x (in-range 0 (bytes-length b1))])
+       (set! diff (+ diff (abs (- (bytes-ref b1 x)
+                                  (bytes-ref b2 x))))))
+     (define avg-diff (/ diff (bytes-length b1)))
+     (<= avg-diff 10)]
+    [else #f]))
        
-(test (rotate 90 (make-object image-snip% green-blue-20x10-bitmap))
+
-      =>
+(test (close-enough (rotate 90 (make-object image-snip% blue-10x20-bitmap))
-      (image-snip->image (make-object image-snip% green-blue-10x20-bitmap)))
+                    (image-snip->image (make-object image-snip% blue-20x10-bitmap)))
+      => #t)
+      
+(test (close-enough (rotate 90 (make-object image-snip% green-blue-20x10-bitmap))
+                    (image-snip->image (make-object image-snip% green-blue-10x20-bitmap)))
+      => #t)
 
 (test (rotate 90 (rotate 90 (make-object image-snip% green-blue-20x10-bitmap)))
       =>

collects/mrlib/image-core.rkt

@@ -1013,6 +1013,44 @@ the mask bitmap and the original bitmap are all together in a single bytes!
     [(and (not flip?) (zero? (ibitmap-angle bitmap)))
      ;; don't rotate anything in this case.
      bitmap-obj]
+    ;; speed up rotated (but not flipped) bitmaps
+    [(not flip?)
+     (define θ (degrees->radians (ibitmap-angle bitmap)))
+     (define ow (send bitmap-obj get-width))
+     (define oh (send bitmap-obj get-height))
+     (define unrotated-pts
+       (list (make-rectangular 0 0)
+             (make-rectangular ow 0)
+             (make-rectangular ow oh)
+             (make-rectangular 0 oh)))
+     (define pts (map (λ (p) (* p (make-polar 1 θ))) unrotated-pts))
+     (define longitudes (map real-part pts))
+     (define latitudes (map imag-part pts))
+     (define east (apply max longitudes))
+     (define west (apply min longitudes))
+     (define nrth (apply min latitudes))
+     (define sth  (apply max latitudes))
+     (define new-w (ceiling (inexact->exact (- east west))))
+     (define new-h (ceiling (inexact->exact (- sth nrth))))
+                            
+     (define new-bm (make-bitmap new-w new-h))
+     (define bdc (make-object bitmap-dc% new-bm))
+     (send bdc set-smoothing 'smoothed)
+     (send bdc rotate (- θ))
+     
+     ;; would like to just translate by 'tp', but
+     ;; the dc applies the translations before applying
+     ;; the rotation, so we have to unrotate the translation
+     ;; before telling the dc about it
+     (define tp (make-rectangular (- west) (- nrth)))
+     (define tp-translated (* tp (make-polar 1 (- θ))))
+     
+     (send bdc translate (real-part tp-translated) (imag-part tp-translated))
+     
+     (send bdc draw-bitmap bitmap-obj 0 0)
+     (send bdc set-bitmap #f)
+     new-bm]
+    
     [else
      (define θ (degrees->radians (ibitmap-angle bitmap)))
      (define-values (bytes w h) (bitmap->bytes bitmap-obj #f))

collects/racket/draw/private/bitmap.rkt

@@ -422,7 +422,12 @@
                                    255)]
                            [premult (lambda (al v)
                                       (if pre?
-                                          (unsafe-fxquotient (fx* al v) 255)
+                                          (unsafe-fl->fx
+                                           (unsafe-flround
+                                            (unsafe-fl/
+                                             (unsafe-fx->fl (fx* al v))
+                                             255.0)))
+                                          #;(unsafe-fxquotient (fx* al v) 255)
                                           v))])
                       (unsafe-bytes-set! dest (fx+ pos A) al)
                       (unsafe-bytes-set! dest (fx+ pos R) (premult al (unsafe-bytes-ref r spos)))