images/icons: add backing-scale arguments

By default, icons render with a backing scale of 2.
2014-01-02 18:57:09 -07:00 · 2014-01-02 18:57:09 -07:00 · 4ee266fd97
commit 4ee266fd97
parent 5e903441a4
14 changed files with 68 additions and 26 deletions
--- a/pkgs/images-pkgs/images-doc/images/scribblings/flomap.scrbl
+++ b/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.
--- a/pkgs/images-pkgs/images-doc/images/scribblings/icons.scrbl
+++ b/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]
--- a/pkgs/images-pkgs/images-lib/images/compile-time.rkt
+++ b/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 h (send bm get-height))
+    (define s (send bm get-backing-scale))
+    (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))])
-             (syntax/loc ctxt (load-png bs)))]
+           (with-syntax ([bs  (datum->syntax ctxt (save-png bm))]
+                         [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)])
-             (syntax/loc ctxt (load-jpeg alpha-bs rgb-bs)))]))
+                         [rgb-bs    (datum->syntax ctxt rgb-bs)]
+                         [scale (send bm get-backing-scale)])
+             (syntax/loc ctxt (load-jpeg alpha-bs rgb-bs scale)))]))
  )

-(define (load-png bs)
-  (read-bitmap (open-input-bytes bs) 'png/alpha))
+(define (load-png bs scale)
+  (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))
-  (send new-bm set-argb-pixels 0 0 w h new-bs #f)
+  (define (/* n d) (inexact->exact (ceiling (/ n d))))
+  (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)
--- a/pkgs/images-pkgs/images-lib/images/icons/arrow.rkt
+++ b/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]
--- a/pkgs/images-pkgs/images-lib/images/icons/control.rkt
+++ b/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]
--- a/pkgs/images-pkgs/images-lib/images/icons/file.rkt
+++ b/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]
--- a/pkgs/images-pkgs/images-lib/images/icons/misc.rkt
+++ b/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])
--- a/pkgs/images-pkgs/images-lib/images/icons/stickman.rkt
+++ b/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!
--- a/pkgs/images-pkgs/images-lib/images/icons/style.rkt
+++ b/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] ...)
-     (with-syntax ([(actual-args ...)  (apply append (map arg-actual (syntax->list #'(arg ...))))])
+    [(_ (arg ...) (scale-arg ...) [icon-fun flomap-fun] ...)
+     (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%)
-             (flomap->bitmap (flomap-fun actual-args ...)))
+           (defproc (icon-fun arg ... backing-arg) (is-a?/c bitmap%)
+             (let ([scale-arg (* scale-arg backing-scale)] ...)
+               (flomap->bitmap (flomap-fun actual-args ...) #:backing-scale backing-scale)))
           ...)))]))
--- a/pkgs/images-pkgs/images-lib/images/icons/symbol.rkt
+++ b/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])
--- a/pkgs/images-pkgs/images-lib/images/icons/tool.rkt
+++ b/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]
--- a/pkgs/images-pkgs/images-lib/images/logos.rkt
+++ b/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])
--- a/pkgs/images-pkgs/images-lib/images/private/flomap-convert.rkt
+++ b/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))
-    (send bm set-argb-pixels 0 0 w h bs #t #t)
-    (send bm set-argb-pixels 0 0 w h bs #f #t)
+    (define (scale d) (inexact->exact (ceiling (/ d backing-scale))))
+    (define bm (make-bitmap (scale w) (scale h) #:backing-scale backing-scale))
+    (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)
--- a/pkgs/images-pkgs/images-lib/images/private/flomap.rkt
+++ b/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"