Caching with weak boxes, cleanup, planet download icon
This commit is contained in:
Neil Toronto
parent
dc2aa3ea5c
commit
6ec78137e3
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))])))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|#
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user