From 4ee266fd97d9e6c7d3d6c647494fd1f1fdd815d8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 2 Jan 2014 18:57:09 -0700 Subject: [PATCH] images/icons: add `backing-scale` arguments By default, icons render with a backing scale of 2. --- .../images/scribblings/flomap.scrbl | 2 +- .../images-doc/images/scribblings/icons.scrbl | 8 +++++ .../images-lib/images/compile-time.rkt | 31 +++++++++++-------- .../images-lib/images/icons/arrow.rkt | 1 + .../images-lib/images/icons/control.rkt | 1 + .../images-lib/images/icons/file.rkt | 2 ++ .../images-lib/images/icons/misc.rkt | 8 +++++ .../images-lib/images/icons/stickman.rkt | 2 ++ .../images-lib/images/icons/style.rkt | 13 +++++--- .../images-lib/images/icons/symbol.rkt | 6 ++++ .../images-lib/images/icons/tool.rkt | 1 + pkgs/images-pkgs/images-lib/images/logos.rkt | 2 ++ .../images/private/flomap-convert.rkt | 9 +++--- .../images-lib/images/private/flomap.rkt | 8 ++--- 14 files changed, 68 insertions(+), 26 deletions(-) diff --git a/pkgs/images-pkgs/images-doc/images/scribblings/flomap.scrbl b/pkgs/images-pkgs/images-doc/images/scribblings/flomap.scrbl index 0f65fa2968..8c07362d81 100644 --- 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. diff --git a/pkgs/images-pkgs/images-doc/images/scribblings/icons.scrbl b/pkgs/images-pkgs/images-doc/images/scribblings/icons.scrbl index 135b1ec7a9..4058e22fb3 100644 --- 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] diff --git a/pkgs/images-pkgs/images-lib/images/compile-time.rkt b/pkgs/images-pkgs/images-lib/images/compile-time.rkt index 6e03a67bce..bd8964ab05 100644 --- 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) diff --git a/pkgs/images-pkgs/images-lib/images/icons/arrow.rkt b/pkgs/images-pkgs/images-lib/images/icons/arrow.rkt index 39fa4c5951..145d99569d 100644 --- 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] diff --git a/pkgs/images-pkgs/images-lib/images/icons/control.rkt b/pkgs/images-pkgs/images-lib/images/icons/control.rkt index a50c656849..d12c3e4984 100644 --- 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] diff --git a/pkgs/images-pkgs/images-lib/images/icons/file.rkt b/pkgs/images-pkgs/images-lib/images/icons/file.rkt index 8be8a008af..0fa948952a 100644 --- 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] diff --git a/pkgs/images-pkgs/images-lib/images/icons/misc.rkt b/pkgs/images-pkgs/images-lib/images/icons/misc.rkt index 0cdbd9e307..bba8c86544 100644 --- 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]) diff --git a/pkgs/images-pkgs/images-lib/images/icons/stickman.rkt b/pkgs/images-pkgs/images-lib/images/icons/stickman.rkt index acd8a426bc..e4994075c6 100644 --- 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! diff --git a/pkgs/images-pkgs/images-lib/images/icons/style.rkt b/pkgs/images-pkgs/images-lib/images/icons/style.rkt index 2133e6fa3d..63c59d7320 100644 --- 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))) ...)))])) diff --git a/pkgs/images-pkgs/images-lib/images/icons/symbol.rkt b/pkgs/images-pkgs/images-lib/images/icons/symbol.rkt index 0039bcdc5a..06fad2de5a 100644 --- 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]) diff --git a/pkgs/images-pkgs/images-lib/images/icons/tool.rkt b/pkgs/images-pkgs/images-lib/images/icons/tool.rkt index 31ecf1c391..78cf70d834 100644 --- 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] diff --git a/pkgs/images-pkgs/images-lib/images/logos.rkt b/pkgs/images-pkgs/images-lib/images/logos.rkt index c5ff4f88c4..6d20a1c17c 100644 --- 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]) diff --git a/pkgs/images-pkgs/images-lib/images/private/flomap-convert.rkt b/pkgs/images-pkgs/images-lib/images/private/flomap-convert.rkt index b275c5120b..b92d61f60e 100644 --- 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) diff --git a/pkgs/images-pkgs/images-lib/images/private/flomap.rkt b/pkgs/images-pkgs/images-lib/images/private/flomap.rkt index 21f60e43f3..e3378bc12a 100644 --- 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"