diff --git a/collects/icons/bomb-32x32.png b/collects/icons/bomb-32x32.png index 2b491a0d17..ba3f641e23 100644 Binary files a/collects/icons/bomb-32x32.png and b/collects/icons/bomb-32x32.png differ diff --git a/collects/icons/macro-stepper-32x32.png b/collects/icons/macro-stepper-32x32.png new file mode 100644 index 0000000000..51766e166f Binary files /dev/null and b/collects/icons/macro-stepper-32x32.png differ diff --git a/collects/icons/stepper-32x32.png b/collects/icons/stepper-32x32.png new file mode 100644 index 0000000000..82d2b492f7 Binary files /dev/null and b/collects/icons/stepper-32x32.png differ diff --git a/collects/images/gui.rkt b/collects/images/gui.rkt new file mode 100644 index 0000000000..3ea5c95af7 --- /dev/null +++ b/collects/images/gui.rkt @@ -0,0 +1,97 @@ +#lang racket/base + +(require racket/gui racket/class string-constants) + +(provide bitmap-canvas% logo-about-dialog%) + +(define bitmap-canvas% + (class canvas% + (init parent) + (init-field bitmap) + (init [enabled #t] [vert-margin 0] [horiz-margin 0]) + + (inherit get-dc refresh min-width min-height) + + (super-new [parent parent] + [enabled enabled] + [vert-margin vert-margin] + [horiz-margin horiz-margin] + [stretchable-width #f] + [stretchable-height #f] + [style '(transparent no-focus)]) + + (min-width (send bitmap get-width)) + (min-height (send bitmap get-height)) + + (define/public (set-bitmap new-bitmap) + (set! bitmap new-bitmap) + (min-width (send bitmap get-width)) + (min-height (send bitmap get-height)) + (refresh)) + + (define/override (on-paint) + (send (get-dc) draw-bitmap bitmap 0 0)) + )) + +(define message-text% + (class text% + (init messages) + (super-new [auto-wrap #t]) + + (define writable? #t) + (define/augment (can-change-style? start len) writable?) + (define/augment (can-delete? start len) writable?) + (define/augment (can-insert? start len) writable?) + (define/augment (can-load-file? filename format) writable?) + (define/augment (can-save-file? filename format) writable?) + (define/override (can-do-edit-operation? op [recursive? #t]) + (case op + [(copy select-all) #t] + [else writable?])) + + (for ([message (in-list messages)]) + (send this insert message)) + (set! writable? #f))) + +(define message-canvas% + (class editor-canvas% + (init parent messages [horiz-margin 0] [vert-margin 0]) + (super-new [parent parent] + [editor (new message-text% [messages messages])] + [horizontal-inset 0] [vertical-inset 0] + [horiz-margin 0] [vert-margin 0] + [enabled #t] [style '(auto-vscroll auto-hscroll no-border transparent)]))) + +(define logo-about-dialog% + (class dialog% + (init label parent bitmap messages [width 640] [height 200] [enabled #t]) + (super-new [label label] + [parent parent] + [width width] + [height height] + [enabled enabled] + [spacing 10] + [border 10]) + + (define top-panel + (new horizontal-panel% [parent this] [alignment '(center top)] [spacing 20])) + + (define bitmap-canvas + (new bitmap-canvas% [parent top-panel] [bitmap bitmap])) + + (define message-canvas + (new message-canvas% [parent top-panel] [messages messages])) + + (define close-button + (new button% + [label (string-constant close)] + [parent this] + [callback (λ (_1 _2) + (when (send this can-close?) + (send this on-close) + (send this show #f)))] + [style '(border)])) + + (send close-button focus) + )) + diff --git a/collects/images/icons/arrow.rkt b/collects/images/icons/arrow.rkt index bbcdd5f3f8..e894e0fd25 100644 --- a/collects/images/icons/arrow.rkt +++ b/collects/images/icons/arrow.rkt @@ -26,6 +26,7 @@ (let ([color (->color% color)]) (draw-icon-flomap 32 32 (λ (dc) + (set-icon-pen dc (icon-color->outline-color color) 1 'solid) (send dc set-brush color 'solid) (send dc draw-polygon (list '(0 . 9) '(15 . 9) '(14 . 0) '(31 . 15.5) @@ -37,6 +38,7 @@ ) flomap? (draw-icon-flomap 32 32 (λ (dc) + (set-icon-pen dc (icon-color->outline-color color) 1 'solid) (send dc set-brush color 'solid) (draw-path-commands dc 0 0 '((m 0 15) diff --git a/collects/images/icons/control.rkt b/collects/images/icons/control.rkt index 36c244378a..2be8f1ccb3 100644 --- a/collects/images/icons/control.rkt +++ b/collects/images/icons/control.rkt @@ -18,14 +18,17 @@ pause-icon pause-flomap step-icon step-flomap step-back-icon step-back-flomap - continue-icon continue-flomap - continue-back-icon continue-back-flomap) + continue-forward-icon continue-forward-flomap + continue-backward-icon continue-backward-flomap + search-forward-icon search-forward-flomap + search-backward-icon search-backward-flomap) (only-doc-out (all-defined-out))) (define (flat-play-flomap color height) (draw-icon-flomap 24 32 (λ (dc) + (set-icon-pen dc (icon-color->outline-color color) 1 'solid) (send dc set-brush color 'solid) (send dc draw-polygon (list (cons 0 0) (cons 4 0) (cons 23 13) (cons 23 18) @@ -45,8 +48,18 @@ [height (and/c rational? (>=/c 0)) (default-icon-height)] [material deep-flomap-material-value? (default-icon-material)] ) flomap? - (define fm (play-flomap color height material)) - (flomap-pin* 3/2 1/2 1 1/2 fm fm)) + (make-cached-flomap + [height color material] + (define fm (draw-rendered-icon-flomap + 20 32 (λ (dc) + (set-icon-pen dc (icon-color->outline-color color) 1 'solid) + (send dc set-brush color 'solid) + (send dc draw-polygon (list (cons 0 0) (cons 4 0) + (cons 19 13) (cons 19 18) + (cons 4 31) (cons 0 31)))) + (/ height 32) + material)) + (flomap-hc-append fm fm))) (defproc (stop-flomap [color (or/c string? (is-a?/c color%))] [height (and/c rational? (>=/c 0)) (default-icon-height)] @@ -56,6 +69,7 @@ [height color material] (draw-rendered-icon-flomap 32 32 (λ (dc) + (set-icon-pen dc (icon-color->outline-color color) 1 'solid) (send dc set-brush color 'solid) (send dc draw-polygon (list '(0 . 0) '(31 . 0) '(31 . 31) '(0 . 31)))) (/ height 32) @@ -69,6 +83,7 @@ [height color material] (draw-rendered-icon-flomap 32 32 (λ (dc) + (set-icon-pen dc (icon-color->outline-color color) 1 'solid) (send dc set-brush color 'solid) (draw-ellipse/smoothed dc 0 0 32 32)) (/ height 32) @@ -82,6 +97,7 @@ [height color material] (draw-rendered-icon-flomap 8 32 (λ (dc) + (set-icon-pen dc (icon-color->outline-color color) 1 'solid) (send dc set-brush color 'solid) (send dc draw-polygon (list '(0 . 0) '(7 . 0) '(7 . 31) '(0 . 31)))) (/ height 32) @@ -126,24 +142,42 @@ (make-flomap 4 (max 1 (inexact->exact (round (* 1/16 height)))) 0) (back-flomap color height material))) -(defproc (continue-flomap [color (or/c string? (is-a?/c color%))] - [height (and/c rational? (>=/c 0)) (default-icon-height)] - [material deep-flomap-material-value? (default-icon-material)] - ) flomap? +(defproc (continue-forward-flomap [color (or/c string? (is-a?/c color%))] + [height (and/c rational? (>=/c 0)) (default-icon-height)] + [material deep-flomap-material-value? (default-icon-material)] + ) flomap? (flomap-hc-append (bar-flomap color height material) (make-flomap 4 (max 1 (inexact->exact (round (* 1/16 height)))) 0) (play-flomap color height material))) -(defproc (continue-back-flomap [color (or/c string? (is-a?/c color%))] - [height (and/c rational? (>=/c 0)) (default-icon-height)] - [material deep-flomap-material-value? (default-icon-material)] - ) flomap? +(defproc (continue-backward-flomap [color (or/c string? (is-a?/c color%))] + [height (and/c rational? (>=/c 0)) (default-icon-height)] + [material deep-flomap-material-value? (default-icon-material)] + ) flomap? (flomap-hc-append (back-flomap color height material) (make-flomap 4 (max 1 (inexact->exact (round (* 1/16 height)))) 0) (bar-flomap color height material))) +(defproc (search-forward-flomap [color (or/c string? (is-a?/c color%))] + [height (and/c rational? (>=/c 0)) (default-icon-height)] + [material deep-flomap-material-value? (default-icon-material)] + ) flomap? + (flomap-hc-append + (fast-forward-flomap color height material) + (make-flomap 4 (max 1 (inexact->exact (round (* 1/16 height)))) 0) + (bar-flomap color height material))) + +(defproc (search-backward-flomap [color (or/c string? (is-a?/c color%))] + [height (and/c rational? (>=/c 0)) (default-icon-height)] + [material deep-flomap-material-value? (default-icon-material)] + ) flomap? + (flomap-hc-append + (bar-flomap color height material) + (make-flomap 4 (max 1 (inexact->exact (round (* 1/16 height)))) 0) + (rewind-flomap color height material))) + (define-icon-wrappers ([color (or/c string? (is-a?/c color%))] [height (and/c rational? (>=/c 0)) (default-icon-height)] @@ -158,5 +192,7 @@ [pause-icon pause-flomap] [step-icon step-flomap] [step-back-icon step-back-flomap] - [continue-icon continue-flomap] - [continue-back-icon continue-back-flomap]) + [continue-forward-icon continue-forward-flomap] + [continue-backward-icon continue-backward-flomap] + [search-forward-icon search-forward-flomap] + [search-backward-icon search-backward-flomap]) diff --git a/collects/images/icons/file.rkt b/collects/images/icons/file.rkt index 3af621ade2..18ca17c374 100644 --- a/collects/images/icons/file.rkt +++ b/collects/images/icons/file.rkt @@ -69,7 +69,7 @@ (send dc draw-rectangle 2.5 i 16 1))) scale)] [dfm (flomap->deep-flomap fm)] - [dfm (deep-flomap-bulge-vertical dfm (* 4 scale))]) + [dfm (deep-flomap-bulge-vertical dfm (* 2 scale))]) (deep-flomap-render-icon dfm matte-material))) (define top-indent-fm @@ -84,6 +84,7 @@ (define case-fm (draw-icon-flomap 32 32 (λ (dc) + (set-icon-pen dc (icon-color->outline-color color) 1 'solid) (send dc set-brush color 'solid) (send dc draw-polygon (list '(0 . 3) '(3 . 0) '(28 . 0) '(31 . 3) diff --git a/collects/images/icons/misc.rkt b/collects/images/icons/misc.rkt index caee86151a..344a2288f6 100644 --- a/collects/images/icons/misc.rkt +++ b/collects/images/icons/misc.rkt @@ -16,6 +16,8 @@ octagon-icon octagon-flomap stop-sign-icon stop-sign-flomap stop-signs-icon stop-signs-flomap + foot-icon foot-flomap + lambda-icon lambda-flomap magnifying-glass-icon magnifying-glass-flomap left-magnifying-glass-icon left-magnifying-glass-flomap bomb-icon bomb-flomap @@ -30,7 +32,8 @@ (define mx 23.5) (draw-icon-flomap 32 32 (λ (dc) - (send dc set-pen (make-object pen% "black" 12 'solid 'projecting 'miter)) + (send dc set-pen (make-object pen% (icon-color->outline-color color) + 12 'solid 'projecting 'miter)) (send dc draw-line mn mn mx mx) (send dc draw-line mn mx mx mn) (send dc set-pen (make-object pen% color 10 'solid 'projecting 'miter)) @@ -41,6 +44,7 @@ (define (flat-check-flomap color height) (draw-icon-flomap 32 32 (λ (dc) + (set-icon-pen dc (icon-color->outline-color color) 1 'solid) (send dc set-brush color 'solid) (draw-path-commands dc 0 0 '((m 0 19) @@ -54,6 +58,7 @@ (let ([start (- start)]) (draw-icon-flomap 32 32 (λ (dc) + (set-icon-pen dc (icon-color->outline-color color) 1 'solid) (send dc set-brush color 'solid) (define dθ (/ (* 2 pi) sides)) (define θs (sequence->list (in-range start (+ start (* 2 pi)) dθ))) @@ -84,20 +89,22 @@ [height str family style weight underline? smoothing color trim? outline material] (let ([font (make-object font% size family style weight underline? smoothing #t)] [outline (if (equal? outline 'auto) (/ height 32) outline)]) + (define outline-color (icon-color->outline-color color)) + (define r (/ (send outline-color red) 255.0)) + (define g (/ (send outline-color green) 255.0)) + (define b (/ (send outline-color blue) 255.0)) (define-values (w h) (get-text-size str font)) (define ceiling-amt (inexact->exact (ceiling outline))) - (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 . > . 0) (flomap-outlined fm outline) fm)]) - fm)) - (flomap-render-icon fm material)))) + (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 . > . 0) (flomap-outlined fm outline (list r g b)) fm)]) + (flomap-render-icon fm material))))) (defproc (recycle-flomap [color (or/c string? (is-a?/c color%))] [height (and/c rational? (>=/c 0)) (default-icon-height)] @@ -129,6 +136,79 @@ [dfm (deep-flomap-raise dfm (* -12 scale))]) (deep-flomap-render-icon dfm material)))) +(define lambda-path-commands + '((m 8.5 1.5) + (c -1.6356765828908555 0.029546719528023596 + -3.191760877876106 0.5981878749262537 + -4.720477489085545 1.1242189706194692) + (c 0.6669351268436579 0.7142825307374631 + 0.5663221427728614 0.9399074888495575 + 0.8574087929203539 0.8856493838348083) + (c 1.1139361982300886 -0.26979469970501474 + 2.7661170029498527 -0.8976661899705014 + 3.5022074713864306 0.2920653404129794) + (c 1.604836361061947 2.027318824778761 + 2.2854387162241885 4.621830343362832 + 2.528554440117994 7.151444427138643) + (c 0.3116530407079646 1.536908007079646 + -2.857777387610619 7.039676186430679 + -3.8315742017699113 9.23609637758112) + (c -1.5828472448377582 2.792818935693215 + -2.9889992117994097 5.691217406489675 + -4.772427818289086 8.366316818879056) + (c 0.42649146902654866 0.5644402784660767 + 1.0427237946902654 0.34355411445427725 + 1.6228086182890855 0.25676724483775815) + (c 0.49529097817109147 -0.07420284601769911 + 0.9905831646017699 -0.14840448377581122 + 1.4858741427728612 -0.22260672566371684) + (c 1.5973270277286136 -3.787185161061947 + 3.3219870961651914 -7.263537085545722 + 4.820870569911505 -11.091467780530973) + (c 0.6830176660766961 -1.5775599008849557 + 1.0166688849557521 -2.445292667846608 + 1.8281710631268435 -3.4783485734513273) + (c 0.9620301781710914 0.5885710348082596 + 1.2484493215339232 2.040281637758112 + 1.77328405899705 3.0419137321533922) + (c 1.5467160542772862 3.979993184660766 + 3.0867486206489674 7.962568420058997 + 4.546565437168141 11.975105472566373) + (c 0.3820927622418879 0.13305596224188793 + 0.7742605970501475 0.5306156554572271 + 1.1366913510324481 0.14744150088495575) + (c 0.9533687693215339 -0.5878412460176992 + 2.0633098572271384 -0.9560281486725664 + 2.857080825958702 -1.7685525144542773) + (c -0.2264924884955752 -1.0982469474926253 + -0.9541940106194691 -2.1254820625368733 + -1.3975098902654866 -3.181664056637168) + (c -2.8100934230088495 -5.615961562241888 + -5.519535197640117 -11.572843233038348 + -7.278479027728613 -17.620018746902655) + (c -0.6478138147492625 -1.9033066855457228 + -1.4455158560471977 -4.19687149120944 + -3.5071903339233037 -4.948212008023599) + (c -0.46965654277286134 -0.13943394171091444 + -0.9645608778761062 -0.1662308436578171 + -1.451858010619469 -0.16614886324483774))) + +(defproc (lambda-flomap [color (or/c string? (is-a?/c color%))] + [height (and/c rational? (>=/c 0)) (default-icon-height)] + [material deep-flomap-material-value? (default-icon-material)]) flomap? + (make-cached-flomap + [height color material] + (draw-rendered-icon-flomap + 32 32 (λ (dc) + (set-icon-pen dc (icon-color->outline-color color) 4 'solid) + (send dc set-brush (icon-color->outline-color color) 'solid) + (draw-path-commands dc 4 0 lambda-path-commands) + (set-icon-pen dc color 2 'solid) + (send dc set-brush color 'solid) + (draw-path-commands dc 4 0 lambda-path-commands)) + (/ height 32) + material))) + (defproc (regular-polygon-flomap [sides exact-positive-integer?] [start real?] [color (or/c string? (is-a?/c color%))] @@ -167,6 +247,24 @@ (flomap-pin* 3/16 1/4 0 0 fm (flomap-pin* 3/16 1/4 0 0 fm fm))) +(defproc (foot-flomap [color (or/c string? (is-a?/c color%))] + [height (and/c rational? (>=/c 0)) (default-icon-height)] + [material deep-flomap-material-value? (default-icon-material)]) flomap? + (make-cached-flomap + [height color material] + (draw-rendered-icon-flomap + 32 32 (λ (dc) + (set-icon-pen dc (icon-color->outline-color color) 1 'solid) + (send dc set-brush color 'solid) + (draw-ellipse/smoothed dc 4 8 24 24) + (draw-ellipse/smoothed dc 0 10 5 4.5) + (draw-ellipse/smoothed dc 3 4.5 5.5 5.5) + (draw-ellipse/smoothed dc 8.75 1 6.25 6.25) + (draw-ellipse/smoothed dc 16 0 7 7) + (draw-ellipse/smoothed dc 23.5 1.5 8.5 10)) + (/ height 32) + material))) + ;; --------------------------------------------------------------------------------------------------- ;; Magnifying glass @@ -188,12 +286,8 @@ (define glass-fm (let* ([fm (draw-icon-flomap 18 18 (λ (dc) - (send dc set-pen handle-color 1 'solid) + (set-icon-pen dc (icon-color->outline-color "azure") 1 'solid) (send dc set-brush "azure" 'solid) - (draw-ellipse/smoothed dc 0 0 18 18) - (send dc set-alpha 0.5) - (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)] @@ -204,8 +298,9 @@ (define circle-fm (let* ([fm (draw-icon-flomap 28 28 (λ (dc) - (send dc set-pen "black" 3 'solid) - (send dc set-brush "black" 'solid) + (define outline-color (icon-color->outline-color frame-color)) + (send dc set-pen outline-color 3 'solid) + (send dc set-brush outline-color 'solid) (draw-ellipse/smoothed dc 1 1 26 26) (send dc set-pen frame-color 1 'solid) (send dc set-brush frame-color 'solid) @@ -228,6 +323,7 @@ (define handle-fm (let* ([fm (draw-icon-flomap 11 11 (λ (dc) + (set-icon-pen dc (icon-color->outline-color handle-color) 1 'solid) (send dc set-brush handle-color 'solid) (define p (new dc-path%)) (send p move-to 4 0) @@ -286,7 +382,7 @@ (define (bomb-cap-flomap color) (draw-icon-flomap 20 20 (λ (dc) - (send dc set-pen "black" 1 'solid) + (set-icon-pen dc (icon-color->outline-color color) 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) @@ -306,6 +402,7 @@ (define sphere-fm (let* ([sphere-fm (draw-icon-flomap 30 30 (λ (dc) + (set-icon-pen dc (icon-color->outline-color bomb-color) 1 'solid) (send dc set-brush bomb-color 'solid) (draw-ellipse/smoothed dc 0 0 30 30)) scale)] @@ -356,7 +453,9 @@ [check-icon check-flomap] [octagon-icon octagon-flomap] [stop-sign-icon stop-sign-flomap] - [stop-signs-icon stop-signs-flomap]) + [stop-signs-icon stop-signs-flomap] + [foot-icon foot-flomap] + [lambda-icon lambda-flomap]) (define-icon-wrappers ([frame-color (or/c string? (is-a?/c color%))] diff --git a/collects/images/icons/stickman.rkt b/collects/images/icons/stickman.rkt index 69f2e48a3c..2cca41dc27 100644 --- a/collects/images/icons/stickman.rkt +++ b/collects/images/icons/stickman.rkt @@ -106,8 +106,9 @@ (define standing-right-hand-point (cons+ standing-right-elbow-point - (polar->cartesian (+ standing-right-elbow-angle standing-torso-angle standing-right-hand-angle) - lower-arm-length))) + (polar->cartesian + (+ standing-right-elbow-angle standing-torso-angle standing-right-hand-angle) + lower-arm-length))) (defproc (standing-stickman-flomap [color (or/c string? (is-a?/c color%))] [arm-color (or/c string? (is-a?/c color%))] @@ -120,7 +121,8 @@ (flomap-lt-superimpose (draw-short-rendered-icon-flomap 26 32 (λ (dc) - (send dc set-pen "black" (+ arm-width (* 2 line-width)) 'solid) + (send dc set-pen (icon-color->outline-color arm-color) + (+ arm-width (* 2 line-width)) 'solid) (send dc draw-lines (list standing-right-shoulder-point standing-right-elbow-point standing-right-hand-point)) @@ -132,17 +134,22 @@ material) (draw-short-rendered-icon-flomap 26 32 (λ (dc) - (send dc set-pen "black" (+ body-width (* 2 line-width)) 'solid) + (send dc set-pen (icon-color->outline-color color) + (+ body-width (* 2 line-width)) 'solid) (send dc draw-lines (list standing-neck-point standing-hip-point)) - (send dc set-pen "black" (+ leg-width (* 2 line-width)) 'solid) + + (send dc set-pen (icon-color->outline-color color) + (+ leg-width (* 2 line-width)) 'solid) (send dc draw-lines (list standing-hip-point standing-left-knee-point standing-left-foot-point)) (send dc draw-lines (list standing-hip-point standing-right-knee-point standing-right-foot-point)) + (send dc set-pen color body-width 'solid) (send dc draw-lines (list standing-neck-point standing-hip-point)) + (send dc set-pen color leg-width 'solid) (send dc draw-lines (list standing-hip-point standing-left-knee-point @@ -154,7 +161,8 @@ material) (draw-short-rendered-icon-flomap 26 32 (λ (dc) - (send dc set-pen "black" (+ arm-width (* 2 line-width)) 'solid) + (send dc set-pen (icon-color->outline-color arm-color) + (+ arm-width (* 2 line-width)) 'solid) (send dc draw-lines (list standing-left-shoulder-point standing-left-elbow-point standing-left-hand-point)) @@ -166,7 +174,7 @@ material) (draw-short-rendered-icon-flomap 26 32 (λ (dc) - (send dc set-pen "black" line-width 'solid) + (send dc set-pen (icon-color->outline-color head-color) line-width 'solid) (send dc set-brush head-color 'solid) (match-define (cons x y) standing-head-point) (draw-ellipse/smoothed dc (- x 3.5) (- y 3.5) 8 8)) @@ -262,7 +270,7 @@ [height t color material] (draw-rendered-icon-flomap 26 32 (λ (dc) - (send dc set-pen "black" line-width 'solid) + (send dc set-pen (icon-color->outline-color color) line-width 'solid) (send dc set-brush color 'solid) (match-define (cons x y) (running-head-point t)) (draw-ellipse/smoothed dc (- x 3.5) (- y 3.5) 8 8)) @@ -274,9 +282,10 @@ [height t body? color material] (draw-rendered-icon-flomap 26 32 (λ (dc) - (draw-running-leg dc t "black" (+ leg-width (* 2 line-width))) + (draw-running-leg dc t (icon-color->outline-color color) (+ leg-width (* 2 line-width))) (when body? - (draw-running-body dc t "black" (+ body-width (* 2 line-width))) + (draw-running-body dc t (icon-color->outline-color color) + (+ body-width (* 2 line-width))) (draw-running-body dc t color body-width)) (draw-running-leg dc t color leg-width)) (/ height 32) @@ -287,7 +296,7 @@ [height t color material] (draw-rendered-icon-flomap 26 32 (λ (dc) - (draw-running-arm dc t "black" (+ arm-width (* 2 line-width))) + (draw-running-arm dc t (icon-color->outline-color color) (+ arm-width (* 2 line-width))) (draw-running-arm dc t color arm-width)) (/ height 32) material))) diff --git a/collects/images/icons/style.rkt b/collects/images/icons/style.rkt index 35a95ca76a..94312b185a 100644 --- a/collects/images/icons/style.rkt +++ b/collects/images/icons/style.rkt @@ -74,7 +74,24 @@ draw-rendered-icon-flomap flomap-render-thin-icon draw-short-rendered-icon-flomap - define-icon-wrappers) + define-icon-wrappers + (activate-contract-out + icon-color->outline-color + set-icon-pen)) + +(defproc (set-icon-pen [dc (is-a?/c dc<%>)] + [color (or/c string? (is-a?/c color%))] + [width (>=/c 0)] + [style symbol?]) void? + (send dc set-pen (make-object pen% color width style 'projecting 'miter))) + +(defproc (icon-color->outline-color [color (or/c string? (is-a?/c color%))]) (is-a?/c color%) + (cond [(string? color) (icon-color->outline-color (send the-color-database find-color color))] + [else + (define r (send color red)) + (define g (send color green)) + (define b (send color blue)) + (make-object color% (quotient r 2) (quotient g 2) (quotient b 2))])) (define icon-lighting (deep-flomap-lighting-value @@ -103,7 +120,7 @@ (send dc set-scale scale scale) (send dc set-smoothing 'smoothed) (send dc set-origin (* 0.5 scale) (* 0.5 scale)) - (send dc set-pen (make-object pen% "black" 1 'solid 'projecting 'miter)) + (set-icon-pen dc "black" 10 'solid) (draw-proc dc)))) (define (flomap-render-icon fm material) diff --git a/collects/images/logos.rkt b/collects/images/logos.rkt index 015d0abf39..7d0d2634ab 100644 --- a/collects/images/logos.rkt +++ b/collects/images/logos.rkt @@ -1,40 +1,331 @@ #lang racket/base -(require racket/class racket/draw racket/promise +(require racket/class racket/draw racket/math racket/match racket/contract unstable/latent-contract unstable/latent-contract/defthing - (rename-in "private/logos.rkt" - [plt-logo uncached-plt-logo] - [planet-logo uncached-planet-logo]) "private/flomap.rkt" - "compile-time.rkt" - (for-syntax racket/base - (rename-in "private/logos.rkt" - [plt-logo uncached-plt-logo] - [planet-logo uncached-planet-logo]) - "private/flomap.rkt")) + "private/deep-flomap.rkt" + "private/utils.rkt" + "icons/misc.rkt" + "icons/style.rkt") (provide (activate-contract-out plt-logo plt-flomap - planet-logo planet-flomap) - (only-doc-out (all-from-out "private/logos.rkt")) + planet-logo planet-flomap + stepper-logo stepper-flomap + macro-stepper-logo macro-stepper-logo-flomap) (only-doc-out (all-defined-out))) -;; Use a delay to keep from using more memory than necessary (saves 256KB) -(define standard-plt-logo (delay (compiled-bitmap (uncached-plt-logo 256)))) +(define glass-logo-material + (deep-flomap-material-value + 'cubic-zirconia 0.7 0.6 0.4 + 0.2 0.1 1.0 + 0.2 0.1 0.1 + 0.0)) -(defproc (plt-logo [height (and/c rational? (>=/c 0)) 256]) (is-a?/c bitmap%) - (cond [(height . = . 256) (force standard-plt-logo)] - [(height . <= . 256) - (flomap->bitmap (flomap-resize (bitmap->flomap (force standard-plt-logo)) #f height))] - [else - (uncached-plt-logo height)])) +(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) + (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 standard-planet-logo (delay (compiled-bitmap (uncached-planet-logo 256)))) +(define blue-θ-start (* -45 (/ pi 180))) +(define blue-θ-end (* 110 (/ pi 180))) -(defproc (planet-logo [height (and/c rational? (>=/c 0)) 256]) (is-a?/c bitmap%) - (cond [(height . = . 256) (force standard-planet-logo)] - [(height . <= . 256) - (flomap->bitmap (flomap-resize (bitmap->flomap (force standard-planet-logo)) #f height))] - [else - (uncached-planet-logo height)])) +(define logo-red-color (make-object color% 255 36 32)) +(define logo-blue-color (make-object color% 32 36 255)) +(define lambda-outline-color (make-object color% 16 16 64)) +(define (lambda-pen color width) (make-object pen% color width 'solid 'projecting 'miter)) + +(define (make-arc-path x y w h start end [ccw? #t]) + (define p (new dc-path%)) + (send p arc x y w h start end ccw?) + (send p close) + p) + +(define (make-random-flomap c w h) + (build-flomap c w h (λ (k x y i) (random)))) + +(define (flomap-rough fm z-amt) + (match-define (flomap _ c w h) fm) + (fm+ fm (fm* z-amt (make-random-flomap c w h)))) + +(defproc (plt-flomap [height (and/c rational? (>=/c 0)) 256]) flomap? + (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)) + + (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))] + [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 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)) + +(defproc (planet-flomap [height (and/c rational? (>=/c 0)) 256]) flomap? + (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 'add earth-dfm indent-dfm)]) + (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))) + +(defproc (stepper-flomap [height (and/c rational? (>=/c 0)) 96]) flomap? + (flomap-pin* + 1/2 20/32 1/2 1/2 + (foot-flomap "forestgreen" height glass-icon-material) + (lambda-flomap light-metal-icon-color (* 5/8 height) metal-icon-material))) + +(defproc (macro-stepper-logo-flomap [height (and/c rational? (>=/c 0)) 96]) flomap? + (define outline-color (icon-color->outline-color light-metal-icon-color)) + + (define (draw-hash dc) + (send dc draw-polygon '((5 . 0) (8 . 0) (6 . 19) (3 . 19))) + (send dc draw-polygon '((13 . 0) (16 . 0) (14 . 19) (11 . 19))) + (send dc draw-polygon '((1 . 4) (1 . 7) (19 . 7) (19 . 4))) + (send dc draw-polygon '((0 . 12) (0 . 15) (18 . 15) (18 . 12)))) + + (flomap-pin* + 1/2 20/32 1/2 1/2 + (foot-flomap (make-object color% 34 42 160) height glass-icon-material) + (draw-rendered-icon-flomap + 32 32 (λ (dc) + (send dc translate 6 6) + (set-icon-pen dc outline-color 2 'solid) + (send dc set-brush outline-color 'solid) + (draw-hash dc) + (send dc set-pen "black" 1 'transparent) + (send dc set-brush light-metal-icon-color 'solid) + (draw-hash dc)) + (/ (* 3/4 height) 32) + metal-icon-material))) + +(define-icon-wrappers + ([height (and/c rational? (>=/c 0)) 256]) + [plt-logo plt-flomap]) + +(define-icon-wrappers + ([height (and/c rational? (>=/c 0)) 96]) + [planet-logo planet-flomap] + [stepper-logo stepper-flomap] + [macro-stepper-logo macro-stepper-logo-flomap]) diff --git a/collects/images/private/logos.rkt b/collects/images/private/logos.rkt deleted file mode 100644 index 4fbc7fb615..0000000000 --- a/collects/images/private/logos.rkt +++ /dev/null @@ -1,290 +0,0 @@ -#lang racket/base - -(require racket/draw racket/class racket/match racket/math racket/flonum - racket/contract unstable/latent-contract unstable/latent-contract/defthing - "flomap.rkt" - "deep-flomap.rkt" - "utils.rkt" - "../icons/style.rkt") - -(provide plt-logo planet-logo - plt-flomap planet-flomap - (only-doc-out (all-defined-out))) - -(define glass-logo-material - (deep-flomap-material-value - 'cubic-zirconia 0.7 0.6 0.4 - 0.2 0.1 1.0 - 0.2 0.1 0.1 - 0.0)) - -(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) - (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))) - -(define logo-red-color (make-object color% 255 36 32)) -(define logo-blue-color (make-object color% 32 36 255)) -(define lambda-outline-color (make-object color% 16 16 64)) -(define (lambda-pen color width) (make-object pen% color width 'solid 'projecting 'miter)) - -(define (make-arc-path x y w h start end [ccw? #t]) - (define p (new dc-path%)) - (send p arc x y w h start end ccw?) - (send p close) - p) - -(define (make-random-flomap c w h) - (build-flomap c w h (λ (k x y i) (random)))) - -(define (flomap-rough fm z-amt) - (match-define (flomap _ c w h) fm) - (fm+ fm (fm* z-amt (make-random-flomap c w h)))) - -(defproc (plt-flomap [height (and/c rational? (>=/c 0)) 256]) flomap? - (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)) - - (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))] - [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 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)) - -(defproc (planet-flomap [height (and/c rational? (>=/c 0)) 256]) flomap? - (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 'add earth-dfm indent-dfm)]) - (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 plt-logo (compose flomap->bitmap plt-flomap)) -(define planet-logo (compose flomap->bitmap planet-flomap)) diff --git a/collects/images/scribblings/compile-time.scrbl b/collects/images/scribblings/compile-time.scrbl index 677b1da753..cc3c4dabb9 100644 --- a/collects/images/scribblings/compile-time.scrbl +++ b/collects/images/scribblings/compile-time.scrbl @@ -9,3 +9,5 @@ @title{Embedding Bitmaps in Compiled Files} @author{@(author+email "Neil Toronto" (author-email))} + +@defmodule[images/compile-time] diff --git a/collects/images/scribblings/icons.scrbl b/collects/images/scribblings/icons.scrbl index 383c8ee5b3..d102816c5f 100644 --- a/collects/images/scribblings/icons.scrbl +++ b/collects/images/scribblings/icons.scrbl @@ -31,6 +31,8 @@ @(define icons-eval (make-base-eval)) @interaction-eval[#:eval icons-eval (require racket/class racket/draw racket/math racket/list)] +@;==================================================================================================== + @section{What is an icon?} @margin-note*{This section describes an ideal that DrRacket and its tools are steadily approaching.} @@ -58,6 +60,8 @@ especially for new users and people with certain forms of color-blindness, and t As another example, the Check Syntax icon @(check-syntax-icon 16) connotes inspecting and passing. Note that the check mark is also the color of syntax. +@;==================================================================================================== + @section{About These Icons} The icons in this collection are designed to be composed to create new ones: they are simple, thematically consistent, and can be constructed in any size and color. @@ -80,6 +84,11 @@ See the @racket[plt-logo] and @racket[planet-logo] functions for more striking e When the rendering API is stable enough to publish, it will allow anyone who can draw a shape to turn that shape into a visually consistent icon. +As with any sort of rendering (such as @link["http://en.wikipedia.org/wiki/Scalable_Vector_Graphics"]{SVG} rendering), ray tracing takes time. +For icons, this usually happens during tool or application start up. +You can reduce the portion of start-up time taken by rendering to almost nothing by using the @racketmodname[images/compile-time] library to embed bitmaps directly into compiled modules. + +@;==================================================================================================== @section{Icon Style} @@ -139,7 +148,8 @@ It has the high refractive index of @link["http://en.wikipedia.org/wiki/Cubic_zi The ``glassy look'' cannot actually be achieved using glass. Metal reflects the most, its @link["http://en.wikipedia.org/wiki/Specular_highlight"]{specular highlight} is nearly the same color as the material (in the others, the highlight is white), -and it diffuses much more ambient light than directional. This is because, while plastic and glass mostly reflect light directly, metal mostly absorbs light and re-emits it. +and it diffuses much more ambient light than directional. +This is because, while plastic and glass mostly reflect light directly, metal mostly absorbs light and re-emits it. @examples[#:eval icons-eval (require images/icons/misc) @@ -154,6 +164,8 @@ The material used for rendering most icons and icon parts. There are exceptions; for example, the @racket[floppy-disk-icon] always renders the sliding cover in metal. } +@;==================================================================================================== + @section[#:tag "arrows"]{Arrow Icons} @defmodule[images/icons/arrow] @@ -163,6 +175,7 @@ There are exceptions; for example, the @racket[floppy-disk-icon] always renders @doc-apply[left-arrow-icon] @doc-apply[up-arrow-icon] @doc-apply[down-arrow-icon]{ +Standard directional arrows. @examples[#:eval icons-eval (list (right-arrow-icon syntax-icon-color (toolbar-icon-height)) (left-arrow-icon run-icon-color) @@ -174,6 +187,7 @@ There are exceptions; for example, the @racket[floppy-disk-icon] always renders @doc-apply[left-over-arrow-icon] @doc-apply[right-under-arrow-icon] @doc-apply[left-under-arrow-icon]{ +Standard bent arrows. @examples[#:eval icons-eval (list (right-over-arrow-icon metal-icon-color (toolbar-icon-height)) (left-over-arrow-icon dark-metal-icon-color) @@ -181,43 +195,32 @@ There are exceptions; for example, the @racket[floppy-disk-icon] always renders (left-under-arrow-icon "lightgreen" 44 glass-icon-material))] } +@;==================================================================================================== + @section[#:tag "control"]{Control Icons} @defmodule[images/icons/control] @interaction-eval[#:eval icons-eval (require images/icons/control)] -@doc-apply[play-icon] -@doc-apply[back-icon] -@doc-apply[fast-forward-icon] -@doc-apply[rewind-icon] -@doc-apply[bar-icon] -@doc-apply[stop-icon] -@doc-apply[record-icon] -@doc-apply[pause-icon] -@doc-apply[step-icon] -@doc-apply[step-back-icon] -@doc-apply[continue-icon] -@doc-apply[continue-back-icon]{ -Typical ``playback control'' icons. -For example, a colorful tape deck: -@interaction[#:eval icons-eval - (for/list ([make-icon (list rewind-icon continue-back-icon - step-back-icon back-icon - pause-icon stop-icon - play-icon step-icon - continue-icon fast-forward-icon - record-icon)] - [color (list run-icon-color halt-icon-color - syntax-icon-color metal-icon-color - dark-metal-icon-color dark-metal-icon-color - metal-icon-color syntax-icon-color - halt-icon-color run-icon-color - "red")] - [material (in-cycle (list plastic-icon-material - glass-icon-material))]) - (make-icon color 32 material))] -The remaining icon @(bar-icon "red" 16), returned by @racket[bar-icon], is used to build the others. +@doc-apply[bar-icon]{ +@examples[#:eval icons-eval (bar-icon run-icon-color 32)] +This is not a ``control'' icon @italic{per se}, but is used to make many others. } +@doc-apply[play-icon]{ @examples[#:eval icons-eval (play-icon run-icon-color 32)] } +@doc-apply[back-icon]{ @examples[#:eval icons-eval (back-icon run-icon-color 32)] } +@doc-apply[fast-forward-icon]{ @examples[#:eval icons-eval (fast-forward-icon syntax-icon-color 32)] } +@doc-apply[rewind-icon]{ @examples[#:eval icons-eval (rewind-icon syntax-icon-color 32)] } +@doc-apply[stop-icon]{ @examples[#:eval icons-eval (stop-icon halt-icon-color 32)] } +@doc-apply[record-icon]{ @examples[#:eval icons-eval (record-icon "red" 32)] } +@doc-apply[pause-icon]{ @examples[#:eval icons-eval (pause-icon halt-icon-color 32)] } +@doc-apply[step-icon]{ @examples[#:eval icons-eval (step-icon run-icon-color 32)] } +@doc-apply[step-back-icon]{ @examples[#:eval icons-eval (step-back-icon run-icon-color 32)] } +@doc-apply[continue-forward-icon]{ @examples[#:eval icons-eval (continue-forward-icon run-icon-color 32)] } +@doc-apply[continue-backward-icon]{ @examples[#:eval icons-eval (continue-backward-icon run-icon-color 32)] } +@doc-apply[search-forward-icon]{ @examples[#:eval icons-eval (search-forward-icon syntax-icon-color 32)] } +@doc-apply[search-backward-icon]{ @examples[#:eval icons-eval (search-backward-icon syntax-icon-color 32)] } + +@;==================================================================================================== @section[#:tag "file"]{File Icons} @@ -240,6 +243,8 @@ The remaining icon @(bar-icon "red" 16), returned by @racket[bar-icon], is used (make-icon syntax-icon-color color 32))] } +@;==================================================================================================== + @section[#:tag "misc"]{Miscellaneous Icons} @defmodule[images/icons/misc] @@ -316,6 +321,16 @@ Equivalent to @racket[(regular-polygon-icon 8 (/ (* 2 pi) 16) color height mater (stop-signs-icon halt-icon-color 32 plastic-icon-material)] } +@doc-apply[foot-icon]{ +@examples[#:eval icons-eval + (foot-icon "chocolate" 32 glass-icon-material)] +} + +@doc-apply[lambda-icon]{ +@examples[#:eval icons-eval + (lambda-icon light-metal-icon-color 32 metal-icon-material)] +} + @doc-apply[magnifying-glass-icon]{ @examples[#:eval icons-eval (magnifying-glass-icon light-metal-icon-color "lightblue" 32 @@ -337,6 +352,8 @@ Equivalent to @racket[(regular-polygon-icon 8 (/ (* 2 pi) 16) color height mater (left-bomb-icon metal-icon-color dark-metal-icon-color 32)] } +@;==================================================================================================== + @section[#:tag "stickman"]{Stickman Icons} @defmodule[images/icons/stickman] @@ -368,6 +385,8 @@ The stickman's joint angles are defined by continuous periodic functions, so the The cycle is modeled after the run cycle of the player's avatar in the Commodore 64 game @link["http://en.wikipedia.org/wiki/Impossible_Mission"]{Impossible Mission}. } +@;==================================================================================================== + @section[#:tag "tool"]{Tool Icons} @defmodule[images/icons/tool] diff --git a/collects/images/scribblings/logos.scrbl b/collects/images/scribblings/logos.scrbl index d3917d2b60..8701378f93 100644 --- a/collects/images/scribblings/logos.scrbl +++ b/collects/images/scribblings/logos.scrbl @@ -18,19 +18,23 @@ @doc-apply[plt-logo]{ Returns the PLT logo, rendered in tinted glass and azure metal by the ray tracer that renders icons. - @examples[#:eval logos-eval (plt-logo)] - -A 256×256 (default height) rendering is compiled into the @racketmodname[images/logos] module using @racket[compiled-bitmap], meaning that constructing the logo at that size and smaller is cheap. -In fact, constructing the logo at the default height is essentially free because it does not need to be downscaled. +The default height is the size used for DrRacket splash screen. } @doc-apply[planet-logo]{ Returns an unofficial PLaneT logo. This is used as the PLaneT icon when DrRacket downloads PLaneT packages. - @examples[#:eval logos-eval (planet-logo) (planet-logo (default-icon-height))] - -As with the @racket[plt-logo], a default-height rendering is compiled into the @racketmodname[images/logos] module for performance reasons. +} + +@doc-apply[stepper-logo]{ +An algebraic stepper logo. +@examples[#:eval logos-eval (stepper-logo)] +} + +@doc-apply[macro-stepper-logo]{ +A macro stepper logo. +@examples[#:eval logos-eval (macro-stepper-logo)] } diff --git a/collects/images/scribblings/running-stickman.gif b/collects/images/scribblings/running-stickman.gif index 79d9de52ee..3c1b9b8f1d 100644 Binary files a/collects/images/scribblings/running-stickman.gif and b/collects/images/scribblings/running-stickman.gif differ diff --git a/collects/macro-debugger/info.rkt b/collects/macro-debugger/info.rkt index 707bf67915..8af28138a0 100644 --- a/collects/macro-debugger/info.rkt +++ b/collects/macro-debugger/info.rkt @@ -2,4 +2,5 @@ (define drracket-tools '(["tool.rkt"])) (define drracket-tool-names '("Macro Stepper")) +(define drracket-tool-icons (list '("macro-stepper-32x32.png" "icons"))) (define scribblings '(("macro-debugger.scrbl" () (tool-library)))) diff --git a/collects/macro-debugger/view/stepper.rkt b/collects/macro-debugger/view/stepper.rkt index f35c65c9f1..c9e156e2ee 100644 --- a/collects/macro-debugger/view/stepper.rkt +++ b/collects/macro-debugger/view/stepper.rkt @@ -15,10 +15,33 @@ "gui-util.rkt" "../syntax-browser/util.rkt" unstable/gui/notify + images/compile-time + images/gui + (for-syntax racket/base + images/icons/arrow images/icons/control images/logos + images/icons/style) (only-in mzscheme [#%top-interaction mz-top-interaction])) (provide macro-stepper-widget% macro-stepper-widget/process-mixin) +;; Compiled-in assets (button icons) + +(define navigate-up-icon + (compiled-bitmap (up-arrow-icon syntax-icon-color (toolbar-icon-height)))) +(define navigate-to-start-icon + (compiled-bitmap (search-backward-icon syntax-icon-color (toolbar-icon-height)))) +(define navigate-previous-icon + (compiled-bitmap (step-back-icon syntax-icon-color (toolbar-icon-height)))) +(define navigate-next-icon + (compiled-bitmap (step-icon syntax-icon-color (toolbar-icon-height)))) +(define navigate-to-end-icon + (compiled-bitmap (search-forward-icon syntax-icon-color (toolbar-icon-height)))) +(define navigate-down-icon + (compiled-bitmap (down-arrow-icon syntax-icon-color (toolbar-icon-height)))) + +(define small-logo (compiled-bitmap (macro-stepper-logo 32))) +(define large-logo (compiled-bitmap (macro-stepper-logo))) + ;; Macro Stepper ;; macro-stepper-widget% @@ -112,9 +135,14 @@ (new vertical-panel% (parent superarea) (enabled #f))) - (define supernavigator + (define top-panel (new horizontal-panel% (parent area) + (horiz-margin 5) + (stretchable-height #f))) + (define supernavigator + (new horizontal-panel% + (parent top-panel) (stretchable-height #f) (alignment '(center center)))) (define navigator @@ -130,7 +158,25 @@ (stretchable-height #f) (alignment '(left center)) (style '(deleted)))) - + + (define about-dialog + (new logo-about-dialog% + (label "About the Macro Stepper") + (parent frame) + (bitmap large-logo) + (messages '("The Macro Stepper is formalized and proved correct in\n" + "\n" + " Ryan Culpepper and Matthias Felleisen\n" + " Debugging Hygienic Macros\n" + " Science of Computer Programming, July 2010\n")))) + + (define logo-canvas + (new (class bitmap-canvas% + (super-new (parent top-panel) (bitmap small-logo)) + (define/override (on-event evt) + (when (eq? (send evt get-event-type) 'left-up) + (send about-dialog show #t)))))) + (define/i sbview sb:syntax-browser<%> (new stepper-syntax-widget% (parent area) @@ -179,22 +225,22 @@ (lambda (_) (update/preserve-view))) (define nav:up - (new button% (label "Previous term") (parent navigator) + (new button% (label (list navigate-up-icon "Previous term" 'left)) (parent navigator) (callback (lambda (b e) (navigate-up))))) (define nav:start - (new button% (label "<-- Start") (parent navigator) + (new button% (label (list navigate-to-start-icon "Start" 'left)) (parent navigator) (callback (lambda (b e) (navigate-to-start))))) (define nav:previous - (new button% (label "<- Step") (parent navigator) + (new button% (label (list navigate-previous-icon "Step" 'left)) (parent navigator) (callback (lambda (b e) (navigate-previous))))) (define nav:next - (new button% (label "Step ->") (parent navigator) + (new button% (label (list navigate-next-icon "Step" 'right)) (parent navigator) (callback (lambda (b e) (navigate-next))))) (define nav:end - (new button% (label "End -->") (parent navigator) + (new button% (label (list navigate-to-end-icon "End" 'right)) (parent navigator) (callback (lambda (b e) (navigate-to-end))))) (define nav:down - (new button% (label "Next term") (parent navigator) + (new button% (label (list navigate-down-icon "Next term" 'right)) (parent navigator) (callback (lambda (b e) (navigate-down))))) (define nav:text diff --git a/collects/stepper/drracket-button.rkt b/collects/stepper/drracket-button.rkt index 0cc450fe04..cd1866fb2d 100644 --- a/collects/stepper/drracket-button.rkt +++ b/collects/stepper/drracket-button.rkt @@ -7,5 +7,5 @@ (define stepper-drracket-button (list (string-constant stepper-button-label) - x:foot-img/horizontal + x:step-img (λ (drs-frame) (send drs-frame stepper-button-callback)))) diff --git a/collects/stepper/info.rkt b/collects/stepper/info.rkt index 81668d6d12..f56ebf5feb 100644 --- a/collects/stepper/info.rkt +++ b/collects/stepper/info.rkt @@ -4,6 +4,6 @@ (define drracket-tool-names (list "The Stepper")) -(define drracket-tool-icons (list '("foot-up.png" "icons"))) +(define drracket-tool-icons (list '("stepper-32x32.png" "icons"))) (define scribblings '(("scribblings/stepper.scrbl"))) diff --git a/collects/stepper/private/mred-extensions.rkt b/collects/stepper/private/mred-extensions.rkt index ddeb5e03c4..a547b840d5 100644 --- a/collects/stepper/private/mred-extensions.rkt +++ b/collects/stepper/private/mred-extensions.rkt @@ -5,11 +5,12 @@ (prefix-in f: framework) mzlib/pretty #;"testing-shared.rkt" - "shared.rkt") + "shared.rkt" + images/compile-time + (for-syntax images/icons/control images/icons/style)) (provide - foot-img/horizontal - foot-img/vertical + step-img stepper-canvas% stepper-text% snip? @@ -516,14 +517,8 @@ (strip-regular stx)) -;; the bitmap to use in a horizontal toolbar: -(define foot-img/horizontal (make-object bitmap% (build-path (collection-path - "icons") "foot.png") 'png/mask)) - -;; the bitmap to use in a vertical toolbar: -(define foot-img/vertical (make-object bitmap% (build-path (collection-path - "icons") "foot-up.png") 'png/mask)) - +;; the bitmap to use in a horizontal or vertical toolbar: +(define step-img (compiled-bitmap (step-icon run-icon-color (toolbar-icon-height)))) ;; testing code diff --git a/collects/stepper/private/view-controller.rkt b/collects/stepper/private/view-controller.rkt index 2a91ac4aff..8c258cccdc 100644 --- a/collects/stepper/private/view-controller.rkt +++ b/collects/stepper/private/view-controller.rkt @@ -14,7 +14,10 @@ (prefix-in x: "mred-extensions.rkt") "shared.rkt" "model-settings.rkt" - "xml-sig.rkt") + "xml-sig.rkt" + images/compile-time + images/gui + (for-syntax racket/base images/icons/control images/icons/style images/logos)) (import drracket:tool^ xml^ stepper-frame^) @@ -214,20 +217,50 @@ ;; GUI ELEMENTS: (define s-frame (make-object stepper-frame% drracket-tab)) + + (define top-panel + (new horizontal-panel% [parent (send s-frame get-area-container)] [horiz-margin 5] + ;[style '(border)] ; for layout testing only + [stretchable-width #t] + [stretchable-height #f])) + (define button-panel - (make-object horizontal-panel% (send s-frame get-area-container))) - (define (add-button name fun) - (new button% - [label name] - [parent button-panel] - [callback (lambda (_1 _2) (fun))] - [enabled #f])) - (define (add-choice-box name fun) - (new choice% [label name] - [choices (map first pulldown-choices)] - [parent button-panel] - [callback fun] - [enabled #f])) + (new horizontal-panel% [parent top-panel] [alignment '(center top)] + ;[style '(border)] ; for layout testing only + [stretchable-width #t] + [stretchable-height #f])) + + (define about-dialog + (new logo-about-dialog% + [label "About the Stepper"] + [parent s-frame] + [bitmap (compiled-bitmap (stepper-logo))] + [messages '("The Algebraic Stepper is formalized and proved correct in\n" + "\n" + " John Clements, Matthew Flatt, Matthias Felleisen\n" + " Modeling an Algebraic Stepper\n" + " European Symposium on Programming, 2001\n")])) + + (define logo-canvas + (new (class bitmap-canvas% + (super-new [parent top-panel] [bitmap (compiled-bitmap (stepper-logo 32))]) + (define/override (on-event evt) + (when (eq? (send evt get-event-type) 'left-up) + (send about-dialog show #t)))))) + + (define prev-img (compiled-bitmap (step-back-icon run-icon-color (toolbar-icon-height)))) + (define previous-button (new button% + [label (list prev-img (string-constant stepper-previous) 'left)] + [parent button-panel] + [callback (λ (_1 _2) (previous))] + [enabled #f])) + + (define next-img (compiled-bitmap (step-icon run-icon-color (toolbar-icon-height)))) + (define next-button (new button% + [label (list next-img (string-constant stepper-next) 'right)] + [parent button-panel] + [callback (λ (_1 _2) (next))] + [enabled #f])) (define pulldown-choices `((,(string-constant stepper-jump-to-beginning) ,jump-to-beginning) @@ -236,10 +269,12 @@ (,(string-constant stepper-jump-to-next-application) ,jump-to-next-application) (,(string-constant stepper-jump-to-previous-application) ,jump-to-prior-application))) - (define previous-button (add-button (string-constant stepper-previous) previous)) - (define next-button (add-button (string-constant stepper-next) next)) - (define jump-button (add-choice-box (string-constant stepper-jump) jump-to)) - + (define jump-button (new choice% + [label (string-constant stepper-jump)] + [choices (map first pulldown-choices)] + [parent button-panel] + [callback jump-to] + [enabled #f])) (define canvas (make-object x:stepper-canvas% (send s-frame get-area-container))) @@ -252,6 +287,7 @@ (new editor-canvas% [parent button-panel] [editor status-text] + [stretchable-width #f] [style '(transparent no-border no-hscroll no-vscroll)] ;; some way to get the height of a line of text? [min-width 100])) @@ -332,8 +368,6 @@ ;; CONFIGURE GUI ELEMENTS (send s-frame set-printing-proc print-current-view) - (send button-panel stretchable-width #f) - (send button-panel stretchable-height #f) (send canvas stretchable-height #t) (send (send s-frame edit-menu:get-undo-item) enable #f) (send (send s-frame edit-menu:get-redo-item) enable #f) diff --git a/collects/stepper/stepper-tool.rkt b/collects/stepper/stepper-tool.rkt index 369bb6294d..85c0b3bcb8 100644 --- a/collects/stepper/stepper-tool.rkt +++ b/collects/stepper/stepper-tool.rkt @@ -182,8 +182,7 @@ (new switchable-button% [parent stepper-button-parent-panel] [label (string-constant stepper-button-label)] - [bitmap x:foot-img/horizontal] - [alternate-bitmap x:foot-img/vertical] + [bitmap x:step-img] [callback (lambda (dont-care) (send (get-current-tab) stepper-button-callback))])) diff --git a/collects/string-constants/private/danish-string-constants.rkt b/collects/string-constants/private/danish-string-constants.rkt index 342eb03c7d..e9db75e5a3 100644 --- a/collects/string-constants/private/danish-string-constants.rkt +++ b/collects/string-constants/private/danish-string-constants.rkt @@ -1125,10 +1125,10 @@ please adhere to these guidelines: (stepper-language-level-message "Sprogniveauet er sat til \"~a\". Indtil videre virker stepperen kun for sprogniveauerne fra \"~a\" til \"~a\".") (stepper-button-label "Step") - (stepper-previous-application "|< Funktionskald") - (stepper-previous "< Step") - (stepper-next "Step >") - (stepper-next-application "Funktionskald >|") + (stepper-previous-application "Funktionskald") + (stepper-previous "Step") + (stepper-next "Step") + (stepper-next-application "Funktionskald") (stepper-jump-to-beginning "Hjem") (debug-tool-button-name "Debug") diff --git a/collects/string-constants/private/english-string-constants.rkt b/collects/string-constants/private/english-string-constants.rkt index e908cd8d94..50d7194fd5 100644 --- a/collects/string-constants/private/english-string-constants.rkt +++ b/collects/string-constants/private/english-string-constants.rkt @@ -1348,8 +1348,8 @@ please adhere to these guidelines: (stepper-language-level-message "The stepper does not work for language \"~a\".") (stepper-button-label "Step") - (stepper-previous "< Step") - (stepper-next "Step >") + (stepper-previous "Step") + (stepper-next "Step") (stepper-jump "Jump...") (stepper-jump-to-beginning "to beginning") (stepper-jump-to-end "to end") diff --git a/collects/string-constants/private/french-string-constants.rkt b/collects/string-constants/private/french-string-constants.rkt index e9a5f745d1..0f9508de1b 100644 --- a/collects/string-constants/private/french-string-constants.rkt +++ b/collects/string-constants/private/french-string-constants.rkt @@ -1348,8 +1348,8 @@ (stepper-language-level-message "Le Pas à Pas n'est pas disponible pour le langage \"~a\".") (stepper-button-label "Pas") - (stepper-previous "< Pas") - (stepper-next "Pas >") + (stepper-previous "Pas") + (stepper-next "Pas") (stepper-jump "Sauter...") (stepper-jump-to-beginning "au début") (stepper-jump-to-end "à la fin") diff --git a/collects/string-constants/private/german-string-constants.rkt b/collects/string-constants/private/german-string-constants.rkt index ba9718e301..2a78808fae 100644 --- a/collects/string-constants/private/german-string-constants.rkt +++ b/collects/string-constants/private/german-string-constants.rkt @@ -1250,8 +1250,8 @@ "Der Stepper unterstützt die Sprachebene \"~a\" nicht.") (stepper-button-label "Stepper") - (stepper-previous "< Schritt") - (stepper-next "Schritt >") + (stepper-previous "Schritt") + (stepper-next "Schritt") (stepper-jump "Springen...") (stepper-jump-to-beginning "an den Anfang") (stepper-jump-to-end "ans Ende") diff --git a/collects/string-constants/private/japanese-string-constants.rkt b/collects/string-constants/private/japanese-string-constants.rkt index 8712add4f4..881b3e5786 100644 --- a/collects/string-constants/private/japanese-string-constants.rkt +++ b/collects/string-constants/private/japanese-string-constants.rkt @@ -1240,10 +1240,10 @@ please adhere to these guidelines: (stepper-name "ステッパ") (stepper-language-level-message "ステッパは \"~a\" 言語に対しては動作しません") (stepper-button-label "ステップ") - (stepper-previous-application "|< アプリケーション") - (stepper-previous "< ステップ") - (stepper-next "ステップ >") - (stepper-next-application "アプリケーション >|") + (stepper-previous-application "アプリケーション") + (stepper-previous "ステップ") + (stepper-next "ステップ") + (stepper-next-application "アプリケーション") (stepper-jump-to-beginning "ホーム") (stepper-jump-to-end "終端まで") diff --git a/collects/string-constants/private/korean-string-constants.rkt b/collects/string-constants/private/korean-string-constants.rkt index ba06c65c25..4b58fda0ac 100644 --- a/collects/string-constants/private/korean-string-constants.rkt +++ b/collects/string-constants/private/korean-string-constants.rkt @@ -1187,8 +1187,8 @@ (stepper-language-level-message "한 단계씩 실행은 \"~a\" 언어에서 지원하지 않습니다.") (stepper-button-label "한 단계씩 실행") - (stepper-previous "< 이전단계") - (stepper-next "다음단계 >") + (stepper-previous "이전단계") + (stepper-next "다음단계") (stepper-jump "건너뛰기...") (stepper-jump-to-beginning "처음으로") (stepper-jump-to-end "끝으로") diff --git a/collects/string-constants/private/portuguese-string-constants.rkt b/collects/string-constants/private/portuguese-string-constants.rkt index e6a6a46826..ee5f1bb4f6 100644 --- a/collects/string-constants/private/portuguese-string-constants.rkt +++ b/collects/string-constants/private/portuguese-string-constants.rkt @@ -1064,11 +1064,11 @@ please adhere to these guidelines: (stepper-language-level-message "The language level is set to \"~a\". Currently, the stepper works only for the \"~a\" through the \"~a\" language levels.") (stepper-button-label "Step") - (stepper-previous-application "|< Application") - (stepper-previous "< Step") - (stepper-next "Step >") + (stepper-previous-application "Application") + (stepper-previous "Step") + (stepper-next "Step") (stepper-jump-to-beginning "Home") - (stepper-next-application "Application >|") + (stepper-next-application "Application") (dialog-back "Back") diff --git a/collects/string-constants/private/russian-string-constants.rkt b/collects/string-constants/private/russian-string-constants.rkt index 5301f5cbe8..7a815c1aa2 100644 --- a/collects/string-constants/private/russian-string-constants.rkt +++ b/collects/string-constants/private/russian-string-constants.rkt @@ -1252,10 +1252,10 @@ please adhere to these guidelines: (stepper-language-level-message "Пошаговое выполнение не работает для языка \"~a\".") (stepper-button-label "Шаг") - (stepper-previous-application "|< Программа") - (stepper-previous "< Шаг") - (stepper-next "Шаг >") - (stepper-next-application "Программа >|") + (stepper-previous-application "Программа") + (stepper-previous "Шаг") + (stepper-next "Шаг") + (stepper-next-application "Программа") (stepper-jump "Перейти...") ;; this one is changed. action? (stepper-out-of-steps "Вычисления завершены ранее, чем достигнут искомый шаг.") (stepper-no-such-step/title "Шаг не найден") diff --git a/collects/string-constants/private/simplified-chinese-string-constants.rkt b/collects/string-constants/private/simplified-chinese-string-constants.rkt index f81b9244ce..1777adae93 100644 --- a/collects/string-constants/private/simplified-chinese-string-constants.rkt +++ b/collects/string-constants/private/simplified-chinese-string-constants.rkt @@ -1145,10 +1145,10 @@ (stepper-name "单步执行器") (stepper-language-level-message "单步执行不支持语言“~a”。") (stepper-button-label "单步执行") - (stepper-previous-application "|< 调用") - (stepper-previous "< 上一步") - (stepper-next "下一步 >") - (stepper-next-application "调用 >|") + (stepper-previous-application "调用") + (stepper-previous "上一步") + (stepper-next "下一步") + (stepper-next-application "调用") (stepper-jump-to-beginning "源程序") (stepper-jump-to-end "最终运行结果") diff --git a/collects/string-constants/private/spanish-string-constants.rkt b/collects/string-constants/private/spanish-string-constants.rkt index 088117114f..5d7c953035 100644 --- a/collects/string-constants/private/spanish-string-constants.rkt +++ b/collects/string-constants/private/spanish-string-constants.rkt @@ -975,8 +975,10 @@ (stepper-language-level-message "El nivel del lenguaje es \"~a\". Actualmente el Stepper funciona para los niveles \"~a\" al \"~a\".") (stepper-button-label "Paso") - (stepper-previous-application "|< Aplicación") - (stepper-previous "< Paso") + (stepper-previous-application "Aplicación") + (stepper-previous "Paso") + (stepper-next "Paso") + (stepper-next-application "Aplicación") (stepper-jump-to-beginning "Hogar") (dialog-back "Atrás") diff --git a/collects/string-constants/private/traditional-chinese-string-constants.rkt b/collects/string-constants/private/traditional-chinese-string-constants.rkt index ebb4b2db12..a3f20d3a65 100644 --- a/collects/string-constants/private/traditional-chinese-string-constants.rkt +++ b/collects/string-constants/private/traditional-chinese-string-constants.rkt @@ -1142,10 +1142,10 @@ (stepper-name "单步执行器") (stepper-language-level-message "单步执行不支持语言“~a”。") (stepper-button-label "单步执行") - (stepper-previous-application "|< 调用") - (stepper-previous "< 上一步") - (stepper-next "下一步 >") - (stepper-next-application "调用 >|") + (stepper-previous-application "调用") + (stepper-previous "上一步") + (stepper-next "下一步") + (stepper-next-application "调用") (stepper-jump-to-beginning "源程序") (stepper-jump-to-end "最终运行结果") diff --git a/collects/string-constants/private/ukrainian-string-constants.rkt b/collects/string-constants/private/ukrainian-string-constants.rkt index 2bd2247caf..3df2ce191f 100644 --- a/collects/string-constants/private/ukrainian-string-constants.rkt +++ b/collects/string-constants/private/ukrainian-string-constants.rkt @@ -1252,10 +1252,10 @@ please adhere to these guidelines: (stepper-language-level-message "Покрокове виконання не працює для мови \"~a\".") (stepper-button-label "Крок") - (stepper-previous-application "|< Програма") - (stepper-previous "< Крок") - (stepper-next "Крок >") - (stepper-next-application "Програма >|") + (stepper-previous-application "Програма") + (stepper-previous "Крок") + (stepper-next "Крок") + (stepper-next-application "Програма") (stepper-jump "Перейти...") ;; this one is changed. action? (stepper-out-of-steps "Обчислення завершено раніше, ніж досягнуто шуканий крок.") (stepper-no-such-step/title "Крок не знайдено")