Pushing unfinished but stable flomap transforms so Matthew can debug a segfault

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])

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

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-θ)))))))))