images/icons: add backing-scale arguments

By default, icons render with a backing scale of 2.

pkgs/images-pkgs/images-doc/images/scribblings/flomap.scrbl

@@ -327,7 +327,7 @@ Like @racket[unsafe-flomap-ref], but returns an flvector containing all the comp
                                                                                           
 @section{Conversion and Construction}
 
-@defproc[(flomap->bitmap [fm flomap]) Any]{
+@defproc[(flomap->bitmap [fm flomap] [#:backing-scale backing-scale (>/c 0.0)]) Any]{
 Converts a flomap to a @racket[bitmap%].
 
 The return type is imprecise because Typed Racket does not support the object system well yet.

pkgs/images-pkgs/images-doc/images/scribblings/icons.scrbl

@@ -143,6 +143,14 @@ Use @racket[(toolbar-icon-height)] as the @racket[height] argument for common ic
 If you cannot, as with the Macro Stepper, send a thinner icon as the @racket[alternate-bitmap] argument to a @racket[switchable-button%].)
 }
 
+@doc-apply[default-icon-backing-scale]{
+The backing scale of DrRacket icons.
+
+A backing scale of 2 means that the icon bitmap internally has two
+pixels per drawing unit, so it it renders well a double resolution,
+such as Retina display mode for Mac OS X.
+}
+
 @doc-apply[plastic-icon-material]
 @doc-apply[rubber-icon-material]
 @doc-apply[glass-icon-material]

pkgs/images-pkgs/images-lib/images/compile-time.rkt

@@ -9,17 +9,19 @@
 (begin-for-syntax
   (define (save-png bm)
     (define p (open-output-bytes))
-    (send bm save-file p 'png)
+    (send bm save-file p 'png #:unscaled? #t)
     (define bs (get-output-bytes p))
     ;(printf "Wrote PNG: ~v bytes~n" (bytes-length bs))
     bs)
   
   (define (save-jpeg bm quality)
-    (define w (send bm get-width))
+    (define s (send bm get-backing-scale))
-    (define h (send bm get-height))
+    (define (scale v) (inexact->exact (ceiling (* s v))))
+    (define w (scale (send bm get-width)))
+    (define h (scale (send bm get-height)))
     (define bs (make-bytes (* 4 w h)))
     
-    (send bm get-argb-pixels 0 0 w h bs #t)
+    (send bm get-argb-pixels 0 0 w h bs #t #:unscaled? #t)
     (for ([i  (in-range 0 (* 4 w h) 4)])
       (define a (bytes-ref bs i))
       (bytes-set! bs i 255)
@@ -50,19 +52,21 @@
     (unless (and (exact-integer? quality) (<= 0 quality 100))
       (raise-type-error 'make-3d-bitmap "(integer-in 0 100)" 1 bm quality))
     (cond [(= quality 100)
-           (with-syntax ([bs  (datum->syntax ctxt (save-png bm))])
+           (with-syntax ([bs  (datum->syntax ctxt (save-png bm))]
-             (syntax/loc ctxt (load-png bs)))]
+                         [scale (send bm get-backing-scale)])
+             (syntax/loc ctxt (load-png bs scale)))]
           [else
            (define-values (alpha-bs rgb-bs) (save-jpeg bm quality))
            (with-syntax ([alpha-bs  (datum->syntax ctxt alpha-bs)]
-                         [rgb-bs    (datum->syntax ctxt rgb-bs)])
+                         [rgb-bs    (datum->syntax ctxt rgb-bs)]
-             (syntax/loc ctxt (load-jpeg alpha-bs rgb-bs)))]))
+                         [scale (send bm get-backing-scale)])
+             (syntax/loc ctxt (load-jpeg alpha-bs rgb-bs scale)))]))
   )
 
-(define (load-png bs)
+(define (load-png bs scale)
-  (read-bitmap (open-input-bytes bs) 'png/alpha))
+  (read-bitmap (open-input-bytes bs) 'png/alpha #:backing-scale scale))
 
-(define (load-jpeg alpha-bs rgb-bs)
+(define (load-jpeg alpha-bs rgb-bs scale)
   (define alpha-bm (read-bitmap (open-input-bytes alpha-bs) 'jpeg))
   (define rgb-bm (read-bitmap (open-input-bytes rgb-bs) 'jpeg))
   (define w (send rgb-bm get-width))
@@ -77,8 +81,9 @@
     (define a (bytes-ref bs (+ i 2)))
     (bytes-set! new-bs i a))
   
-  (define new-bm (make-bitmap w h))
+  (define (/* n d) (inexact->exact (ceiling (/ n d))))
-  (send new-bm set-argb-pixels 0 0 w h new-bs #f)
+  (define new-bm (make-bitmap (/* w scale) (/* h scale) #:backing-scale scale))
+  (send new-bm set-argb-pixels 0 0 w h new-bs #f #:unscaled? #t)
   new-bm)
 
 (define-syntax (compiled-bitmap stx)

pkgs/images-pkgs/images-lib/images/icons/arrow.rkt

@@ -119,6 +119,7 @@
   ([#:color color (or/c string? (is-a?/c color%))]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [left-arrow-icon left-arrow-flomap]
   [right-arrow-icon right-arrow-flomap]
   [up-arrow-icon up-arrow-flomap]

pkgs/images-pkgs/images-lib/images/icons/control.rkt

@@ -181,6 +181,7 @@
   ([#:color color (or/c string? (is-a?/c color%))]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [play-icon play-flomap]
   [back-icon back-flomap]
   [fast-forward-icon fast-forward-flomap]

pkgs/images-pkgs/images-lib/images/icons/file.rkt

@@ -152,6 +152,7 @@
   ([#:color color (or/c string? (is-a?/c color%)) "slategray"]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [floppy-disk-icon floppy-disk-flomap])
 
 (define-icon-wrappers
@@ -159,6 +160,7 @@
    [#:arrow-color arrow-color (or/c string? (is-a?/c color%)) syntax-icon-color]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [save-icon save-flomap]
   [load-icon load-flomap]
   [small-save-icon small-save-flomap]

pkgs/images-pkgs/images-lib/images/icons/misc.rkt

@@ -576,6 +576,7 @@
    [#:color color (or/c string? (is-a?/c color%))]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [regular-polygon-icon regular-polygon-flomap])
 
 (define-icon-wrappers
@@ -584,6 +585,7 @@
    [#:face-color face-color (or/c string? (is-a?/c color%)) light-metal-icon-color]
    [#:hand-color hand-color (or/c string? (is-a?/c color%)) "firebrick"]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)])
+  (height)
   [clock-icon clock-flomap]
   [stopwatch-icon stopwatch-flomap])
 
@@ -591,6 +593,7 @@
   ([#:color color (or/c string? (is-a?/c color%)) halt-icon-color]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [stop-sign-icon stop-sign-flomap]
   [stop-signs-icon stop-signs-flomap])
 
@@ -598,6 +601,7 @@
   ([#:color color (or/c string? (is-a?/c color%))]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [foot-icon foot-flomap])
 
 (define-icon-wrappers
@@ -605,6 +609,7 @@
    [#:handle-color handle-color (or/c string? (is-a?/c color%)) "brown"]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [magnifying-glass-icon magnifying-glass-flomap]
   [left-magnifying-glass-icon  left-magnifying-glass-flomap])
 
@@ -613,6 +618,7 @@
    [#:bomb-color bomb-color (or/c string? (is-a?/c color%)) dark-metal-icon-color]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [bomb-icon bomb-flomap]
   [left-bomb-icon left-bomb-flomap])
 
@@ -622,10 +628,12 @@
    [#:shackle-color shackle-color (or/c string? (is-a?/c color%)) light-metal-icon-color]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [lock-icon lock-flomap])
 
 (define-icon-wrappers
   ([#:color color (or/c string? (is-a?/c color%)) "black"]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)])
+  (height)
   [stethoscope-icon stethoscope-flomap]
   [short-stethoscope-icon short-stethoscope-flomap])

pkgs/images-pkgs/images-lib/images/icons/stickman.rkt

@@ -319,6 +319,7 @@
    [#:head-color head-color (or/c string? (is-a?/c color%)) run-icon-color]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [standing-stickman-icon standing-stickman-flomap])
 
 (define-icon-wrappers
@@ -328,6 +329,7 @@
    [#:head-color head-color (or/c string? (is-a?/c color%)) run-icon-color]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [running-stickman-icon running-stickman-flomap])
 
 #;; FOR TESTING ONLY: Do not let this find its way into the repo uncommented!

pkgs/images-pkgs/images-lib/images/icons/style.rkt

@@ -18,6 +18,7 @@
          metal-icon-material
          bitmap-render-icon
          (activate-contract-out
+          default-icon-backing-scale
           default-icon-height
           toolbar-icon-height
           default-icon-material
@@ -42,6 +43,7 @@
 (defthing run-icon-color (or/c string? (is-a?/c color%)) #:document-value
   "lawngreen")
 
+(defparam default-icon-backing-scale (and/c rational? (>/c 0)) 2)
 (defparam default-icon-height (and/c rational? (>=/c 0)) 24)
 (defparam toolbar-icon-height (and/c rational? (>=/c 0)) 16)
 
@@ -175,10 +177,13 @@
 
 (define-syntax (define-icon-wrappers stx)
   (syntax-case stx ()
-    [(_ (arg ...) [icon-fun flomap-fun] ...)
+    [(_ (arg ...) (scale-arg ...) [icon-fun flomap-fun] ...)
-     (with-syntax ([(actual-args ...)  (apply append (map arg-actual (syntax->list #'(arg ...))))])
+     (with-syntax ([(actual-args ...)  (apply append (map arg-actual (syntax->list #'(arg ...))))]
+                   [backing-arg #'[#:backing-scale backing-scale (and/c rational? (>/c 0.0))
+                                                   (default-icon-backing-scale)]])
        (syntax/loc stx
          (begin
-           (defproc (icon-fun arg ...) (is-a?/c bitmap%)
+           (defproc (icon-fun arg ... backing-arg) (is-a?/c bitmap%)
-             (flomap->bitmap (flomap-fun actual-args ...)))
+             (let ([scale-arg (* scale-arg backing-scale)] ...)
+               (flomap->bitmap (flomap-fun actual-args ...) #:backing-scale backing-scale)))
            ...)))]))

pkgs/images-pkgs/images-lib/images/icons/symbol.rkt

@@ -285,34 +285,40 @@
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)]
    [#:outline outline (and/c rational? (>=/c 0)) (/ height 32)])
+  (height outline)
   [text-icon text-flomap])
 
 (define-icon-wrappers
   ([#:color color (or/c string? (is-a?/c color%)) "forestgreen"]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [recycle-icon recycle-flomap])
 
 (define-icon-wrappers
   ([#:color color (or/c string? (is-a?/c color%)) halt-icon-color]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [x-icon x-flomap])
 
 (define-icon-wrappers
   ([#:color color (or/c string? (is-a?/c color%)) run-icon-color]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [check-icon check-flomap])
 
 (define-icon-wrappers
   ([#:color color (or/c string? (is-a?/c color%)) light-metal-icon-color]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [lambda-icon lambda-flomap])
 
 (define-icon-wrappers
   ([#:color color (or/c string? (is-a?/c color%)) "mediumseagreen"]
    [#:height height (and/c rational? (>=/c 0)) (default-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [hash-quote-icon hash-quote-flomap])

pkgs/images-pkgs/images-lib/images/icons/tool.rkt

@@ -93,6 +93,7 @@
 (define-icon-wrappers
   ([#:height height (and/c rational? (>=/c 0)) (toolbar-icon-height)]
    [#:material material deep-flomap-material-value? (default-icon-material)])
+  (height)
   [check-syntax-icon check-syntax-flomap]
   [small-check-syntax-icon small-check-syntax-flomap]
   [macro-stepper-icon macro-stepper-flomap]

pkgs/images-pkgs/images-lib/images/logos.rkt

@@ -408,11 +408,13 @@
 
 (define-icon-wrappers
   ([#:height height (and/c rational? (>=/c 0)) 256])
+  (height)
   [plt-logo plt-flomap]
   [racket-logo racket-flomap])
 
 (define-icon-wrappers
   ([#:height height (and/c rational? (>=/c 0)) 96])
+  (height)
   [planet-logo planet-flomap]
   [stepper-logo stepper-flomap]
   [macro-stepper-logo macro-stepper-logo-flomap])

pkgs/images-pkgs/images-lib/images/private/flomap-convert.rkt

@@ -39,7 +39,7 @@
    (unsafe-flround
     (unsafe-flmax 0.0 (unsafe-flmin 255.0 (unsafe-fl* x 255.0))))))
 
-(define (flomap->bitmap fm)
+(define (flomap->bitmap fm #:backing-scale [backing-scale 1.0])
   (match-define (flomap vs c w h) fm)
   (let* ([fm  (case c
                 [(0)  (make-flomap 4 w h)]
@@ -68,9 +68,10 @@
       (unsafe-bytes-set! bs i2 (unsafe-fl->byte g))
       (unsafe-bytes-set! bs i3 (unsafe-fl->byte b)))
     
-    (define bm (make-bitmap w h))
+    (define (scale d) (inexact->exact (ceiling (/ d backing-scale))))
-    (send bm set-argb-pixels 0 0 w h bs #t #t)
+    (define bm (make-bitmap (scale w) (scale h) #:backing-scale backing-scale))
-    (send bm set-argb-pixels 0 0 w h bs #f #t)
+    (send bm set-argb-pixels 0 0 w h bs #t #t #:unscaled? #t)
+    (send bm set-argb-pixels 0 0 w h bs #f #t #:unscaled? #t)
     bm))
 
 (define (draw-flomap draw-proc w h)

pkgs/images-pkgs/images-lib/images/private/flomap.rkt

@@ -20,17 +20,17 @@
           [get-height (-> Integer)]
           [get-argb-pixels
            (case-> 
-            (Integer Integer Integer Integer Bytes
+            (Integer Integer Integer Integer Bytes [#:unscaled? Boolean]
                      -> Void)
-            (Integer Integer Integer Integer Bytes Boolean
+            (Integer Integer Integer Integer Bytes Boolean [#:unscaled? Boolean]
                      -> Void)
-            (Integer Integer Integer Integer Bytes Boolean Boolean
+            (Integer Integer Integer Integer Bytes Boolean Boolean [#:unscaled? Boolean]
                      -> Void))])))
 
 (require/typed
  "flomap-convert.rkt"
  [bitmap->flomap  ((Instance Bitmap%) -> flomap)]
- [flomap->bitmap  (flomap -> (Instance Bitmap%))]
+ [flomap->bitmap  (flomap [#:backing-scale Positive-Real] -> (Instance Bitmap%))]
  [draw-flomap     ((Any -> Any) Integer Integer -> flomap)])
 
 (provide (all-from-out "flomap-struct.rkt"