.

original commit: 89c7f99a2af274f05b30b2e8db7e9dd6b8ec6007

collects/mrlib/cache-image-snip.ss

@@ -6,8 +6,9 @@
   (provide argb-vector->bitmap
            overlay-bitmap
            build-bitmap
+           flatten-bitmap
            cache-image-snip%
-           snipclass)
+           snip-class)
   
   #|
 
@@ -76,15 +77,17 @@
       ;; if it were drawn
       (define/public (get-bitmap)
         (unless bitmap
-          (set! bitmap (argb-vector->bitmap (get-argb-vector)
+          (set! bitmap (flatten-bitmap
-                                            (ceiling (inexact->exact width))
+                        (argb-vector->bitmap
-                                            (ceiling (inexact->exact height)))))
+                         (get-argb-vector)
+                         (ceiling (inexact->exact width))
+                         (ceiling (inexact->exact height))))))
         bitmap)
       
       ;; get-argb-vector : -> argb-vector
       (define/public (get-argb-vector)
         (unless argb-vector
-          (set! argb-vector (make-string (* 4 width height) #\000))
+          (set! argb-vector (make-vector (* 4 width height) 255))
           (argb-proc argb-vector 0 0))
         argb-vector)
       
@@ -100,25 +103,34 @@
         (cond
           [argb-vector
            (let ([bitmap (get-bitmap)])
-             (send dc draw-bitmap bitmap x y))]
+             (send dc draw-bitmap bitmap x y 'solid 
+                   (send the-color-database find-color "black")
+                   (send bitmap get-loaded-mask)))]
           [dc-proc
            (dc-proc dc x y)]
           [else (void)]))
       
       (define/override (write f)
+        (printf "calling write\n")
         (let ([str (format "~s"
                            (list width
                                  height
                                  (get-argb-vector)))])
-          (send f write str)))
+          (send f put str)))
       
       (super-new)
       (inherit set-snipclass)
-      (set-snipclass snipclass)))
+      (set-snipclass snip-class)))
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;; snip-class
+  ;;
   
   (define cache-image-snip-class%
     (class snip-class%
       (define/override (read f)
+        (printf "called read\n")
         (let ([data (read-from-string (send f get-string)
                                       void
                                       (lambda (x) #f))])
@@ -133,6 +145,12 @@
               (make-null-cache-image-snip))))
       (super-new)))
   
+  (define snip-class (new cache-image-snip-class%))
+  (send snip-class set-version 1)
+  (send snip-class set-classname (format "~s" `(lib "cache-image-snip.ss" "mrlib")))
+  (printf "installing snipclass\n")
+  (send (get-the-snip-class-list) add snip-class)
+  
   (define (make-null-cache-image-snip)
     (define size 10)
     (define (draw dc dx dy)
@@ -141,7 +159,7 @@
        "black" 'solid
        "black" 'transparent
        (send dc draw-ellipse dx dy size size)
-       (send dc draw-line dx dy (+ dx size -1) (+ dy size -1))))
+       (send dc draw-line dx (+ dy size -1) (+ dx size -1) dy)))
     (define bm (build-bitmap (lambda (dc) (draw dc 0 0))
                              size
                              size))
@@ -152,7 +170,52 @@
          (argb-proc 
           (lambda (argb-vector dx dy)
             (overlay-bitmap argb-vector dx dy bm bm)))))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;; misc. utilities
+  ;;
+  
+  ;; takes a bitmap with a mask and flattens the colors and the mask
+  ;; drawing them as they would appear on the screen.
+  (define (flatten-bitmap bm)
+    (let* ([w (send bm get-width)]
+           [h (send bm get-height)]
+           [new-bm (make-object bitmap% w h)]
+           [bdc (make-object bitmap-dc% new-bm)])
+      (send bdc draw-bitmap bm 0 0 'solid 
+            (send the-color-database find-color "black")
+            (send bm get-loaded-mask))
+      (send bdc set-bitmap #f)
+      new-bm))
+  
+  (define (build-bitmap draw w h)
+    (let* ([bm (make-object bitmap% w h)]
+           [bdc (make-object bitmap-dc% bm)])
+      (send bdc clear)
+      (draw bdc)
+      (send bdc set-bitmap #f)
+      bm))
 
+  (define-syntax (with-pen/brush stx)
+    (syntax-case stx ()
+      [(_ dc pen-color pen-style brush-color brush-style code ...)
+       (syntax
+        (let ([old-pen (send dc get-pen)]
+              [old-brush (send dc get-brush)])
+          (send dc set-pen (send the-pen-list find-or-create-pen pen-color 1 pen-style))
+          (send dc set-brush (send the-brush-list find-or-create-brush brush-color brush-style))
+          code ...
+          (send dc set-pen old-pen)
+          (send dc set-brush old-brush)))]))
+  
+  (define (set-box/f! b v) (when (box? b) (set-box! b v)))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;; argb vector utilties
+  ;;
+  
   ;; argb-vector->bitmap : argb-vector int int -> bitmap
   ;; flattens the argb vector into a bitmap
   (define (argb-vector->bitmap argb-vector w h)
@@ -520,6 +583,7 @@ for b3, we have:
 
 
 |#
+  
   (define (build-m3 m1 m2) (* m1 m2 1/255))
   
   (define (build-b3 m1 b1 m2 b2 m3)
@@ -529,62 +593,4 @@ for b3, we have:
               (* m1 b1 m2 -1/255)
               (* 255 b2)
               (* -255 m3))
-           (- 255 m3))))
+           (- 255 m3)))))
-  
-  (define snipclass (new cache-image-snip-class%))
-  (send snipclass set-version 1)
-  (send snipclass set-classname (format "~s" `(lib "cache-image-snip.ss" "mrlib")))
-  (send (get-the-snip-class-list) add snipclass)  
-  
-  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-  ;;
-  ;; misc. utilities
-  ;;
-  
-  (define (build-bitmap draw w h)
-    (let* ([bm (make-object bitmap% w h)]
-           [bdc (make-object bitmap-dc% bm)])
-      (send bdc clear)
-      (draw bdc)
-      (send bdc set-bitmap #f)
-      bm))
-
-  (define-syntax (with-pen/brush stx)
-    (syntax-case stx ()
-      [(_ dc pen-color pen-style brush-color brush-style code ...)
-       (syntax
-        (let ([old-pen (send dc get-pen)]
-              [old-brush (send dc get-brush)])
-          (send dc set-pen (send the-pen-list find-or-create-pen pen-color 1 pen-style))
-          (send dc set-brush (send the-brush-list find-or-create-brush brush-color brush-style))
-          code ...
-          (send dc set-pen old-pen)
-          (send dc set-brush old-brush)))]))
-  
-  (define (set-box/f! b v) (when (box? b) (set-box! b v)))
-  
-  ;; --
-
-    ;; bitmaps->cache-image-snip : bitmap bitmap -> cache-image-snip
-  (define (bitmaps->cache-image-snip bmp bmp-mask)
-    (new cache-image-snip%
-         [dc-proc (lambda (dc dx dy)
-                    (send dc draw-bitmap 
-                          bmp 
-                          dx
-                          dy
-                          'solid
-                          (send the-color-database find-color "black")
-                          bmp-mask))]
-         [argb-proc (lambda (dc dx dy)
-                      (send dc draw-bitmap 
-                            bmp 
-                            dx
-                            dy
-                            'solid
-                            (send the-color-database find-color "black")
-                            bmp-mask))]
-         [width (send bmp get-width)]
-         [height (send bmp get-height)]))
-  
-  )

collects/tests/mzscheme/cache-image-snip-test.ss

@@ -153,19 +153,6 @@
                   (get-one (send main-bm get-loaded-mask)))
              (get-one main-bm))))
    
