From 950f034936a127638b483c12a16855da26b0ba5e Mon Sep 17 00:00:00 2001 From: Neil Toronto Date: Wed, 1 Feb 2012 09:54:25 -0700 Subject: [PATCH] Pushing unfinished but stable flomap transforms so Matthew can debug a segfault --- collects/images/icons/misc.rkt | 123 +++++++++++++++++- collects/images/logos.rkt | 124 ++++++++++++++++++- collects/images/private/flomap-transform.rkt | 75 ++++++++++- 3 files changed, 315 insertions(+), 7 deletions(-) diff --git a/collects/images/icons/misc.rkt b/collects/images/icons/misc.rkt index b6a47b7d60..b569f1397f 100644 --- a/collects/images/icons/misc.rkt +++ b/collects/images/icons/misc.rkt @@ -19,7 +19,9 @@ bomb-icon bomb-flomap left-bomb-icon left-bomb-flomap clock-icon clock-flomap - stopwatch-icon stopwatch-flomap) + stopwatch-icon stopwatch-flomap + stethoscope-icon stethoscope-flomap + short-stethoscope-icon short-stethoscope-flomap) (only-doc-out (all-defined-out))) (define (flat-regular-polygon-flomap sides start color size) @@ -253,7 +255,7 @@ ) flomap? (flomap-flip-horizontal (left-bomb-flomap cap-color bomb-color height material))) -;; =================================================================================================== +;; --------------------------------------------------------------------------------------------------- ;; Clock (define clock-shell-material @@ -373,6 +375,117 @@ metal-icon-material)) (flomap-pin* 1/2 0 1/2 -2/32 buttons-fm clock-fm))) +;; --------------------------------------------------------------------------------------------------- +;; Stethoscopes + +(define rubber-t-commands + '((m 6 13) + (c 0 6 3 7.5 9.5 7.5 + 6.5 0 9.5 -1.5 9.5 -7.5))) + +(define rubber-hose-commands + '((m 15 21.25) + (c 0 0 1 3.5 -3 4.5 + -4 1 -7 -8.5 -10.5 -3.5 + -3.5 5 4.0182351 8.2793 11 8 + 6.981765 -0.2793 13 -4.5 13 -4.5))) + +(define left-metal-commands + '((m 6 1.5) + (c -4 2 0 5.5 0 11.5))) + +(define right-metal-commands + '((m 25 1.5) + (c 4 2 0 5.5 0 11.5))) + +(define rubber-material + (deep-flomap-material-value + 'cubic-zirconia 2.0 0.0 1.0 + 1.5 0.25 1.0 + 0.25 0.5 0.0 + 0.03)) + +(defproc (stethoscope-flomap [color (or/c string? (is-a?/c color%)) "black"] + [height (and/c rational? (>=/c 0)) (default-icon-height)]) flomap? + (define scale (/ height 32)) + (flomap-ct-superimpose + (draw-rendered-icon-flomap + 32 32 (λ (dc) + (send dc set-pen (make-object pen% color 2 'solid 'round 'round)) + (send dc set-brush "white" 'transparent) + (draw-path-commands dc rubber-hose-commands 0 0) + (draw-path-commands dc rubber-t-commands 0 0) + (send dc set-pen (make-object pen% "black" 3 'solid 'round 'round)) + (send dc draw-line 23.5 1 25 1.5) + (send dc draw-line 7.5 1 6 1.5)) + scale + rubber-material) + (draw-rendered-icon-flomap + 32 32 (λ (dc) + (send dc set-pen (make-object pen% dark-metal-icon-color 2.5 'solid 'round 'round)) + (send dc set-brush "white" 'transparent) + (draw-path-commands dc left-metal-commands 0 0) + (draw-path-commands dc right-metal-commands 0 0) + (send dc set-pen (make-object pen% metal-icon-color 2 'solid 'round 'round)) + (draw-path-commands dc left-metal-commands 0 0) + (draw-path-commands dc right-metal-commands 0 0) + (set-icon-pen dc dark-metal-icon-color 0.5 'solid) + (send dc set-brush metal-icon-color 'solid) + (draw-ellipse/smoothed dc 21.25 21.25 11 11) + (set-icon-pen dc dark-metal-icon-color 0.25 'solid) + (send dc set-brush light-metal-icon-color 'solid) + (draw-ellipse/smoothed dc 22.25 22.25 9 9)) + scale + metal-icon-material))) + +(define short-rubber-t-commands + '((m 3 12.5) + (c 0 6 10 6.5 12.5 6.5 + 2.5 0 12.5 -0.5 12.5 -6.5))) + +(define short-rubber-hose-commands + '((m 15 19.25) + (c 0 0 -3 1 -10 1 + -7 0 -6.5 4.5 6 4 + 12.5 -0.5 14.5 -5 14.5 -5))) + +(defproc (short-stethoscope-flomap [color (or/c string? (is-a?/c color%)) "black"] + [height (and/c rational? (>=/c 0)) (default-icon-height)] + ) flomap? + (define scale (/ height 32)) + (flomap-ct-superimpose + (draw-rendered-icon-flomap + 32 32 (λ (dc) + (send dc translate 0 6) + (send dc set-pen (make-object pen% color 2 'solid 'round 'round)) + (send dc set-brush "white" 'transparent) + (draw-path-commands dc short-rubber-hose-commands 0 0) + (draw-path-commands dc short-rubber-t-commands 0 0) + (send dc set-pen (make-object pen% "black" 3 'solid 'round 'round)) + (send dc draw-line 4.5 1 3 1.5) + (send dc draw-line 26.5 1 28 1.5)) + scale + rubber-material) + (draw-rendered-icon-flomap + 32 32 (λ (dc) + (send dc translate 0 6) + (send dc set-pen (make-object pen% dark-metal-icon-color 2.5 'solid 'round 'round)) + (send dc set-brush "white" 'transparent) + (draw-path-commands dc left-metal-commands -3 0) + (draw-path-commands dc right-metal-commands 3 0) + (send dc set-pen (make-object pen% metal-icon-color 2 'solid 'round 'round)) + (draw-path-commands dc left-metal-commands -3 0) + (draw-path-commands dc right-metal-commands 3 0) + (set-icon-pen dc dark-metal-icon-color 0.5 'solid) + (send dc set-brush metal-icon-color 'solid) + (draw-ellipse/smoothed dc 21.25 15.25 11 11) + (set-icon-pen dc dark-metal-icon-color 0.25 'solid) + (send dc set-brush light-metal-icon-color 'solid) + (draw-ellipse/smoothed dc 22.25 16.25 9 9) + ) + scale + metal-icon-material))) + ;; =================================================================================================== ;; Bitmaps (icons) @@ -417,3 +530,9 @@ [material deep-flomap-material-value? (default-icon-material)]) [bomb-icon bomb-flomap] [left-bomb-icon left-bomb-flomap]) + +(define-icon-wrappers + ([color (or/c string? (is-a?/c color%)) "black"] + [height (and/c rational? (>=/c 0)) (default-icon-height)]) + [stethoscope-icon stethoscope-flomap] + [short-stethoscope-icon short-stethoscope-flomap]) diff --git a/collects/images/logos.rkt b/collects/images/logos.rkt index 05cb4cbd76..6a576484c0 100644 --- a/collects/images/logos.rkt +++ b/collects/images/logos.rkt @@ -12,10 +12,14 @@ (provide (activate-contract-out plt-logo plt-flomap planet-logo planet-flomap + racket-logo racket-flomap stepper-logo stepper-flomap macro-stepper-logo macro-stepper-logo-flomap) (only-doc-out (all-defined-out))) +;; =================================================================================================== +;; PLT logo + (define glass-logo-material (deep-flomap-material-value 'cubic-zirconia 0.7 0.6 0.4 @@ -156,6 +160,9 @@ fm)]) fm))) +;; =================================================================================================== +;; Planet logo + (define continents-path-commands '((m 11.526653 18.937779) (c 0.05278 0.724075 1.940414 1.202607 0.678885 2.296248 @@ -254,7 +261,7 @@ (make-cached-flomap [height] (define scale (/ height 32)) - (define-values (earth-fm earth-z) + (define earth-fm (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))] @@ -268,8 +275,7 @@ [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)))) + (deep-flomap-render-icon earth-dfm water-logo-material))) (define land-fm (let* ([land-fm (continents-flomap logo-continents-color height)] @@ -291,24 +297,134 @@ earth-fm land-fm))) +;; =================================================================================================== +;; Algebraic stepper logo + (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))) +;; =================================================================================================== +;; Macro stepper logo + (defproc (macro-stepper-logo-flomap [height (and/c rational? (>=/c 0)) 96]) flomap? (flomap-pin* 1/2 20/32 15/36 1/2 (foot-flomap (make-object color% 34 42 160) height glass-icon-material) (hash-quote-flomap light-metal-icon-color (* 1/2 height) metal-icon-material))) +;; =================================================================================================== +;; Racket logo + +(define racket-r-commands + (scale-path-commands + '((m 4 76) + (c 12 28 20 56 28 92 + 5.560411 25.02185 4 44.00002 12 76.00002 + 20 0 39.835333 -8 56 -24 + -20 -36.00004 -28 -72.00002 -28 -108.00002 + 60 -40 96 -44 144 -40 + 6 -12 16.19861 -35.94773 16 -48 + -60 -4 -112 4 -168 48 + -1 -12 -0.958295 -20 0 -28 + -28 4 -44 12 -60 32)) + 1/8 1/8)) + +(define (racket-r-flomap color height) + (draw-icon-flomap + 32 32 (λ (dc) + (set-icon-pen dc lambda-outline-color 3/8 'solid) + (send dc set-brush color 'solid) + (draw-path-commands dc racket-r-commands 0 0)) + (/ height 32))) + +(define racket-sphere-material + (deep-flomap-material-value + 'cubic-zirconia 0.75 0.75 0.75 + 3.5 0.25 0.25 + 0.5 0.25 0.0 + 0.01)) + +(defproc (racket-flomap [height (and/c rational? (>=/c 0)) 256]) flomap? + (make-cached-flomap + [height] + (define scale (/ height 32)) + (define sphere-fm + (let* ([indent-fm (racket-r-flomap lambda-outline-color height)] + [indent-dfm (flomap->deep-flomap indent-fm)] + [indent-dfm (deep-flomap-raise indent-dfm (* -1.5 scale))] + [indent-dfm (deep-flomap-smooth-z indent-dfm (* 0.5 scale))] + [sphere-fm (draw-icon-flomap + 32 32 (λ (dc) + (define top-rgn (make-object region% dc)) + (send top-rgn set-polygon + '((0 . 0) (31 . 0) (31 . 4) (5 . 13) (8 . 31) (0 . 31))) + + (send dc set-pen logo-blue-color 1/2 'solid) + (send dc set-brush logo-blue-color 'solid) + (draw-ellipse/smoothed dc 0.75 0.75 30.5 30.5) + + (send dc set-clipping-region top-rgn) + (send dc set-pen logo-red-color 1/2 'solid) + (send dc set-brush logo-red-color 'solid) + (draw-ellipse/smoothed dc 0.75 0.75 30.5 30.5)) + scale)] + [sphere-dfm (flomap->deep-flomap sphere-fm)] + [sphere-dfm (deep-flomap-bulge-spheroid sphere-dfm (* 14 scale))] + [sphere-dfm (deep-flomap-raise sphere-dfm (* 0 scale))] + [sphere-dfm (deep-flomap-cc-superimpose 'add sphere-dfm indent-dfm)]) + (deep-flomap-render-icon sphere-dfm glass-logo-material))) + + (define r-fm + (let* ([r-fm (racket-r-flomap light-metal-icon-color height)] + [r-dfm (flomap->deep-flomap r-fm)] + ;[r-dfm (deep-flomap-emboss r-dfm (* 2 scale) (* 8 scale))] + [r-dfm (deep-flomap-bulge-round r-dfm (* 48 scale))] + [r-dfm (deep-flomap-smooth-z r-dfm (* 1/2 scale))]) + (deep-flomap-render-icon r-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) + sphere-fm + r-fm))) + +;; =================================================================================================== +;; Bitmaps + (define-icon-wrappers ([height (and/c rational? (>=/c 0)) 256]) - [plt-logo plt-flomap]) + [plt-logo plt-flomap] + [racket-logo racket-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]) + + +#| +(define steth-flomap + (short-stethoscope-flomap (make-object color% 16 32 48) 256)) + +(define drracket-logo1 + (flomap->bitmap + (flomap-cc-superimpose (plt-flomap 256) steth-flomap))) + +drracket-logo1 + +(define drracket-logo2 + (flomap->bitmap + (flomap-ct-superimpose (racket-flomap 212) steth-flomap))) + +drracket-logo2 +|# diff --git a/collects/images/private/flomap-transform.rkt b/collects/images/private/flomap-transform.rkt index f9d3860a25..9022162d56 100644 --- a/collects/images/private/flomap-transform.rkt +++ b/collects/images/private/flomap-transform.rkt @@ -7,7 +7,10 @@ "flomap-struct.rkt") (provide flomap-flip-horizontal flomap-flip-vertical flomap-transpose - flomap-cw-rotate flomap-ccw-rotate) + flomap-cw-rotate flomap-ccw-rotate + invertible-2d-function Flomap-Transform + flomap-transform rotate-transform + ) (: flomap-flip-horizontal (flomap -> flomap)) (define (flomap-flip-horizontal fm) @@ -38,3 +41,73 @@ (define w-1 (fx- w 1)) (inline-build-flomap c h w (λ (k x y _i) (unsafe-flvector-ref vs (coords->index c w k y (fx- w-1 x)))))) + +(struct: invertible-2d-function ([f : (Flonum Flonum -> (values Flonum Flonum))] + [g : (Flonum Flonum -> (values Flonum Flonum))])) + +(define-type Flomap-Transform (Integer Integer -> invertible-2d-function)) + +(: flomap-transform (case-> (flomap Flomap-Transform -> flomap) + (flomap Flomap-Transform Real Real Real Real -> flomap))) +(define flomap-transform + (case-lambda + [(fm t) + (match-define (flomap vs c w h) fm) + (match-define (invertible-2d-function f g) (t w h)) + (define x-min +inf.0) + (define x-max -inf.0) + (define y-min +inf.0) + (define y-max -inf.0) + (let: y-loop : Void ([y : Integer 0]) + (when (y . fx< . h) + (let: x-loop : Void ([x : Integer 0]) + (cond [(x . fx< . w) + (define-values (new-x new-y) (f (+ 0.5 (fx->fl x)) (+ 0.5 (fx->fl y)))) + (when (new-x . < . x-min) (set! x-min new-x)) + (when (new-x . > . x-max) (set! x-max new-x)) + (when (new-y . < . y-min) (set! y-min new-y)) + (when (new-y . > . y-max) (set! y-max new-y)) + (x-loop (fx+ x 1))] + [else + (y-loop (fx+ y 1))])))) + (flomap-transform fm t (- x-min 0.5) (+ x-max 0.5) (- y-min 0.5) (+ y-max 0.5))] + [(fm t x-min x-max y-min y-max) + (let ([x-min (exact->inexact x-min)] + [x-max (exact->inexact x-max)] + [y-min (exact->inexact y-min)] + [y-max (exact->inexact y-max)]) + (match-define (flomap vs c w h) fm) + (match-define (invertible-2d-function f g) (t w h)) + (define int-x-min (fl->fx (floor x-min))) + (define int-x-max (fl->fx (ceiling x-max))) + (define int-y-min (fl->fx (floor y-min))) + (define int-y-max (fl->fx (ceiling y-max))) + (define new-w (- int-x-max int-x-min)) + (define new-h (- int-y-max int-y-min)) + (define x-offset (+ 0.5 (fx->fl int-x-min))) + (define y-offset (+ 0.5 (fx->fl int-y-min))) + (inline-build-flomap + c new-w new-h + (λ (k x y _i) + (define-values (old-x old-y) (g (+ (fx->fl x) x-offset) + (+ (fx->fl y) y-offset))) + (flomap-bilinear-ref fm k old-x old-y))))])) + +(: rotate-transform (Real -> Flomap-Transform)) +(define ((rotate-transform θ) w h) + (let ([θ (- (exact->inexact θ))]) + (define cos-θ (cos θ)) + (define sin-θ (sin θ)) + (define x-mid (* 0.5 (fx->fl w))) + (define y-mid (* 0.5 (fx->fl h))) + (invertible-2d-function + (λ: ([x : Flonum] [y : Flonum]) + (let ([x (- x x-mid)] + [y (- y y-mid)]) + (values (+ x-mid (- (* x cos-θ) (* y sin-θ))) + (+ y-mid (+ (* x sin-θ) (* y cos-θ)))))) + (λ: ([x : Flonum] [y : Flonum]) + (let ([x (- x x-mid)] + [y (- y y-mid)]) + (values (+ x-mid (+ (* x cos-θ) (* y sin-θ))) + (+ y-mid (- (* y cos-θ) (* x sin-θ)))))))))