suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Caching with weak boxes, cleanup, planet download icon

Browse Source
This commit is contained in:
Neil Toronto 2012-01-08 23:13:37 -07:00
parent dc2aa3ea5c
commit 6ec78137e3
11 changed files with 864 additions and 691 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/drracket/private/debug.rkt
View File

@ -26,7 +26,7 @@ profile todo:
net/url net/url
racket/match racket/match
mrlib/include-bitmap 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)) (for-syntax racket/base))
(define orig (current-output-port)) (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 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 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)) (define planet-note% (make-note% "small-planet.png" small-planet-bitmap))
;; display-stats : (syntax -> syntax) ;; display-stats : (syntax -> syntax)

10
collects/drracket/private/unit.rkt
View File

@ -38,7 +38,8 @@ module browser threading seems wrong.
"local-member-names.rkt" "local-member-names.rkt"
"eval-helpers.rkt" "eval-helpers.rkt"
(prefix-in drracket:arrow: "../arrow.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 mred
(prefix-in mred: mred) (prefix-in mred: mred)
@ -385,11 +386,12 @@ module browser threading seems wrong.
frame frame
program-filename)))]))) 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 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 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))) (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))) (icons:toolbar-icon-height)))
(define-values (get-program-editor-mixin add-to-program-editor-mixin) (define-values (get-program-editor-mixin add-to-program-editor-mixin)
@ -4696,7 +4698,7 @@ module browser threading seems wrong.
[(null? l) '()] [(null? l) '()]
[else (cons (car l) (loop (cdr l) (- n 1)))]))) [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-window #f)
(define saved-bug-reports-panel #f) (define saved-bug-reports-panel #f)

76
collects/images/icons/arrow.rkt
View File

@ -8,7 +8,7 @@
(provide (all-defined-out)) (provide (all-defined-out))
(define (right-arrow-flomap color height) (define (flat-right-arrow-flomap color height)
(draw-icon-flomap (draw-icon-flomap
32 32 (λ (dc) 32 32 (λ (dc)
(send dc set-brush color 'solid) (send dc set-brush color 'solid)
@ -17,15 +17,16 @@
'(14 . 31) '(15 . 22) '(0 . 22)))) '(14 . 31) '(15 . 22) '(0 . 22))))
(/ height 32))) (/ height 32)))
(define (right-over-arrow-flomap color height) (define (flat-right-over-arrow-flomap color height)
(draw-icon-flomap (draw-icon-flomap
32 32 (λ (dc) 32 32 (λ (dc)
(send dc set-brush color 'solid) (send dc set-brush color 'solid)
(draw-path-commands (draw-path-commands
dc 0 15 '((c (9 . -14) (19.5 . -8) (24 . -2)) dc 0 0 '((m 0 15)
(l (5 . -7) (2 . 20) (-20 . -2) (7 . -5)) (c 9 -14 19.5 -8 24 -2)
(c (-2.5 . -4) (-8 . -8.5) (-14 . 0)) (l 5 -7 2 20 -20 -2 7 -5)
(l (-4 . -4))))) (c -2.5 -4 -8 -8.5 -14 0)
(l -4 -4))))
(/ height 32))) (/ height 32)))
(define (flomap-render-short-icon fm material) (define (flomap-render-short-icon fm material)
@ -37,37 +38,46 @@
dfm)) dfm))
(deep-flomap-render-icon dfm material)) (deep-flomap-render-icon dfm material))
(define (right-arrow-icon-flomap* color height material) (define (right-arrow-flomap color [height (default-icon-height)] [material (default-icon-material)])
(flomap-render-short-icon (right-arrow-flomap color height) 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) (define (up-arrow-flomap color [height (default-icon-height)] [material (default-icon-material)])
(flomap-render-icon (flomap-cw-rotate (right-arrow-flomap color height)) 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) (define (down-arrow-flomap color [height (default-icon-height)] [material (default-icon-material)])
(flomap-render-icon (flomap-ccw-rotate (right-arrow-flomap color height)) 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) (define (right-over-arrow-flomap color
(flomap-render-short-icon (right-over-arrow-flomap color height) material)) [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) (define (right-under-arrow-flomap color
(flomap-render-short-icon (flomap-flip-vertical (right-over-arrow-flomap color height)) material)) [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 left-arrow-flomap (compose flomap-flip-horizontal right-arrow-flomap))
(define-icon-flomap-proc up-arrow-icon-flomap up-arrow-icon-flomap* 32 color) (define left-over-arrow-flomap (compose flomap-flip-horizontal right-over-arrow-flomap))
(define-icon-flomap-proc down-arrow-icon-flomap down-arrow-icon-flomap* 32 color) (define left-under-arrow-flomap (compose flomap-flip-horizontal right-under-arrow-flomap))
(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-icon-flomap (compose flomap-flip-horizontal right-arrow-icon-flomap)) (define right-arrow-icon (compose flomap->bitmap right-arrow-flomap))
(define left-over-arrow-icon-flomap (compose flomap-flip-horizontal right-over-arrow-icon-flomap)) (define left-arrow-icon (compose flomap->bitmap left-arrow-flomap))
(define left-under-arrow-icon-flomap (compose flomap-flip-horizontal right-under-arrow-icon-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 right-over-arrow-icon (compose flomap->bitmap right-over-arrow-flomap))
(define left-arrow-icon (compose flomap->bitmap left-arrow-icon-flomap)) (define left-over-arrow-icon (compose flomap->bitmap left-over-arrow-flomap))
(define up-arrow-icon (compose flomap->bitmap up-arrow-icon-flomap)) (define right-under-arrow-icon (compose flomap->bitmap right-under-arrow-flomap))
(define down-arrow-icon (compose flomap->bitmap down-arrow-icon-flomap)) (define left-under-arrow-icon (compose flomap->bitmap left-under-arrow-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))

117
collects/images/icons/control.rkt
View File

@ -1,23 +1,32 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/serialize web-server/lang/serial-lambda
"../private/flomap.rkt" "../private/flomap.rkt"
"../private/utils.rkt" "../private/utils.rkt"
"style.rkt") "style.rkt")
(provide (all-defined-out)) (provide (all-defined-out))
(define (play-flomap color height) (define play-points
(draw-icon-flomap (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) 24 32 (λ (dc)
(send dc set-brush color 'solid) (send dc set-brush color 'solid)
(send dc draw-polygon (list '(0 . 0) '(4 . 0) (send dc draw-polygon play-points))
'(23 . 13) '(23 . 18) (/ height 32)
'(4 . 31) '(0 . 31)))) material)))
(/ height 32)))
(define (fast-forward-flomap color height) (define (fast-forward-flomap color [height (default-icon-height)] [material (default-icon-material)])
(draw-icon-flomap (make-cached-flomap
[height color material]
(draw-rendered-icon-flomap
32 32 (λ (dc) 32 32 (λ (dc)
(send dc set-brush color 'solid) (send dc set-brush color 'solid)
(send dc draw-polygon (list '(0 . 0) '(4 . 0) (send dc draw-polygon (list '(0 . 0) '(4 . 0)
@ -33,91 +42,85 @@
'(8 . 29) '(8 . 29)
'(18 . 19) '(18 . 12) '(18 . 19) '(18 . 12)
'(8 . 2)))) '(8 . 2))))
(/ height 32))) (/ height 32)
material)))
(define (play-icon-flomap* color height material) (define (stop-flomap color [height (default-icon-height)] [material (default-icon-material)])
(flomap-render-icon (play-flomap color height) material)) (make-cached-flomap
[height color 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 (draw-rendered-icon-flomap
32 32 (λ (dc) 32 32 (λ (dc)
(send dc set-brush color 'solid) (send dc set-brush color 'solid)
(send dc draw-polygon (list '(0 . 0) '(31 . 0) '(31 . 31) '(0 . 31)))) (send dc draw-polygon (list '(0 . 0) '(31 . 0) '(31 . 31) '(0 . 31))))
(/ height 32) (/ height 32)
material)) material)))
(define (record-icon-flomap* color height material) (define (record-flomap color [height (default-icon-height)] [material (default-icon-material)])
(make-cached-flomap
[height color material]
(draw-rendered-icon-flomap (draw-rendered-icon-flomap
32 32 (λ (dc) 32 32 (λ (dc)
(send dc set-brush color 'solid) (send dc set-brush color 'solid)
(draw-ellipse/smoothed dc 0 0 32 32)) (draw-ellipse/smoothed dc 0 0 32 32))
(/ height 32) (/ height 32)
material)) material)))
(define (bar-icon-flomap* color height material) (define (bar-flomap color height material)
(make-cached-flomap
[height color material]
(draw-rendered-icon-flomap (draw-rendered-icon-flomap
8 32 (λ (dc) 8 32 (λ (dc)
(send dc set-brush color 'solid) (send dc set-brush color 'solid)
(send dc draw-polygon (list '(0 . 0) '(7 . 0) '(7 . 31) '(0 . 31)))) (send dc draw-polygon (list '(0 . 0) '(7 . 0) '(7 . 31) '(0 . 31))))
(/ height 32) (/ height 32)
material)) material)))
(define-icon-flomap-proc play-icon-flomap play-icon-flomap* 32 color) (define back-flomap (compose flomap-flip-horizontal play-flomap))
(define-icon-flomap-proc fast-forward-icon-flomap fast-forward-icon-flomap* 32 color) (define reverse-flomap (compose flomap-flip-horizontal fast-forward-flomap))
(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 (pause-flomap color [height (default-icon-height)] [material (default-icon-material)])
(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)])
(flomap-hc-append (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) (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)]) [material (default-icon-material)])
(flomap-hc-append (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) (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)]) [material (default-icon-material)])
(flomap-hc-append (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) (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)]) [material (default-icon-material)])
(flomap-hc-append (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) (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)]) [material (default-icon-material)])
(flomap-hc-append (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) (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 play-icon (compose flomap->bitmap play-flomap))
(define back-icon (compose flomap->bitmap back-icon-flomap)) (define back-icon (compose flomap->bitmap back-flomap))
(define fast-forward-icon (compose flomap->bitmap fast-forward-icon-flomap)) (define fast-forward-icon (compose flomap->bitmap fast-forward-flomap))
(define reverse-icon (compose flomap->bitmap reverse-icon-flomap)) (define reverse-icon (compose flomap->bitmap reverse-flomap))
(define bar-icon (compose flomap->bitmap bar-icon-flomap)) (define bar-icon (compose flomap->bitmap bar-flomap))
(define stop-icon (compose flomap->bitmap stop-icon-flomap)) (define stop-icon (compose flomap->bitmap stop-flomap))
(define record-icon (compose flomap->bitmap record-icon-flomap)) (define record-icon (compose flomap->bitmap record-flomap))
(define pause-icon (compose flomap->bitmap pause-icon-flomap)) (define pause-icon (compose flomap->bitmap pause-flomap))
(define step-icon (compose flomap->bitmap step-icon-flomap)) (define step-icon (compose flomap->bitmap step-flomap))
(define step-back-icon (compose flomap->bitmap step-back-icon-flomap)) (define step-back-icon (compose flomap->bitmap step-back-flomap))
(define continue-icon (compose flomap->bitmap continue-icon-flomap)) (define continue-icon (compose flomap->bitmap continue-flomap))
(define continue-back-icon (compose flomap->bitmap continue-back-icon-flomap)) (define continue-back-icon (compose flomap->bitmap continue-back-flomap))

47
collects/images/icons/file.rkt
View File

@ -4,12 +4,15 @@
"../private/flomap.rkt" "../private/flomap.rkt"
"../private/deep-flomap.rkt" "../private/deep-flomap.rkt"
"../private/renderfx.rkt" "../private/renderfx.rkt"
"../private/utils.rkt"
"arrow.rkt" "arrow.rkt"
"style.rkt") "style.rkt")
(provide (all-defined-out)) (provide (all-defined-out))
(define (floppy-disk-icon-flomap* color height material) (define (floppy-disk-flomap color [height (default-icon-height)] [material (default-icon-material)])
(make-cached-flomap
[height color material]
(define scale (/ height 32)) (define scale (/ height 32))
(define metal-fm (define metal-fm
@ -92,36 +95,38 @@
(let* ([fm (flomap-cb-superimpose disk-fm metal-fm)] (let* ([fm (flomap-cb-superimpose disk-fm metal-fm)]
[fm (flomap-ct-superimpose fm label-fm)]) [fm (flomap-ct-superimpose fm label-fm)])
fm)) fm)))
(define-icon-flomap-proc floppy-disk-icon-flomap floppy-disk-icon-flomap* 32 color) (define (save-flomap arrow-color color
[height (default-icon-height)]
(define (save-icon-flomap arrow-color color [height (default-icon-height)]
[material (default-icon-material)]) [material (default-icon-material)])
(flomap-hc-append (right-arrow-icon-flomap arrow-color (* 3/4 height) 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) (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)] (define (load-flomap arrow-color color
[height (default-icon-height)]
[material (default-icon-material)]) [material (default-icon-material)])
(flomap-hc-append (floppy-disk-icon-flomap color height material) (flomap-hc-append (floppy-disk-flomap color height material)
(make-flomap 4 (max 1 (inexact->exact (round (* 1/16 height)))) 0) (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)] (define (small-save-flomap arrow-color color
[height (default-icon-height)]
[material (default-icon-material)]) [material (default-icon-material)])
(flomap-pin* 0 0 11/16 0 (flomap-pin* 0 0 11/16 0
(floppy-disk-icon-flomap color height material) (floppy-disk-flomap color height material)
(right-arrow-icon-flomap arrow-color (* 3/4 height) material))) (right-arrow-flomap arrow-color (* 3/4 height) material)))
(define (small-load-icon-flomap arrow-color color [height (default-icon-height)] (define (small-load-flomap arrow-color color
[height (default-icon-height)]
[material (default-icon-material)]) [material (default-icon-material)])
(flomap-pin* 1 1 5/16 1 (flomap-pin* 1 1 5/16 1
(floppy-disk-icon-flomap color height material) (floppy-disk-flomap color height material)
(right-arrow-icon-flomap arrow-color (* 3/4 height) material))) (right-arrow-flomap arrow-color (* 3/4 height) material)))
(define floppy-disk-icon (compose flomap->bitmap floppy-disk-icon-flomap)) (define floppy-disk-icon (compose flomap->bitmap floppy-disk-flomap))
(define save-icon (compose flomap->bitmap save-icon-flomap)) (define save-icon (compose flomap->bitmap save-flomap))
(define load-icon (compose flomap->bitmap load-icon-flomap)) (define load-icon (compose flomap->bitmap load-flomap))
(define small-save-icon (compose flomap->bitmap small-save-icon-flomap)) (define small-save-icon (compose flomap->bitmap small-save-flomap))
(define small-load-icon (compose flomap->bitmap small-load-icon-flomap)) (define small-load-icon (compose flomap->bitmap small-load-flomap))

156
collects/images/icons/misc.rkt
View File

@ -12,7 +12,7 @@
;; =================================================================================================== ;; ===================================================================================================
;; Unrendered flomaps ;; Unrendered flomaps
(define (x-flomap color height) (define (flat-x-flomap color height)
(define mn 7.5) (define mn 7.5)
(define mx 23.5) (define mx 23.5)
(draw-icon-flomap (draw-icon-flomap
@ -25,18 +25,19 @@
(send dc draw-line mn mx mx mn)) (send dc draw-line mn mx mx mn))
(/ height 32))) (/ height 32)))
(define (check-flomap color height) (define (flat-check-flomap color height)
(draw-icon-flomap (draw-icon-flomap
32 32 (λ (dc) 32 32 (λ (dc)
(send dc set-brush color 'solid) (send dc set-brush color 'solid)
(draw-path-commands (draw-path-commands
dc 0 19 '((c (0 . 0) (7 . 4) (14 . 12) (5.5 . -13.5) (17 . -23) (17 . -23)) dc 0 0 '((m 0 19)
(l (-9 . -8)) (c 0 0 7 4 14 12 5.5 -13.5 17 -23 17 -23)
(c (0 . 0) (-6.5 . 7.5) (-9.5 . 16) (-2.5 . -4) (-6 . -6.5) (-6 . -6.5)) (l -9 -8)
(l (-6 . 9))))) (c 0 0 -6.5 7.5 -9.5 16 -2.5 -4 -6 -6.5 -6 -6.5)
(l -6 9))))
(/ height 32))) (/ height 32)))
(define (regular-polygon-flomap sides start color size) (define (flat-regular-polygon-flomap sides start color size)
(draw-icon-flomap (draw-icon-flomap
32 32 (λ (dc) 32 32 (λ (dc)
(send dc set-brush color 'solid) (send dc set-brush color 'solid)
@ -52,12 +53,16 @@
;; =================================================================================================== ;; ===================================================================================================
;; Rendered flomaps ;; 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 family (send font get-family))
(define style (send font get-style)) (define style (send font get-style))
(define weight (send font get-weight)) (define weight (send font get-weight))
(define underline? (send font get-underlined)) (define underline? (send font get-underlined))
(define smoothing (send font get-smoothing)) (define smoothing (send font get-smoothing))
(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))) (let ([font (make-object font% (min 255 (inexact->exact (ceiling height)))
family style weight underline? smoothing #t)]) family style weight underline? smoothing #t)])
(define-values (w h) (get-text-size str font)) (define-values (w h) (get-text-size str font))
@ -74,31 +79,41 @@
[fm (flomap-inset fm ceiling-amt)] [fm (flomap-inset fm ceiling-amt)]
[fm (if outline? (flomap-outlined fm outline-amt) fm)]) [fm (if outline? (flomap-outlined fm outline-amt) fm)])
fm)) fm))
(flomap-render-icon fm material))) (flomap-render-icon fm material))))
(define (x-icon-flomap* color height material) (define (x-flomap color [height (default-icon-height)] [material (default-icon-material)])
(make-cached-flomap
[height color material]
(define scale (/ height 32)) (define scale (/ height 32))
(let* ([fm (x-flomap color height)] (let* ([fm (flat-x-flomap color height)]
[dfm (flomap->deep-flomap fm)] [dfm (flomap->deep-flomap fm)]
[dfm (deep-flomap-icon-style dfm)] [dfm (deep-flomap-icon-style dfm)]
[dfm (deep-flomap-raise dfm (* -8 scale))]) [dfm (deep-flomap-raise dfm (* -8 scale))])
(deep-flomap-render-icon dfm material))) (deep-flomap-render-icon dfm material))))
(define (check-icon-flomap* color height material) (define (check-flomap color [height (default-icon-height)] [material (default-icon-material)])
(make-cached-flomap
[height color material]
(define scale (/ height 32)) (define scale (/ height 32))
(let* ([fm (check-flomap color height)] (let* ([fm (flat-check-flomap color height)]
[dfm (flomap->deep-flomap fm)] [dfm (flomap->deep-flomap fm)]
[dfm (deep-flomap-icon-style dfm)] [dfm (deep-flomap-icon-style dfm)]
[dfm (deep-flomap-raise dfm (* -12 scale))]) [dfm (deep-flomap-raise dfm (* -12 scale))])
(deep-flomap-render-icon dfm material))) (deep-flomap-render-icon dfm material))))
(define (regular-polygon-icon-flomap* sides start color height material) (define (regular-polygon-flomap sides start color
(flomap-render-icon (regular-polygon-flomap sides start color height) material)) [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) (define (octagon-flomap color [height (default-icon-height)] [material (default-icon-material)])
(regular-polygon-icon-flomap* 8 (/ (* 2 pi) 16) color height material)) (regular-polygon-flomap 8 (/ (* 2 pi) 16) color height material))
(define (stop-sign-icon-flomap* color height material) (define (stop-sign-flomap color [height (default-icon-height)] [material (default-icon-material)])
(make-cached-flomap
[height color material]
(define scale (/ height 32)) (define scale (/ height 32))
(let* ([indent-fm (fm* 0.5 (x-flomap "black" (* 22 scale)))] (let* ([indent-fm (fm* 0.5 (x-flomap "black" (* 22 scale)))]
[indent-dfm (deep-flomap-raise (flomap->deep-flomap indent-fm) (* -2 scale))] [indent-dfm (deep-flomap-raise (flomap->deep-flomap indent-fm) (* -2 scale))]
@ -107,9 +122,7 @@
[dfm (deep-flomap-cc-superimpose dfm indent-dfm #:z-mode 'add)] [dfm (deep-flomap-cc-superimpose dfm indent-dfm #:z-mode 'add)]
[dfm (deep-flomap-icon-style dfm)] [dfm (deep-flomap-icon-style dfm)]
[fm (deep-flomap-render-icon dfm material)]) [fm (deep-flomap-render-icon dfm material)])
(flomap-cc-superimpose (flomap-cc-superimpose fm (x-flomap "azure" (* 22 scale) metal-material)))))
fm
(x-icon-flomap* "azure" (* 22 scale) metal-material))))
;; --------------------------------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------------------------------
;; Magnifying glass ;; Magnifying glass
@ -127,7 +140,12 @@
0.8 0.1 0.2 0.8 0.1 0.2
0.2 0.8 0.0 0.2 0.8 0.0
0.0)) 0.0))
(define (magnifying-glass-icon-flomap* metal-color handle-color height material)
(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 scale (/ height 32))
(define glass-fm (define glass-fm
(let* ([fm (draw-icon-flomap (let* ([fm (draw-icon-flomap
@ -188,17 +206,29 @@
(flomap-pin* 0 0 21/28 21/28 (flomap-pin* 0 0 21/28 21/28
handle-fm handle-fm
(flomap-pin* 1/2 1/2 1/2 1/2 circle-fm glass-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) ;; ---------------------------------------------------------------------------------------------------
;; Bomb
(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 scale (/ height 32))
(define fuse-fm (define fuse-fm
(let* ([fm (draw-icon-flomap (let* ([fm (draw-icon-flomap
16 16 (λ (dc) 16 16 (λ (dc)
(send dc set-pen "black" 5 'solid) (send dc set-pen "black" 1/2 'solid)
(draw-path-commands dc 5.5 5.5 '((c (0 . -1) (-2.5 . -4) (-3 . -2.5)))) (send dc set-brush "gold" 'solid)
(send dc set-pen "orange" 4 'solid) (draw-path-commands
(draw-path-commands dc 5.5 5.5 '((c (0 . -1) (-2.5 . -4) (-3 . -2.5))))) 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)] scale)]
[dfm (flomap->deep-flomap fm)] [dfm (flomap->deep-flomap fm)]
[dfm (deep-flomap-icon-style dfm)] [dfm (deep-flomap-icon-style dfm)]
@ -210,13 +240,13 @@
20 20 (λ (dc) 20 20 (λ (dc)
(send dc set-pen "black" 1 'solid) (send dc set-pen "black" 1 'solid)
(send dc set-brush color 'solid) (send dc set-brush color 'solid)
(draw-path-commands (draw-path-commands dc 0 0 '((m 1.5 11.5)
dc 1 11 '((l (10 . -10) (3 . 3)) (l 10 -10 2.5 2.5)
(c (4 . 5) (-5 . 14) (-10 . 10)) (c 4 5 -5 14 -10 10)
(l (-3 . -3)))) (l -2.5 -2.5)))
(draw-path-commands (draw-path-commands dc 0 0 '((m 1.5 11.5)
dc 1 11 '((c (-2 . -5) (5 . -12) (10 . -10) (c -2 -5 5 -12 10 -10
(4 . 5) (-5 . 14) (-10 . 10))))) 4 5 -5 14 -10 10))))
scale)) scale))
(define cap-fm (define cap-fm
@ -227,53 +257,41 @@
(define sphere-fm (define sphere-fm
(let* ([sphere-fm (draw-icon-flomap (let* ([sphere-fm (draw-icon-flomap
32 32 (λ (dc) 30 30 (λ (dc)
(send dc set-brush bomb-color 'solid) (send dc set-brush bomb-color 'solid)
(draw-ellipse/smoothed dc 0 0 32 32)) (draw-ellipse/smoothed dc 0 0 30 30))
scale)] scale)]
[cap-fm (bomb-cap-flomap cap-color)] [cap-fm (bomb-cap-flomap cap-color)]
[cap-dfm (flomap->deep-flomap cap-fm)] [cap-dfm (flomap->deep-flomap cap-fm)]
[cap-dfm (deep-flomap-raise cap-dfm (* -2 scale))] [cap-dfm (deep-flomap-raise cap-dfm (* -2 scale))]
[cap-dfm (deep-flomap-smooth-z cap-dfm (* 1 scale))] [cap-dfm (deep-flomap-smooth-z cap-dfm (* 1 scale))]
[sphere-dfm (flomap->deep-flomap sphere-fm)] [sphere-dfm (flomap->deep-flomap sphere-fm)]
[sphere-dfm (deep-flomap-bulge-spheroid sphere-dfm (* 16 scale))] [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)] [sphere-dfm (deep-flomap-lt-superimpose sphere-dfm cap-dfm #:z-mode 'add)]
) )
(deep-flomap-render-icon sphere-dfm material))) (deep-flomap-render-icon sphere-dfm material)))
(flomap-lt-superimpose sphere-fm cap-fm fuse-fm)) (flomap-lt-superimpose sphere-fm cap-fm fuse-fm)))
(define-icon-flomap-proc text-icon-flomap text-icon-flomap* 32 str font color trim? outline?) (define (stop-signs-flomap color [height (default-icon-height)] [material (default-icon-material)])
(define-icon-flomap-proc regular-polygon-icon-flomap regular-polygon-icon-flomap* 32 color) (define fm (stop-sign-flomap color (* height 2/3) material))
(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)
(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))
(flomap-pin* 3/16 1/4 0 0 (flomap-pin* 3/16 1/4 0 0
fm (flomap-pin* 3/16 1/4 0 0 fm fm))) fm (flomap-pin* 3/16 1/4 0 0 fm fm)))
(define left-magnifying-glass-icon-flomap (define left-magnifying-glass-flomap (compose flomap-flip-horizontal magnifying-glass-flomap))
(compose flomap-flip-horizontal magnifying-glass-icon-flomap)) (define bomb-flomap (compose flomap-flip-horizontal left-bomb-flomap))
(define bomb-icon-flomap (compose flomap-flip-horizontal left-bomb-icon-flomap))
;; =================================================================================================== ;; ===================================================================================================
;; Bitmaps (icons) ;; Bitmaps (icons)
(define text-icon (compose flomap->bitmap text-icon-flomap)) (define text-icon (compose flomap->bitmap text-flomap))
(define regular-polygon-icon (compose flomap->bitmap regular-polygon-icon-flomap)) (define regular-polygon-icon (compose flomap->bitmap regular-polygon-flomap))
(define octagon-icon (compose flomap->bitmap octagon-icon-flomap)) (define octagon-icon (compose flomap->bitmap octagon-flomap))
(define x-icon (compose flomap->bitmap x-icon-flomap)) (define x-icon (compose flomap->bitmap x-flomap))
(define stop-sign-icon (compose flomap->bitmap stop-sign-icon-flomap)) (define stop-sign-icon (compose flomap->bitmap stop-sign-flomap))
(define stop-signs-icon (compose flomap->bitmap stop-signs-icon-flomap)) (define stop-signs-icon (compose flomap->bitmap stop-signs-flomap))
(define check-icon (compose flomap->bitmap check-icon-flomap)) (define check-icon (compose flomap->bitmap check-flomap))
(define magnifying-glass-icon (compose flomap->bitmap magnifying-glass-icon-flomap)) (define magnifying-glass-icon (compose flomap->bitmap magnifying-glass-flomap))
(define left-magnifying-glass-icon (compose flomap->bitmap left-magnifying-glass-icon-flomap)) (define left-magnifying-glass-icon (compose flomap->bitmap left-magnifying-glass-flomap))
(define bomb-icon (compose flomap->bitmap bomb-icon-flomap)) (define bomb-icon (compose flomap->bitmap bomb-flomap))
(define left-bomb-icon (compose flomap->bitmap left-bomb-icon-flomap)) (define left-bomb-icon (compose flomap->bitmap left-bomb-flomap))

52
collects/images/icons/style.rkt
View File

@ -3,8 +3,7 @@
(require racket/draw unstable/parameter-group (require racket/draw unstable/parameter-group
"../private/flomap.rkt" "../private/flomap.rkt"
"../private/deep-flomap.rkt" "../private/deep-flomap.rkt"
"../private/renderfx.rkt" "../private/renderfx.rkt")
"../private/transient-box.rkt")
(provide (all-defined-out)) (provide (all-defined-out))
@ -31,7 +30,7 @@
(define metal-icon-color "lightsteelblue") (define metal-icon-color "lightsteelblue")
(define dark-metal-icon-color "steelblue") (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 halt-icon-color (make-object color% 255 32 24))
(define run-icon-color "lawngreen") (define run-icon-color "lawngreen")
@ -72,50 +71,3 @@
(let* ([fm (draw-icon-flomap w h draw-proc scale)] (let* ([fm (draw-icon-flomap w h draw-proc scale)]
[fm (flomap-render-icon fm material)]) [fm (flomap-render-icon fm material)])
fm)) 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)))])))))

65
collects/images/icons/tool.rkt
View File

@ -11,53 +11,50 @@
(provide (all-defined-out)) (provide (all-defined-out))
(define (check-syntax-icon-flomap [height (toolbar-icon-height)] (define debugger-bomb-color (make-object color% 128 64 64))
[material (default-icon-material)]) (define macro-stepper-hash-color (make-object color% 30 96 30))
(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 (small-check-syntax-icon-flomap [height (toolbar-icon-height)] (define (check-syntax-flomap [height (toolbar-icon-height)] [material (default-icon-material)])
[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* (flomap-pin*
1 1 5/16 1 1 1 5/16 1
(check-icon-flomap run-icon-color height material) (check-flomap syntax-icon-color height material)
(magnifying-glass-icon-flomap metal-icon-color syntax-icon-color (* 3/4 height) material))) (magnifying-glass-flomap metal-icon-color "chocolate" (* 3/4 height) material)))
(define (macro-stepper-icon-flomap [height (toolbar-icon-height)] (define (macro-stepper-flomap [height (toolbar-icon-height)] [material (default-icon-material)])
[material (default-icon-material)])
(flomap-ht-append (flomap-ht-append
(text-icon-flomap "#'" (make-object font% 12 'system 'normal 'normal) (text-flomap "#'" (make-object font% 12 'system 'normal 'normal)
run-icon-color #t #t height material) macro-stepper-hash-color #t #t height material)
(make-flomap 4 (max 1 (inexact->exact (round (* 1/32 height)))) 0) (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)] (define (small-macro-stepper-flomap [height (toolbar-icon-height)] [material (default-icon-material)])
[material (default-icon-material)])
(flomap-pin* (flomap-pin*
0 0 7/16 0 0 0 7/16 0
(step-icon-flomap (make-object color% 38 38 128) height material) (step-flomap syntax-icon-color height material)
(text-icon-flomap "#'" (make-object font% 12 'system 'normal 'bold) (text-flomap "#'" (make-object font% 12 'system 'normal 'bold)
run-icon-color #t #t (* 3/4 height) material))) macro-stepper-hash-color #t #t (* 3/4 height) material)))
(define (debugger-icon-flomap [height (toolbar-icon-height)] (define (debugger-flomap [height (toolbar-icon-height)] [material (default-icon-material)])
[material (default-icon-material)])
(flomap-ht-append (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) (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)] (define (small-debugger-flomap [height (toolbar-icon-height)] [material (default-icon-material)])
[material (default-icon-material)])
(flomap-pin* (flomap-pin*
0 0 9/16 0 0 0 9/16 0
(step-icon-flomap run-icon-color height material) (step-flomap run-icon-color height material)
(left-bomb-icon-flomap metal-icon-color halt-icon-color (* 3/4 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 check-syntax-icon (compose flomap->bitmap check-syntax-flomap))
(define small-check-syntax-icon (compose flomap->bitmap small-check-syntax-icon-flomap)) (define small-check-syntax-icon (compose flomap->bitmap small-check-syntax-flomap))
(define macro-stepper-icon (compose flomap->bitmap macro-stepper-icon-flomap)) (define macro-stepper-icon (compose flomap->bitmap macro-stepper-flomap))
(define small-macro-stepper-icon (compose flomap->bitmap small-macro-stepper-icon-flomap)) (define small-macro-stepper-icon (compose flomap->bitmap small-macro-stepper-flomap))
(define debugger-icon (compose flomap->bitmap debugger-icon-flomap)) (define debugger-icon (compose flomap->bitmap debugger-flomap))
(define small-debugger-icon (compose flomap->bitmap small-debugger-icon-flomap)) (define small-debugger-icon (compose flomap->bitmap small-debugger-flomap))

311
collects/images/logos.rkt
View File

@ -5,9 +5,10 @@
"private/deep-flomap.rkt" "private/deep-flomap.rkt"
"private/renderfx.rkt" "private/renderfx.rkt"
"icons/style.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 (define glass-logo-material
(deep-flomap-material-value (deep-flomap-material-value
@ -16,44 +17,67 @@
0.2 0.1 0.1 0.2 0.1 0.1
0.0)) 0.0))
(define lambda-start-point (cons 235.0 38.0)) (define lambda-path-commands
(define lambda-control-points '((m 97.5 10)
(list (list (cons -27.07492 0.489079) (cons -52.83237 9.901645) (cons -78.13681 18.608898)) (c -12.267574371681416 0.22160039646017698
(list (cons 11.0396 11.823329) (cons 9.37418 15.558039) (cons 14.19246 14.659919)) -23.938206584070794 4.486409061946903
(list (cons 18.43869 -4.46584) (cons 45.7868 -14.85883) (cons 57.97111 4.83448)) -35.40358116814159 8.431642279646018
(list (cons 26.56443 33.55767) (cons 37.83026 76.50393) (cons 41.85449 118.37596)) 5.002013451327434 5.357118980530973
(list (cons 5.15871 25.44003) (cons -47.30403 116.52589) (cons -63.42303 152.88265)) 4.2474160707964606 7.049306166371681
(list (cons -26.20045 46.22879) (cons -49.47611 94.20521) (cons -78.99673 138.48542)) 6.430565946902655 6.642370378761062
(list (cons 7.0596 9.34303) (cons 17.25993 5.68676) (cons 26.86192 4.2502)) 8.354521486725664 -2.0234602477876105
(list (cons 8.19842 -1.22826) (cons 16.39686 -2.4565) (cons 24.59528 -3.68475)) 20.745877522123894 -6.732496424778761
(list (cons 26.44013 -62.68827) (cons 54.98797 -120.2314) (cons 79.79859 -183.59412)) 26.26655603539823 2.1904900530973452
(list (cons 11.30581 -26.11293) (cons 16.82865 -40.47628) (cons 30.26123 -57.57618)) 12.036272707964603 15.204891185840708
(list (cons 15.92423 9.74246) (cons 20.66525 33.77224) (cons 29.3527 50.35199)) 17.140790371681415 34.66372757522124
(list (cons 25.60238 65.87977) (cons 51.09413 131.80228) (cons 75.25809 198.22074)) 18.964158300884954 53.635833203539825
(list (cons 6.32468 2.20244) (cons 12.81613 8.78314) (cons 18.81535 2.44056)) 2.3373978053097346 11.526810053097345
(list (cons 15.78086 -9.73038) (cons 34.15342 -15.82488) (cons 47.2925 -29.27438)) -21.433330407079644 52.79757139823009
(list (cons -3.74907 -18.17899) (cons -15.79452 -35.18254) (cons -23.13261 -52.66524)) -28.736806513274335 69.27072283185841
(list (cons -46.51473 -92.95952) (cons -91.3634 -191.5622) (cons -120.47873 -291.65949)) -11.871354336283186 20.946142017699113
(list (cons -10.72309 -31.50493) (cons -23.92724 -69.469699) (cons -58.05359 -81.906439)) -22.417494088495573 42.68413054867256
(list (cons -7.7741 -2.308013) (cons -15.96612 -2.751575) (cons -24.03222 -2.750218)))) -35.79320863716814 62.74737614159292
3.198686017699115 4.233302088495575
(define (lambda-path x y x-scale y-scale) 7.820428460176991 2.5766558584070793
(define (scale-x x) (* x x-scale)) 12.171064637168142 1.925754336283186
(define (scale-y y) (* y y-scale)) 3.714682336283186 -0.5565213451327433
(define p (new dc-path%)) 7.429373734513274 -1.1130336283185842
(match-define (cons (app scale-x sx) (app scale-y sy)) lambda-start-point) 11.14405607079646 -1.6695504424778762
(send p move-to sx sy) 11.979952707964602 -28.4038887079646
(for/fold ([lx sx] [ly sy]) ([pt (in-list lambda-control-points)]) 24.914903221238937 -54.476528141592915
(match-define (list (cons (app scale-x x1) (app scale-y y1)) 36.156529274336286 -83.1860083539823
(cons (app scale-x x2) (app scale-y y2)) 5.122632495575221 -11.831699256637167
(cons (app scale-x x3) (app scale-y y3))) pt) 7.625016637168141 -18.33969500884956
(send p curve-to (+ lx x1) (+ ly y1) (+ lx x2) (+ ly y2) (+ lx x3) (+ ly y3)) 13.711282973451327 -26.087614300884955
(values (+ lx x3) (+ ly y3))) 7.215226336283186 4.414282761061947
(send p close) 9.363369911504424 15.302112283185838
p) 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) (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-θ-start (* -45 (/ pi 180)))
(define blue-θ-end (* 110 (/ pi 180))) (define blue-θ-end (* 110 (/ pi 180)))
@ -84,70 +108,205 @@
(unsafe-fl* g l) (unsafe-fl* g l)
(unsafe-fl* b l))))) (unsafe-fl* b l)))))
(define (flomap-rough fm z-amt) (define (make-random-flomap c w h)
(match-define (flomap vs c w h) fm) (unsafe-build-flomap c w h (λ (k x y) (random))))
(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 (plt-logo height) (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 scale (/ height 256))
(define bulge-fm (define bulge-fm
(draw-flomap (draw-icon-flomap
height height 256 256 (λ (dc)
(λ (dc) (send dc set-pen logo-red-color 2 'transparent)
(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 set-brush logo-red-color 'solid)
(send dc draw-path (make-arc-path 7 7 242 242 blue-θ-end blue-θ-start)) (send dc draw-path (make-arc-path 8 8 239 239 blue-θ-end blue-θ-start))
(send dc set-pen logo-blue-color 2 'solid) (send dc set-pen logo-blue-color 2 'transparent)
(send dc set-brush logo-blue-color '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 draw-path (make-arc-path 8 8 239 239 blue-θ-start blue-θ-end))
(send dc set-pen (lambda-pen lambda-outline-color 12)) (send dc set-pen (lambda-pen lambda-outline-color 10))
(send dc set-brush lambda-outline-color 'solid) (send dc set-brush lambda-outline-color 'solid)
(draw-lambda dc 0 0 256 256)))) (draw-lambda dc 8 8 240 240))
scale))
;(flomap-add-sparkles! bulge-fm) ;(flomap-add-sparkles! bulge-fm)
(define (lambda-flomap color pen-width) (define (lambda-flomap color pen-width)
(draw-flomap (draw-icon-flomap
height height 256 256 (λ (dc)
(λ (dc)
(send dc set-scale scale scale) (send dc set-scale scale scale)
(send dc set-pen (lambda-pen color pen-width)) (send dc set-pen (lambda-pen color pen-width))
(send dc set-brush color 'solid) (send dc set-brush color 'solid)
(draw-lambda dc 0 0 256 256)))) (draw-lambda dc 8 8 240 240))
scale))
(let* ([bulge-dfm (flomap->deep-flomap bulge-fm)] (let* ([bulge-dfm (flomap->deep-flomap bulge-fm)]
[bulge-dfm (deep-flomap-bulge-spheroid bulge-dfm (* 116 scale))] [bulge-dfm (deep-flomap-bulge-spheroid bulge-dfm (* 112 scale))]
;[bulge-dfm (deep-flomap-raise bulge-dfm (* 8 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-smooth-z bulge-dfm (* 1/2 scale))]
#;[bulge-dfm (deep-flomap (deep-flomap-argb bulge-dfm) #;[bulge-dfm (deep-flomap (deep-flomap-argb bulge-dfm)
(flomap-rough (deep-flomap-z bulge-dfm) 0.5))] (flomap-rough (deep-flomap-z bulge-dfm) 0.5))]
[lambda-dfm (flomap->deep-flomap (lambda-flomap "azure" 4))] [lambda-dfm (flomap->deep-flomap (lambda-flomap "azure" 4))]
[lambda-dfm (deep-flomap-bulge-spheroid lambda-dfm (* 116 scale))] [lambda-dfm (deep-flomap-bulge-spheroid lambda-dfm (* 112 scale))]
[lambda-dfm (deep-flomap-smooth-z lambda-dfm (* 3 scale))] [lambda-dfm (deep-flomap-smooth-z lambda-dfm (* 3 scale))]
[lambda-fm (deep-flomap-render-icon lambda-dfm metal-material)] [lambda-fm (deep-flomap-render-icon lambda-dfm metal-material)]
[fm (deep-flomap-render-icon bulge-dfm glass-logo-material)] [fm (deep-flomap-render-icon bulge-dfm glass-logo-material)]
[fm (flomap-cc-superimpose [fm (flomap-cc-superimpose
fm fm
(lambda-flomap lambda-outline-color 12) (lambda-flomap lambda-outline-color 10)
lambda-fm)] lambda-fm)]
[fm (flomap-inset fm 16)]
[fm (flomap-cc-superimpose [fm (flomap-cc-superimpose
fm (draw-icon-flomap
(draw-flomap 256 256 (λ (dc)
(inexact->exact (ceiling (* 1.015625 height))) (send dc set-pen "lightblue" 2 'solid)
(inexact->exact (ceiling (* 1.015625 height))) (send dc set-brush "white" 'transparent)
(λ (dc) (send dc draw-ellipse 7 7 242 242)
(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-pen lambda-outline-color 4 'solid)
(send dc set-brush lambda-outline-color 'transparent) (send dc draw-ellipse 2 2 252 252))
(send dc draw-ellipse 0 0 256 256))))] scale)
[fm (flomap-cc-superimpose (fm* 0.5 (flomap-shadow fm (* 4 scale))) fm)] fm)]
) )
(flomap->bitmap 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))

57
collects/images/private/transient-box.rkt
View File

@ -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
|#

102
collects/images/private/utils.rkt
View File

@ -1,9 +1,74 @@
#lang racket/base #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)) (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 (draw-ellipse/smoothed dc x y w h)
(define pen (send dc get-pen)) (define pen (send dc get-pen))
(define brush (send dc get-brush)) (define brush (send dc get-brush))
@ -25,22 +90,22 @@
[`(M) (loop x y (rest cmds))] [`(M) (loop x y (rest cmds))]
[`(L) (loop x y (rest cmds))] [`(L) (loop x y (rest cmds))]
[`(C) (loop x y (rest cmds))] [`(C) (loop x y (rest cmds))]
[`(M (,ax . ,ay) ,as ...) (send p move-to ax ay) [`(M ,ax ,ay ,as ...) (send p move-to ax ay)
(loop ax ay (cons `(M ,@as) (rest cmds)))] (loop ax ay (cons `(M ,@as) (rest cmds)))]
[`(L (,ax . ,ay) ,as ...) (send p line-to ax ay) [`(L ,ax ,ay ,as ...) (send p line-to ax ay)
(loop ax ay (cons `(L ,@as) (rest cmds)))] (loop ax ay (cons `(L ,@as) (rest cmds)))]
[`(C (,ax1 . ,ay1) (,ax2 . ,ay2) (,ax . ,ay) ,as ...) [`(C ,ax1 ,ay1 ,ax2 ,ay2 ,ax ,ay ,as ...)
(send p curve-to ax1 ay1 ax2 ay2 ax ay) (send p curve-to ax1 ay1 ax2 ay2 ax ay)
(loop ax ay (cons `(C ,@as) (rest cmds)))] (loop ax ay (cons `(C ,@as) (rest cmds)))]
;; relative commands ;; relative commands
[`(m) (loop x y (rest cmds))] [`(m) (loop x y (rest cmds))]
[`(l) (loop x y (rest cmds))] [`(l) (loop x y (rest cmds))]
[`(c) (loop x y (rest cmds))] [`(c) (loop x y (rest cmds))]
[`(m (,dx . ,dy) ,ds ...) (send p move-to (+ x dx) (+ y dy)) [`(m ,dx ,dy ,ds ...) (send p move-to (+ x dx) (+ y dy))
(loop (+ x dx) (+ y dy) (cons `(m ,@ds) (rest cmds)))] (loop (+ x dx) (+ y dy) (cons `(m ,@ds) (rest cmds)))]
[`(l (,dx . ,dy) ,ds ...) (send p line-to (+ x dx) (+ y dy)) [`(l ,dx ,dy ,ds ...) (send p line-to (+ x dx) (+ y dy))
(loop (+ x dx) (+ y dy) (cons `(l ,@ds) (rest cmds)))] (loop (+ x dx) (+ y dy) (cons `(l ,@ds) (rest cmds)))]
[`(c (,dx1 . ,dy1) (,dx2 . ,dy2) (,dx . ,dy) ,ds ...) [`(c ,dx1 ,dy1 ,dx2 ,dy2 ,dx ,dy ,ds ...)
(send p curve-to (+ dx1 x) (+ dy1 y) (+ dx2 x) (+ dy2 y) (+ dx x) (+ dy y)) (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)))] (loop (+ x dx) (+ y dy) (cons `(c ,@ds) (rest cmds)))]
[_ (error 'apply-path-commands "unknown path command ~e" cmd)])])) [_ (error 'apply-path-commands "unknown path command ~e" cmd)])]))
@ -48,8 +113,27 @@
(define (draw-path-commands dc x y cmds) (define (draw-path-commands dc x y cmds)
(define p (new dc-path%)) (define p (new dc-path%))
(apply-path-commands p (cons `(M (,x . ,y)) cmds)) (apply-path-commands p cmds)
(send dc draw-path p)) (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 (get-text-size str font)
(define bm (make-bitmap 1 1)) (define bm (make-bitmap 1 1))