diff --git a/collects/drracket/private/debug.rkt b/collects/drracket/private/debug.rkt index ae1434fe4c..4df3981356 100644 --- a/collects/drracket/private/debug.rkt +++ b/collects/drracket/private/debug.rkt @@ -26,7 +26,7 @@ profile todo: net/url racket/match mrlib/include-bitmap - images/icons/misc images/icons/style images/icons/control + images/icons/misc images/icons/style images/icons/control images/logos (for-syntax racket/base)) (define orig (current-output-port)) @@ -191,7 +191,7 @@ profile todo: (define bug-note% (make-note% "stop-multi.png" (stop-signs-icon halt-icon-color))) (define mf-note% (make-note% "mf.gif" (include-bitmap (lib "icons/mf.gif") 'gif))) - (define small-planet-bitmap (record-icon "blue")) + (define small-planet-bitmap (planet-logo (default-icon-height))) (define planet-note% (make-note% "small-planet.png" small-planet-bitmap)) ;; display-stats : (syntax -> syntax) diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index dbd7a57293..b18001286d 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -38,7 +38,8 @@ module browser threading seems wrong. "local-member-names.rkt" "eval-helpers.rkt" (prefix-in drracket:arrow: "../arrow.rkt") - (prefix-in icons: (combine-in images/icons/file images/icons/control images/icons/style)) + (prefix-in icons: (combine-in images/icons/file images/icons/control images/icons/style + images/logos)) mred (prefix-in mred: mred) @@ -385,11 +386,12 @@ module browser threading seems wrong. frame program-filename)))]))) + (define disk-color (make-object color% 255 233 112)) (define execute-bitmap (icons:play-icon icons:run-icon-color (icons:toolbar-icon-height))) (define break-bitmap (icons:stop-icon icons:halt-icon-color (icons:toolbar-icon-height))) - (define small-save-bitmap (icons:small-save-icon icons:syntax-icon-color icons:metal-icon-color + (define small-save-bitmap (icons:small-save-icon icons:syntax-icon-color disk-color (icons:toolbar-icon-height))) - (define save-bitmap (icons:save-icon icons:syntax-icon-color icons:metal-icon-color + (define save-bitmap (icons:save-icon icons:syntax-icon-color disk-color (icons:toolbar-icon-height))) (define-values (get-program-editor-mixin add-to-program-editor-mixin) @@ -4696,7 +4698,7 @@ module browser threading seems wrong. [(null? l) '()] [else (cons (car l) (loop (cdr l) (- n 1)))]))) - (define very-small-planet-bitmap (icons:record-icon "blue" (icons:toolbar-icon-height))) + (define very-small-planet-bitmap (icons:planet-logo (icons:toolbar-icon-height))) (define saved-bug-reports-window #f) (define saved-bug-reports-panel #f) diff --git a/collects/images/icons/arrow.rkt b/collects/images/icons/arrow.rkt index 644b769f89..861cb50954 100644 --- a/collects/images/icons/arrow.rkt +++ b/collects/images/icons/arrow.rkt @@ -8,7 +8,7 @@ (provide (all-defined-out)) -(define (right-arrow-flomap color height) +(define (flat-right-arrow-flomap color height) (draw-icon-flomap 32 32 (λ (dc) (send dc set-brush color 'solid) @@ -17,15 +17,16 @@ '(14 . 31) '(15 . 22) '(0 . 22)))) (/ height 32))) -(define (right-over-arrow-flomap color height) +(define (flat-right-over-arrow-flomap color height) (draw-icon-flomap 32 32 (λ (dc) (send dc set-brush color 'solid) (draw-path-commands - dc 0 15 '((c (9 . -14) (19.5 . -8) (24 . -2)) - (l (5 . -7) (2 . 20) (-20 . -2) (7 . -5)) - (c (-2.5 . -4) (-8 . -8.5) (-14 . 0)) - (l (-4 . -4))))) + dc 0 0 '((m 0 15) + (c 9 -14 19.5 -8 24 -2) + (l 5 -7 2 20 -20 -2 7 -5) + (c -2.5 -4 -8 -8.5 -14 0) + (l -4 -4)))) (/ height 32))) (define (flomap-render-short-icon fm material) @@ -37,37 +38,46 @@ dfm)) (deep-flomap-render-icon dfm material)) -(define (right-arrow-icon-flomap* color height material) - (flomap-render-short-icon (right-arrow-flomap color height) material)) +(define (right-arrow-flomap color [height (default-icon-height)] [material (default-icon-material)]) + (make-cached-flomap + [height color material] + (flomap-render-short-icon (flat-right-arrow-flomap color height) material))) -(define (up-arrow-icon-flomap* color height material) - (flomap-render-icon (flomap-cw-rotate (right-arrow-flomap color height)) material)) +(define (up-arrow-flomap color [height (default-icon-height)] [material (default-icon-material)]) + (make-cached-flomap + [height color material] + (flomap-render-icon (flomap-cw-rotate (flat-right-arrow-flomap color height)) material))) -(define (down-arrow-icon-flomap* color height material) - (flomap-render-icon (flomap-ccw-rotate (right-arrow-flomap color height)) material)) +(define (down-arrow-flomap color [height (default-icon-height)] [material (default-icon-material)]) + (make-cached-flomap + [height color material] + (flomap-render-icon (flomap-ccw-rotate (flat-right-arrow-flomap color height)) material))) -(define (right-over-arrow-icon-flomap* color height material) - (flomap-render-short-icon (right-over-arrow-flomap color height) material)) +(define (right-over-arrow-flomap color + [height (default-icon-height)] + [material (default-icon-material)]) + (make-cached-flomap + [height color material] + (flomap-render-short-icon (flat-right-over-arrow-flomap color height) material))) -(define (right-under-arrow-icon-flomap* color height material) - (flomap-render-short-icon (flomap-flip-vertical (right-over-arrow-flomap color height)) material)) +(define (right-under-arrow-flomap color + [height (default-icon-height)] + [material (default-icon-material)]) + (make-cached-flomap + [height color material] + (flomap-render-short-icon + (flomap-flip-vertical (flat-right-over-arrow-flomap color height)) material))) -(define-icon-flomap-proc right-arrow-icon-flomap right-arrow-icon-flomap* 32 color) -(define-icon-flomap-proc up-arrow-icon-flomap up-arrow-icon-flomap* 32 color) -(define-icon-flomap-proc down-arrow-icon-flomap down-arrow-icon-flomap* 32 color) -(define-icon-flomap-proc right-over-arrow-icon-flomap right-over-arrow-icon-flomap* 32 color) -(define-icon-flomap-proc right-under-arrow-icon-flomap right-under-arrow-icon-flomap* 32 color) +(define left-arrow-flomap (compose flomap-flip-horizontal right-arrow-flomap)) +(define left-over-arrow-flomap (compose flomap-flip-horizontal right-over-arrow-flomap)) +(define left-under-arrow-flomap (compose flomap-flip-horizontal right-under-arrow-flomap)) -(define left-arrow-icon-flomap (compose flomap-flip-horizontal right-arrow-icon-flomap)) -(define left-over-arrow-icon-flomap (compose flomap-flip-horizontal right-over-arrow-icon-flomap)) -(define left-under-arrow-icon-flomap (compose flomap-flip-horizontal right-under-arrow-icon-flomap)) +(define right-arrow-icon (compose flomap->bitmap right-arrow-flomap)) +(define left-arrow-icon (compose flomap->bitmap left-arrow-flomap)) +(define up-arrow-icon (compose flomap->bitmap up-arrow-flomap)) +(define down-arrow-icon (compose flomap->bitmap down-arrow-flomap)) -(define right-arrow-icon (compose flomap->bitmap right-arrow-icon-flomap)) -(define left-arrow-icon (compose flomap->bitmap left-arrow-icon-flomap)) -(define up-arrow-icon (compose flomap->bitmap up-arrow-icon-flomap)) -(define down-arrow-icon (compose flomap->bitmap down-arrow-icon-flomap)) - -(define right-over-arrow-icon (compose flomap->bitmap right-over-arrow-icon-flomap)) -(define left-over-arrow-icon (compose flomap->bitmap left-over-arrow-icon-flomap)) -(define right-under-arrow-icon (compose flomap->bitmap right-under-arrow-icon-flomap)) -(define left-under-arrow-icon (compose flomap->bitmap left-under-arrow-icon-flomap)) +(define right-over-arrow-icon (compose flomap->bitmap right-over-arrow-flomap)) +(define left-over-arrow-icon (compose flomap->bitmap left-over-arrow-flomap)) +(define right-under-arrow-icon (compose flomap->bitmap right-under-arrow-flomap)) +(define left-under-arrow-icon (compose flomap->bitmap left-under-arrow-flomap)) diff --git a/collects/images/icons/control.rkt b/collects/images/icons/control.rkt index e12e8168d8..ce523b644e 100644 --- a/collects/images/icons/control.rkt +++ b/collects/images/icons/control.rkt @@ -1,123 +1,126 @@ #lang racket/base (require racket/class + racket/serialize web-server/lang/serial-lambda "../private/flomap.rkt" "../private/utils.rkt" "style.rkt") (provide (all-defined-out)) -(define (play-flomap color height) - (draw-icon-flomap - 24 32 (λ (dc) +(define play-points + (list '(0 . 0) '(4 . 0) + '(23 . 13) '(23 . 18) + '(4 . 31) '(0 . 31))) + +(define (play-flomap color [height (default-icon-height)] [material (default-icon-material)]) + (make-cached-flomap + [height color material] + (draw-rendered-icon-flomap + 24 32 (λ (dc) + (send dc set-brush color 'solid) + (send dc draw-polygon play-points)) + (/ height 32) + material))) + +(define (fast-forward-flomap color [height (default-icon-height)] [material (default-icon-material)]) + (make-cached-flomap + [height color material] + (draw-rendered-icon-flomap + 32 32 (λ (dc) + (send dc set-brush color 'solid) + (send dc draw-polygon (list '(0 . 0) '(4 . 0) + '(17 . 13) '(17 . 18) + '(4 . 31) '(0 . 31))) + (send dc translate 2 0) + (send dc draw-polygon (list + ;; right side + '(14 . 2) + '(27 . 13) '(27 . 18) + '(14 . 29) + ;; left side + '(8 . 29) + '(18 . 19) '(18 . 12) + '(8 . 2)))) + (/ height 32) + material))) + +(define (stop-flomap color [height (default-icon-height)] [material (default-icon-material)]) + (make-cached-flomap + [height color material] + (draw-rendered-icon-flomap + 32 32 (λ (dc) + (send dc set-brush color 'solid) + (send dc draw-polygon (list '(0 . 0) '(31 . 0) '(31 . 31) '(0 . 31)))) + (/ height 32) + material))) + +(define (record-flomap color [height (default-icon-height)] [material (default-icon-material)]) + (make-cached-flomap + [height color material] + (draw-rendered-icon-flomap + 32 32 (λ (dc) + (send dc set-brush color 'solid) + (draw-ellipse/smoothed dc 0 0 32 32)) + (/ height 32) + material))) + +(define (bar-flomap color height material) + (make-cached-flomap + [height color material] + (draw-rendered-icon-flomap + 8 32 (λ (dc) (send dc set-brush color 'solid) - (send dc draw-polygon (list '(0 . 0) '(4 . 0) - '(23 . 13) '(23 . 18) - '(4 . 31) '(0 . 31)))) - (/ height 32))) + (send dc draw-polygon (list '(0 . 0) '(7 . 0) '(7 . 31) '(0 . 31)))) + (/ height 32) + material))) -(define (fast-forward-flomap color height) - (draw-icon-flomap - 32 32 (λ (dc) - (send dc set-brush color 'solid) - (send dc draw-polygon (list '(0 . 0) '(4 . 0) - '(17 . 13) '(17 . 18) - '(4 . 31) '(0 . 31))) - (send dc translate 2 0) - (send dc draw-polygon (list - ;; right side - '(14 . 2) - '(27 . 13) '(27 . 18) - '(14 . 29) - ;; left side - '(8 . 29) - '(18 . 19) '(18 . 12) - '(8 . 2)))) - (/ height 32))) +(define back-flomap (compose flomap-flip-horizontal play-flomap)) +(define reverse-flomap (compose flomap-flip-horizontal fast-forward-flomap)) -(define (play-icon-flomap* color height material) - (flomap-render-icon (play-flomap color height) material)) - -(define (fast-forward-icon-flomap* color height material) - (flomap-render-icon (fast-forward-flomap color height) material)) - -(define (stop-icon-flomap* color height material) - (draw-rendered-icon-flomap - 32 32 (λ (dc) - (send dc set-brush color 'solid) - (send dc draw-polygon (list '(0 . 0) '(31 . 0) '(31 . 31) '(0 . 31)))) - (/ height 32) - material)) - -(define (record-icon-flomap* color height material) - (draw-rendered-icon-flomap - 32 32 (λ (dc) - (send dc set-brush color 'solid) - (draw-ellipse/smoothed dc 0 0 32 32)) - (/ height 32) - material)) - -(define (bar-icon-flomap* color height material) - (draw-rendered-icon-flomap - 8 32 (λ (dc) - (send dc set-brush color 'solid) - (send dc draw-polygon (list '(0 . 0) '(7 . 0) '(7 . 31) '(0 . 31)))) - (/ height 32) - material)) - -(define-icon-flomap-proc play-icon-flomap play-icon-flomap* 32 color) -(define-icon-flomap-proc fast-forward-icon-flomap fast-forward-icon-flomap* 32 color) -(define-icon-flomap-proc record-icon-flomap record-icon-flomap* 32 color) -(define-icon-flomap-proc bar-icon-flomap bar-icon-flomap* 32 color) -(define-icon-flomap-proc stop-icon-flomap stop-icon-flomap* 32 color) - -(define back-icon-flomap (compose flomap-flip-horizontal play-icon-flomap)) -(define reverse-icon-flomap (compose flomap-flip-horizontal fast-forward-icon-flomap)) - -(define (pause-icon-flomap color [height (default-icon-height)] - [material (default-icon-material)]) +(define (pause-flomap color [height (default-icon-height)] [material (default-icon-material)]) (flomap-hc-append - (bar-icon-flomap color height material) + (bar-flomap color height material) (make-flomap 4 (max 1 (inexact->exact (round (* 1/8 height)))) 0) - (bar-icon-flomap color height material))) + (bar-flomap color height material))) -(define (step-icon-flomap color [height (default-icon-height)] +(define (step-flomap color [height (default-icon-height)] [material (default-icon-material)]) (flomap-hc-append - (play-icon-flomap color height material) + (play-flomap color height material) (make-flomap 4 (max 1 (inexact->exact (round (* 1/16 height)))) 0) - (bar-icon-flomap color height material))) + (bar-flomap color height material))) -(define (step-back-icon-flomap color [height (default-icon-height)] +(define (step-back-flomap color [height (default-icon-height)] [material (default-icon-material)]) (flomap-hc-append - (bar-icon-flomap color height material) + (bar-flomap color height material) (make-flomap 4 (max 1 (inexact->exact (round (* 1/16 height)))) 0) - (back-icon-flomap color height material))) + (back-flomap color height material))) -(define (continue-icon-flomap color [height (default-icon-height)] +(define (continue-flomap color [height (default-icon-height)] [material (default-icon-material)]) (flomap-hc-append - (bar-icon-flomap color height material) + (bar-flomap color height material) (make-flomap 4 (max 1 (inexact->exact (round (* 1/16 height)))) 0) - (play-icon-flomap color height material))) + (play-flomap color height material))) -(define (continue-back-icon-flomap color [height (default-icon-height)] +(define (continue-back-flomap color [height (default-icon-height)] [material (default-icon-material)]) (flomap-hc-append - (back-icon-flomap color height material) + (back-flomap color height material) (make-flomap 4 (max 1 (inexact->exact (round (* 1/16 height)))) 0) - (bar-icon-flomap color height material))) + (bar-flomap color height material))) -(define play-icon (compose flomap->bitmap play-icon-flomap)) -(define back-icon (compose flomap->bitmap back-icon-flomap)) -(define fast-forward-icon (compose flomap->bitmap fast-forward-icon-flomap)) -(define reverse-icon (compose flomap->bitmap reverse-icon-flomap)) -(define bar-icon (compose flomap->bitmap bar-icon-flomap)) -(define stop-icon (compose flomap->bitmap stop-icon-flomap)) -(define record-icon (compose flomap->bitmap record-icon-flomap)) -(define pause-icon (compose flomap->bitmap pause-icon-flomap)) -(define step-icon (compose flomap->bitmap step-icon-flomap)) -(define step-back-icon (compose flomap->bitmap step-back-icon-flomap)) -(define continue-icon (compose flomap->bitmap continue-icon-flomap)) -(define continue-back-icon (compose flomap->bitmap continue-back-icon-flomap)) +(define play-icon (compose flomap->bitmap play-flomap)) +(define back-icon (compose flomap->bitmap back-flomap)) +(define fast-forward-icon (compose flomap->bitmap fast-forward-flomap)) +(define reverse-icon (compose flomap->bitmap reverse-flomap)) +(define bar-icon (compose flomap->bitmap bar-flomap)) +(define stop-icon (compose flomap->bitmap stop-flomap)) +(define record-icon (compose flomap->bitmap record-flomap)) +(define pause-icon (compose flomap->bitmap pause-flomap)) +(define step-icon (compose flomap->bitmap step-flomap)) +(define step-back-icon (compose flomap->bitmap step-back-flomap)) +(define continue-icon (compose flomap->bitmap continue-flomap)) +(define continue-back-icon (compose flomap->bitmap continue-back-flomap)) diff --git a/collects/images/icons/file.rkt b/collects/images/icons/file.rkt index 99badd68cb..d8a0477fd5 100644 --- a/collects/images/icons/file.rkt +++ b/collects/images/icons/file.rkt @@ -4,124 +4,129 @@ "../private/flomap.rkt" "../private/deep-flomap.rkt" "../private/renderfx.rkt" + "../private/utils.rkt" "arrow.rkt" "style.rkt") (provide (all-defined-out)) -(define (floppy-disk-icon-flomap* color height material) - (define scale (/ height 32)) - - (define metal-fm - (let* ([fm (draw-icon-flomap - 18 11 (λ (dc) - (send dc set-background "lightgray") - (define outer-path (new dc-path%)) - (send outer-path rounded-rectangle 0.5 0.5 13 12 1) - (define inner-path (new dc-path%)) - (send inner-path rectangle 2.5 2.5 4 6) - (define outer-rgn (new region%)) - (send outer-rgn set-path outer-path) - (define inner-rgn (new region%)) - (send inner-rgn set-path inner-path) - (send outer-rgn subtract inner-rgn) - (send dc set-clipping-region outer-rgn) - (send dc clear)) - scale)] - [dfm (flomap->deep-flomap fm)] - [dfm (deep-flomap-icon-style dfm)] - [dfm (deep-flomap-scale-z dfm 1/16)]) - (deep-flomap-render-icon dfm metal-material))) - - (define bottom-indent-fm - (draw-icon-flomap - 20 11 (λ (dc) - (send dc set-alpha 1/4) - (send dc set-pen "black" 1 'transparent) - (send dc set-brush "black" 'solid) - (send dc draw-rounded-rectangle 1.5 0.5 18 11 1)) - scale)) - - (define label-fm - (let* ([fm (draw-icon-flomap - 22 20 (λ (dc) - (send dc set-pen "black" 1 'transparent) - (send dc set-brush "black" 'solid) - (send dc draw-rounded-rectangle -0.5 -3.5 22 21 3) - (send dc set-brush "lemonchiffon" 'solid) - (send dc draw-rounded-rectangle 0.5 -3.5 20 20 2) - (send dc set-brush "chocolate" 'solid) - (send dc draw-rectangle 0.5 -0.5 20 4) - (send dc set-brush "navy" 'solid) - (for ([i (in-range 5.5 15 3)]) - (send dc draw-rectangle 2.5 i 16 1))) - scale)] - [dfm (flomap->deep-flomap fm)] - [dfm (deep-flomap-bulge-vertical dfm (* 4 scale))]) - (deep-flomap-render-icon dfm matte-material))) - - (define top-indent-fm - (draw-icon-flomap - 22 19 (λ (dc) - (send dc set-alpha 1) - (send dc set-pen "black" 1 'transparent) - (send dc set-brush "black" 'solid) - (send dc draw-rounded-rectangle -0.5 -2.5 22 20 2.5)) - scale)) - - (define case-fm - (draw-icon-flomap - 32 32 (λ (dc) - (send dc set-brush color 'solid) - (send dc draw-polygon (list '(0 . 3) '(3 . 0) - '(28 . 0) '(31 . 3) - '(31 . 28) '(28 . 31) - '(3 . 31) '(0 . 28)))) - scale)) - - (define disk-fm - (let* ([dfm (deep-flomap-ct-superimpose - (deep-flomap-cb-superimpose - (flomap->deep-flomap case-fm) - (deep-flomap-raise (flomap->deep-flomap bottom-indent-fm) (* -4 scale)) - #:z-mode 'add) - (deep-flomap-raise (flomap->deep-flomap top-indent-fm) (* -1 scale)) - #:z-mode 'add)] - [dfm (deep-flomap-icon-style dfm)]) - (deep-flomap-render-icon dfm material))) - - (let* ([fm (flomap-cb-superimpose disk-fm metal-fm)] - [fm (flomap-ct-superimpose fm label-fm)]) - fm)) +(define (floppy-disk-flomap color [height (default-icon-height)] [material (default-icon-material)]) + (make-cached-flomap + [height color material] + (define scale (/ height 32)) + + (define metal-fm + (let* ([fm (draw-icon-flomap + 18 11 (λ (dc) + (send dc set-background "lightgray") + (define outer-path (new dc-path%)) + (send outer-path rounded-rectangle 0.5 0.5 13 12 1) + (define inner-path (new dc-path%)) + (send inner-path rectangle 2.5 2.5 4 6) + (define outer-rgn (new region%)) + (send outer-rgn set-path outer-path) + (define inner-rgn (new region%)) + (send inner-rgn set-path inner-path) + (send outer-rgn subtract inner-rgn) + (send dc set-clipping-region outer-rgn) + (send dc clear)) + scale)] + [dfm (flomap->deep-flomap fm)] + [dfm (deep-flomap-icon-style dfm)] + [dfm (deep-flomap-scale-z dfm 1/16)]) + (deep-flomap-render-icon dfm metal-material))) + + (define bottom-indent-fm + (draw-icon-flomap + 20 11 (λ (dc) + (send dc set-alpha 1/4) + (send dc set-pen "black" 1 'transparent) + (send dc set-brush "black" 'solid) + (send dc draw-rounded-rectangle 1.5 0.5 18 11 1)) + scale)) + + (define label-fm + (let* ([fm (draw-icon-flomap + 22 20 (λ (dc) + (send dc set-pen "black" 1 'transparent) + (send dc set-brush "black" 'solid) + (send dc draw-rounded-rectangle -0.5 -3.5 22 21 3) + (send dc set-brush "lemonchiffon" 'solid) + (send dc draw-rounded-rectangle 0.5 -3.5 20 20 2) + (send dc set-brush "chocolate" 'solid) + (send dc draw-rectangle 0.5 -0.5 20 4) + (send dc set-brush "navy" 'solid) + (for ([i (in-range 5.5 15 3)]) + (send dc draw-rectangle 2.5 i 16 1))) + scale)] + [dfm (flomap->deep-flomap fm)] + [dfm (deep-flomap-bulge-vertical dfm (* 4 scale))]) + (deep-flomap-render-icon dfm matte-material))) + + (define top-indent-fm + (draw-icon-flomap + 22 19 (λ (dc) + (send dc set-alpha 1) + (send dc set-pen "black" 1 'transparent) + (send dc set-brush "black" 'solid) + (send dc draw-rounded-rectangle -0.5 -2.5 22 20 2.5)) + scale)) + + (define case-fm + (draw-icon-flomap + 32 32 (λ (dc) + (send dc set-brush color 'solid) + (send dc draw-polygon (list '(0 . 3) '(3 . 0) + '(28 . 0) '(31 . 3) + '(31 . 28) '(28 . 31) + '(3 . 31) '(0 . 28)))) + scale)) + + (define disk-fm + (let* ([dfm (deep-flomap-ct-superimpose + (deep-flomap-cb-superimpose + (flomap->deep-flomap case-fm) + (deep-flomap-raise (flomap->deep-flomap bottom-indent-fm) (* -4 scale)) + #:z-mode 'add) + (deep-flomap-raise (flomap->deep-flomap top-indent-fm) (* -1 scale)) + #:z-mode 'add)] + [dfm (deep-flomap-icon-style dfm)]) + (deep-flomap-render-icon dfm material))) + + (let* ([fm (flomap-cb-superimpose disk-fm metal-fm)] + [fm (flomap-ct-superimpose fm label-fm)]) + fm))) -(define-icon-flomap-proc floppy-disk-icon-flomap floppy-disk-icon-flomap* 32 color) - -(define (save-icon-flomap arrow-color color [height (default-icon-height)] - [material (default-icon-material)]) - (flomap-hc-append (right-arrow-icon-flomap arrow-color (* 3/4 height) material) +(define (save-flomap arrow-color color + [height (default-icon-height)] + [material (default-icon-material)]) + (flomap-hc-append (right-arrow-flomap arrow-color (* 3/4 height) material) (make-flomap 4 (max 1 (inexact->exact (round (* 1/16 height)))) 0) - (floppy-disk-icon-flomap color height material))) + (floppy-disk-flomap color height material))) -(define (load-icon-flomap arrow-color color [height (default-icon-height)] - [material (default-icon-material)]) - (flomap-hc-append (floppy-disk-icon-flomap color height material) +(define (load-flomap arrow-color color + [height (default-icon-height)] + [material (default-icon-material)]) + (flomap-hc-append (floppy-disk-flomap color height material) (make-flomap 4 (max 1 (inexact->exact (round (* 1/16 height)))) 0) - (right-arrow-icon-flomap arrow-color (* 3/4 height) material))) + (right-arrow-flomap arrow-color (* 3/4 height) material))) -(define (small-save-icon-flomap arrow-color color [height (default-icon-height)] - [material (default-icon-material)]) +(define (small-save-flomap arrow-color color + [height (default-icon-height)] + [material (default-icon-material)]) (flomap-pin* 0 0 11/16 0 - (floppy-disk-icon-flomap color height material) - (right-arrow-icon-flomap arrow-color (* 3/4 height) material))) + (floppy-disk-flomap color height material) + (right-arrow-flomap arrow-color (* 3/4 height) material))) -(define (small-load-icon-flomap arrow-color color [height (default-icon-height)] - [material (default-icon-material)]) +(define (small-load-flomap arrow-color color + [height (default-icon-height)] + [material (default-icon-material)]) (flomap-pin* 1 1 5/16 1 - (floppy-disk-icon-flomap color height material) - (right-arrow-icon-flomap arrow-color (* 3/4 height) material))) + (floppy-disk-flomap color height material) + (right-arrow-flomap arrow-color (* 3/4 height) material))) -(define floppy-disk-icon (compose flomap->bitmap floppy-disk-icon-flomap)) -(define save-icon (compose flomap->bitmap save-icon-flomap)) -(define load-icon (compose flomap->bitmap load-icon-flomap)) -(define small-save-icon (compose flomap->bitmap small-save-icon-flomap)) -(define small-load-icon (compose flomap->bitmap small-load-icon-flomap)) +(define floppy-disk-icon (compose flomap->bitmap floppy-disk-flomap)) +(define save-icon (compose flomap->bitmap save-flomap)) +(define load-icon (compose flomap->bitmap load-flomap)) +(define small-save-icon (compose flomap->bitmap small-save-flomap)) +(define small-load-icon (compose flomap->bitmap small-load-flomap)) diff --git a/collects/images/icons/misc.rkt b/collects/images/icons/misc.rkt index ff321c51de..264fa5dfad 100644 --- a/collects/images/icons/misc.rkt +++ b/collects/images/icons/misc.rkt @@ -12,7 +12,7 @@ ;; =================================================================================================== ;; Unrendered flomaps -(define (x-flomap color height) +(define (flat-x-flomap color height) (define mn 7.5) (define mx 23.5) (draw-icon-flomap @@ -25,18 +25,19 @@ (send dc draw-line mn mx mx mn)) (/ height 32))) -(define (check-flomap color height) +(define (flat-check-flomap color height) (draw-icon-flomap 32 32 (λ (dc) (send dc set-brush color 'solid) (draw-path-commands - dc 0 19 '((c (0 . 0) (7 . 4) (14 . 12) (5.5 . -13.5) (17 . -23) (17 . -23)) - (l (-9 . -8)) - (c (0 . 0) (-6.5 . 7.5) (-9.5 . 16) (-2.5 . -4) (-6 . -6.5) (-6 . -6.5)) - (l (-6 . 9))))) + dc 0 0 '((m 0 19) + (c 0 0 7 4 14 12 5.5 -13.5 17 -23 17 -23) + (l -9 -8) + (c 0 0 -6.5 7.5 -9.5 16 -2.5 -4 -6 -6.5 -6 -6.5) + (l -6 9)))) (/ height 32))) -(define (regular-polygon-flomap sides start color size) +(define (flat-regular-polygon-flomap sides start color size) (draw-icon-flomap 32 32 (λ (dc) (send dc set-brush color 'solid) @@ -52,64 +53,76 @@ ;; =================================================================================================== ;; Rendered flomaps -(define (text-icon-flomap* str font color trim? outline? height material) +(define (text-flomap str font color trim? outline? + [height (default-icon-height)] + [material (default-icon-material)]) (define family (send font get-family)) (define style (send font get-style)) (define weight (send font get-weight)) (define underline? (send font get-underlined)) (define smoothing (send font get-smoothing)) - (let ([font (make-object font% (min 255 (inexact->exact (ceiling height))) - family style weight underline? smoothing #t)]) - (define-values (w h) (get-text-size str font)) - (define outline-amt (if outline? (/ height 32) 0)) - (define ceiling-amt (inexact->exact (ceiling outline-amt))) - (define fm - (let* ([fm (draw-flomap - w h (λ (dc) - (send dc set-font font) - (send dc set-text-foreground color) - (send dc draw-text str 0 0 #t)))] - [fm (if trim? (flomap-trim fm) fm)] - [fm (flomap-resize fm #f (- height (* 2 ceiling-amt)))] - [fm (flomap-inset fm ceiling-amt)] - [fm (if outline? (flomap-outlined fm outline-amt) fm)]) - fm)) - (flomap-render-icon fm material))) + (make-cached-flomap + [height str family style weight underline? smoothing color trim? outline? material] + (let ([font (make-object font% (min 255 (inexact->exact (ceiling height))) + family style weight underline? smoothing #t)]) + (define-values (w h) (get-text-size str font)) + (define outline-amt (if outline? (/ height 32) 0)) + (define ceiling-amt (inexact->exact (ceiling outline-amt))) + (define fm + (let* ([fm (draw-flomap + w h (λ (dc) + (send dc set-font font) + (send dc set-text-foreground color) + (send dc draw-text str 0 0 #t)))] + [fm (if trim? (flomap-trim fm) fm)] + [fm (flomap-resize fm #f (- height (* 2 ceiling-amt)))] + [fm (flomap-inset fm ceiling-amt)] + [fm (if outline? (flomap-outlined fm outline-amt) fm)]) + fm)) + (flomap-render-icon fm material)))) -(define (x-icon-flomap* color height material) - (define scale (/ height 32)) - (let* ([fm (x-flomap color height)] - [dfm (flomap->deep-flomap fm)] - [dfm (deep-flomap-icon-style dfm)] - [dfm (deep-flomap-raise dfm (* -8 scale))]) - (deep-flomap-render-icon dfm material))) +(define (x-flomap color [height (default-icon-height)] [material (default-icon-material)]) + (make-cached-flomap + [height color material] + (define scale (/ height 32)) + (let* ([fm (flat-x-flomap color height)] + [dfm (flomap->deep-flomap fm)] + [dfm (deep-flomap-icon-style dfm)] + [dfm (deep-flomap-raise dfm (* -8 scale))]) + (deep-flomap-render-icon dfm material)))) -(define (check-icon-flomap* color height material) - (define scale (/ height 32)) - (let* ([fm (check-flomap color height)] - [dfm (flomap->deep-flomap fm)] - [dfm (deep-flomap-icon-style dfm)] - [dfm (deep-flomap-raise dfm (* -12 scale))]) - (deep-flomap-render-icon dfm material))) +(define (check-flomap color [height (default-icon-height)] [material (default-icon-material)]) + (make-cached-flomap + [height color material] + (define scale (/ height 32)) + (let* ([fm (flat-check-flomap color height)] + [dfm (flomap->deep-flomap fm)] + [dfm (deep-flomap-icon-style dfm)] + [dfm (deep-flomap-raise dfm (* -12 scale))]) + (deep-flomap-render-icon dfm material)))) -(define (regular-polygon-icon-flomap* sides start color height material) - (flomap-render-icon (regular-polygon-flomap sides start color height) material)) +(define (regular-polygon-flomap sides start color + [height (default-icon-height)] + [material (default-icon-material)]) + (make-cached-flomap + [height sides start color material] + (flomap-render-icon (flat-regular-polygon-flomap sides start color height) material))) -(define (octagon-icon-flomap* color height material) - (regular-polygon-icon-flomap* 8 (/ (* 2 pi) 16) color height material)) +(define (octagon-flomap color [height (default-icon-height)] [material (default-icon-material)]) + (regular-polygon-flomap 8 (/ (* 2 pi) 16) color height material)) -(define (stop-sign-icon-flomap* color height material) - (define scale (/ height 32)) - (let* ([indent-fm (fm* 0.5 (x-flomap "black" (* 22 scale)))] - [indent-dfm (deep-flomap-raise (flomap->deep-flomap indent-fm) (* -2 scale))] - [fm (regular-polygon-flomap 8 (/ (* 2 pi) 16) color height)] - [dfm (flomap->deep-flomap fm)] - [dfm (deep-flomap-cc-superimpose dfm indent-dfm #:z-mode 'add)] - [dfm (deep-flomap-icon-style dfm)] - [fm (deep-flomap-render-icon dfm material)]) - (flomap-cc-superimpose - fm - (x-icon-flomap* "azure" (* 22 scale) metal-material)))) +(define (stop-sign-flomap color [height (default-icon-height)] [material (default-icon-material)]) + (make-cached-flomap + [height color material] + (define scale (/ height 32)) + (let* ([indent-fm (fm* 0.5 (x-flomap "black" (* 22 scale)))] + [indent-dfm (deep-flomap-raise (flomap->deep-flomap indent-fm) (* -2 scale))] + [fm (regular-polygon-flomap 8 (/ (* 2 pi) 16) color height)] + [dfm (flomap->deep-flomap fm)] + [dfm (deep-flomap-cc-superimpose dfm indent-dfm #:z-mode 'add)] + [dfm (deep-flomap-icon-style dfm)] + [fm (deep-flomap-render-icon dfm material)]) + (flomap-cc-superimpose fm (x-flomap "azure" (* 22 scale) metal-material))))) ;; --------------------------------------------------------------------------------------------------- ;; Magnifying glass @@ -127,153 +140,158 @@ 0.8 0.1 0.2 0.2 0.8 0.0 0.0)) -(define (magnifying-glass-icon-flomap* metal-color handle-color height material) - (define scale (/ height 32)) - (define glass-fm - (let* ([fm (draw-icon-flomap - 18 18 (λ (dc) - (send dc set-pen handle-color 1 'solid) - (send dc set-brush "azure" 'solid) - (draw-ellipse/smoothed dc 0 0 18 18) - (send dc set-alpha 0.75) - (send dc set-pen "black" 1 'solid) - (send dc set-brush "white" 'transparent) - (draw-ellipse/smoothed dc 0 0 18 18)) - scale)] - [dfm (flomap->deep-flomap fm)] - [dfm (deep-flomap-bulge-spheroid dfm (* 4 scale))] - [dfm (deep-flomap-raise dfm (* 4 scale))]) - (deep-flomap-render-icon dfm magnifying-glass-material))) - - (define circle-fm - (let* ([fm (draw-icon-flomap - 28 28 (λ (dc) - (send dc set-pen "black" 3 'solid) - (send dc set-brush "black" 'solid) - (draw-ellipse/smoothed dc 1 1 26 26) - (send dc set-pen metal-color 1 'solid) - (send dc set-brush metal-color 'solid) - (draw-ellipse/smoothed dc 1 1 26 26)) - scale)] - [indent-fm (draw-icon-flomap - 28 28 (λ (dc) - (send dc set-pen metal-color 1 'solid) - (send dc set-brush metal-color 'solid) - (draw-ellipse/smoothed dc 5 5 18 18)) - scale)] - [indent-dfm (flomap->deep-flomap indent-fm)] - [indent-dfm (deep-flomap-raise indent-dfm (* -3 scale))] - ;[indent-dfm (deep-flomap-smooth-z indent-dfm (* 2 scale))] - [dfm (flomap->deep-flomap fm)] - ;[dfm (deep-flomap-icon-style dfm)] - [dfm (deep-flomap-raise dfm (* 4 scale))] - [dfm (deep-flomap-cc-superimpose dfm indent-dfm #:z-mode 'add)] - [dfm (deep-flomap-smooth-z dfm (* 1 scale))] - ) - (deep-flomap-render-icon dfm magnifying-glass-metal-material))) - - (define handle-fm - (let* ([fm (draw-icon-flomap - 11 11 (λ (dc) - (send dc set-brush handle-color 'solid) - (define p (new dc-path%)) - (send p move-to 4 0) - (send p line-to 10 5) - (send p curve-to 10 8 8 10 5 10) - (send p line-to 0 4) - (send p move-to 4 0) - (send dc draw-path p)) - scale)]) - (flomap-render-icon fm material))) - - (flomap-pin* 0 0 21/28 21/28 - handle-fm - (flomap-pin* 1/2 1/2 1/2 1/2 circle-fm glass-fm))) -(define (left-bomb-icon-flomap* cap-color bomb-color height material) - (define scale (/ height 32)) - (define fuse-fm - (let* ([fm (draw-icon-flomap - 16 16 (λ (dc) - (send dc set-pen "black" 5 'solid) - (draw-path-commands dc 5.5 5.5 '((c (0 . -1) (-2.5 . -4) (-3 . -2.5)))) - (send dc set-pen "orange" 4 'solid) - (draw-path-commands dc 5.5 5.5 '((c (0 . -1) (-2.5 . -4) (-3 . -2.5))))) - scale)] - [dfm (flomap->deep-flomap fm)] - [dfm (deep-flomap-icon-style dfm)] - [dfm (deep-flomap-scale-z dfm 1)]) - (deep-flomap-render-icon dfm matte-material))) - - (define (bomb-cap-flomap color) - (draw-icon-flomap - 20 20 (λ (dc) - (send dc set-pen "black" 1 'solid) - (send dc set-brush color 'solid) - (draw-path-commands - dc 1 11 '((l (10 . -10) (3 . 3)) - (c (4 . 5) (-5 . 14) (-10 . 10)) - (l (-3 . -3)))) - (draw-path-commands - dc 1 11 '((c (-2 . -5) (5 . -12) (10 . -10) - (4 . 5) (-5 . 14) (-10 . 10))))) - scale)) - - (define cap-fm - (let* ([cap-fm (bomb-cap-flomap cap-color)] - [cap-dfm (flomap->deep-flomap cap-fm)] - [cap-dfm (deep-flomap-icon-style cap-dfm)]) - (deep-flomap-render-icon cap-dfm material))) - - (define sphere-fm - (let* ([sphere-fm (draw-icon-flomap - 32 32 (λ (dc) - (send dc set-brush bomb-color 'solid) - (draw-ellipse/smoothed dc 0 0 32 32)) - scale)] - [cap-fm (bomb-cap-flomap cap-color)] - [cap-dfm (flomap->deep-flomap cap-fm)] - [cap-dfm (deep-flomap-raise cap-dfm (* -2 scale))] - [cap-dfm (deep-flomap-smooth-z cap-dfm (* 1 scale))] - [sphere-dfm (flomap->deep-flomap sphere-fm)] - [sphere-dfm (deep-flomap-bulge-spheroid sphere-dfm (* 16 scale))] - [sphere-dfm (deep-flomap-lt-superimpose sphere-dfm cap-dfm #:z-mode 'add)] - ) - (deep-flomap-render-icon sphere-dfm material))) - (flomap-lt-superimpose sphere-fm cap-fm fuse-fm)) +(define (magnifying-glass-flomap metal-color handle-color + [height (default-icon-height)] + [material (default-icon-material)]) + (make-cached-flomap + [height metal-color handle-color material] + (define scale (/ height 32)) + (define glass-fm + (let* ([fm (draw-icon-flomap + 18 18 (λ (dc) + (send dc set-pen handle-color 1 'solid) + (send dc set-brush "azure" 'solid) + (draw-ellipse/smoothed dc 0 0 18 18) + (send dc set-alpha 0.75) + (send dc set-pen "black" 1 'solid) + (send dc set-brush "white" 'transparent) + (draw-ellipse/smoothed dc 0 0 18 18)) + scale)] + [dfm (flomap->deep-flomap fm)] + [dfm (deep-flomap-bulge-spheroid dfm (* 4 scale))] + [dfm (deep-flomap-raise dfm (* 4 scale))]) + (deep-flomap-render-icon dfm magnifying-glass-material))) + + (define circle-fm + (let* ([fm (draw-icon-flomap + 28 28 (λ (dc) + (send dc set-pen "black" 3 'solid) + (send dc set-brush "black" 'solid) + (draw-ellipse/smoothed dc 1 1 26 26) + (send dc set-pen metal-color 1 'solid) + (send dc set-brush metal-color 'solid) + (draw-ellipse/smoothed dc 1 1 26 26)) + scale)] + [indent-fm (draw-icon-flomap + 28 28 (λ (dc) + (send dc set-pen metal-color 1 'solid) + (send dc set-brush metal-color 'solid) + (draw-ellipse/smoothed dc 5 5 18 18)) + scale)] + [indent-dfm (flomap->deep-flomap indent-fm)] + [indent-dfm (deep-flomap-raise indent-dfm (* -3 scale))] + ;[indent-dfm (deep-flomap-smooth-z indent-dfm (* 2 scale))] + [dfm (flomap->deep-flomap fm)] + ;[dfm (deep-flomap-icon-style dfm)] + [dfm (deep-flomap-raise dfm (* 4 scale))] + [dfm (deep-flomap-cc-superimpose dfm indent-dfm #:z-mode 'add)] + [dfm (deep-flomap-smooth-z dfm (* 1 scale))] + ) + (deep-flomap-render-icon dfm magnifying-glass-metal-material))) + + (define handle-fm + (let* ([fm (draw-icon-flomap + 11 11 (λ (dc) + (send dc set-brush handle-color 'solid) + (define p (new dc-path%)) + (send p move-to 4 0) + (send p line-to 10 5) + (send p curve-to 10 8 8 10 5 10) + (send p line-to 0 4) + (send p move-to 4 0) + (send dc draw-path p)) + scale)]) + (flomap-render-icon fm material))) + + (flomap-pin* 0 0 21/28 21/28 + handle-fm + (flomap-pin* 1/2 1/2 1/2 1/2 circle-fm glass-fm)))) -(define-icon-flomap-proc text-icon-flomap text-icon-flomap* 32 str font color trim? outline?) -(define-icon-flomap-proc regular-polygon-icon-flomap regular-polygon-icon-flomap* 32 color) -(define-icon-flomap-proc octagon-icon-flomap octagon-icon-flomap* 32 color) -(define-icon-flomap-proc x-icon-flomap x-icon-flomap* 24 color) -(define-icon-flomap-proc stop-sign-icon-flomap stop-sign-icon-flomap* 32 color) -(define-icon-flomap-proc check-icon-flomap check-icon-flomap* 32 color) -(define-icon-flomap-proc magnifying-glass-icon-flomap - magnifying-glass-icon-flomap* 32 color metal-color) -(define-icon-flomap-proc left-bomb-icon-flomap left-bomb-icon-flomap* 32 cap-color bomb-color) +;; --------------------------------------------------------------------------------------------------- +;; Bomb -(define (stop-signs-icon-flomap color [height (default-icon-height)] - [icon-material (default-icon-material)]) - (define fm (stop-sign-icon-flomap color (* height 2/3) icon-material)) +(define (left-bomb-flomap cap-color bomb-color + [height (default-icon-height)] + [material (default-icon-material)]) + (make-cached-flomap + [height cap-color bomb-color material] + (define scale (/ height 32)) + (define fuse-fm + (let* ([fm (draw-icon-flomap + 16 16 (λ (dc) + (send dc set-pen "black" 1/2 'solid) + (send dc set-brush "gold" 'solid) + (draw-path-commands + dc 0 0 + '((m 0.5 5.5) + (c -1.5 -2 -0.5 -5 2 -5.5 + 3 0.5 5 2.5 6 5 + 0.5 2.5 -1.5 4.5 -4 4 + -1 -2 -1.5 -3.5 -4 -3.5)))) + scale)] + [dfm (flomap->deep-flomap fm)] + [dfm (deep-flomap-icon-style dfm)] + [dfm (deep-flomap-scale-z dfm 1)]) + (deep-flomap-render-icon dfm matte-material))) + + (define (bomb-cap-flomap color) + (draw-icon-flomap + 20 20 (λ (dc) + (send dc set-pen "black" 1 'solid) + (send dc set-brush color 'solid) + (draw-path-commands dc 0 0 '((m 1.5 11.5) + (l 10 -10 2.5 2.5) + (c 4 5 -5 14 -10 10) + (l -2.5 -2.5))) + (draw-path-commands dc 0 0 '((m 1.5 11.5) + (c -2 -5 5 -12 10 -10 + 4 5 -5 14 -10 10)))) + scale)) + + (define cap-fm + (let* ([cap-fm (bomb-cap-flomap cap-color)] + [cap-dfm (flomap->deep-flomap cap-fm)] + [cap-dfm (deep-flomap-icon-style cap-dfm)]) + (deep-flomap-render-icon cap-dfm material))) + + (define sphere-fm + (let* ([sphere-fm (draw-icon-flomap + 30 30 (λ (dc) + (send dc set-brush bomb-color 'solid) + (draw-ellipse/smoothed dc 0 0 30 30)) + scale)] + [cap-fm (bomb-cap-flomap cap-color)] + [cap-dfm (flomap->deep-flomap cap-fm)] + [cap-dfm (deep-flomap-raise cap-dfm (* -2 scale))] + [cap-dfm (deep-flomap-smooth-z cap-dfm (* 1 scale))] + [sphere-dfm (flomap->deep-flomap sphere-fm)] + [sphere-dfm (deep-flomap-bulge-spheroid sphere-dfm (* 15 scale))] + [sphere-dfm (deep-flomap-inset sphere-dfm 2 2 0 0)] + [sphere-dfm (deep-flomap-lt-superimpose sphere-dfm cap-dfm #:z-mode 'add)] + ) + (deep-flomap-render-icon sphere-dfm material))) + (flomap-lt-superimpose sphere-fm cap-fm fuse-fm))) + +(define (stop-signs-flomap color [height (default-icon-height)] [material (default-icon-material)]) + (define fm (stop-sign-flomap color (* height 2/3) material)) (flomap-pin* 3/16 1/4 0 0 fm (flomap-pin* 3/16 1/4 0 0 fm fm))) -(define left-magnifying-glass-icon-flomap - (compose flomap-flip-horizontal magnifying-glass-icon-flomap)) - -(define bomb-icon-flomap (compose flomap-flip-horizontal left-bomb-icon-flomap)) +(define left-magnifying-glass-flomap (compose flomap-flip-horizontal magnifying-glass-flomap)) +(define bomb-flomap (compose flomap-flip-horizontal left-bomb-flomap)) ;; =================================================================================================== ;; Bitmaps (icons) -(define text-icon (compose flomap->bitmap text-icon-flomap)) -(define regular-polygon-icon (compose flomap->bitmap regular-polygon-icon-flomap)) -(define octagon-icon (compose flomap->bitmap octagon-icon-flomap)) -(define x-icon (compose flomap->bitmap x-icon-flomap)) -(define stop-sign-icon (compose flomap->bitmap stop-sign-icon-flomap)) -(define stop-signs-icon (compose flomap->bitmap stop-signs-icon-flomap)) -(define check-icon (compose flomap->bitmap check-icon-flomap)) -(define magnifying-glass-icon (compose flomap->bitmap magnifying-glass-icon-flomap)) -(define left-magnifying-glass-icon (compose flomap->bitmap left-magnifying-glass-icon-flomap)) -(define bomb-icon (compose flomap->bitmap bomb-icon-flomap)) -(define left-bomb-icon (compose flomap->bitmap left-bomb-icon-flomap)) +(define text-icon (compose flomap->bitmap text-flomap)) +(define regular-polygon-icon (compose flomap->bitmap regular-polygon-flomap)) +(define octagon-icon (compose flomap->bitmap octagon-flomap)) +(define x-icon (compose flomap->bitmap x-flomap)) +(define stop-sign-icon (compose flomap->bitmap stop-sign-flomap)) +(define stop-signs-icon (compose flomap->bitmap stop-signs-flomap)) +(define check-icon (compose flomap->bitmap check-flomap)) +(define magnifying-glass-icon (compose flomap->bitmap magnifying-glass-flomap)) +(define left-magnifying-glass-icon (compose flomap->bitmap left-magnifying-glass-flomap)) +(define bomb-icon (compose flomap->bitmap bomb-flomap)) +(define left-bomb-icon (compose flomap->bitmap left-bomb-flomap)) diff --git a/collects/images/icons/style.rkt b/collects/images/icons/style.rkt index 0042a08f65..16b625afd7 100644 --- a/collects/images/icons/style.rkt +++ b/collects/images/icons/style.rkt @@ -3,8 +3,7 @@ (require racket/draw unstable/parameter-group "../private/flomap.rkt" "../private/deep-flomap.rkt" - "../private/renderfx.rkt" - "../private/transient-box.rkt") + "../private/renderfx.rkt") (provide (all-defined-out)) @@ -31,7 +30,7 @@ (define metal-icon-color "lightsteelblue") (define dark-metal-icon-color "steelblue") -(define syntax-icon-color (make-object color% 38 38 128)) +(define syntax-icon-color (make-object color% 76 76 255)) (define halt-icon-color (make-object color% 255 32 24)) (define run-icon-color "lawngreen") @@ -72,50 +71,3 @@ (let* ([fm (draw-icon-flomap w h draw-proc scale)] [fm (flomap-render-icon fm material)]) fm)) - -(define (clean-cache! h) - (define ks (for*/list ([(k v) (in-hash h)] - [vv (in-value (transient-box-value v))] - #:when (not vv)) - k)) - (for ([k (in-list ks)]) (hash-remove! h k))) - -(define (transient-value-hash-ref! h k thnk) - (thnk) - #;(begin - (define bx (hash-ref! h k (λ () (make-transient-box (thnk))))) - (transient-box-touch! bx) - (define val (transient-box-value bx)) - (cond [val val] - [else (clean-cache! h) - (let ([val (thnk)]) - (hash-set! h k (make-transient-box val)) - val)]))) - -(define caches empty) - -(define (add-cache! cache) (set! caches (cons cache caches))) - -(define (clean-caches!) - (for ([h (in-list caches)]) - (clean-cache! h))) - -(define (read-caches) - (for*/list ([cache (in-list caches)] - [(k v) (in-hash cache)]) - (cons k v))) - -(define-syntax-rule (define-icon-flomap-proc name name* min-height args ...) - (define name - (let ([cache (make-hash)]) - (add-cache! cache) - (λ (args ... - [height (default-icon-height)] - [material (default-icon-material)]) - (cond [(height . < . min-height) - (flomap-scale (transient-value-hash-ref! cache (list args ... min-height material) - (λ () (name* args ... min-height material))) - (/ height min-height))] - [else - (transient-value-hash-ref! cache (list args ... height material) - (λ () (name* args ... height material)))]))))) diff --git a/collects/images/icons/tool.rkt b/collects/images/icons/tool.rkt index 9e448e66b8..5b0052472c 100644 --- a/collects/images/icons/tool.rkt +++ b/collects/images/icons/tool.rkt @@ -11,53 +11,50 @@ (provide (all-defined-out)) -(define (check-syntax-icon-flomap [height (toolbar-icon-height)] - [material (default-icon-material)]) - (flomap-ht-append - (left-magnifying-glass-icon-flomap metal-icon-color syntax-icon-color height material) - (make-flomap 4 (max 1 (inexact->exact (round (* 1/32 height)))) 0) - (check-icon-flomap run-icon-color height material))) +(define debugger-bomb-color (make-object color% 128 64 64)) +(define macro-stepper-hash-color (make-object color% 30 96 30)) -(define (small-check-syntax-icon-flomap [height (toolbar-icon-height)] - [material (default-icon-material)]) +(define (check-syntax-flomap [height (toolbar-icon-height)] [material (default-icon-material)]) + (flomap-ht-append + (left-magnifying-glass-flomap metal-icon-color "chocolate" height material) + (make-flomap 4 (max 1 (inexact->exact (round (* 1/32 height)))) 0) + (check-flomap syntax-icon-color height material))) + +(define (small-check-syntax-flomap [height (toolbar-icon-height)] [material (default-icon-material)]) (flomap-pin* 1 1 5/16 1 - (check-icon-flomap run-icon-color height material) - (magnifying-glass-icon-flomap metal-icon-color syntax-icon-color (* 3/4 height) material))) + (check-flomap syntax-icon-color height material) + (magnifying-glass-flomap metal-icon-color "chocolate" (* 3/4 height) material))) -(define (macro-stepper-icon-flomap [height (toolbar-icon-height)] - [material (default-icon-material)]) +(define (macro-stepper-flomap [height (toolbar-icon-height)] [material (default-icon-material)]) (flomap-ht-append - (text-icon-flomap "#'" (make-object font% 12 'system 'normal 'normal) - run-icon-color #t #t height material) + (text-flomap "#'" (make-object font% 12 'system 'normal 'normal) + macro-stepper-hash-color #t #t height material) (make-flomap 4 (max 1 (inexact->exact (round (* 1/32 height)))) 0) - (step-icon-flomap (make-object color% 38 38 128) height material))) + (step-flomap syntax-icon-color height material))) -(define (small-macro-stepper-icon-flomap [height (toolbar-icon-height)] - [material (default-icon-material)]) +(define (small-macro-stepper-flomap [height (toolbar-icon-height)] [material (default-icon-material)]) (flomap-pin* 0 0 7/16 0 - (step-icon-flomap (make-object color% 38 38 128) height material) - (text-icon-flomap "#'" (make-object font% 12 'system 'normal 'bold) - run-icon-color #t #t (* 3/4 height) material))) + (step-flomap syntax-icon-color height material) + (text-flomap "#'" (make-object font% 12 'system 'normal 'bold) + macro-stepper-hash-color #t #t (* 3/4 height) material))) -(define (debugger-icon-flomap [height (toolbar-icon-height)] - [material (default-icon-material)]) +(define (debugger-flomap [height (toolbar-icon-height)] [material (default-icon-material)]) (flomap-ht-append - (left-bomb-icon-flomap metal-icon-color halt-icon-color height material) + (left-bomb-flomap metal-icon-color debugger-bomb-color height material) (make-flomap 4 (max 1 (inexact->exact (round (* 1/16 height)))) 0) - (step-icon-flomap run-icon-color height material))) + (step-flomap run-icon-color height material))) -(define (small-debugger-icon-flomap [height (toolbar-icon-height)] - [material (default-icon-material)]) +(define (small-debugger-flomap [height (toolbar-icon-height)] [material (default-icon-material)]) (flomap-pin* 0 0 9/16 0 - (step-icon-flomap run-icon-color height material) - (left-bomb-icon-flomap metal-icon-color halt-icon-color (* 3/4 height) material))) + (step-flomap run-icon-color height material) + (left-bomb-flomap metal-icon-color debugger-bomb-color (* 3/4 height) material))) -(define check-syntax-icon (compose flomap->bitmap check-syntax-icon-flomap)) -(define small-check-syntax-icon (compose flomap->bitmap small-check-syntax-icon-flomap)) -(define macro-stepper-icon (compose flomap->bitmap macro-stepper-icon-flomap)) -(define small-macro-stepper-icon (compose flomap->bitmap small-macro-stepper-icon-flomap)) -(define debugger-icon (compose flomap->bitmap debugger-icon-flomap)) -(define small-debugger-icon (compose flomap->bitmap small-debugger-icon-flomap)) +(define check-syntax-icon (compose flomap->bitmap check-syntax-flomap)) +(define small-check-syntax-icon (compose flomap->bitmap small-check-syntax-flomap)) +(define macro-stepper-icon (compose flomap->bitmap macro-stepper-flomap)) +(define small-macro-stepper-icon (compose flomap->bitmap small-macro-stepper-flomap)) +(define debugger-icon (compose flomap->bitmap debugger-flomap)) +(define small-debugger-icon (compose flomap->bitmap small-debugger-flomap)) diff --git a/collects/images/logos.rkt b/collects/images/logos.rkt index 5751014ffe..ac78a25481 100644 --- a/collects/images/logos.rkt +++ b/collects/images/logos.rkt @@ -5,9 +5,10 @@ "private/deep-flomap.rkt" "private/renderfx.rkt" "icons/style.rkt" - "private/unsafe.rkt") + "private/unsafe.rkt" + "private/utils.rkt") -(provide plt-logo) +(provide plt-logo planet-logo) (define glass-logo-material (deep-flomap-material-value @@ -16,44 +17,67 @@ 0.2 0.1 0.1 0.0)) -(define lambda-start-point (cons 235.0 38.0)) -(define lambda-control-points - (list (list (cons -27.07492 0.489079) (cons -52.83237 9.901645) (cons -78.13681 18.608898)) - (list (cons 11.0396 11.823329) (cons 9.37418 15.558039) (cons 14.19246 14.659919)) - (list (cons 18.43869 -4.46584) (cons 45.7868 -14.85883) (cons 57.97111 4.83448)) - (list (cons 26.56443 33.55767) (cons 37.83026 76.50393) (cons 41.85449 118.37596)) - (list (cons 5.15871 25.44003) (cons -47.30403 116.52589) (cons -63.42303 152.88265)) - (list (cons -26.20045 46.22879) (cons -49.47611 94.20521) (cons -78.99673 138.48542)) - (list (cons 7.0596 9.34303) (cons 17.25993 5.68676) (cons 26.86192 4.2502)) - (list (cons 8.19842 -1.22826) (cons 16.39686 -2.4565) (cons 24.59528 -3.68475)) - (list (cons 26.44013 -62.68827) (cons 54.98797 -120.2314) (cons 79.79859 -183.59412)) - (list (cons 11.30581 -26.11293) (cons 16.82865 -40.47628) (cons 30.26123 -57.57618)) - (list (cons 15.92423 9.74246) (cons 20.66525 33.77224) (cons 29.3527 50.35199)) - (list (cons 25.60238 65.87977) (cons 51.09413 131.80228) (cons 75.25809 198.22074)) - (list (cons 6.32468 2.20244) (cons 12.81613 8.78314) (cons 18.81535 2.44056)) - (list (cons 15.78086 -9.73038) (cons 34.15342 -15.82488) (cons 47.2925 -29.27438)) - (list (cons -3.74907 -18.17899) (cons -15.79452 -35.18254) (cons -23.13261 -52.66524)) - (list (cons -46.51473 -92.95952) (cons -91.3634 -191.5622) (cons -120.47873 -291.65949)) - (list (cons -10.72309 -31.50493) (cons -23.92724 -69.469699) (cons -58.05359 -81.906439)) - (list (cons -7.7741 -2.308013) (cons -15.96612 -2.751575) (cons -24.03222 -2.750218)))) - -(define (lambda-path x y x-scale y-scale) - (define (scale-x x) (* x x-scale)) - (define (scale-y y) (* y y-scale)) - (define p (new dc-path%)) - (match-define (cons (app scale-x sx) (app scale-y sy)) lambda-start-point) - (send p move-to sx sy) - (for/fold ([lx sx] [ly sy]) ([pt (in-list lambda-control-points)]) - (match-define (list (cons (app scale-x x1) (app scale-y y1)) - (cons (app scale-x x2) (app scale-y y2)) - (cons (app scale-x x3) (app scale-y y3))) pt) - (send p curve-to (+ lx x1) (+ ly y1) (+ lx x2) (+ ly y2) (+ lx x3) (+ ly y3)) - (values (+ lx x3) (+ ly y3))) - (send p close) - p) +(define lambda-path-commands + '((m 97.5 10) + (c -12.267574371681416 0.22160039646017698 + -23.938206584070794 4.486409061946903 + -35.40358116814159 8.431642279646018 + 5.002013451327434 5.357118980530973 + 4.2474160707964606 7.049306166371681 + 6.430565946902655 6.642370378761062 + 8.354521486725664 -2.0234602477876105 + 20.745877522123894 -6.732496424778761 + 26.26655603539823 2.1904900530973452 + 12.036272707964603 15.204891185840708 + 17.140790371681415 34.66372757522124 + 18.964158300884954 53.635833203539825 + 2.3373978053097346 11.526810053097345 + -21.433330407079644 52.79757139823009 + -28.736806513274335 69.27072283185841 + -11.871354336283186 20.946142017699113 + -22.417494088495573 42.68413054867256 + -35.79320863716814 62.74737614159292 + 3.198686017699115 4.233302088495575 + 7.820428460176991 2.5766558584070793 + 12.171064637168142 1.925754336283186 + 3.714682336283186 -0.5565213451327433 + 7.429373734513274 -1.1130336283185842 + 11.14405607079646 -1.6695504424778762 + 11.979952707964602 -28.4038887079646 + 24.914903221238937 -54.476528141592915 + 36.156529274336286 -83.1860083539823 + 5.122632495575221 -11.831699256637167 + 7.625016637168141 -18.33969500884956 + 13.711282973451327 -26.087614300884955 + 7.215226336283186 4.414282761061947 + 9.363369911504424 15.302112283185838 + 13.299630442477875 22.814352991150443 + 11.600370407079646 29.849948884955747 + 23.150614654867255 59.71926315044247 + 34.09924077876106 89.81329104424779 + 2.8656957168141592 0.9979197168141594 + 5.806954477876106 3.9796174159292033 + 8.525185132743362 1.105811256637168 + 7.150265769911504 -4.4088093451327435 + 15.474823929203538 -7.170211115044248 + 21.428106194690265 -13.26414385840708 + -1.6986936637168142 -8.23685210619469 + -7.156455079646018 -15.941115469026549 + -10.48132417699115 -23.86248042477876 + -21.07570067256637 -42.11971171681416 + -41.39651398230088 -86.79632424778761 + -54.5885927079646 -132.15014060176992 + -4.858603610619468 -14.274800141592921 + -10.841368920353982 -31.4765361840708 + -26.303927504424777 -37.111590060176994 + -3.5224240707964602 -1.0457545628318583 + -7.2342065840707965 -1.2467313274336282 + -10.888935079646018 -1.2461164743362831))) (define (draw-lambda dc x y w h) - (send dc draw-path (lambda-path x y (/ w 565) (/ h 565)))) + (define-values (sx sy) (send dc get-scale)) + (draw-path-commands dc x y (scale-path-commands lambda-path-commands (/ w 240) (/ h 240))) + (send dc set-scale sx sy)) (define blue-θ-start (* -45 (/ pi 180))) (define blue-θ-end (* 110 (/ pi 180))) @@ -84,70 +108,205 @@ (unsafe-fl* g l) (unsafe-fl* b l))))) -(define (flomap-rough fm z-amt) - (match-define (flomap vs c w h) fm) - (unsafe-build-flomap - c w h - (λ (k x y) - (define i (unsafe-fx+ k (unsafe-fx* c (unsafe-fx+ x (unsafe-fx* w y))))) - (unsafe-fl+ (unsafe-fl* z-amt (exact->inexact (random))) - (unsafe-flvector-ref vs i))))) +(define (make-random-flomap c w h) + (unsafe-build-flomap c w h (λ (k x y) (random)))) -(define (plt-logo height) - (define scale (/ height 256)) - (define bulge-fm - (draw-flomap - height height - (λ (dc) - (send dc set-scale scale scale) - (send dc set-pen logo-red-color 2 'solid) - (send dc set-brush logo-red-color 'solid) - (send dc draw-path (make-arc-path 7 7 242 242 blue-θ-end blue-θ-start)) - (send dc set-pen logo-blue-color 2 'solid) - (send dc set-brush logo-blue-color 'solid) - (send dc draw-path (make-arc-path 7 7 242 242 blue-θ-start blue-θ-end)) - (send dc set-pen (lambda-pen lambda-outline-color 12)) - (send dc set-brush lambda-outline-color 'solid) - (draw-lambda dc 0 0 256 256)))) - - ;(flomap-add-sparkles! bulge-fm) - - (define (lambda-flomap color pen-width) - (draw-flomap - height height - (λ (dc) - (send dc set-scale scale scale) - (send dc set-pen (lambda-pen color pen-width)) - (send dc set-brush color 'solid) - (draw-lambda dc 0 0 256 256)))) - - (let* ([bulge-dfm (flomap->deep-flomap bulge-fm)] - [bulge-dfm (deep-flomap-bulge-spheroid bulge-dfm (* 116 scale))] - ;[bulge-dfm (deep-flomap-raise bulge-dfm (* 8 scale))] - ;[bulge-dfm (deep-flomap-smooth-z bulge-dfm (* 1/2 scale))] - #;[bulge-dfm (deep-flomap (deep-flomap-argb bulge-dfm) - (flomap-rough (deep-flomap-z bulge-dfm) 0.5))] - [lambda-dfm (flomap->deep-flomap (lambda-flomap "azure" 4))] - [lambda-dfm (deep-flomap-bulge-spheroid lambda-dfm (* 116 scale))] - [lambda-dfm (deep-flomap-smooth-z lambda-dfm (* 3 scale))] - [lambda-fm (deep-flomap-render-icon lambda-dfm metal-material)] - [fm (deep-flomap-render-icon bulge-dfm glass-logo-material)] - [fm (flomap-cc-superimpose - fm - (lambda-flomap lambda-outline-color 12) - lambda-fm)] - [fm (flomap-inset fm 16)] - [fm (flomap-cc-superimpose - fm - (draw-flomap - (inexact->exact (ceiling (* 1.015625 height))) - (inexact->exact (ceiling (* 1.015625 height))) - (λ (dc) - (send dc set-scale scale scale) - (send dc set-origin (* 2.5 scale) (* 2.5 scale)) - (send dc set-pen lambda-outline-color 4 'solid) - (send dc set-brush lambda-outline-color 'transparent) - (send dc draw-ellipse 0 0 256 256))))] - [fm (flomap-cc-superimpose (fm* 0.5 (flomap-shadow fm (* 4 scale))) fm)] - ) - (flomap->bitmap fm))) +(define (flomap-rough fm z-amt) + (match-define (flomap _ c w h) fm) + (fm+ fm (fm* z-amt (make-random-flomap c w h)))) + +(define (plt-flomap height) + (make-cached-flomap + [height] + (define scale (/ height 256)) + (define bulge-fm + (draw-icon-flomap + 256 256 (λ (dc) + (send dc set-pen logo-red-color 2 'transparent) + (send dc set-brush logo-red-color 'solid) + (send dc draw-path (make-arc-path 8 8 239 239 blue-θ-end blue-θ-start)) + (send dc set-pen logo-blue-color 2 'transparent) + (send dc set-brush logo-blue-color 'solid) + (send dc draw-path (make-arc-path 8 8 239 239 blue-θ-start blue-θ-end)) + (send dc set-pen (lambda-pen lambda-outline-color 10)) + (send dc set-brush lambda-outline-color 'solid) + (draw-lambda dc 8 8 240 240)) + scale)) + + ;(flomap-add-sparkles! bulge-fm) + + (define (lambda-flomap color pen-width) + (draw-icon-flomap + 256 256 (λ (dc) + (send dc set-scale scale scale) + (send dc set-pen (lambda-pen color pen-width)) + (send dc set-brush color 'solid) + (draw-lambda dc 8 8 240 240)) + scale)) + + (let* ([bulge-dfm (flomap->deep-flomap bulge-fm)] + [bulge-dfm (deep-flomap-bulge-spheroid bulge-dfm (* 112 scale))] + ;[bulge-dfm (deep-flomap-raise bulge-dfm (* 8 scale))] + ;[bulge-dfm (deep-flomap-smooth-z bulge-dfm (* 1/2 scale))] + #;[bulge-dfm (deep-flomap (deep-flomap-argb bulge-dfm) + (flomap-rough (deep-flomap-z bulge-dfm) 0.5))] + [lambda-dfm (flomap->deep-flomap (lambda-flomap "azure" 4))] + [lambda-dfm (deep-flomap-bulge-spheroid lambda-dfm (* 112 scale))] + [lambda-dfm (deep-flomap-smooth-z lambda-dfm (* 3 scale))] + [lambda-fm (deep-flomap-render-icon lambda-dfm metal-material)] + [fm (deep-flomap-render-icon bulge-dfm glass-logo-material)] + [fm (flomap-cc-superimpose + fm + (lambda-flomap lambda-outline-color 10) + lambda-fm)] + [fm (flomap-cc-superimpose + (draw-icon-flomap + 256 256 (λ (dc) + (send dc set-pen "lightblue" 2 'solid) + (send dc set-brush "white" 'transparent) + (send dc draw-ellipse 7 7 242 242) + (send dc set-pen lambda-outline-color 4 'solid) + (send dc draw-ellipse 2 2 252 252)) + scale) + fm)] + ) + fm))) + +(define plt-logo (compose flomap->bitmap plt-flomap)) + +(define continents-path-commands + '((m 11.526653 18.937779) + (c 0.05278 0.724075 1.940414 1.202607 0.678885 2.296248 + 0.249172 0.918181 1.040063 1.620575 1.448285 0.308034 + 1.219485 -0.885607 3.250882 -0.938443 3.317014 -2.906655 + -1.599965 -1.033954 -4.029479 -0.431148 -5.444184 0.302373) + (M 11.53125 18.125) + (C 10.786965 18.380649 9.3917452 18.611001 9.1304904 19.245707 + 10.289001 19.269837 11.178405 18.606302 11.53125 18.125) + (M 8.1875 19.65625) + (C 7.2652998 23.370888 8.6787734 19.63772 9.9124431 20.95891 + 10.727811 21.80382 11.739516 20.92275 10.465247 20.422456 + 9.7714766 19.980166 8.3964342 19.699414 8.1875 19.65625) + (M 7.5625 21.125) + (c -0.9196331 -1.962382 -3.205955 1.390782 -4.0978229 2.41995 + -1.707808 2.289408 -2.72190385 5.078558 -2.9334271 7.9238 + 1.0237952 1.983695 5.5272247 2.76676 4.7145431 4.084262 + -0.7368064 1.151552 -0.8906555 2.601652 0.1135446 3.680893 + 2.7495495 2.364498 1.2541019 5.824595 2.5609489 6.229519 + 2.5755284 0.853846 2.7512924 -3.696022 4.1297234 -3.843434 + 0.745066 -1.051147 0.04765 -2.428466 1.056101 -3.411232) + (C 12.318556 36.222109 8.8169859 35.479018 8.6188979 33.8253 + 7.7181807 34.141675 7.0679715 33.334232 6.30372 33.30415 + 5.7220663 34.646967 3.9378253 34.122031 4.3012403 32.699798 + 3.024533 33.043038 4.3605584 31.222879 3.40625 31.28125 + 0.5 33 2.5 26.5 5.0295875 29.903027 + 5.5 30.5 6.9002733 26.371666 8.8261905 25.876953 + 9.8027554 25.533149 9.5159021 24.727855 8.5279357 25.0625 + 7.6214946 24.941384 9.6975411 24.462771 10.075856 24.483273 + 11.540792 24.233047 9.904685 23.334106 9.8601011 22.602389 + 9.0900535 22.676405 9.4028275 22.737933 9.1185443 22.100147 + 6.8948741 22.58513 7.6831847 24.739145 5.9002404 23.244912 + 4.6247757 22.264239 7.321322 21.942832 7.5625 21.125) + (m 15.15625 -0.9375) + (c -1.37421 0.06218 -2.005432 1.159129 -2.784107 1.978327 + -0.114565 1.368674 0.952693 -0.07002 1.385771 0.968032 + 0.953881 -0.129572 -0.01507 -1.993413 1.425543 -2.008859 + -0.269351 0.525838 -0.494795 1.470731 0.411144 1.15174 + -0.646943 0.90275 -1.874871 2.045333 -2.613442 0.960703 + 0.08813 0.809648 -1.042388 0.509104 -1.186702 1.40851 + -0.738698 0.338761 -1.028513 0.375271 -0.383294 1.119927 + -1.340908 -0.226887 -1.979854 2.002883 -0.346874 1.903539 + 3.128783 -3.578714 2.7333 -0.07275 3.379252 -0.61531 + -0.408321 -3.069544 0.823059 1.69915 1.30948 -0.328623 + 0.476726 0.916648 1.583858 0.757279 2.129612 1.386838 + -2.140558 2.214946 -4.171988 -1.055384 -6.363065 -0.232922 + -2.486751 0.823935 -2.418258 3.347586 -3.103635 4.864439 + 0.687061 3.597921 3.669743 1.43585 5.132502 2.724104 + -0.344691 1.08929 0.484513 1.884668 0.473244 3.022942 + -0.01352 2.068761 0.378264 6.65826 1.845318 5.542497 + 1.472489 0.175399 1.430793 -1.740909 2.30904 -2.30502 + -1.36358 -1.181833 2.025569 -1.358588 0.887958 -2.838158 + -0.499809 -1.988948 1.367195 -3.177085 1.789594 -4.928946 + 0.579613 -0.960476 -1.588234 -0.05789 -0.373062 -1.023304 + 0.927113 -0.301781 2.379761 -2.07879 0.994298 -2.428506 + -0.676988 0.933612 -1.737597 -2.080985 -0.549773 -0.651497 + 0.699549 -0.419557 1.900516 1.563553 1.759683 -0.08984 + -0.608903 -3.386912 -2.4601 -6.520148 -5.090986 -8.736865 + -0.200722 0.802307 -1.230158 0.889683 -1.228926 0.0694 + 2.155263 -0.50116 -0.789058 -0.572123 -1.208573 -0.913148) + (M 17.09375 21) + (c -1.221276 0.05745 -0.44882 1.331427 0.232503 0.449916) + (C 17.458514 21.23484 17.234278 21.104353 17.09375 21) + (m -7.5 0.125) + (c -1.2040413 0.60218 1.459244 1.052142 0.289004 0.112253) + (m 8.96875 1.5) + (c 0.38412 0.655402 -0.236077 2.74213 1.030518 1.55154 + 0.0634 -0.524592 -0.59842 -1.401743 -1.030518 -1.55154) + (m -0.21875 0.75) + (c -1.155615 0.198578 0.509999 1.388302 0.06733 0.201634) + (M 10.5 24.53125) + (c -0.117519 1.313533 1.058399 0.642504 0 0))) + +(define water-logo-material + (deep-flomap-material-value + 'cubic-zirconia 1.0 0.7 1.0 + 0.25 0.15 1.0 + 0.15 0.1 0.2 + 0.0)) + +(define logo-under-continents-color "black") +(define logo-continents-color "azure") +(define logo-water-color "lightskyblue") +(define logo-earth-outline-color logo-red-color) + +(define (continents-flomap color height) + (define scale (/ height 32)) + (draw-icon-flomap + 32 32 (λ (dc) + (send dc set-pen lambda-outline-color 3/8 'solid) + (send dc set-brush color 'solid) + (draw-path-commands dc 0 -17 continents-path-commands)) + scale)) + +(define (planet-flomap height) + (make-cached-flomap + [height] + (define scale (/ height 32)) + (define-values (earth-fm earth-z) + (let* ([indent-fm (continents-flomap logo-red-color height)] + [indent-dfm (flomap->deep-flomap indent-fm)] + [indent-dfm (deep-flomap-raise indent-dfm (* -1/8 scale))] + [indent-dfm (deep-flomap-smooth-z indent-dfm (* 1 scale))] + [earth-fm (draw-icon-flomap + 32 32 (λ (dc) + (send dc set-pen logo-water-color 1/2 'solid) + (send dc set-brush logo-water-color 'solid) + (draw-ellipse/smoothed dc 0.75 0.75 30.5 30.5)) + scale)] + [earth-dfm (flomap->deep-flomap earth-fm)] + [earth-dfm (deep-flomap-bulge-spheroid earth-dfm (* 16 scale))] + [earth-dfm (deep-flomap-cc-superimpose earth-dfm indent-dfm #:z-mode 'add)]) + (values (deep-flomap-render-icon earth-dfm water-logo-material) + (deep-flomap-z earth-dfm)))) + + (define land-fm + (let* ([land-fm (continents-flomap logo-continents-color height)] + [land-dfm (flomap->deep-flomap land-fm)] + ;[land-dfm (deep-flomap-emboss land-dfm (* 2 scale) (* 8 scale))] + [land-dfm (deep-flomap-bulge-spheroid land-dfm (* 16 scale))] + [land-dfm (deep-flomap-smooth-z land-dfm (* 1/2 scale))]) + (deep-flomap-render-icon land-dfm metal-material))) + + (flomap-cc-superimpose + (draw-icon-flomap + 32 32 (λ (dc) + (send dc set-pen "lightblue" 1/2 'solid) + (send dc set-brush "white" 'transparent) + (send dc draw-ellipse 0.5 0.5 31 31) + (send dc set-pen lambda-outline-color 1/2 'solid) + (send dc draw-ellipse -0.25 -0.25 32.5 32.5)) + scale) + earth-fm + land-fm))) + +(define planet-logo (compose flomap->bitmap planet-flomap)) diff --git a/collects/images/private/transient-box.rkt b/collects/images/private/transient-box.rkt deleted file mode 100644 index 431917eb63..0000000000 --- a/collects/images/private/transient-box.rkt +++ /dev/null @@ -1,57 +0,0 @@ -#lang racket - -(require ffi/unsafe) - -(provide make-transient-box transient-box? - (rename-out [transient-box-value* transient-box-value]) - transient-box-touch!) - -(define (register-gc-callback f) - (define v (make-vector 0)) - (register-finalizer v (λ (x) (when (f) (register-gc-callback f))))) - -(struct transient-box (value counter max-counter touched?) #:mutable #:transparent) - -(struct no-value-struct ()) -(define no-value (no-value-struct)) - -(define (make-transient-box value) - (define bx (transient-box value 1 1 #f)) - (register-gc-callback - (λ () - (define cnt (transient-box-counter bx)) - (cond [(cnt . <= . 0) - (cond [(transient-box-touched? bx) - (define max-cnt (* 2 (transient-box-max-counter bx))) - (set-transient-box-counter! bx max-cnt) - (set-transient-box-max-counter! bx max-cnt) - (set-transient-box-touched?! bx #f) - #t] - [else - (set-transient-box-value! bx no-value) - #f])] - [else - (set-transient-box-counter! bx (- cnt 1)) - #t]))) - bx) - -(define (transient-box-value* bx [gced-value #f]) - (define value (transient-box-value bx)) - (if (eq? value no-value) gced-value value)) - -(define (transient-box-touch! bx) - (set-transient-box-touched?! bx #t)) - -#| -(define bx (make-transient-box (make-vector 0))) -(transient-box-value* bx) -bx -(collect-garbage) -bx -(transient-box-value* bx) -bx -(collect-garbage) -bx -(collect-garbage) -bx -|# diff --git a/collects/images/private/utils.rkt b/collects/images/private/utils.rkt index f73e0d2c74..48794567ec 100644 --- a/collects/images/private/utils.rkt +++ b/collects/images/private/utils.rkt @@ -1,9 +1,74 @@ #lang racket/base -(require racket/draw racket/class racket/match racket/list) +(require racket/draw racket/class racket/match racket/list ffi/unsafe + (for-syntax racket/base) + "flomap.rkt") (provide (all-defined-out)) +(define (register-gc-callback proc) + (define val (box 0)) + (register-finalizer val (λ (_) + (define again? (proc)) + (when again? (register-gc-callback proc))))) + +(define (weak-value-hash-clean! h) + (define ks (for*/list ([(k bx) (in-hash h)] + [val (in-value (weak-box-value bx))] + #:when (not val)) + k)) + (for ([k (in-list ks)]) (hash-remove! h k))) + +;(define total-time-saved 0) +;(define total-time-spent 0) + +;; Can't simply wrap hash-ref! with weak-box-value and thnk with make-weak-box, because +;; 1. If weak-box-value returns #f, we need to regenerate the value +;; 2. We need to keep a handle to the generated value while it's being stored in the hash +(define (weak-value-hash-ref! h k thnk) + (define (cache-ref!) + ;(define start (current-milliseconds)) + (define val (thnk)) + ;(define time (- (current-milliseconds) start)) + ;(set! total-time-spent (+ total-time-spent time)) + ;(printf "total-time-spent = ~v~n" total-time-spent) + (hash-set! h k (cons (make-weak-box val) 0)) + val) + (cond [(hash-has-key? h k) (define p (hash-ref h k)) + (define val (weak-box-value (car p))) + (cond [val ;(set! total-time-saved (+ total-time-saved (cdr p))) + ;(printf "total-time-saved = ~v~n" total-time-saved) + val] + [else (cache-ref!)])] + [else (cache-ref!)])) + +(define flomap-cache (make-hash)) + +(define (clean-flomap-cache!) + (weak-value-hash-clean! flomap-cache)) + +(register-gc-callback clean-flomap-cache!) + +(define (read-flomap-cache) + (for/list ([(k bx) (in-hash flomap-cache)]) + (cons k (weak-box-value bx)))) + +(define (make-cached-flomap* name proc size . args) + (define rendered-size + (cond [(size . < . 32) 32] + [else (expt 2 (inexact->exact (ceiling (/ (log size) (log 2)))))])) + (define fm (weak-value-hash-ref! flomap-cache (list name rendered-size args) + (λ () (apply proc rendered-size args)))) + (flomap-scale fm (/ size rendered-size))) + +(define-syntax (make-cached-flomap stx) + (syntax-case stx () + [(_ (size args ...) expr0 expr ...) + (with-syntax ([(name) (generate-temporaries #'(make-cached-flomap))]) + (syntax/loc stx + (make-cached-flomap* 'name (λ (size args ...) expr0 expr ...) size args ...)))])) + + (define (draw-ellipse/smoothed dc x y w h) (define pen (send dc get-pen)) (define brush (send dc get-brush)) @@ -25,22 +90,22 @@ [`(M) (loop x y (rest cmds))] [`(L) (loop x y (rest cmds))] [`(C) (loop x y (rest cmds))] - [`(M (,ax . ,ay) ,as ...) (send p move-to ax ay) - (loop ax ay (cons `(M ,@as) (rest cmds)))] - [`(L (,ax . ,ay) ,as ...) (send p line-to ax ay) - (loop ax ay (cons `(L ,@as) (rest cmds)))] - [`(C (,ax1 . ,ay1) (,ax2 . ,ay2) (,ax . ,ay) ,as ...) + [`(M ,ax ,ay ,as ...) (send p move-to ax ay) + (loop ax ay (cons `(M ,@as) (rest cmds)))] + [`(L ,ax ,ay ,as ...) (send p line-to ax ay) + (loop ax ay (cons `(L ,@as) (rest cmds)))] + [`(C ,ax1 ,ay1 ,ax2 ,ay2 ,ax ,ay ,as ...) (send p curve-to ax1 ay1 ax2 ay2 ax ay) (loop ax ay (cons `(C ,@as) (rest cmds)))] ;; relative commands [`(m) (loop x y (rest cmds))] [`(l) (loop x y (rest cmds))] [`(c) (loop x y (rest cmds))] - [`(m (,dx . ,dy) ,ds ...) (send p move-to (+ x dx) (+ y dy)) - (loop (+ x dx) (+ y dy) (cons `(m ,@ds) (rest cmds)))] - [`(l (,dx . ,dy) ,ds ...) (send p line-to (+ x dx) (+ y dy)) - (loop (+ x dx) (+ y dy) (cons `(l ,@ds) (rest cmds)))] - [`(c (,dx1 . ,dy1) (,dx2 . ,dy2) (,dx . ,dy) ,ds ...) + [`(m ,dx ,dy ,ds ...) (send p move-to (+ x dx) (+ y dy)) + (loop (+ x dx) (+ y dy) (cons `(m ,@ds) (rest cmds)))] + [`(l ,dx ,dy ,ds ...) (send p line-to (+ x dx) (+ y dy)) + (loop (+ x dx) (+ y dy) (cons `(l ,@ds) (rest cmds)))] + [`(c ,dx1 ,dy1 ,dx2 ,dy2 ,dx ,dy ,ds ...) (send p curve-to (+ dx1 x) (+ dy1 y) (+ dx2 x) (+ dy2 y) (+ dx x) (+ dy y)) (loop (+ x dx) (+ y dy) (cons `(c ,@ds) (rest cmds)))] [_ (error 'apply-path-commands "unknown path command ~e" cmd)])])) @@ -48,8 +113,27 @@ (define (draw-path-commands dc x y cmds) (define p (new dc-path%)) - (apply-path-commands p (cons `(M (,x . ,y)) cmds)) - (send dc draw-path p)) + (apply-path-commands p cmds) + (define t (send dc get-transformation)) + (send dc translate x y) + (send dc draw-path p) + (send dc set-transformation t)) + +(define (list->pairs lst) + (match lst + [(list x y xs ...) (cons (cons x y) (list->pairs xs))] + [(list) (list)])) + +(define (scale-path-commands cmds sx sy) + (match cmds + [(list `(,sym ,xys ...) cmds ...) + (cons + `(,sym ,@(flatten (map (λ (xy) + (match-define (cons x y) xy) + (list (* x sx) (* y sy))) + (list->pairs xys)))) + (scale-path-commands cmds sx sy))] + [(list) (list)])) (define (get-text-size str font) (define bm (make-bitmap 1 1))