mrlib/close-icon: revise, especially for @2x

Modernize by using alpha instead of constructing masks, etc.

pkgs/gui-pkgs/gui-lib/mrlib/close-icon.rkt

@@ -8,48 +8,10 @@
 (define-runtime-path icon-path '(lib "close.png" "icons"))
   
 (define icon 'icon-not-yet-init)
-(define mask1 'mask-not-yet-init)
-(define mask2 'mask-not-yet-init)
-(define mask3 'mask-not-yet-init)
 
-(define (init-masks)
+(define (init-icon)
-  (define (for-each/b bytes r g b)
+  (when (symbol? icon)
-    (let loop ([i 0])
+    (set! icon (read-bitmap icon-path #:try-@2x? #t))))
-      (when (< i (bytes-length bytes))
-        (bytes-set! bytes (+ i 1) (r (bytes-ref bytes (+ i 1))))
-        (bytes-set! bytes (+ i 2) (g (bytes-ref bytes (+ i 2))))
-        (bytes-set! bytes (+ i 3) (b (bytes-ref bytes (+ i 3))))
-        (loop (+ i 4)))))
-  
-  (define stupid-internal-define-syntax1
-    (set! icon (make-object bitmap% icon-path 'png/mask)))
-  (define stupid-internal-define-syntax2
-    (set! mask1 (send icon get-loaded-mask)))
-  
-  (define bytes (make-bytes (* (send icon get-width) (send icon get-width) 4)))
-  (define bdc (make-object bitmap-dc% mask1))
-  
-  (set! mask2 (make-object bitmap% (send mask1 get-width) (send mask1 get-height)))
-  (set! mask3 (make-object bitmap% (send mask1 get-width) (send mask1 get-height)))
-  
-  (send bdc get-argb-pixels 0 0 (send mask1 get-width) (send mask1 get-height) bytes)
-  (send bdc set-bitmap mask2)
-  (for-each/b bytes 
-              (λ (x) (- 255 (floor (* (- 255 x) 2/3))))
-              values
-              values)
-  (send bdc set-argb-pixels 0 0 (send mask1 get-width) (send mask1 get-height) bytes)
-  
-  (send bdc set-bitmap mask1)
-  (send bdc get-argb-pixels 0 0 (send mask1 get-width) (send mask1 get-height) bytes)
-  (send bdc set-bitmap mask3)
-  (for-each/b bytes 
-              (λ (x) (- 255 (floor (* (- 255 x) 1/4))))
-              values
-              values)
-  (send bdc set-argb-pixels 0 0 (send mask1 get-width) (send mask1 get-height) bytes)
-  
-  (send bdc set-bitmap #f))
 
 (define close-icon%
   (class canvas%
@@ -59,7 +21,7 @@
                 [bg-color #f])
     (init [horizontal-pad 4]
           [vertical-pad 4])
-    (init-masks)
+    (init-icon)
     
     (define mouse-in? #f)
     (define mouse-down? #f)
@@ -82,9 +44,11 @@
            (callback))]
         [(send evt moving?)
          (let ([new-mouse-in?
-                (and (<= (send evt get-x)
+                (and (<= 0
+                         (send evt get-x)
                          (send icon get-width))
-                     (<= (send evt get-y)
+                     (<= 0
+                         (send evt get-y)
                          (send icon get-height)))])
            (unless (equal? new-mouse-in? mouse-in?)
              (set! mouse-in? new-mouse-in?)
@@ -98,20 +62,25 @@
             (send dc set-pen bg-color 1 'transparent)
             (let-values ([(w h) (get-client-size)])
               (send dc draw-rectangle 0 0 w h)))
+          (send dc set-alpha (cond
+                              [(and mouse-in?
+                                    mouse-down?)
+                               0.5]
+                              [(and mouse-in?
+                                    (not mouse-down?))
+                               0.75]
+                              [else
+                               1]))
           (send dc draw-bitmap icon 
                 (- (/ cw 2) (/ (send icon get-width) 2))
                 (- (/ ch 2) (/ (send icon get-height) 2))
                 'solid
-                (send the-color-database find-color "black")
+                (send the-color-database find-color "black")))))
-                (cond
+
-                  [(and mouse-in?
+    (define/override (on-superwindow-show on?)
-                        mouse-down?)
+      (unless on?
-                   mask3]
+        (set! mouse-in? #f)
-                  [(and mouse-in?
+        (set! mouse-down? #f)))
-                        (not mouse-down?))
-                   mask2]
-                  [else
-                   mask1])))))
     
     (super-new [style '(transparent no-focus)])
     (min-width (+ horizontal-pad horizontal-pad (send icon get-width)))