-   ;; takes a bitmap with a mask and flattens the colors and the mask
-   ;; drawing them as they would appear on the screen.
-   (define (flatten-bitmap bm)
-     (let* ([w (send bm get-width)]
-            [h (send bm get-height)]
-            [new-bm (make-object bitmap% w h)]
-            [bdc (make-object bitmap-dc% new-bm)])
-       (send bdc draw-bitmap bm 0 0 'solid 
-             (send the-color-database find-color "black")
-             (send bm get-loaded-mask))
-       (send bdc set-bitmap #f)
-       new-bm))
-   
    (test '("\377\377\377\377" "\377\377\377\377") argb-vector->bitmap->string #(255 255 255 255) 1 1)
    (test '("\377\377\377\377" "\377\0\0\0") argb-vector->bitmap->string #(255 0 0 0) 1 1)
    (test '("\377\1\1\1" "\377\100\100\100") argb-vector->bitmap->string #(1 64 64 64) 1 1)
@@ -241,6 +228,28 @@
      ;; but it isn't, due to rounding error (final is actually wrong!)
      ;; the stuff below just makes sure that each entry is within 3
      
+     
+     ;; the expression below shows the truncated bitmap, 
+     ;; the true bitmap (after rounding) and the difference, as a bitmap
+     #;
+     (let* ([argb-bitmap (flatten-bitmap (argb-vector->bitmap argb-str w h))]
+            [argb-str (cadr (bitmap->string argb-bitmap))]
+            [bitmap-str (cadr (bitmap->string final))]
+            [new-bitmap-str (make-string (string-length argb-str) #\000)]
+            [new-bitmap (make-object bitmap% w h)]
+            [dc (make-object bitmap-dc% new-bitmap)])
+       (let loop ([i 0])
+         (when (< i (string-length argb-str))
+           (unless (equal? (string-ref argb-str i)
+                           (string-ref bitmap-str i))
+             (string-set! new-bitmap-str i #\377))
+           (loop (+ i 1))))
+       (send dc set-argb-pixels 0 0 w h new-bitmap-str)
+       (send dc set-bitmap #f)
+       (show-bitmap argb-bitmap #f "argb")
+       (show-bitmap final #f "final")
+       (show-bitmap new-bitmap #f "difference"))
+     
      (let* ([argb-bitmap (flatten-bitmap (argb-vector->bitmap argb-str w h))]
             [argb-ents (map char->integer (string->list (cadr (bitmap->string argb-bitmap))))]
             [bitmap-ents (map char->integer (string->list (cadr (bitmap->string final))))])