diff --git a/collects/images/icons/control.rkt b/collects/images/icons/control.rkt index ce523b644e..e0eb70afb8 100644 --- a/collects/images/icons/control.rkt +++ b/collects/images/icons/control.rkt @@ -1,7 +1,6 @@ #lang racket/base (require racket/class - racket/serialize web-server/lang/serial-lambda "../private/flomap.rkt" "../private/utils.rkt" "style.rkt") diff --git a/collects/images/icons/file.rkt b/collects/images/icons/file.rkt index d8a0477fd5..4d7fedd6f1 100644 --- a/collects/images/icons/file.rkt +++ b/collects/images/icons/file.rkt @@ -3,7 +3,6 @@ (require racket/draw racket/class "../private/flomap.rkt" "../private/deep-flomap.rkt" - "../private/renderfx.rkt" "../private/utils.rkt" "arrow.rkt" "style.rkt") @@ -84,12 +83,12 @@ (define disk-fm (let* ([dfm (deep-flomap-ct-superimpose + 'add (deep-flomap-cb-superimpose + 'add (flomap->deep-flomap case-fm) - (deep-flomap-raise (flomap->deep-flomap bottom-indent-fm) (* -4 scale)) - #:z-mode 'add) - (deep-flomap-raise (flomap->deep-flomap top-indent-fm) (* -1 scale)) - #:z-mode 'add)] + (deep-flomap-raise (flomap->deep-flomap bottom-indent-fm) (* -4 scale))) + (deep-flomap-raise (flomap->deep-flomap top-indent-fm) (* -1 scale)))] [dfm (deep-flomap-icon-style dfm)]) (deep-flomap-render-icon dfm material))) diff --git a/collects/images/icons/misc.rkt b/collects/images/icons/misc.rkt index 264fa5dfad..316d374acc 100644 --- a/collects/images/icons/misc.rkt +++ b/collects/images/icons/misc.rkt @@ -3,7 +3,6 @@ (require racket/draw racket/class racket/math racket/sequence "../private/flomap.rkt" "../private/deep-flomap.rkt" - "../private/renderfx.rkt" "../private/utils.rkt" "style.rkt") @@ -119,7 +118,7 @@ [indent-dfm (deep-flomap-raise (flomap->deep-flomap indent-fm) (* -2 scale))] [fm (regular-polygon-flomap 8 (/ (* 2 pi) 16) color height)] [dfm (flomap->deep-flomap fm)] - [dfm (deep-flomap-cc-superimpose dfm indent-dfm #:z-mode 'add)] + [dfm (deep-flomap-cc-superimpose 'add dfm indent-dfm)] [dfm (deep-flomap-icon-style dfm)] [fm (deep-flomap-render-icon dfm material)]) (flomap-cc-superimpose fm (x-flomap "azure" (* 22 scale) metal-material))))) @@ -185,7 +184,7 @@ [dfm (flomap->deep-flomap fm)] ;[dfm (deep-flomap-icon-style dfm)] [dfm (deep-flomap-raise dfm (* 4 scale))] - [dfm (deep-flomap-cc-superimpose dfm indent-dfm #:z-mode 'add)] + [dfm (deep-flomap-cc-superimpose 'add dfm indent-dfm)] [dfm (deep-flomap-smooth-z dfm (* 1 scale))] ) (deep-flomap-render-icon dfm magnifying-glass-metal-material))) @@ -268,8 +267,7 @@ [sphere-dfm (flomap->deep-flomap sphere-fm)] [sphere-dfm (deep-flomap-bulge-spheroid sphere-dfm (* 15 scale))] [sphere-dfm (deep-flomap-inset sphere-dfm 2 2 0 0)] - [sphere-dfm (deep-flomap-lt-superimpose sphere-dfm cap-dfm #:z-mode 'add)] - ) + [sphere-dfm (deep-flomap-lt-superimpose 'add sphere-dfm cap-dfm)]) (deep-flomap-render-icon sphere-dfm material))) (flomap-lt-superimpose sphere-fm cap-fm fuse-fm))) diff --git a/collects/images/icons/style.rkt b/collects/images/icons/style.rkt index 16b625afd7..ae3c8184b3 100644 --- a/collects/images/icons/style.rkt +++ b/collects/images/icons/style.rkt @@ -2,8 +2,7 @@ (require racket/draw unstable/parameter-group "../private/flomap.rkt" - "../private/deep-flomap.rkt" - "../private/renderfx.rkt") + "../private/deep-flomap.rkt") (provide (all-defined-out)) diff --git a/collects/images/icons/tool.rkt b/collects/images/icons/tool.rkt index 5b0052472c..33ce9166b6 100644 --- a/collects/images/icons/tool.rkt +++ b/collects/images/icons/tool.rkt @@ -3,7 +3,6 @@ (require racket/draw racket/class racket/math racket/sequence "../private/flomap.rkt" "../private/deep-flomap.rkt" - "../private/renderfx.rkt" "../private/utils.rkt" "control.rkt" "misc.rkt" diff --git a/collects/images/logos.rkt b/collects/images/logos.rkt index ac78a25481..56da35d64e 100644 --- a/collects/images/logos.rkt +++ b/collects/images/logos.rkt @@ -3,9 +3,7 @@ (require racket/draw racket/class racket/match racket/math racket/flonum "private/flomap.rkt" "private/deep-flomap.rkt" - "private/renderfx.rkt" "icons/style.rkt" - "private/unsafe.rkt" "private/utils.rkt") (provide plt-logo planet-logo) @@ -93,23 +91,8 @@ (send p close) p) -(define (flomap-add-sparkles! fm) - (match-define (flomap vs c w h) fm) - (for ([_ (in-range 2000)]) - (define x (random w)) - (define y (random h)) - (define i (unsafe-fx* c (unsafe-fx+ x (unsafe-fx* w y)))) - (define a (flvector-ref vs i)) - (when (a . > . 0) - (define l (unsafe-fl+ 0.5 (unsafe-fl* 1.5 (random)))) - (define-values (r g b) (unsafe-flvector-3ref vs (unsafe-fx+ 1 i))) - (unsafe-flvector-3set! vs (unsafe-fx+ 1 i) - (unsafe-fl* r l) - (unsafe-fl* g l) - (unsafe-fl* b l))))) - (define (make-random-flomap c w h) - (unsafe-build-flomap c w h (λ (k x y) (random)))) + (build-flomap c w h (λ (k x y i) (random)))) (define (flomap-rough fm z-amt) (match-define (flomap _ c w h) fm) @@ -133,8 +116,6 @@ (draw-lambda dc 8 8 240 240)) scale)) - ;(flomap-add-sparkles! bulge-fm) - (define (lambda-flomap color pen-width) (draw-icon-flomap 256 256 (λ (dc) @@ -153,8 +134,9 @@ [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)] + [lambda-fm (time (printf "render lam:~n") + (deep-flomap-render-icon lambda-dfm metal-material))] + [fm (time (printf "render fm:~n") (deep-flomap-render-icon bulge-dfm glass-logo-material))] [fm (flomap-cc-superimpose fm (lambda-flomap lambda-outline-color 10) @@ -168,11 +150,13 @@ (send dc set-pen lambda-outline-color 4 'solid) (send dc draw-ellipse 2 2 252 252)) scale) - fm)] - ) + fm)]) fm))) -(define plt-logo (compose flomap->bitmap plt-flomap)) +(define (plt-logo height) + (define fm (plt-flomap height)) + (time (printf "flomap->bitmap:~n") + (flomap->bitmap fm))) (define continents-path-commands '((m 11.526653 18.937779) @@ -285,7 +269,7 @@ scale)] [earth-dfm (flomap->deep-flomap earth-fm)] [earth-dfm (deep-flomap-bulge-spheroid earth-dfm (* 16 scale))] - [earth-dfm (deep-flomap-cc-superimpose earth-dfm indent-dfm #:z-mode 'add)]) + [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)))) diff --git a/collects/images/private/deep-flomap-parameters.rkt b/collects/images/private/deep-flomap-parameters.rkt new file mode 100644 index 0000000000..849000f511 --- /dev/null +++ b/collects/images/private/deep-flomap-parameters.rkt @@ -0,0 +1,33 @@ +#lang typed/racket/base + +(require typed/private/utils + (except-in "deep-flomap-untyped-parameters.rkt" + light-direction light-intensity ambient-intensity reflected-intensity + refractive-index ideal-reflectance ideal-transmission transmission-density + specular-reflectance specular-roughness specular-purity + diffuse-reflectance ambient-reflectance ambient-transmission + shadow-blur + ->refractive-index)) + +(provide (all-from-out "deep-flomap-untyped-parameters.rkt")) + +(require/typed/provide + "deep-flomap-untyped-parameters.rkt" + ;; lighting parameters + [light-direction (Parameterof (List Flonum Flonum Flonum))] + [light-intensity (Parameterof (List Flonum Flonum Flonum))] + [ambient-intensity (Parameterof (List Flonum Flonum Flonum))] + [reflected-intensity (Parameterof (List Flonum Flonum Flonum))] + ;; material parameters + [refractive-index (Parameterof Flonum)] + [ideal-reflectance (Parameterof Flonum)] + [ideal-transmission (Parameterof Flonum)] + [transmission-density (Parameterof Flonum)] + [specular-reflectance (Parameterof Flonum)] + [specular-roughness (Parameterof Flonum)] + [specular-purity (Parameterof Flonum)] + [diffuse-reflectance (Parameterof Flonum)] + [ambient-reflectance (Parameterof Flonum)] + [ambient-transmission (Parameterof Flonum)] + [shadow-blur (Parameterof Flonum)] + [->refractive-index ((U Symbol Real) -> Flonum)]) diff --git a/collects/images/private/deep-flomap-render.rkt b/collects/images/private/deep-flomap-render.rkt new file mode 100644 index 0000000000..6d46cfb856 --- /dev/null +++ b/collects/images/private/deep-flomap-render.rkt @@ -0,0 +1,530 @@ +#lang typed/racket/base + +(require racket/flonum + (except-in racket/fixnum fl->fx fx->fl) + racket/match racket/math + "flonum.rkt" + "flomap.rkt" + "deep-flomap-struct.rkt" + "deep-flomap-parameters.rkt") + +(provide deep-flomap-render) + +;; Hacks +(define specular-blur 1/2) +(define diffuse-blur 1/2) +(define ideal-transmission-blur 1) +(define ambient-transmission-blur-fraction 1/32) + +;; =================================================================================================== +;; Ray tracing ops + +;; assumes direction to viewer is 0.0 0.0 1.0 (i.e. viewer above at infinity) +(: reflect-view-ray (Flonum Flonum Flonum -> (values Flonum Flonum Flonum))) +(define (reflect-view-ray nx ny nz) + (values (* 2.0 (* nz nx)) + (* 2.0 (* nz ny)) + (- (* 2.0 (* nz nz)) 1.0))) + +;; calculates intensity of transmitted rays using Fresnel's equation +(: transmission-intensity (Flonum Flonum Flonum -> Flonum)) +(define (transmission-intensity cos-i η1 η2) + (define n1/n2 (/ η1 η2)) + (define cos^2-i (* cos-i cos-i)) + (define sin^2-t (* (* n1/n2 n1/n2) (- 1.0 cos^2-i))) + (define cos-t (flsqrt (- 1.0 sin^2-t))) + (define n1-cos-i (* η1 cos-i)) + (define n2-cos-t (* η2 cos-t)) + (define n1-cos-t (* η1 cos-t)) + (define n2-cos-i (* η2 cos-i)) + (define perp (/ (- n1-cos-i n2-cos-t) + (+ n1-cos-i n2-cos-t))) + (define parl (/ (- n2-cos-i n1-cos-t) + (+ n2-cos-i n1-cos-t))) + (- 1.0 (* 0.5 (+ (* perp perp) (* parl parl))))) + +(: transmitted-vector (Flonum Flonum Flonum Flonum Flonum Flonum Flonum Flonum + -> (values Flonum Flonum Flonum))) +(define (transmitted-vector nx ny nz ix iy iz η1 η2) + (define η1/η2 (/ η1 η2)) + (define cos-i (- (fl3dot nx ny nz ix iy iz))) + (define cos^2-i (* cos-i cos-i)) + (define sin^2-t (* (* η1/η2 η1/η2) (- 1.0 cos^2-i))) + (define c (- (* η1/η2 cos-i) (flsqrt (- 1.0 sin^2-t)))) + (define-values (tx1 ty1 tz1) (fl3* ix iy iz η1/η2)) + (define-values (tx2 ty2 tz2) (fl3* nx ny nz c)) + (fl3+ tx1 ty1 tz1 tx2 ty2 tz2)) + +(: absorb-intensity (Flonum Flonum -> Flonum)) +(define (absorb-intensity opacity dist) + (let* ([o (+ (* opacity 0.99) 0.005)]) + (cond [(o . = . 0.0) 0.0] + [else (exp (* (fllog o) dist))]))) + +(: beckmann-distribution (Flonum Flonum -> Flonum)) +(define (beckmann-distribution cos-θ m) + (define x (/ (tan (acos cos-θ)) m)) + (define m*cos^2-θ (* m cos-θ cos-θ)) + (/ (exp (- (* x x))) (* pi m*cos^2-θ m*cos^2-θ))) + +;; =================================================================================================== +;; Pass 1: tracing from a directional light source + +(: trace-directional-light (flomap flomap flomap flomap -> (values flomap flomap))) +(define (trace-directional-light alpha-fm rgb-fm z-fm normal-fm) + (match-define (flomap alpha-vs 1 w h) alpha-fm) + (match-define (list rgb-vs z-vs normal-vs) (map flomap-values (list rgb-fm z-fm normal-fm))) + + (define z-max (flomap-max-value z-fm)) + (define opacity-z (/ z-max (transmission-density))) + ;; max coordinates of the shadow image + (define sx-max (- w 1.0)) + (define sy-max (- h 1.0)) + ;; vector pointing toward light source, incident vector, and light color + (define-values (lx ly lz) (match-let ([(list lx ly lz) (light-direction)]) + (fl3normalize lx ly lz))) + (define-values (ix iy iz) (fl3- lx ly lz)) + (match-define (list lr lg lb) (light-intensity)) + ;; view and "half" directions + (define-values (hx hy hz) (fl3-half-norm lx ly lz 0.0 0.0 1.0)) + ;; material properties + (define η2 (exact->inexact (refractive-index))) + (define η1/η2 (/ 1.0 η2)) + ;; proportion of diffracted reflection + (define 0.5*v-dot-h (* 0.5 hz)) + (define Ra (ambient-reflectance)) + (define Ta (ambient-transmission)) + (define Rd (diffuse-reflectance)) + (define Rs (specular-reflectance)) + (define Ti (ideal-transmission)) + (define roughness (specular-roughness)) + (define purity (specular-purity)) + + (match-define (list ar ag ab) (ambient-intensity)) + (define-values (Tar Tag Tab) (fl3* ar ag ab Ta)) + (define-values (Rar Rag Rab) (fl3* ar ag ab Ra)) + + (define intensity-fm (make-flomap 3 w h)) + (define intensity-vs (flomap-values intensity-fm)) + (define specular-fm (make-flomap 1 w h)) + (define specular-vs (flomap-values specular-fm)) + (define diffuse-fm (make-flomap 3 w h lz)) + (define diffuse-vs (flomap-values diffuse-fm)) + + (define sx-vs (make-flvector (* w h) +nan.0)) + (define sy-vs (make-flvector (* w h) +nan.0)) + (define Irgb-vs (make-flvector (* 3 w h))) + + (for*: ([int-y : Integer (in-range h)] [int-x : Integer (in-range w)]) + (define i (fx+ int-x (fx* int-y w))) + (define a (unsafe-flvector-ref alpha-vs i)) + (when (a . > . 0.0) + (define j (fx* 3 i)) + ;; altitude and surface normal + (define z (unsafe-flvector-ref z-vs i)) + (define nx (unsafe-flvector-ref normal-vs j)) + (define ny (unsafe-flvector-ref normal-vs (fx+ j 1))) + (define nz (unsafe-flvector-ref normal-vs (fx+ j 2))) + ;; cosine of angle between light and surface normal + (define n-dot-l (fl3dot nx ny nz lx ly lz)) + ;; intensity of incident light (Lambert's cosine law) + (define-values (Ilr Ilg Ilb) (fl3* lr lg lb n-dot-l)) + (unsafe-flvector-set! intensity-vs j Ilr) + (unsafe-flvector-set! intensity-vs (fx+ j 1) Ilg) + (unsafe-flvector-set! intensity-vs (fx+ j 2) Ilb) + ;; diffraction intensity due to specular, diffuse and ambient reflection + (cond + [(n-dot-l . > . 0.0) ; does the microfacet face the light? + (define Is + (cond + ;; Cook-Torrance specular reflection intensity + [(Rs . > . 0.0) + (define n-dot-h (fl3dot nx ny nz hx hy hz)) + (define n-dot-v nz) + ;; geometrical attenuation factor (has something to do with local reflections) + (define G (min 1.0 + (/ (* n-dot-h n-dot-v) 0.5*v-dot-h) + (/ (* n-dot-h n-dot-l) 0.5*v-dot-h))) + ;; scatter distribution + (define D (beckmann-distribution n-dot-h roughness)) + ;; Fresnel term + (define F (- 1.0 (transmission-intensity n-dot-l 1.0 η2))) + (* Rs F (/ D n-dot-l) (/ G n-dot-v))] + [else 0.0])) + (unsafe-flvector-set! specular-vs i Is) + + (let*-values ([(Idr Idg Idb) (fl3* Ilr Ilg Ilb Rd)] + [(Idr Idg Idb) (fl3+ Idr Idg Idb Rar Rag Rab)]) + (unsafe-flvector-set! diffuse-vs j Idr) + (unsafe-flvector-set! diffuse-vs (fx+ j 1) Idg) + (unsafe-flvector-set! diffuse-vs (fx+ j 2) Idb))] + [else + (unsafe-flvector-set! diffuse-vs j Rar) + (unsafe-flvector-set! diffuse-vs (fx+ j 1) Rag) + (unsafe-flvector-set! diffuse-vs (fx+ j 2) Rab)]) + + (when (and (Ti . > . 0.0) (n-dot-l . > . 0.0)) + ;; ideal transmission vector + (define-values (tx ty tz) (transmitted-vector nx ny nz ix iy iz 1.0 η2)) + ;; sz = z + dist * tz, so dist = (sz - z) / tz + (define dist (/ (- 0.0 z) tz)) + (when (and (dist . >= . 0.0) (dist . < . +inf.0)) + ;; transmitted ray intersects with shadow plane at sx sy 0.0 + (define sx (+ 0.5 (fx->fl int-x) (* dist tx))) + (define sy (+ 0.5 (fx->fl int-y) (* dist ty))) + ;; actual transmission proportion (Fresnel's law) + (define T (* Ti (transmission-intensity n-dot-l 1.0 η2))) + ;; intensity of incident light (Lambert's cosine law) + (define-values (Ilr Ilg Ilb) (fl3* lr lg lb n-dot-l)) + ;; normalized distance to the surface + (define norm-dist (/ dist opacity-z)) + ;; intensity of the light that strikes the surface + (define r (unsafe-flvector-ref rgb-vs j)) + (define g (unsafe-flvector-ref rgb-vs (fx+ j 1))) + (define b (unsafe-flvector-ref rgb-vs (fx+ j 2))) + (define-values (Ir Ig Ib) + (values (* T Ilr (absorb-intensity r norm-dist)) + (* T Ilg (absorb-intensity g norm-dist)) + (* T Ilb (absorb-intensity b norm-dist)))) + (unsafe-flvector-set! sx-vs i sx) + (unsafe-flvector-set! sy-vs i sy) + (unsafe-flvector-set! Irgb-vs j Ir) + (unsafe-flvector-set! Irgb-vs (fx+ j 1) Ig) + (unsafe-flvector-set! Irgb-vs (fx+ j 2) Ib))))) + + (define diffracted-fm (fm+ (fm* (flomap-blur diffuse-fm diffuse-blur) + rgb-fm) + (fm* (flomap-blur specular-fm specular-blur) + (fm+ (fm* (- 1.0 purity) rgb-fm) + (fm* purity intensity-fm))))) + + ;; approximate ambient transmission by casting light downward with no refraction, then blurring + (define ambient-shadow-fm (make-flomap 3 w h)) + (define ambient-shadow-vs (flomap-values ambient-shadow-fm)) + (when (Ta . > . 0.0) + (for*: ([int-y : Integer (in-range h)] [int-x : Integer (in-range w)]) + (define i (fx+ int-x (fx* int-y w))) + (define a (unsafe-flvector-ref alpha-vs i)) + (when (a . > . 0.0) + (define z (unsafe-flvector-ref z-vs i)) + (define j (fx* 3 i)) + (define r (unsafe-flvector-ref rgb-vs j)) + (define g (unsafe-flvector-ref rgb-vs (fx+ j 1))) + (define b (unsafe-flvector-ref rgb-vs (fx+ j 2))) + (define norm-dist (/ z opacity-z)) + (define-values (Ir Ig Ib) + (values (* Tar (absorb-intensity r norm-dist)) + (* Tag (absorb-intensity g norm-dist)) + (* Tab (absorb-intensity b norm-dist)))) + (unsafe-flvector-set! ambient-shadow-vs j Ir) + (unsafe-flvector-set! ambient-shadow-vs (fx+ j 1) Ig) + (unsafe-flvector-set! ambient-shadow-vs (fx+ j 2) Ib)))) + + ;; cast approximate shadow volumes + (define shadow-fm (flomap-blur ambient-shadow-fm (* ambient-transmission-blur-fraction (min w h)))) + (define shadow-vs (flomap-values shadow-fm)) + (when (Ti . > . 0.0) + ;; Gaussian kernels - make as wide as possible to keep from having to reallocate + (define kxs (make-flvector w)) + (define kys (make-flvector h)) + (for*: ([int-y : Integer (in-range (- h 1))] [int-x : Integer (in-range (- w 1))]) + (define i00 (fx+ int-x (fx* int-y w))) + (define i01 (fx+ i00 1)) + (define i10 (fx+ i00 w)) + (define i11 (fx+ i10 1)) + (define sx00 (unsafe-flvector-ref sx-vs i00)) + (define sx01 (unsafe-flvector-ref sx-vs i01)) + (define sx10 (unsafe-flvector-ref sx-vs i10)) + (define sx11 (unsafe-flvector-ref sx-vs i11)) + (when (and (flrational? sx00) (flrational? sx01) + (flrational? sx10) (flrational? sx11)) + (define sy00 (unsafe-flvector-ref sy-vs i00)) + (define sy01 (unsafe-flvector-ref sy-vs i01)) + (define sy10 (unsafe-flvector-ref sy-vs i10)) + (define sy11 (unsafe-flvector-ref sy-vs i11)) + (define sx-min (min sx00 sx01 sx10 sx11)) + (define sy-min (min sy00 sy01 sy10 sy11)) + (define sx-max (max sx00 sx01 sx10 sx11)) + (define sy-max (max sy00 sy01 sy10 sy11)) + ;; find the mean and standard deviation + (define sx-mid (* 0.25 (+ sx00 sx01 sx10 sx11))) + (define sy-mid (* 0.25 (+ sy00 sy01 sy10 sy11))) + (define sx-mid^2 (* 0.25 (+ (* sx00 sx00) (* sx01 sx01) (* sx10 sx10) (* sx11 sx11)))) + (define sy-mid^2 (* 0.25 (+ (* sy00 sy00) (* sy01 sy01) (* sy10 sy10) (* sy11 sy11)))) + (define sx-stddev (flsqrt (- sx-mid^2 (* sx-mid sx-mid)))) + (define sy-stddev (flsqrt (- sy-mid^2 (* sy-mid sy-mid)))) + (define x-min (fxmax 0 (fl->fx (floor sx-min)))) + (define x-max (fxmin w (fx+ 1 (fl->fx (floor sx-max))))) + (define y-min (fxmax 0 (fl->fx (floor sy-min)))) + (define y-max (fxmin h (fx+ 1 (fl->fx (floor sy-max))))) + (define x-size (fx- x-max x-min)) + (define y-size (fx- y-max y-min)) + (when (and (x-size . fx> . 0) (y-size . fx> . 0)) + ;; average the color + (define j00 (fx* 3 i00)) + (define j01 (fx* 3 i01)) + (define j10 (fx* 3 i10)) + (define j11 (fx* 3 i11)) + (define r (* 0.25 (+ (unsafe-flvector-ref Irgb-vs j00) + (unsafe-flvector-ref Irgb-vs j01) + (unsafe-flvector-ref Irgb-vs j10) + (unsafe-flvector-ref Irgb-vs j11)))) + (define g (* 0.25 (+ (unsafe-flvector-ref Irgb-vs (fx+ j00 1)) + (unsafe-flvector-ref Irgb-vs (fx+ j01 1)) + (unsafe-flvector-ref Irgb-vs (fx+ j10 1)) + (unsafe-flvector-ref Irgb-vs (fx+ j11 1))))) + (define b (* 0.25 (+ (unsafe-flvector-ref Irgb-vs (fx+ j00 2)) + (unsafe-flvector-ref Irgb-vs (fx+ j01 2)) + (unsafe-flvector-ref Irgb-vs (fx+ j10 2)) + (unsafe-flvector-ref Irgb-vs (fx+ j11 2))))) + ;; precalculate the Gaussian kernel for the x direction + (for ([dx (in-range x-size)]) + (define x (fx+ dx x-min)) + (define d (/ (- (+ 0.5 (fx->fl x)) sx-mid) sx-stddev)) + (define kx (exp (* -0.5 (* d d)))) + (unsafe-flvector-set! kxs dx kx)) + ;; precalculate the Gaussian kernel for the y direction + ;; this shouldn't help because it's used only once per y iteration, but it reduces allocs + ;; within the loop (unsafe-flexp has no bytecode op yet, so its args and return are boxed) + (for ([dy (in-range y-size)]) + (define y (fx+ dy y-min)) + (define d (/ (- (+ 0.5 (fx->fl y)) sy-mid) sy-stddev)) + (define ky (exp (* -0.5 (* d d)))) + (unsafe-flvector-set! kys dy ky)) + ;; normalization constant for a 2D Gaussian kernel + (define c (* 2.0 pi sx-stddev sy-stddev)) + ;; cast the approximate shadow volume + (let y-loop ([dy 0]) + (when (dy . fx< . y-size) + (define ky (unsafe-flvector-ref kys dy)) + (cond [(ky . > . 0.1) + (define a (/ ky c)) + (define Ir (* r a)) + (define Ig (* g a)) + (define Ib (* b a)) + (define i (fx* 3 (fx+ x-min (fx* (fx+ dy y-min) w)))) + (let x-loop ([dx 0] [i i]) + (cond [(dx . fx< . x-size) + (define kx (unsafe-flvector-ref kxs dx)) + (when (kx . > . 0.1) + (unsafe-flvector-set! + shadow-vs i (+ (* Ir kx) (unsafe-flvector-ref shadow-vs i))) + (define i1 (fx+ i 1)) + (unsafe-flvector-set! + shadow-vs i1 (+ (* Ig kx) (unsafe-flvector-ref shadow-vs i1))) + (define i2 (fx+ i 2)) + (unsafe-flvector-set! + shadow-vs i2 (+ (* Ib kx) (unsafe-flvector-ref shadow-vs i2)))) + (x-loop (fx+ 1 dx) (fx+ 3 i))] + [else + (y-loop (fx+ 1 dy))]))] + [else + (y-loop (fx+ 1 dy))]))))))) + + ;; blur the shadow a bit to make up for approximating it with Gaussians + (values diffracted-fm (flomap-box-blur shadow-fm 1))) + +;; =================================================================================================== +;; Pass 2: tracing from a directional viewer + +(: trace-directional-view (flomap flomap flomap flomap flomap -> (values flomap flomap))) +(define (trace-directional-view alpha-fm rgb-fm z-fm normal-fm shadow-fm) + (define-values (w h) (flomap-size alpha-fm)) + (match-define (list alpha-vs rgb-vs z-vs normal-vs shadow-vs) + (map flomap-values (list alpha-fm rgb-fm z-fm normal-fm shadow-fm))) + + (define w-1 (fx- w 1)) + (define h-1 (fx- h 1)) + (define x-size (fx->fl w)) + (define y-size (fx->fl h)) + (define z-size (flomap-max-value z-fm)) + (define x-mid (* 0.5 x-size)) + (define y-mid (* 0.5 y-size)) + (define opacity-z (/ z-size (transmission-density))) + + ;; reflected wall is tilted a bit toward the viewer + (define wall-tilt-θ (* 1/8 pi)) + (define cos-wall-tilt-θ (cos wall-tilt-θ)) + (define sin-wall-tilt-θ (sin wall-tilt-θ)) + (match-define (list Irr Irg Irb) (reflected-intensity)) + + ;; max coords of the shadow image + ;; subtract epsilon to ensure that sx < (w - 1) so that (flfloor sx) < (w - 1) (similarly for sy) + (define sx-max (- w 1.00001)) + (define sy-max (- h 1.00001)) + ;; material properties + (define η2 (refractive-index)) + (define η1/η2 (/ 1.0 η2)) + (define Ri (ideal-reflectance)) + (define Ti (ideal-transmission)) + + (define reflected-fm (make-flomap 3 w h)) + (define reflected-vs (flomap-values reflected-fm)) + (define transmitted-fm (make-flomap 3 w h)) + (define transmitted-vs (flomap-values transmitted-fm)) + + (when (or (Ri . > . 0.0) (Ti . > . 0.0)) + (for*: ([int-y : Integer (in-range h)] [int-x : Integer (in-range w)]) + (define i (fx+ int-x (fx* int-y w))) + (define a (unsafe-flvector-ref alpha-vs i)) + (when (a . > . 0.0) + (define j (fx* 3 i)) + ;; surface normal + (define nx (unsafe-flvector-ref normal-vs j)) + (define ny (unsafe-flvector-ref normal-vs (fx+ j 1))) + (define nz (unsafe-flvector-ref normal-vs (fx+ j 2))) + ;; cosine of angle between viewer and surface normal + ;; with gradient inferred from z flomap, this is always > 0.0 + (define cos-i nz) + ;; transmitted intensity + (define orig-T (transmission-intensity cos-i 1.0 η2)) + (define T (* Ti orig-T)) + (define R (* Ri (- 1.0 orig-T))) + ;; surface coordinates + (define x (+ 0.5 (fx->fl int-x))) + (define y (+ 0.5 (fx->fl int-y))) + (define z (unsafe-flvector-ref z-vs i)) + ;; reflection + (when (and (Ri . > . 0.0) + (int-x . fx> . 0) (int-x . fx< . w-1) + (int-y . fx> . 0) (int-y . fx< . h-1)) + (define-values (rx ry rz) (reflect-view-ray nx ny nz)) + ;; tilt the wall a little so flat surfaces reflect something + (define ry* (- (* ry cos-wall-tilt-θ) (* rz sin-wall-tilt-θ))) + ;(define rz* (+ (* ry sin-wall-tilt-θ) (* rz cos-wall-tilt-θ))) + ;; distance to the wall + (define rdist (/ (- (- z-size) y) ry*)) + (define sx (+ x (* rx rdist))) + (define sy (+ y (* ry rdist))) + (define sz (+ z (* rz rdist))) + (when (rdist . >= . 0.0) + (define cdist (fl3dist sx sy sz x-mid y-mid 0.0)) + (define v (flsigmoid (* 0.25 (- (* 4.5 z-size) cdist)))) + (define trash 0.0) + (set! trash Irr) + (set! trash Irg) + (set! trash Irb) + (let-values ([(r g b) (fl3* Irr Irg Irb (* R v))]) + (unsafe-flvector-set! reflected-vs j r) + (unsafe-flvector-set! reflected-vs (fx+ j 1) g) + (unsafe-flvector-set! reflected-vs (fx+ j 2) b)))) + ;; transmission (refraction) + (when (Ti . > . 0.0) + (define-values (tx ty tz) (transmitted-vector nx ny nz 0.0 0.0 -1.0 1.0 η2)) + ;; sz = z + dist * tz, so dist = (sz - z) / tz + (define dist (/ (- 0.0 z) tz)) + (when (and (dist . >= . 0.0) (dist . < . +inf.0)) + ;; Find the color of the point on the shadow that the ray struck + (define sx (max 0.0 (min sx-max (+ x (* dist tx))))) + (define sy (max 0.0 (min sy-max (+ y (* dist ty))))) + (define floor-sx (floor sx)) + (define floor-sy (floor sy)) + (define bx (fl->fx floor-sx)) + (define by (fl->fx floor-sy)) + ;; Bilinearly interpolate the four colors nearest the point on the shadow + (define 1-αx (- sx floor-sx)) + (define 1-αy (- sy floor-sy)) + (define αx (- 1.0 1-αx)) + (define αy (- 1.0 1-αy)) + ;; upper-left weighted values + (define j1 (fx* 3 (fx+ bx (fx* by w)))) + (define r1 (unsafe-flvector-ref shadow-vs j1)) + (define g1 (unsafe-flvector-ref shadow-vs (fx+ j1 1))) + (define b1 (unsafe-flvector-ref shadow-vs (fx+ j1 2))) + (define-values (sr1 sg1 sb1) (fl3* r1 g1 b1 (* αx αy))) + ;; upper-right weighted values + (define j2 (fx+ j1 3)) + (define r2 (unsafe-flvector-ref shadow-vs j2)) + (define g2 (unsafe-flvector-ref shadow-vs (fx+ j2 1))) + (define b2 (unsafe-flvector-ref shadow-vs (fx+ j2 2))) + (define-values (sr2 sg2 sb2) (fl3* r2 g2 b2 (* 1-αx αy))) + ;; lower-left weighted values + (define j3 (fx+ j1 (fx* 3 w))) + (define r3 (unsafe-flvector-ref shadow-vs j3)) + (define g3 (unsafe-flvector-ref shadow-vs (fx+ j3 1))) + (define b3 (unsafe-flvector-ref shadow-vs (fx+ j3 2))) + (define-values (sr3 sg3 sb3) (fl3* r3 g3 b3 (* αx 1-αy))) + ;; lower-right weighted values + (define j4 (fx+ j3 3)) + (define r4 (unsafe-flvector-ref shadow-vs j4)) + (define g4 (unsafe-flvector-ref shadow-vs (fx+ j4 1))) + (define b4 (unsafe-flvector-ref shadow-vs (fx+ j4 2))) + (define-values (sr4 sg4 sb4) (fl3* r4 g4 b4 (* 1-αx 1-αy))) + ;; final interpolated shadow color + (define sr (+ sr1 sr2 sr3 sr4)) + (define sg (+ sg1 sg2 sg3 sg4)) + (define sb (+ sb1 sb2 sb3 sb4)) + ;; normalized distance to the surface + (define norm-dist (/ dist opacity-z)) + ;; intensities of each r g b by the time the light emerges from the surface + (define-values (r g b) + ;; colors represent absorption rates + (let ([r (unsafe-flvector-ref rgb-vs j)] + [g (unsafe-flvector-ref rgb-vs (fx+ j 1))] + [b (unsafe-flvector-ref rgb-vs (fx+ j 2))]) + (values (* T sr (absorb-intensity r norm-dist)) + (* T sg (absorb-intensity g norm-dist)) + (* T sb (absorb-intensity b norm-dist))))) + (unsafe-flvector-set! transmitted-vs j r) + (unsafe-flvector-set! transmitted-vs (fx+ j 1) g) + (unsafe-flvector-set! transmitted-vs (fx+ j 2) b)))))) + + ;; blur to cut down on sparklies (poor man's supersampling) + (values reflected-fm + (flomap-blur transmitted-fm ideal-transmission-blur))) + +;; =================================================================================================== +;; Full rendering + +(: prep-background (flomap Integer Integer -> (Option flomap))) +(define (prep-background fm w h) + (let loop ([fm (flomap-cc-crop fm w h)]) + (case (flomap-components fm) + [(0) #f] + [(1) (flomap-append-components fm fm fm)] + [(2) (define value-fm (flomap-ref-component fm 1)) + (loop (flomap-append-components fm value-fm value-fm))] + [(3) fm] + [(4) (flomap-drop-components (flomap-cc-superimpose (make-flomap 4 w h 1.0) fm) 1)] + [else (raise-type-error 'deep-flomap-render "flomap with 0, 1, 2, 3 or 4 components" fm)]))) + +(: deep-flomap-render (case-> (deep-flomap -> flomap) + (deep-flomap (Option flomap) -> flomap))) +(define deep-flomap-render + (case-lambda + [(dfm) (deep-flomap-render dfm #f)] + [(dfm background-fm) + (define-values (w h) (deep-flomap-size dfm)) + (define argb-fm (flomap-divide-alpha (deep-flomap-argb dfm))) + (define alpha-fm (flomap-ref-component argb-fm 0)) + (define rgb-fm (flomap-drop-components argb-fm 1)) + (define z-fm (fmmax 0.0 (deep-flomap-z dfm))) + (define normal-fm (flomap-gradient-normal z-fm)) + (define bg-fm (if background-fm (prep-background background-fm w h) #f)) + + ;; pass 1: trace from the light source + (define-values (diffracted-fm raw-shadow-fm) + (trace-directional-light alpha-fm rgb-fm z-fm normal-fm)) + + ;; blur the shadow to simulate internal scatter + (define σ (* (min w h) (shadow-blur))) + (define shadow-fm + (cond [bg-fm + ;; two Gaussian blurs by half-σ is equivalent to one Gaussian blur by σ + (define half-σ (* (/ 1 (sqrt 2)) σ)) + (let* ([fm (flomap-blur raw-shadow-fm half-σ)] + [fm (fm* fm bg-fm)] + [fm (flomap-blur fm half-σ)]) + fm)] + [else + (flomap-blur raw-shadow-fm σ)])) + + ;; pass 2: trace from the viewer + (define-values (reflected-fm transmitted-fm) + (trace-directional-view alpha-fm rgb-fm z-fm normal-fm shadow-fm)) + + ;; add all the light together, convert to premultiplied-alpha flomap + (let* ([fm (fm+ (fm+ diffracted-fm transmitted-fm) reflected-fm)] + [fm (flomap-append-components alpha-fm fm)] + [fm (flomap-multiply-alpha fm)]) + fm)])) diff --git a/collects/images/private/deep-flomap-struct.rkt b/collects/images/private/deep-flomap-struct.rkt new file mode 100644 index 0000000000..71ba4a34d7 --- /dev/null +++ b/collects/images/private/deep-flomap-struct.rkt @@ -0,0 +1,482 @@ +#lang typed/racket/base + +(require racket/flonum + (except-in racket/fixnum fx->fl fl->fx) + racket/match racket/math + "flonum.rkt" + "flomap.rkt") + +(provide deep-flomap deep-flomap? deep-flomap-argb deep-flomap-z + deep-flomap-width deep-flomap-height deep-flomap-z-min deep-flomap-z-max + deep-flomap-size deep-flomap-alpha deep-flomap-rgb + flomap->deep-flomap + ;; Sizing + deep-flomap-inset deep-flomap-trim deep-flomap-scale deep-flomap-resize + ;; Z-adjusting + deep-flomap-scale-z deep-flomap-smooth-z deep-flomap-raise deep-flomap-tilt + deep-flomap-emboss + deep-flomap-bulge deep-flomap-bulge-round deep-flomap-bulge-round-rect + deep-flomap-bulge-spheroid deep-flomap-bulge-horizontal deep-flomap-bulge-vertical + deep-flomap-bulge-ripple + ;; Compositing + deep-flomap-pin deep-flomap-pin* + deep-flomap-lt-superimpose deep-flomap-lc-superimpose deep-flomap-lb-superimpose + deep-flomap-ct-superimpose deep-flomap-cc-superimpose deep-flomap-cb-superimpose + deep-flomap-rt-superimpose deep-flomap-rc-superimpose deep-flomap-rb-superimpose + deep-flomap-vl-append deep-flomap-vc-append deep-flomap-vr-append + deep-flomap-ht-append deep-flomap-hc-append deep-flomap-hb-append) + +(struct: deep-flomap ([argb : flomap] [z : flomap]) + #:transparent + #:guard + (λ (argb-fm z-fm name) + (match-define (flomap _ 4 w h) argb-fm) + (match-define (flomap _ 1 zw zh) z-fm) + (unless (and (= w zw) (= h zh)) + (error 'deep-flomap + "expected flomaps of equal dimension; given dimensions ~e×~e and ~e×~e" w h zw zh)) + (values argb-fm z-fm))) + +(: flomap->deep-flomap (flomap -> deep-flomap)) +(define (flomap->deep-flomap argb-fm) + (match-define (flomap _ 4 w h) argb-fm) + (deep-flomap argb-fm (make-flomap 1 w h))) + +(: deep-flomap-width (deep-flomap -> Nonnegative-Fixnum)) +(define (deep-flomap-width dfm) + (define w (flomap-width (deep-flomap-argb dfm))) + (with-asserts ([w nonnegative-fixnum?]) + w)) + +(: deep-flomap-height (deep-flomap -> Nonnegative-Fixnum)) +(define (deep-flomap-height dfm) + (define h (flomap-height (deep-flomap-argb dfm))) + (with-asserts ([h nonnegative-fixnum?]) + h)) + +(: deep-flomap-z-min (deep-flomap -> Flonum)) +(define (deep-flomap-z-min dfm) + (flomap-min-value (deep-flomap-z dfm))) + +(: deep-flomap-z-max (deep-flomap -> Flonum)) +(define (deep-flomap-z-max dfm) + (flomap-max-value (deep-flomap-z dfm))) + +(: deep-flomap-size (deep-flomap -> (values Nonnegative-Fixnum Nonnegative-Fixnum))) +(define (deep-flomap-size dfm) + (values (deep-flomap-width dfm) (deep-flomap-height dfm))) + +(: deep-flomap-alpha (deep-flomap -> flomap)) +(define (deep-flomap-alpha dfm) + (flomap-ref-component (deep-flomap-argb dfm) 0)) + +(: deep-flomap-rgb (deep-flomap -> flomap)) +(define (deep-flomap-rgb dfm) + (flomap-drop-components (deep-flomap-argb dfm) 1)) + +;; =================================================================================================== +;; Z adjusters + +(: deep-flomap-scale-z (deep-flomap (U Real flomap) -> deep-flomap)) +(define (deep-flomap-scale-z dfm z) + (match-define (deep-flomap argb-fm z-fm) dfm) + (deep-flomap argb-fm (fm* z-fm z))) + +(: deep-flomap-smooth-z (deep-flomap Real -> deep-flomap)) +(define (deep-flomap-smooth-z dfm σ) + (let ([σ (exact->inexact σ)]) + (match-define (deep-flomap argb-fm z-fm) dfm) + (define new-z-fm (flomap-blur z-fm σ)) + (deep-flomap argb-fm new-z-fm))) + +;; deep-flomap-raise and everything derived from it observe an invariant: +;; when z is added, added z must be 0.0 everywhere alpha is 0.0 + +(: deep-flomap-raise (deep-flomap (U Real flomap) -> deep-flomap)) +(define (deep-flomap-raise dfm z) + (match-define (deep-flomap argb-fm z-fm) dfm) + (define alpha-fm (deep-flomap-alpha dfm)) + (deep-flomap argb-fm (fm+ z-fm (fm* alpha-fm z)))) + +(: deep-flomap-emboss (deep-flomap Real (U Real flomap) -> deep-flomap)) +(define (deep-flomap-emboss dfm xy-amt z-amt) + (let ([σ (/ xy-amt 3.0)]) + (define z-fm (flomap-normalize (deep-flomap-alpha dfm))) + (define new-z-fm (fm* (flomap-blur z-fm σ) z-amt)) + (deep-flomap-raise dfm new-z-fm))) + +(define-syntax-rule (inline-deep-flomap-bulge dfm f) + (let () + (define-values (w h) (deep-flomap-size dfm)) + (define half-x-size (- (* 0.5 (fx->fl w)) 0.5)) + (define half-y-size (- (* 0.5 (fx->fl h)) 0.5)) + (define z-fm + (inline-build-flomap + 1 w h + (λ (_ x y _i) + (f (- (/ (fx->fl x) half-x-size) 1.0) + (- (/ (fx->fl y) half-y-size) 1.0))))) + (deep-flomap-raise dfm z-fm))) + +(: deep-flomap-bulge (deep-flomap (Flonum Flonum -> Real) -> deep-flomap)) +(define (deep-flomap-bulge dfm f) + (inline-deep-flomap-bulge dfm (λ (cx cy) (exact->inexact (f cx cy))))) + +(: deep-flomap-tilt (deep-flomap Real Real Real Real -> deep-flomap)) +(define (deep-flomap-tilt dfm left-z-amt top-z-amt right-z-amt bottom-z-amt) + (let ([l (exact->inexact left-z-amt)] + [t (exact->inexact top-z-amt)] + [r (exact->inexact right-z-amt)] + [b (exact->inexact bottom-z-amt)]) + (define: (f [x : Flonum] [y : Flonum]) : Flonum + (define α (/ (+ x 1.0) 2.0)) + (define β (/ (+ y 1.0) 2.0)) + (+ (* (- 1.0 α) l) (* α r) + (* (- 1.0 β) t) (* β b))) + (inline-deep-flomap-bulge dfm f))) + +(: deep-flomap-bulge-round (deep-flomap Real -> deep-flomap)) +(define (deep-flomap-bulge-round dfm z-amt) + (let ([z-amt (exact->inexact z-amt)]) + (define: (f [x : Flonum] [y : Flonum]) : Flonum + (define d^2 (+ (* x x) (* y y))) + (* z-amt (flsqrt (/ (- 2.0 d^2) 2.0)))) + (inline-deep-flomap-bulge dfm f))) + +(: deep-flomap-bulge-round-rect (deep-flomap Real -> deep-flomap)) +(define (deep-flomap-bulge-round-rect dfm z-amt) + (let ([z-amt (exact->inexact z-amt)]) + (define: (f [x : Flonum] [y : Flonum]) : Flonum + (* z-amt (flsqrt (* (- 1.0 (* x x)) + (- 1.0 (* y y)))))) + (inline-deep-flomap-bulge dfm f))) + +(: deep-flomap-bulge-spheroid (deep-flomap Real -> deep-flomap)) +(define (deep-flomap-bulge-spheroid dfm z-amt) + (let ([z-amt (exact->inexact z-amt)]) + (define: (f [x : Flonum] [y : Flonum]) : Flonum + (define d^2 (+ (* x x) (* y y))) + (if (d^2 . < . 1.0) (* z-amt (flsqrt (- 1.0 d^2))) 0.0)) + (inline-deep-flomap-bulge dfm f))) + +(: deep-flomap-bulge-horizontal (deep-flomap Real -> deep-flomap)) +(define (deep-flomap-bulge-horizontal dfm z-amt) + (let ([z-amt (exact->inexact z-amt)]) + (define: (f [x : Flonum] [y : Flonum]) : Flonum + (* z-amt (flsqrt (- 1.0 (* x x))))) + (inline-deep-flomap-bulge dfm f))) + +(: deep-flomap-bulge-vertical (deep-flomap Real -> deep-flomap)) +(define (deep-flomap-bulge-vertical dfm z-amt) + (let ([z-amt (exact->inexact z-amt)]) + (define: (f [x : Flonum] [y : Flonum]) : Flonum + (* z-amt (flsqrt (- 1.0 (* y y))))) + (inline-deep-flomap-bulge dfm f))) + +(: deep-flomap-bulge-ripple (deep-flomap Real Real -> deep-flomap)) +(define (deep-flomap-bulge-ripple dfm freq z-amt) + (let ([freq (exact->inexact freq)] + [z-amt (exact->inexact z-amt)]) + (define: (f [x : Flonum] [y : Flonum]) : Flonum + (define d^2 (+ (* x x) (* y y))) + (define d (* freq pi (flsqrt d^2))) + (* z-amt 0.5 (- 1.0 (cos d)))) + (inline-deep-flomap-bulge dfm f))) + +;; =================================================================================================== +;; Sizing + +(: deep-flomap-inset (case-> (deep-flomap Integer -> deep-flomap) + (deep-flomap Integer Integer -> deep-flomap) + (deep-flomap Integer Integer Integer Integer -> deep-flomap))) +(define deep-flomap-inset + (case-lambda + [(dfm amt) (deep-flomap-inset dfm amt amt amt amt)] + [(dfm h-amt v-amt) (deep-flomap-inset dfm h-amt v-amt h-amt v-amt)] + [(dfm l-amt t-amt r-amt b-amt) + (match-define (deep-flomap argb-fm z-fm) dfm) + (deep-flomap (flomap-inset argb-fm l-amt t-amt r-amt b-amt) + (flomap-inset z-fm l-amt t-amt r-amt b-amt))])) + +(: deep-flomap-trim (deep-flomap -> deep-flomap)) +(define (deep-flomap-trim dfm) + (define-values (w h) (deep-flomap-size dfm)) + (define-values (_k-min x-min y-min _k-max x-max y-max) + (flomap-nonzero-rect (deep-flomap-alpha dfm))) + (deep-flomap-inset dfm (- x-min) (- y-min) (- x-max w) (- y-max h))) + +(: deep-flomap-scale (case-> (deep-flomap Real -> deep-flomap) + (deep-flomap Real Real Real -> deep-flomap))) +(define deep-flomap-scale + (case-lambda + [(dfm scale) + (match-define (deep-flomap argb-fm z-fm) (deep-flomap-scale-z dfm scale)) + (deep-flomap (flomap-scale argb-fm scale) + (flomap-scale z-fm scale))] + [(dfm x-scale y-scale z-scale) + (match-define (deep-flomap argb-fm z-fm) (deep-flomap-scale-z dfm z-scale)) + (deep-flomap (flomap-scale argb-fm x-scale y-scale) + (flomap-scale z-fm x-scale y-scale))])) + +(: deep-flomap-resize (deep-flomap (Option Integer) (Option Integer) (Option Real) (Option Real) + -> deep-flomap)) +(define (deep-flomap-resize dfm width height z-min z-max) + (match-define (deep-flomap argb-fm z-fm) dfm) + (define new-z-fm + (cond [(or z-min z-max) + (let ([z-min (if z-min z-min (flomap-min-value z-fm))] + [z-max (if z-max z-max (flomap-max-value z-fm))]) + (fm+ (fm* (flomap-normalize z-fm) (- z-max z-min)) z-min))] + [else z-fm])) + (deep-flomap (flomap-resize argb-fm width height) + (flomap-resize new-z-fm width height))) + +;; =================================================================================================== +;; Combining + +(define-type Z-Mode (U 'add 'blend 'place 'replace)) + +(: deep-flomap-pin (Z-Mode deep-flomap Real Real deep-flomap Real Real -> deep-flomap)) +(define (deep-flomap-pin z-mode dfm1 x1 y1 dfm2 x2 y2) + (cond + [(not (and (zero? x2) (zero? y2))) + (deep-flomap-pin z-mode dfm1 (- x1 x2) (- y1 y2) dfm2 0 0)] + [else + (define-values (w1 h1) (deep-flomap-size dfm1)) + (define-values (w2 h2) (deep-flomap-size dfm2)) + (let ([x1 (exact->inexact x1)] [y1 (exact->inexact y1)]) + ;; dfm1 and dfm2 offsets, in final image coordinates + (define dx1 (fl->fx (round (max 0.0 (- x1))))) + (define dy1 (fl->fx (round (max 0.0 (- y1))))) + (define dx2 (fl->fx (round (max 0.0 x1)))) + (define dy2 (fl->fx (round (max 0.0 y1)))) + ;; final image size + (define w (fxmax (fx+ dx1 w1) (fx+ dx2 w2))) + (define h (fxmax (fx+ dy1 h1) (fx+ dy2 h2))) + + (case z-mode + [(place) (deep-flomap-superimpose/place w h dfm1 dx1 dy1 w1 h1 dfm2 dx2 dy2 w2 h2)] + [(blend) (deep-flomap-superimpose/blend w h dfm1 dx1 dy1 w1 h1 dfm2 dx2 dy2 w2 h2)] + [else (deep-flomap-superimpose/replace z-mode w h + dfm1 dx1 dy1 w1 h1 + dfm2 dx2 dy2 w2 h2)]))])) + +(: deep-flomap-superimpose/replace + (Z-Mode Integer Integer + deep-flomap Integer Integer Integer Integer + deep-flomap Integer Integer Integer Integer -> deep-flomap)) +(define (deep-flomap-superimpose/replace z-mode w h dfm1 dx1 dy1 w1 h1 dfm2 dx2 dy2 w2 h2) + (match-define (deep-flomap argb1-fm z1-fm) dfm1) + (match-define (deep-flomap argb2-fm z2-fm) dfm2) + (define argb1-vs (flomap-values argb1-fm)) + (define argb2-vs (flomap-values argb2-fm)) + (define z1-vs (flomap-values z1-fm)) + (define z2-vs (flomap-values z2-fm)) + + (define-syntax-rule (get-argbz-pixel argb-vs z-vs dx dy w h x y) + (let ([x (fx- x dx)] [y (fx- y dy)]) + (cond [(and (x . fx>= . 0) (x . fx< . w) (y . fx>= . 0) (y . fx< . h)) + (define i (fx+ x (fx* y w))) + (define j (fx* 4 i)) + (values (unsafe-flvector-ref argb-vs j) + (unsafe-flvector-ref argb-vs (fx+ j 1)) + (unsafe-flvector-ref argb-vs (fx+ j 2)) + (unsafe-flvector-ref argb-vs (fx+ j 3)) + (unsafe-flvector-ref z-vs i))] + [else + (values 0.0 0.0 0.0 0.0 0.0)]))) + + (define argb-vs (make-flvector (* 4 w h))) + (define z-vs (make-flvector (* w h))) + (let: y-loop : Void ([y : Nonnegative-Fixnum 0]) + (when (y . fx< . h) + (let: x-loop : Void ([x : Nonnegative-Fixnum 0]) + (cond [(x . fx< . w) + (define-values (a1 r1 g1 b1 z1) (get-argbz-pixel argb1-vs z1-vs dx1 dy1 w1 h1 x y)) + (define-values (a2 r2 g2 b2 z2) (get-argbz-pixel argb2-vs z2-vs dx2 dy2 w2 h2 x y)) + + (define i (fx+ x (fx* y w))) + (define j (fx* 4 i)) + (unsafe-flvector-set! argb-vs j (fl-alpha-blend a1 a2 a2)) + (unsafe-flvector-set! argb-vs (fx+ j 1) (fl-alpha-blend r1 r2 a2)) + (unsafe-flvector-set! argb-vs (fx+ j 2) (fl-alpha-blend g1 g2 a2)) + (unsafe-flvector-set! argb-vs (fx+ j 3) (fl-alpha-blend b1 b2 a2)) + (unsafe-flvector-set! z-vs i (case z-mode + [(replace) (fl-alpha-blend z1 z2 a2)] + [else (+ z1 z2)])) + (x-loop (fx+ x 1))] + [else + (y-loop (fx+ y 1))])))) + + (deep-flomap (flomap argb-vs 4 w h) + (flomap z-vs 1 w h))) + +(: deep-flomap-superimpose/place (Integer Integer + deep-flomap Integer Integer Integer Integer + deep-flomap Integer Integer Integer Integer -> deep-flomap)) +(define (deep-flomap-superimpose/place w h dfm1 dx1 dy1 w1 h1 dfm2 dx2 dy2 w2 h2) + (match-define (deep-flomap argb1-fm z1-fm) dfm1) + (match-define (deep-flomap argb2-fm z2-fm) dfm2) + (match-define (flomap argb1-vs 4 argb1-w argb1-h) argb1-fm) + (match-define (flomap argb2-vs 4 argb2-w argb2-h) argb2-fm) + (match-define (flomap z1-vs 1 z1-w z1-h) z1-fm) + (match-define (flomap z2-vs 1 z2-w z2-h) z2-fm) + + (define-syntax-rule (get-alpha-pixel vs dx dy w h x y) + (let ([x (fx- x dx)] [y (fx- y dy)]) + (cond [(and (x . fx>= . 0) (x . fx< . w) (y . fx>= . 0) (y . fx< . h)) + (unsafe-flvector-ref vs (fx* 4 (fx+ x (fx* y w))))] + [else 0.0]))) + + (define-syntax-rule (get-z-pixel vs dx dy w h x y) + (let ([x (fx- x dx)] [y (fx- y dy)]) + (cond [(and (x . fx>= . 0) (x . fx< . w) (y . fx>= . 0) (y . fx< . h)) + (unsafe-flvector-ref vs (fx+ x (fx* y w)))] + [else 0.0]))) + + (define z1-max -inf.0) + (let: y-loop : Void ([y : Nonnegative-Fixnum 0]) + (when (y . fx< . h) + (let: x-loop : Void ([x : Nonnegative-Fixnum 0]) + (cond [(x . fx< . w) + (define a1 (get-alpha-pixel argb1-vs dx1 dy1 w1 h1 x y)) + (define a2 (get-alpha-pixel argb2-vs dx2 dy2 w2 h2 x y)) + (when (and (a1 . > . 0.0) (a2 . > . 0.0)) + (define z1 (get-z-pixel z1-vs dx1 dy1 w1 h1 x y)) + (set! z1-max (max z1-max z1))) + (x-loop (fx+ x 1))] + [else + (y-loop (fx+ y 1))])))) + + (define new-dfm2 (deep-flomap argb2-fm (fm+ z2-fm z1-max))) + (deep-flomap-superimpose/replace 'replace w h dfm1 dx1 dy1 w1 h1 new-dfm2 dx2 dy2 w2 h2)) + +(: deep-flomap-superimpose/blend (Integer Integer + deep-flomap Integer Integer Integer Integer + deep-flomap Integer Integer Integer Integer -> deep-flomap)) +(define (deep-flomap-superimpose/blend w h dfm1 dx1 dy1 w1 h1 dfm2 dx2 dy2 w2 h2) + (match-define (deep-flomap argb1-fm z1-fm) dfm1) + (match-define (deep-flomap argb2-fm z2-fm) dfm2) + (define argb1-vs (flomap-values argb1-fm)) + (define argb2-vs (flomap-values argb2-fm)) + (define z1-vs (flomap-values z1-fm)) + (define z2-vs (flomap-values z2-fm)) + + (define-values (u1-fm v1-fm) (flomap-gradient z1-fm)) + (define-values (u2-fm v2-fm) (flomap-gradient z2-fm)) + (define u1-vs (flomap-values u1-fm)) + (define v1-vs (flomap-values v1-fm)) + (define u2-vs (flomap-values u2-fm)) + (define v2-vs (flomap-values v2-fm)) + + (define-syntax-rule (get-argbzuv-pixel argb-vs z-vs u-vs v-vs dx dy w h x y) + (let ([x (fx- x dx)] [y (fx- y dy)]) + (cond [(and (x . fx>= . 0) (x . fx< . w) (y . fx>= . 0) (y . fx< . h)) + (define i (fx+ x (fx* y w))) + (define j (fx* 4 i)) + (values (unsafe-flvector-ref argb-vs j) + (unsafe-flvector-ref argb-vs (fx+ j 1)) + (unsafe-flvector-ref argb-vs (fx+ j 2)) + (unsafe-flvector-ref argb-vs (fx+ j 3)) + (unsafe-flvector-ref z-vs i) + (unsafe-flvector-ref u-vs i) + (unsafe-flvector-ref v-vs i))] + [else + (values 0.0 0.0 0.0 0.0 0.0 0.0 0.0)]))) + + (define argb-vs (make-flvector (* 4 w h))) + (define z-vs (make-flvector (* w h))) + (let: y-loop : Void ([y : Nonnegative-Fixnum 0]) + (when (y . fx< . h) + (let: x-loop : Void ([x : Nonnegative-Fixnum 0]) + (cond [(x . fx< . w) + (define-values (a1 r1 g1 b1 z1 u1 v1) + (get-argbzuv-pixel argb1-vs z1-vs u1-vs v1-vs dx1 dy1 w1 h1 x y)) + (define-values (a2 r2 g2 b2 z2 u2 v2) + (get-argbzuv-pixel argb2-vs z2-vs u2-vs v2-vs dx2 dy2 w2 h2 x y)) + + ;; softmax blending + (define α + (cond [(and (a1 . > . 0.0) (a2 . > . 0.0)) + (define u (- (* a2 u2) (* a1 u1))) + (define v (- (* a2 v2) (* a1 v1))) + (define β (/ (- (* a2 z2) (* a1 z1)) + (flsqrt (+ (* u u) (* v v))))) + (flsigmoid (* 15.0 β))] + [(a1 . > . 0.0) 0.0] + [(a2 . > . 0.0) 1.0] + [else 0.5])) + + (define i (fx+ x (fx* y w))) + (define j (fx* 4 i)) + (unsafe-flvector-set! argb-vs j (fl-convex-combination a1 a2 α)) + (unsafe-flvector-set! argb-vs (fx+ j 1) (fl-convex-combination r1 r2 α)) + (unsafe-flvector-set! argb-vs (fx+ j 2) (fl-convex-combination g1 g2 α)) + (unsafe-flvector-set! argb-vs (fx+ j 3) (fl-convex-combination b1 b2 α)) + (unsafe-flvector-set! z-vs i (fl-convex-combination z1 z2 α)) + (x-loop (fx+ x 1))] + [else + (y-loop (fx+ y 1))])))) + + (deep-flomap (flomap argb-vs 4 w h) + (flomap z-vs 1 w h))) + +(: deep-flomap-pin* (Z-Mode Real Real Real Real deep-flomap deep-flomap * -> deep-flomap)) +(define (deep-flomap-pin* z-mode x1-frac y1-frac x2-frac y2-frac dfm . dfms) + (for/fold ([dfm1 dfm]) ([dfm2 (in-list dfms)]) + (define-values (w1 h1) (deep-flomap-size dfm1)) + (define-values (w2 h2) (deep-flomap-size dfm2)) + (deep-flomap-pin z-mode + dfm1 (* x1-frac w1) (* y1-frac h1) + dfm2 (* x2-frac w2) (* y2-frac h2)))) + +(: deep-flomap-lt-superimpose (Z-Mode deep-flomap deep-flomap * -> deep-flomap)) +(: deep-flomap-lc-superimpose (Z-Mode deep-flomap deep-flomap * -> deep-flomap)) +(: deep-flomap-lb-superimpose (Z-Mode deep-flomap deep-flomap * -> deep-flomap)) +(: deep-flomap-ct-superimpose (Z-Mode deep-flomap deep-flomap * -> deep-flomap)) +(: deep-flomap-cc-superimpose (Z-Mode deep-flomap deep-flomap * -> deep-flomap)) +(: deep-flomap-cb-superimpose (Z-Mode deep-flomap deep-flomap * -> deep-flomap)) +(: deep-flomap-rt-superimpose (Z-Mode deep-flomap deep-flomap * -> deep-flomap)) +(: deep-flomap-rc-superimpose (Z-Mode deep-flomap deep-flomap * -> deep-flomap)) +(: deep-flomap-rb-superimpose (Z-Mode deep-flomap deep-flomap * -> deep-flomap)) + +(define (deep-flomap-lt-superimpose z-mode dfm . dfms) + (apply deep-flomap-pin* z-mode 0 0 0 0 dfm dfms)) + +(define (deep-flomap-lc-superimpose z-mode dfm . dfms) + (apply deep-flomap-pin* z-mode 0 1/2 0 1/2 dfm dfms)) + +(define (deep-flomap-lb-superimpose z-mode dfm . dfms) + (apply deep-flomap-pin* z-mode 0 1 0 1 dfm dfms)) + +(define (deep-flomap-ct-superimpose z-mode dfm . dfms) + (apply deep-flomap-pin* z-mode 1/2 0 1/2 0 dfm dfms)) + +(define (deep-flomap-cc-superimpose z-mode dfm . dfms) + (apply deep-flomap-pin* z-mode 1/2 1/2 1/2 1/2 dfm dfms)) + +(define (deep-flomap-cb-superimpose z-mode dfm . dfms) + (apply deep-flomap-pin* z-mode 1/2 1 1/2 1 dfm dfms)) + +(define (deep-flomap-rt-superimpose z-mode dfm . dfms) + (apply deep-flomap-pin* z-mode 1 0 1 0 dfm dfms)) + +(define (deep-flomap-rc-superimpose z-mode dfm . dfms) + (apply deep-flomap-pin* z-mode 1 1/2 1 1/2 dfm dfms)) + +(define (deep-flomap-rb-superimpose z-mode dfm . dfms) + (apply deep-flomap-pin* z-mode 1 1 1 1 dfm dfms)) + +(: deep-flomap-vl-append (deep-flomap deep-flomap * -> deep-flomap)) +(: deep-flomap-vc-append (deep-flomap deep-flomap * -> deep-flomap)) +(: deep-flomap-vr-append (deep-flomap deep-flomap * -> deep-flomap)) +(: deep-flomap-ht-append (deep-flomap deep-flomap * -> deep-flomap)) +(: deep-flomap-hc-append (deep-flomap deep-flomap * -> deep-flomap)) +(: deep-flomap-hb-append (deep-flomap deep-flomap * -> deep-flomap)) + +(define (deep-flomap-vl-append dfm . dfms) (apply deep-flomap-pin* 'add 0 1 0 0 dfm dfms)) +(define (deep-flomap-vc-append dfm . dfms) (apply deep-flomap-pin* 'add 1/2 1 1/2 0 dfm dfms)) +(define (deep-flomap-vr-append dfm . dfms) (apply deep-flomap-pin* 'add 1 1 1 0 dfm dfms)) +(define (deep-flomap-ht-append dfm . dfms) (apply deep-flomap-pin* 'add 1 0 0 0 dfm dfms)) +(define (deep-flomap-hc-append dfm . dfms) (apply deep-flomap-pin* 'add 1 1/2 0 1/2 dfm dfms)) +(define (deep-flomap-hb-append dfm . dfms) (apply deep-flomap-pin* 'add 1 1 0 1 dfm dfms)) diff --git a/collects/images/private/deep-flomap-untyped-parameters.rkt b/collects/images/private/deep-flomap-untyped-parameters.rkt new file mode 100644 index 0000000000..0005babeb9 --- /dev/null +++ b/collects/images/private/deep-flomap-untyped-parameters.rkt @@ -0,0 +1,117 @@ +#lang racket/base + +(require unstable/parameter-group) + +(provide (all-defined-out)) + +(define refractive-indexes + #hash((diamond . 2.42) + (cubic-zirconia . 2.15) + (ruby . 1.76) + (enamel . 1.63) + (glass . 1.54) + (wax . 1.43) + (water . 1.33) + (vacuum . 1.0))) + +(define (->refractive-index idx) + (cond [(symbol? idx) + (hash-ref refractive-indexes idx + (λ () (error 'refractive-index + "`refractive-indexes' does not have a refractive index for ~e" + idx)))] + [else (exact->inexact idx)])) + +(define (list-exact->inexact vs) + (map exact->inexact vs)) + +;; light parameters +(define light-direction (make-parameter '(0.0 -1.0 1.0) list-exact->inexact)) +(define light-intensity (make-parameter '(1.0 1.0 1.0) list-exact->inexact)) +(define ambient-intensity (make-parameter '(1.0 1.0 1.0) list-exact->inexact)) +(define reflected-intensity (make-parameter '(1.0 1.0 1.0) list-exact->inexact)) + +;; material parameters +(define refractive-index (make-parameter (->refractive-index 'glass) ->refractive-index)) +(define ideal-reflectance (make-parameter 1.0 exact->inexact)) +(define ideal-transmission (make-parameter 1.0 exact->inexact)) +(define transmission-density (make-parameter 0.65 exact->inexact)) +(define specular-reflectance (make-parameter 0.15 exact->inexact)) +(define specular-roughness (make-parameter 0.15 exact->inexact)) +(define specular-purity (make-parameter 1.0 exact->inexact)) +(define diffuse-reflectance (make-parameter 0.25 exact->inexact)) +(define ambient-reflectance (make-parameter 0.1 exact->inexact)) +(define ambient-transmission (make-parameter 0.7 exact->inexact)) +(define shadow-blur (make-parameter 0.02 exact->inexact)) + +(define-parameter-group deep-flomap-lighting + (light-direction light-intensity ambient-intensity reflected-intensity)) + +(define-parameter-group deep-flomap-material + (refractive-index ideal-reflectance ideal-transmission transmission-density + specular-reflectance specular-roughness specular-purity + diffuse-reflectance ambient-reflectance ambient-transmission + shadow-blur)) + +(define matte-material + (deep-flomap-material-value + 'vacuum 0.0 0.0 1.0 + 0.0 1.0 1.0 + 1.0 0.25 0.0 + 0.0)) + +(define dull-plastic-material + (deep-flomap-material-value + 'glass 0.0 0.0 1.0 + 1.0 0.25 1.0 + 1.0 0.25 0.0 + 0.0)) + +(define wax-material + (deep-flomap-material-value + 'wax 1.0 0.5 1.25 + 0.5 0.5 0.5 + 0.5 0.5 0.5 + 0.04)) + +(define plastic-material + (deep-flomap-material-value + 'glass 0.375 1.0 2.0 + 0.25 0.15 1.0 + 0.6 0.5 0.1 + 0.03)) + +(define metal-material + (deep-flomap-material-value + 3.0 0.3 0.0 1.0 + 0.8 0.1 0.2 + 0.2 0.8 0.0 + 0.0)) + +(define porcelain-material + (deep-flomap-material-value + 'enamel 0.9 0.5 1.5 + 0.4 0.2 1.0 + 0.5 0.5 0.5 + 0.04)) + +(define frosted-glass-material + (deep-flomap-material-value + 'glass 0.9 1.0 0.8 + 0.4 0.2 1.0 + 0.5 0.1 0.5 + 0.04)) + +(define glass-material + (deep-flomap-material-value + 'glass 1.0 1.0 0.65 + 0.15 0.15 1.0 + 0.25 0.1 0.7 + 0.02)) + +(define diamond-material + (deep-flomap-material-value + 'diamond 1.0 1.0 0.5 + 0.15 0.15 1.0 + 0.15 0.1 0.7 + 0.02)) diff --git a/collects/images/private/deep-flomap.rkt b/collects/images/private/deep-flomap.rkt index 5ab232a45f..2f0f4b6a2c 100644 --- a/collects/images/private/deep-flomap.rkt +++ b/collects/images/private/deep-flomap.rkt @@ -1,486 +1,9 @@ -#lang racket/base +#lang typed/racket/base -(require racket/flonum racket/draw racket/match racket/math racket/contract racket/class - "unsafe.rkt" - "flomap.rkt") +(require "deep-flomap-struct.rkt" + "deep-flomap-parameters.rkt" + "deep-flomap-render.rkt") -(provide - (contract-out - ;; type, contructors and accessors - (struct deep-flomap ([argb flomap?] [z flomap?])) - [flomap->deep-flomap (flomap? . -> . deep-flomap?)] - [bitmap->deep-flomap ((is-a?/c bitmap%) . -> . deep-flomap?)] - [deep-flomap-width (deep-flomap? . -> . (fx>=/c 0))] - [deep-flomap-height (deep-flomap? . -> . (fx>=/c 0))] - [deep-flomap-z-min (deep-flomap? . -> . flonum?)] - [deep-flomap-z-max (deep-flomap? . -> . flonum?)] - [deep-flomap-size (deep-flomap? . -> . (values (fx>=/c 0) (fx>=/c 0)))] - [deep-flomap-alpha (deep-flomap? . -> . flomap?)] - [deep-flomap-rgb (deep-flomap? . -> . flomap?)] - ;; sizing - [deep-flomap-inset (case-> (deep-flomap? fixnum? . -> . deep-flomap?) - (deep-flomap? fixnum? fixnum? . -> . deep-flomap?) - (deep-flomap? fixnum? fixnum? fixnum? fixnum? . -> . deep-flomap?))] - [deep-flomap-trim (deep-flomap? . -> . deep-flomap?)] - [deep-flomap-scale (case-> (deep-flomap? (>/c 0.0) . -> . deep-flomap?) - (deep-flomap? (>/c 0.0) (>/c 0.0) (>/c 0.0) . -> . deep-flomap?))] - [deep-flomap-resize (deep-flomap? (or/c (>/c 0.0) #f) (or/c (>/c 0.0) #f) - (or/c real? #f) (or/c real? #f) - . -> . deep-flomap?)] - ;; z-adjusting - [deep-flomap-scale-z (deep-flomap? (or/c flomap? real?) . -> . deep-flomap?)] - [deep-flomap-smooth-z (deep-flomap? real? . -> . deep-flomap?)] - [deep-flomap-raise (deep-flomap? (or/c flomap? real?) . -> . deep-flomap?)] - [deep-flomap-tilt (deep-flomap? real? real? real? real? . -> . deep-flomap?)] - [deep-flomap-emboss (deep-flomap? real? real? . -> . deep-flomap?)] - [deep-flomap-bulge (deep-flomap? (flonum? flonum? . -> . real?) . -> . deep-flomap?)] - [deep-flomap-bulge-round (deep-flomap? real? . -> . deep-flomap?)] - [deep-flomap-bulge-round-rect (deep-flomap? real? . -> . deep-flomap?)] - [deep-flomap-bulge-spheroid (deep-flomap? real? . -> . deep-flomap?)] - [deep-flomap-bulge-horizontal (deep-flomap? real? . -> . deep-flomap?)] - [deep-flomap-bulge-vertical (deep-flomap? real? . -> . deep-flomap?)] - [deep-flomap-bulge-ripple (deep-flomap? real? real? . -> . deep-flomap?)] - ;; combining - [deep-flomap-pin (->* [deep-flomap? real? real? deep-flomap? real? real?] - [#:z-mode (one-of/c 'place 'replace 'add 'blend)] - deep-flomap?)] - [deep-flomap-pin* (->* [real? real? real? real? deep-flomap?] - [#:z-mode (one-of/c 'place 'replace 'add 'blend)] - #:rest (listof deep-flomap?) - deep-flomap?)] - [deep-flomap-lt-superimpose deep-flomap-superimpose/c] - [deep-flomap-lc-superimpose deep-flomap-superimpose/c] - [deep-flomap-lb-superimpose deep-flomap-superimpose/c] - [deep-flomap-ct-superimpose deep-flomap-superimpose/c] - [deep-flomap-cc-superimpose deep-flomap-superimpose/c] - [deep-flomap-cb-superimpose deep-flomap-superimpose/c] - [deep-flomap-rt-superimpose deep-flomap-superimpose/c] - [deep-flomap-rc-superimpose deep-flomap-superimpose/c] - [deep-flomap-rb-superimpose deep-flomap-superimpose/c] - [deep-flomap-vl-append deep-flomap-append/c] - [deep-flomap-vc-append deep-flomap-append/c] - [deep-flomap-vr-append deep-flomap-append/c] - [deep-flomap-ht-append deep-flomap-append/c] - [deep-flomap-hc-append deep-flomap-append/c] - [deep-flomap-hb-append deep-flomap-append/c] - [deep-flomap-superimpose/c contract?] - [deep-flomap-append/c contract?] - )) - -(struct deep-flomap (argb z) - #:guard - (λ (argb-fm z-fm name) - (match-define (flomap _ 4 w h) argb-fm) - (match-define (flomap _ 1 zw zh) z-fm) - (unless (and (= w zw) (= h zh)) - (error 'deep-flomap - "expected flomaps of equal dimension; given dimensions ~e×~e and ~e×~e" w h zw zh)) - (values argb-fm z-fm))) - -(define (flomap->deep-flomap argb-fm) - (match-define (flomap _ 4 w h) argb-fm) - (deep-flomap argb-fm (make-flomap 1 w h))) - -(define (bitmap->deep-flomap bm) - (flomap->deep-flomap (bitmap->flomap bm))) - -(define (deep-flomap-width dfm) - (flomap-width (deep-flomap-argb dfm))) - -(define (deep-flomap-height dfm) - (flomap-height (deep-flomap-argb dfm))) - -(define (deep-flomap-z-min dfm) - (flomap-min-value (deep-flomap-z dfm))) - -(define (deep-flomap-z-max dfm) - (flomap-max-value (deep-flomap-z dfm))) - -(define (deep-flomap-size dfm) - (values (deep-flomap-width dfm) (deep-flomap-height dfm))) - -(define (deep-flomap-alpha dfm) - (flomap-ref-component (deep-flomap-argb dfm) 0)) - -(define (deep-flomap-rgb dfm) - (flomap-drop-components (deep-flomap-argb dfm) 1)) - -;; =================================================================================================== -;; Z adjusters - -(define (deep-flomap-scale-z dfm z) - (match-define (deep-flomap argb-fm z-fm) dfm) - (deep-flomap argb-fm (fm* z-fm z))) - -(define (deep-flomap-smooth-z dfm σ) - (let ([σ (exact->inexact σ)]) - (match-define (deep-flomap argb-fm z-fm) dfm) - (define new-z-fm (flomap-blur z-fm σ)) - (deep-flomap argb-fm new-z-fm))) - -;; deep-flomap-raise and everything derived from it observe an invariant: -;; when z is added, added z must be 0.0 everywhere alpha is 0.0 - -(define (deep-flomap-raise dfm z) - (match-define (deep-flomap argb-fm z-fm) dfm) - (define alpha-fm (deep-flomap-alpha dfm)) - (deep-flomap argb-fm (fm+ z-fm (fm* alpha-fm z)))) - -(define (deep-flomap-emboss dfm xy-amt z-amt) - (let ([σ (/ xy-amt 3.0)]) - (define z-fm (flomap-normalize (deep-flomap-alpha dfm))) - (define new-z-fm (fm* (flomap-blur z-fm σ) - (exact->inexact z-amt))) - (deep-flomap-raise dfm new-z-fm))) - -(define-syntax-rule (unsafe-deep-flomap-bulge dfm f) - (let () - (define-values (w h) (deep-flomap-size dfm)) - (define half-x-size (unsafe-fl- (unsafe-fl* 0.5 (unsafe-fx->fl w)) 0.5)) - (define half-y-size (unsafe-fl- (unsafe-fl* 0.5 (unsafe-fx->fl h)) 0.5)) - (define z-fm - (unsafe-build-flomap - 1 w h - (λ (_ x y) - (f (unsafe-fl- (unsafe-fl/ (unsafe-fx->fl x) half-x-size) 1.0) - (unsafe-fl- (unsafe-fl/ (unsafe-fx->fl y) half-y-size) 1.0))))) - (deep-flomap-raise dfm z-fm))) - -(define (deep-flomap-bulge dfm f) - (unsafe-deep-flomap-bulge dfm (λ (cx cy) (exact->inexact (f cx cy))))) - -(define (deep-flomap-tilt dfm left-z-amt top-z-amt right-z-amt bottom-z-amt) - (let ([l (exact->inexact left-z-amt)] - [t (exact->inexact top-z-amt)] - [r (exact->inexact right-z-amt)] - [b (exact->inexact bottom-z-amt)]) - (define (f x y) - (define α (unsafe-fl/ (unsafe-fl+ x 1.0) 2.0)) - (define β (unsafe-fl/ (unsafe-fl+ y 1.0) 2.0)) - (unsafe-flsum (unsafe-fl* (unsafe-fl- 1.0 α) l) (unsafe-fl* α r) - (unsafe-fl* (unsafe-fl- 1.0 β) t) (unsafe-fl* β b))) - (unsafe-deep-flomap-bulge dfm f))) - -(define (deep-flomap-bulge-round dfm z-amt) - (let ([z-amt (exact->inexact z-amt)]) - (define (f x y) - (define d^2 (unsafe-fl+ (unsafe-fl* x x) (unsafe-fl* y y))) - (unsafe-fl* z-amt (unsafe-flsqrt (unsafe-fl/ (unsafe-fl- 2.0 d^2) 2.0)))) - (unsafe-deep-flomap-bulge dfm f))) - -(define (deep-flomap-bulge-round-rect dfm z-amt) - (let ([z-amt (exact->inexact z-amt)]) - (define (f x y) - (unsafe-fl* z-amt (unsafe-flsqrt - (unsafe-fl* (unsafe-fl- 1.0 (unsafe-fl* x x)) - (unsafe-fl- 1.0 (unsafe-fl* y y)))))) - (unsafe-deep-flomap-bulge dfm f))) - -(define (deep-flomap-bulge-spheroid dfm z-amt) - (let ([z-amt (exact->inexact z-amt)]) - (define (f x y) - (define d^2 (unsafe-fl+ (unsafe-fl* x x) (unsafe-fl* y y))) - (cond [(d^2 . unsafe-fl< . 1.0) - (unsafe-fl* z-amt (unsafe-flsqrt (unsafe-fl- 1.0 d^2)))] - [else 0.0])) - (unsafe-deep-flomap-bulge dfm f))) - -(define (deep-flomap-bulge-horizontal dfm z-amt) - (let ([z-amt (exact->inexact z-amt)]) - (define (f x _) - (define d^2 (unsafe-fl* x x)) - (unsafe-fl* z-amt (unsafe-flsqrt (unsafe-fl- 1.0 d^2)))) - (unsafe-deep-flomap-bulge dfm f))) - -(define (deep-flomap-bulge-vertical dfm z-amt) - (let ([z-amt (exact->inexact z-amt)]) - (define (f _ y) - (define d^2 (unsafe-fl* y y)) - (unsafe-fl* z-amt (unsafe-flsqrt (unsafe-fl- 1.0 d^2)))) - (unsafe-deep-flomap-bulge dfm f))) - -(define (deep-flomap-bulge-ripple dfm freq z-amt) - (let ([freq (exact->inexact freq)] - [z-amt (exact->inexact z-amt)]) - (define (f x y) - (define d^2 (unsafe-fl+ (unsafe-fl* x x) (unsafe-fl* y y))) - (define d (unsafe-flproduct freq pi (unsafe-flsqrt d^2))) - (unsafe-flproduct z-amt 0.5 (unsafe-fl- 1.0 (unsafe-flcos d)))) - (unsafe-deep-flomap-bulge dfm f))) - -;; =================================================================================================== -;; Sizing - -(define deep-flomap-inset - (case-lambda - [(dfm amt) - (deep-flomap-inset dfm amt amt amt amt)] - [(dfm h-amt v-amt) - (deep-flomap-inset dfm h-amt v-amt h-amt v-amt)] - [(dfm l-amt t-amt r-amt b-amt) - (match-define (deep-flomap argb-fm z-fm) dfm) - (deep-flomap (flomap-inset argb-fm l-amt t-amt r-amt b-amt) - (flomap-inset z-fm l-amt t-amt r-amt b-amt))])) - -(define (deep-flomap-trim dfm) - (define-values (w h) (deep-flomap-size dfm)) - (define-values (_k-min x-min y-min _k-max x-max y-max) - (flomap-nonzero-rect (deep-flomap-alpha dfm))) - (deep-flomap-inset dfm (- x-min) (- y-min) (- x-max w) (- y-max h))) - -(define deep-flomap-scale - (case-lambda - [(dfm scale) - (match-define (deep-flomap argb-fm z-fm) (deep-flomap-scale-z dfm scale)) - (deep-flomap (flomap-scale argb-fm scale) - (flomap-scale z-fm scale))] - [(dfm x-scale y-scale z-scale) - (match-define (deep-flomap argb-fm z-fm) (deep-flomap-scale-z dfm z-scale)) - (deep-flomap (flomap-scale argb-fm x-scale y-scale) - (flomap-scale z-fm x-scale y-scale))])) - -(define (deep-flomap-resize dfm width height z-min z-max) - (match-define (deep-flomap argb-fm z-fm) dfm) - (define new-z-fm - (cond [(or z-min z-max) - (let ([z-min (if z-min z-min (flomap-min-value z-fm))] - [z-max (if z-max z-max (flomap-max-value z-fm))]) - (fm+ (fm* (flomap-normalize z-fm) (- z-max z-min)) z-min))] - [else z-fm])) - (deep-flomap (flomap-resize argb-fm width height) - (flomap-resize new-z-fm width height))) - -;; =================================================================================================== -;; Combining - -(define (deep-flomap-pin dfm1 x1 y1 dfm2 x2 y2 #:z-mode [z-mode 'blend]) - (cond - [(not (and (zero? x2) (zero? y2))) - (deep-flomap-pin dfm1 (- x1 x2) (- y1 y2) dfm2 0 0 #:z-mode z-mode)] - [else - (define-values (w1 h1) (deep-flomap-size dfm1)) - (define-values (w2 h2) (deep-flomap-size dfm2)) - - ;; dfm1 and dfm2 offsets, in final image coordinates - (define dx1 (inexact->exact (round (max 0 (- x1))))) - (define dy1 (inexact->exact (round (max 0 (- y1))))) - (define dx2 (inexact->exact (round (max 0 x1)))) - (define dy2 (inexact->exact (round (max 0 y1)))) - ;; final image size - (define w (max (+ dx1 w1) (+ dx2 w2))) - (define h (max (+ dy1 h1) (+ dy2 h2))) - - (case z-mode - [(place) (deep-flomap-superimpose/place w h dfm1 dx1 dy1 w1 h1 dfm2 dx2 dy2 w2 h2)] - [(blend) (deep-flomap-superimpose/blend w h dfm1 dx1 dy1 w1 h1 dfm2 dx2 dy2 w2 h2)] - [(replace add) (deep-flomap-superimpose/replace w h - dfm1 dx1 dy1 w1 h1 - dfm2 dx2 dy2 w2 h2 z-mode)])])) - -(define (deep-flomap-superimpose/replace w h dfm1 dx1 dy1 w1 h1 dfm2 dx2 dy2 w2 h2 z-mode) - (match-define (deep-flomap argb1-fm z1-fm) dfm1) - (match-define (deep-flomap argb2-fm z2-fm) dfm2) - (define argb1-vs (flomap-values argb1-fm)) - (define argb2-vs (flomap-values argb2-fm)) - (define z1-vs (flomap-values z1-fm)) - (define z2-vs (flomap-values z2-fm)) - - (define-syntax-rule (get-argbz-pixel argb-vs z-vs dx dy w h x y) - (let ([x (unsafe-fx- x dx)] - [y (unsafe-fx- y dy)]) - (cond [(and (x . unsafe-fx>= . 0) (x . unsafe-fx< . w) - (y . unsafe-fx>= . 0) (y . unsafe-fx< . h)) - (define i (unsafe-fx+ x (unsafe-fx* y w))) - (define-values (a r g b) (unsafe-flvector-4ref argb-vs (unsafe-fx* 4 i))) - (define z (unsafe-flvector-ref z-vs i)) - (values a r g b z)] - [else - (values 0.0 0.0 0.0 0.0 0.0)]))) - - (define argb-vs (make-flvector (* 4 w h))) - (define z-vs (make-flvector (* w h))) - (for* ([y (in-range h)] [x (in-range w)]) - (define-values (a1 r1 g1 b1 z1) (get-argbz-pixel argb1-vs z1-vs dx1 dy1 w1 h1 x y)) - (define-values (a2 r2 g2 b2 z2) (get-argbz-pixel argb2-vs z2-vs dx2 dy2 w2 h2 x y)) - - (define i (unsafe-fx+ x (unsafe-fx* y w))) - (unsafe-flvector-4set! argb-vs (unsafe-fx* 4 i) - (unsafe-fl-alpha-blend a1 a2 a2) - (unsafe-fl-alpha-blend r1 r2 a2) - (unsafe-fl-alpha-blend g1 g2 a2) - (unsafe-fl-alpha-blend b1 b2 a2)) - (unsafe-flvector-set! z-vs i - (case z-mode - [(replace) (unsafe-fl-alpha-blend z1 z2 a2)] - [else (unsafe-fl+ z1 z2)]))) - - (deep-flomap (flomap argb-vs 4 w h) - (flomap z-vs 1 w h))) - -(define (deep-flomap-superimpose/place w h dfm1 dx1 dy1 w1 h1 dfm2 dx2 dy2 w2 h2) - (match-define (deep-flomap argb1-fm z1-fm) dfm1) - (match-define (deep-flomap argb2-fm z2-fm) dfm2) - (match-define (flomap argb1-vs 4 argb1-w argb1-h) argb1-fm) - (match-define (flomap argb2-vs 4 argb2-w argb2-h) argb2-fm) - (match-define (flomap z1-vs 1 z1-w z1-h) z1-fm) - (match-define (flomap z2-vs 1 z2-w z2-h) z2-fm) - - (define-syntax-rule (get-alpha-pixel vs dx dy w h x y) - (let ([x (unsafe-fx- x dx)] - [y (unsafe-fx- y dy)]) - (cond [(and (x . unsafe-fx>= . 0) (x . unsafe-fx< . w) - (y . unsafe-fx>= . 0) (y . unsafe-fx< . h)) - (unsafe-flvector-ref vs (unsafe-fx* 4 (unsafe-fx+ x (unsafe-fx* y w))))] - [else 0.0]))) - - (define-syntax-rule (get-z-pixel vs dx dy w h x y) - (let ([x (unsafe-fx- x dx)] - [y (unsafe-fx- y dy)]) - (cond [(and (x . unsafe-fx>= . 0) (x . unsafe-fx< . w) - (y . unsafe-fx>= . 0) (y . unsafe-fx< . h)) - (unsafe-flvector-ref vs (unsafe-fx+ x (unsafe-fx* y w)))] - [else 0.0]))) - - (define z1-max - (for*/fold ([z1-max -inf.0]) ([y (in-range h)] [x (in-range w)]) - (define a1 (get-alpha-pixel argb1-vs dx1 dy1 w1 h1 x y)) - (define a2 (get-alpha-pixel argb2-vs dx2 dy2 w2 h2 x y)) - (cond [(and (a1 . unsafe-fl> . 0.0) (a2 . unsafe-fl> . 0.0)) - (define z1 (get-z-pixel z1-vs dx1 dy1 w1 h1 x y)) - (unsafe-flmax z1-max z1)] - [else z1-max]))) - - (define new-dfm2 (deep-flomap argb2-fm (fm+ z2-fm z1-max))) - (deep-flomap-superimpose/replace w h dfm1 dx1 dy1 w1 h1 new-dfm2 dx2 dy2 w2 h2 'replace)) - -(define (deep-flomap-superimpose/blend w h dfm1 dx1 dy1 w1 h1 dfm2 dx2 dy2 w2 h2) - (match-define (deep-flomap argb1-fm z1-fm) dfm1) - (match-define (deep-flomap argb2-fm z2-fm) dfm2) - (define argb1-vs (flomap-values argb1-fm)) - (define argb2-vs (flomap-values argb2-fm)) - (define z1-vs (flomap-values z1-fm)) - (define z2-vs (flomap-values z2-fm)) - - (define-values (u1-fm v1-fm) (flomap-gradient z1-fm)) - (define-values (u2-fm v2-fm) (flomap-gradient z2-fm)) - (define u1-vs (flomap-values u1-fm)) - (define v1-vs (flomap-values v1-fm)) - (define u2-vs (flomap-values u2-fm)) - (define v2-vs (flomap-values v2-fm)) - - (define-syntax-rule (get-argbzuv-pixel argb-vs z-vs u-vs v-vs dx dy w h x y) - (let ([x (unsafe-fx- x dx)] - [y (unsafe-fx- y dy)]) - (cond [(and (x . unsafe-fx>= . 0) (x . unsafe-fx< . w) - (y . unsafe-fx>= . 0) (y . unsafe-fx< . h)) - (define i (unsafe-fx+ x (unsafe-fx* y w))) - (define-values (a r g b) (unsafe-flvector-4ref argb-vs (unsafe-fx* 4 i))) - (define z (unsafe-flvector-ref z-vs i)) - (define u (unsafe-flvector-ref u-vs i)) - (define v (unsafe-flvector-ref v-vs i)) - (values a r g b z u v)] - [else - (values 0.0 0.0 0.0 0.0 0.0 0.0 0.0)]))) - - (define argb-vs (make-flvector (* 4 w h))) - (define z-vs (make-flvector (* w h))) - (for* ([y (in-range h)] [x (in-range w)]) - (define-values (a1 r1 g1 b1 z1 u1 v1) - (get-argbzuv-pixel argb1-vs z1-vs u1-vs v1-vs dx1 dy1 w1 h1 x y)) - (define-values (a2 r2 g2 b2 z2 u2 v2) - (get-argbzuv-pixel argb2-vs z2-vs u2-vs v2-vs dx2 dy2 w2 h2 x y)) - - #;; max blending: if both alphas nonzero and unequal, keep the pixel with greatest z - (define α - (cond [(and (a1 . unsafe-fl> . 0.0) (a2 . unsafe-fl> . 0.0)) - (cond [(a1 . unsafe-fl> . a2) 0.0] - [(a2 . unsafe-fl> . a1) 1.0] - [else (cond [(z1 . unsafe-fl> . z2) 0.0] - [(z2 . unsafe-fl> . z1) 1.0] - [else 0.5])])] - [(a1 . unsafe-fl> . 0.0) 0.0] - [(a2 . unsafe-fl> . 0.0) 1.0] - [else 0.5])) - ;; softmax blending - (define α - (cond [(and (a1 . unsafe-fl> . 0.0) (a2 . unsafe-fl> . 0.0)) - (define u (unsafe-fl- (unsafe-fl* a2 u2) (unsafe-fl* a1 u1))) - (define v (unsafe-fl- (unsafe-fl* a2 v2) (unsafe-fl* a1 v1))) - (define β (unsafe-fl/ (unsafe-fl- (unsafe-fl* a2 z2) (unsafe-fl* a1 z1)) - (unsafe-flsqrt (unsafe-fl+ (unsafe-fl* u u) (unsafe-fl* v v))))) - (unsafe-flsigmoid (unsafe-fl* 15.0 β))] - [(a1 . unsafe-fl> . 0.0) 0.0] - [(a2 . unsafe-fl> . 0.0) 1.0] - [else 0.5])) - - (define i (unsafe-fx+ x (unsafe-fx* y w))) - (unsafe-flvector-4set! argb-vs (unsafe-fx* 4 i) - (unsafe-fl-convex-combination a1 a2 α) - (unsafe-fl-convex-combination r1 r2 α) - (unsafe-fl-convex-combination g1 g2 α) - (unsafe-fl-convex-combination b1 b2 α)) - (unsafe-flvector-set! z-vs i (unsafe-fl-convex-combination z1 z2 α))) - - (deep-flomap (flomap argb-vs 4 w h) - (flomap z-vs 1 w h))) - -(define (deep-flomap-pin* x1-frac y1-frac x2-frac y2-frac dfm #:z-mode [z-mode 'blend] . dfms) - (for/fold ([dfm1 dfm]) ([dfm2 (in-list dfms)]) - (define-values (w1 h1) (deep-flomap-size dfm1)) - (define-values (w2 h2) (deep-flomap-size dfm2)) - (deep-flomap-pin dfm1 (* x1-frac w1) (* y1-frac h1) - dfm2 (* x2-frac w2) (* y2-frac h2) #:z-mode z-mode))) - -(define deep-flomap-superimpose/c (->* [deep-flomap?] - [#:z-mode (one-of/c 'place 'replace 'add 'blend)] - #:rest (listof deep-flomap?) - deep-flomap?)) - -(define (deep-flomap-lt-superimpose dfm #:z-mode [z-mode 'blend] . dfms) - (apply deep-flomap-pin* 0 0 0 0 dfm dfms #:z-mode z-mode)) - -(define (deep-flomap-lc-superimpose dfm #:z-mode [z-mode 'blend] . dfms) - (apply deep-flomap-pin* 0 1/2 0 1/2 dfm dfms #:z-mode z-mode)) - -(define (deep-flomap-lb-superimpose dfm #:z-mode [z-mode 'blend] . dfms) - (apply deep-flomap-pin* 0 1 0 1 dfm dfms #:z-mode z-mode)) - -(define (deep-flomap-ct-superimpose dfm #:z-mode [z-mode 'blend] . dfms) - (apply deep-flomap-pin* 1/2 0 1/2 0 dfm dfms #:z-mode z-mode)) - -(define (deep-flomap-cc-superimpose dfm #:z-mode [z-mode 'blend] . dfms) - (apply deep-flomap-pin* 1/2 1/2 1/2 1/2 dfm dfms #:z-mode z-mode)) - -(define (deep-flomap-cb-superimpose dfm #:z-mode [z-mode 'blend] . dfms) - (apply deep-flomap-pin* 1/2 1 1/2 1 dfm dfms #:z-mode z-mode)) - -(define (deep-flomap-rt-superimpose dfm #:z-mode [z-mode 'blend] . dfms) - (apply deep-flomap-pin* 1 0 1 0 dfm dfms #:z-mode z-mode)) - -(define (deep-flomap-rc-superimpose dfm #:z-mode [z-mode 'blend] . dfms) - (apply deep-flomap-pin* 1 1/2 1 1/2 dfm dfms #:z-mode z-mode)) - -(define (deep-flomap-rb-superimpose dfm #:z-mode [z-mode 'blend] . dfms) - (apply deep-flomap-pin* 1 1 1 1 dfm dfms #:z-mode z-mode)) - -(define deep-flomap-append/c (->* [deep-flomap?] - #:rest (listof deep-flomap?) - deep-flomap?)) - -(define (deep-flomap-vl-append dfm . dfms) - (apply deep-flomap-pin* 0 1 0 0 dfm dfms #:z-mode 'add)) - -(define (deep-flomap-vc-append dfm . dfms) - (apply deep-flomap-pin* 1/2 1 1/2 0 dfm dfms #:z-mode 'add)) - -(define (deep-flomap-vr-append dfm . dfms) - (apply deep-flomap-pin* 1 1 1 0 dfm dfms #:z-mode 'add)) - -(define (deep-flomap-ht-append dfm . dfms) - (apply deep-flomap-pin* 1 0 0 0 dfm dfms #:z-mode 'add)) - -(define (deep-flomap-hc-append dfm . dfms) - (apply deep-flomap-pin* 1 1/2 0 1/2 dfm dfms #:z-mode 'add)) - -(define (deep-flomap-hb-append dfm . dfms) - (apply deep-flomap-pin* 1 1 0 1 dfm dfms #:z-mode 'add)) +(provide (all-from-out "deep-flomap-struct.rkt" + "deep-flomap-parameters.rkt" + "deep-flomap-render.rkt")) diff --git a/collects/images/private/draw-predicates.rkt b/collects/images/private/draw-predicates.rkt new file mode 100644 index 0000000000..b0a9c4a011 --- /dev/null +++ b/collects/images/private/draw-predicates.rkt @@ -0,0 +1,11 @@ +#lang racket/base + +(require racket/draw racket/class) + +(provide bitmap? dc?) + +(define (bitmap? bm) + (bm . is-a? . bitmap%)) + +(define (dc? dc) + (dc . is-a? . dc<%>)) diff --git a/collects/images/private/flomap-blur.rkt b/collects/images/private/flomap-blur.rkt new file mode 100644 index 0000000000..22b75829af --- /dev/null +++ b/collects/images/private/flomap-blur.rkt @@ -0,0 +1,338 @@ +#lang typed/racket/base + +(require racket/flonum + (except-in racket/fixnum fl->fx fx->fl) + racket/match racket/math + "flonum.rkt" + "flomap-struct.rkt") + +(provide flomap-gaussian-blur-x flomap-gaussian-blur-y flomap-gaussian-blur + flomap-box-blur-x flomap-box-blur-y flomap-box-blur + flomap-blur-x flomap-blur-y flomap-blur) + +;; =================================================================================================== +;; Gaussian blur + +(: flomap-gaussian-blur (case-> (flomap Real -> flomap) + (flomap Real Real -> flomap))) +(define flomap-gaussian-blur + (case-lambda + [(fm xσ) (flomap-gaussian-blur fm xσ xσ)] + [(fm xσ yσ) + (flomap-gaussian-blur-y (flomap-gaussian-blur-x fm (abs (exact->inexact xσ))) + (abs (exact->inexact yσ)))])) + +(: flomap-gaussian-blur-x (flomap Flonum -> flomap)) +(define (flomap-gaussian-blur-x fm σ) + (cond + [(σ . = . 0.0) fm] + [else + (define dx-min (fl->fx (floor (* (- 3.0) σ)))) + (define dx-max (fx+ 1 (fl->fx (ceiling (* 3.0 σ))))) + (define ss (gaussian-kernel-1d dx-min dx-max σ)) + + (match-define (flomap vs c w h) fm) + (inline-build-flomap + c w h + (λ (k x y i) + (define dx-start (fx- (fxmax (fx+ x dx-min) 0) x)) + (define dx-end (fx- (fxmin (fx+ x dx-max) w) x)) + (define j (fx+ i (fx* c dx-start))) + (let: src-loop : Flonum ([sum : Flonum 0.0] [dx : Fixnum dx-start] [j : Fixnum j]) + (cond [(dx . fx< . dx-end) (define s (unsafe-flvector-ref ss (fx- dx dx-min))) + (src-loop (+ sum (* s (unsafe-flvector-ref vs j))) + (fx+ dx 1) + (fx+ j c))] + [else sum]))))])) + +(: flomap-gaussian-blur-y (flomap Flonum -> flomap)) +(define (flomap-gaussian-blur-y fm σ) + (cond + [(σ . = . 0.0) fm] + [else + (define dy-min (fl->fx (floor (* (- 3.0) σ)))) + (define dy-max (fx+ 1 (fl->fx (ceiling (* 3.0 σ))))) + (define ss (gaussian-kernel-1d dy-min dy-max σ)) + + (match-define (flomap vs c w h) fm) + (define cw (* c w)) + (inline-build-flomap + c w h + (λ (k x y i) + (define dy-start (fx- (fxmax (fx+ y dy-min) 0) y)) + (define dy-end (fx- (fxmin (fx+ y dy-max) h) y)) + (define j (fx+ i (fx* cw dy-start))) + (let: src-loop : Flonum ([sum : Flonum 0.0] [dy : Fixnum dy-start] [j : Fixnum j]) + (cond [(dy . fx< . dy-end) (define s (unsafe-flvector-ref ss (fx- dy dy-min))) + (src-loop (+ sum (* s (unsafe-flvector-ref vs j))) + (fx+ dy 1) + (fx+ j cw))] + [else sum]))))])) + +(: gaussian-kernel-1d (Fixnum Fixnum Flonum -> FlVector)) +(define (gaussian-kernel-1d mn mx σ) + (define n (fx- mx mn)) + (define ys (make-flvector n)) + (define sum + (let: loop : Flonum ([i : Fixnum 0] [sum : Flonum 0.0]) + (cond [(i . fx< . n) (define v (flgaussian (fx->fl (fx+ i mn)) σ)) + (unsafe-flvector-set! ys i v) + (loop (fx+ i 1) (+ sum v))] + [else sum]))) + (let: loop : FlVector ([i : Integer 0]) + (cond [(i . fx< . n) (unsafe-flvector-set! ys i (/ (unsafe-flvector-ref ys i) sum)) + (loop (fx+ i 1))] + [else ys]))) + + +;; =================================================================================================== +;; Integral images + +(: flomap-integral (flomap -> flomap)) +(define (flomap-integral fm) + (match-define (flomap vs c w h) fm) + (define w+1 (fx+ w 1)) + (define c*w+1 (fx* c w+1)) + (define h+1 (fx+ h 1)) + (define new-vs (make-flvector (* c w+1 h+1))) + (let: y-loop : Void ([y : Nonnegative-Fixnum 0] [i : Nonnegative-Fixnum 0]) + (when (y . fx< . h) + (let: x-loop : Void ([x : Nonnegative-Fixnum 0] [i : Nonnegative-Fixnum i]) + (cond [(x . fx< . w) + (let: k-loop : Void ([k : Nonnegative-Fixnum 0] [i : Nonnegative-Fixnum i]) + (cond [(k . fx< . c) + (define j00 (coords->index c w+1 k x y)) + (define j01 (fx+ j00 c*w+1)) + (unsafe-flvector-set! new-vs (fx+ j01 c) + (- (+ (unsafe-flvector-ref vs i) + (unsafe-flvector-ref new-vs j01) + (unsafe-flvector-ref new-vs (fx+ j00 c))) + (unsafe-flvector-ref new-vs j00))) + (k-loop (fx+ k 1) (fx+ i 1))] + [else (x-loop (fx+ x 1) i)]))] + [else (y-loop (fx+ y 1) i)])))) + (flomap new-vs c w+1 h+1)) + +(: flomap-integral-x (flomap -> flomap)) +(define (flomap-integral-x fm) + (match-define (flomap vs c w h) fm) + (define w+1 (fx+ w 1)) + (define new-vs (make-flvector (* c w+1 h))) + (let: y-loop : Void ([y : Nonnegative-Fixnum 0] [i : Nonnegative-Fixnum 0]) + (when (y . fx< . h) + (let: x-loop : Void ([x : Nonnegative-Fixnum 0] [i : Nonnegative-Fixnum i]) + (cond [(x . fx< . w) + (let: k-loop : Void ([k : Nonnegative-Fixnum 0] [i : Nonnegative-Fixnum i]) + (cond [(k . fx< . c) + (define j0 (coords->index c w+1 k x y)) + (define j1 (fx+ j0 c)) + (unsafe-flvector-set! new-vs j1 (+ (unsafe-flvector-ref vs i) + (unsafe-flvector-ref new-vs j0))) + (k-loop (fx+ k 1) (fx+ i 1))] + [else (x-loop (fx+ x 1) i)]))] + [else (y-loop (fx+ y 1) i)])))) + (flomap new-vs c w+1 h)) + +(: flomap-integral-y (flomap -> flomap)) +(define (flomap-integral-y fm) + (match-define (flomap vs c w h) fm) + (define h+1 (fx+ h 1)) + (define cw (fx* c w)) + (define new-vs (make-flvector (* c w h+1))) + (let: y-loop : Void ([y : Nonnegative-Fixnum 0]) + (when (y . fx< . h) + (let: x-loop : Void ([x : Nonnegative-Fixnum 0]) + (cond [(x . fx< . w) + (let: k-loop : Void ([k : Nonnegative-Fixnum 0]) + (cond [(k . fx< . c) + (define j0 (coords->index c w k x y)) + (define j1 (fx+ j0 cw)) + (unsafe-flvector-set! new-vs j1 (+ (unsafe-flvector-ref vs j0) + (unsafe-flvector-ref new-vs j0))) + (k-loop (fx+ k 1))] + [else (x-loop (fx+ x 1))]))] + [else (y-loop (fx+ y 1))])))) + (flomap new-vs c w h+1)) + +(: raw-flomap-integral-sum (FlVector Integer Integer Integer + Integer Integer Integer Integer Integer + -> Flonum)) +(define (raw-flomap-integral-sum vs c w h k x-start y-start x-end y-end) + (define w-1 (fx- w 1)) + (define h-1 (fx- h 1)) + (define x1 (fxmax 0 (fxmin x-start w-1))) + (define x2 (fxmax 0 (fxmin x-end w-1))) + (define y1 (fxmax 0 (fxmin y-start h-1))) + (define y2 (fxmax 0 (fxmin y-end h-1))) + (- (+ (unsafe-flvector-ref vs (coords->index c w k x1 y1)) + (unsafe-flvector-ref vs (coords->index c w k x2 y2))) + (+ (unsafe-flvector-ref vs (coords->index c w k x1 y2)) + (unsafe-flvector-ref vs (coords->index c w k x2 y1))))) + +(: raw-flomap-integral-x-sum (FlVector Integer Integer + Integer Integer Integer Integer -> Flonum)) +(define (raw-flomap-integral-x-sum vs c w k x-start x-end y) + (define w-1 (fx- w 1)) + (define x1 (fxmax 0 (fxmin x-start w-1))) + (define x2 (fxmax 0 (fxmin x-end w-1))) + (- (unsafe-flvector-ref vs (coords->index c w k x2 y)) + (unsafe-flvector-ref vs (coords->index c w k x1 y)))) + +(: raw-flomap-integral-y-sum (FlVector Integer Integer Integer + Integer Integer Integer Integer -> Flonum)) +(define (raw-flomap-integral-y-sum vs c w h k x y-start y-end) + (define h-1 (fx- h 1)) + (define y1 (fxmax 0 (fxmin y-start h-1))) + (define y2 (fxmax 0 (fxmin y-end h-1))) + (- (unsafe-flvector-ref vs (coords->index c w k x y2)) + (unsafe-flvector-ref vs (coords->index c w k x y1)))) + +;; =================================================================================================== +;; Box blur + +(: flomap-box-blur (case-> (flomap Real -> flomap) + (flomap Real Real -> flomap))) +(define flomap-box-blur + (case-lambda + [(fm xr) (flomap-box-blur fm xr xr)] + [(fm xr yr) + (let ([xr (abs (exact->inexact xr))] [yr (abs (exact->inexact yr))]) + (cond [(and (integer? xr) (integer? yr)) + (let ([xr (fl->fx xr)] [yr (fl->fx yr)]) + (with-asserts ([xr nonnegative-fixnum?] [yr nonnegative-fixnum?]) + (flomap-box-blur/int fm xr yr)))] + [else + (flomap-box-blur-y (flomap-box-blur-x fm xr) yr)]))])) + +(: flomap-box-blur-x (flomap Flonum -> flomap)) +(define (flomap-box-blur-x fm r) + (cond + [(integer? r) (let ([r (fl->fx r)]) + (with-asserts ([r nonnegative-fixnum?]) + (flomap-box-blur-x/int fm r)))] + [else + (define r1 (fl->fx (floor r))) + (define r2 (fx+ r1 1)) + (define s (+ 1.0 (* 2.0 r))) + (define s1 (+ 1.0 (* 2.0 r1))) + (define s2 (+ 1.0 (* 2.0 r2))) + (define α (/ (- (sqr s2) (sqr s)) (- (sqr s2) (sqr s1)))) + (define norm1 (/ α s1)) + (define norm2 (/ (- 1.0 α) s2)) + (define r1+1 (fx+ r1 1)) + (define r2+1 (fx+ r2 1)) + (match-define (flomap _ c w h) fm) + (match-define (flomap int-vs int-c int-w int-h) (flomap-integral-x fm)) + (inline-build-flomap + c w h + (λ (k x y _i) + (+ (* norm1 (raw-flomap-integral-x-sum int-vs int-c int-w k (fx- x r1) (fx+ x r1+1) y)) + (* norm2 (raw-flomap-integral-x-sum int-vs int-c int-w k (fx- x r2) (fx+ x r2+1) y)) + )))])) + +(: flomap-box-blur-y (flomap Flonum -> flomap)) +(define (flomap-box-blur-y fm r) + (cond + [(integer? r) (let ([r (fl->fx r)]) + (with-asserts ([r nonnegative-fixnum?]) + (flomap-box-blur-y/int fm r)))] + [else + (define r1 (fl->fx (floor r))) + (define r2 (fx+ r1 1)) + (define s (+ 1.0 (* 2.0 r))) + (define s1 (+ 1.0 (* 2.0 r1))) + (define s2 (+ 1.0 (* 2.0 r2))) + (define α (/ (- (sqr s2) (sqr s)) (- (sqr s2) (sqr s1)))) + (define norm1 (/ α s1)) + (define norm2 (/ (- 1.0 α) s2)) + (define r1+1 (fx+ r1 1)) + (define r2+1 (fx+ r2 1)) + (match-define (flomap _ c w h) fm) + (match-define (flomap int-vs int-c int-w int-h) (flomap-integral-y fm)) + (inline-build-flomap + c w h + (λ (k x y _i) + (+ (* norm1 (raw-flomap-integral-y-sum int-vs int-c int-w int-h k x (fx- y r1) (fx+ y r1+1))) + (* norm2 (raw-flomap-integral-y-sum int-vs int-c int-w int-h k x (fx- y r2) (fx+ y r2+1))) + )))])) + +(: flomap-box-blur/int (flomap Nonnegative-Fixnum Nonnegative-Fixnum -> flomap)) +(define (flomap-box-blur/int fm xr yr) + (define norm (/ 1.0 (* (+ 1.0 (* 2.0 xr)) (+ 1.0 (* 2.0 yr))))) + (define xr+1 (fx+ xr 1)) + (define yr+1 (fx+ yr 1)) + (match-define (flomap _ c w h) fm) + (match-define (flomap int-vs int-c int-w int-h) (flomap-integral fm)) + (inline-build-flomap + c w h + (λ (k x y _i) + (* norm (raw-flomap-integral-sum int-vs int-c int-w int-h k + (fx- x xr) (fx- y yr) + (fx+ x xr+1) (fx+ y yr+1)))))) + +(: flomap-box-blur-x/int (flomap Nonnegative-Fixnum -> flomap)) +(define (flomap-box-blur-x/int fm r) + (define norm (/ 1.0 (+ 1.0 (* 2.0 r)))) + (define r+1 (fx+ r 1)) + (match-define (flomap _ c w h) fm) + (match-define (flomap int-vs int-c int-w int-h) (flomap-integral-x fm)) + (inline-build-flomap + c w h + (λ (k x y _i) + (* norm (raw-flomap-integral-x-sum int-vs int-c int-w k (fx- x r) (fx+ x r+1) y))))) + +(: flomap-box-blur-y/int (flomap Nonnegative-Fixnum -> flomap)) +(define (flomap-box-blur-y/int fm r) + (define norm (/ 1.0 (+ 1.0 (* 2.0 r)))) + (define r+1 (fx+ r 1)) + (match-define (flomap _ c w h) fm) + (match-define (flomap int-vs int-c int-w int-h) (flomap-integral-y fm)) + (inline-build-flomap + c w h + (λ (k x y _i) + (* norm (raw-flomap-integral-y-sum int-vs int-c int-w int-h k x (fx- y r) (fx+ y r+1)))))) + +;; =================================================================================================== +;; Default blur + +(: box-radius->variance (Flonum -> Flonum)) +(define (box-radius->variance r) + (* 1/12 (sqr (+ 1 (* 2 r))))) + +(: variance->box-radius (Flonum -> Flonum)) +(define (variance->box-radius σ^2) + (* 1/2 (- (flsqrt (* 12 σ^2)) 1))) + +(: flomap-blur (case-> (flomap Real -> flomap) + (flomap Real Real -> flomap))) +(define flomap-blur + (case-lambda + [(fm σ) (flomap-blur fm σ σ)] + [(fm xσ yσ) + (let ([xσ (abs (exact->inexact xσ))] [yσ (abs (exact->inexact yσ))]) + (cond + [(and (xσ . >= . 1.5) (yσ . >= . 1.5)) + (define xσ^2 (sqr xσ)) + (define yσ^2 (sqr yσ)) + (define xr (floor (variance->box-radius (/ xσ^2 3.0)))) + (define yr (floor (variance->box-radius (/ yσ^2 3.0)))) + (flomap-box-blur (flomap-box-blur (flomap-box-blur fm xr yr) xr yr) + (variance->box-radius (- xσ^2 (* 2.0 (box-radius->variance xr)))) + (variance->box-radius (- yσ^2 (* 2.0 (box-radius->variance yr)))))] + [else + (flomap-blur-x (flomap-blur-y fm yσ) xσ)]))])) + +(: make-flomap-blur-dimension + ((flomap Flonum -> flomap) (flomap Flonum -> flomap) -> (flomap Flonum -> flomap))) +(define ((make-flomap-blur-dimension gaussian-blur box-blur) fm σ) + (cond + [(σ . = . 0.0) fm] + [(σ . < . 1.5) (gaussian-blur fm σ)] + [else + (define σ^2 (sqr σ)) + (define r (floor (variance->box-radius (/ σ^2 3.0)))) + (box-blur (box-blur (box-blur fm r) r) + (variance->box-radius (- σ^2 (* 2.0 (box-radius->variance r)))))])) + +(define flomap-blur-x (make-flomap-blur-dimension flomap-gaussian-blur-x flomap-box-blur-x)) +(define flomap-blur-y (make-flomap-blur-dimension flomap-gaussian-blur-y flomap-box-blur-y)) diff --git a/collects/images/private/flomap-composite.rkt b/collects/images/private/flomap-composite.rkt new file mode 100644 index 0000000000..b5c925a85c --- /dev/null +++ b/collects/images/private/flomap-composite.rkt @@ -0,0 +1,103 @@ +#lang typed/racket/base + +(require racket/flonum + (except-in racket/fixnum fl->fx fx->fl) + racket/match + "flonum.rkt" + "flomap-struct.rkt") + +(provide flomap-pin flomap-pin* + flomap-lt-superimpose flomap-lc-superimpose flomap-lb-superimpose + flomap-ct-superimpose flomap-cc-superimpose flomap-cb-superimpose + flomap-rt-superimpose flomap-rc-superimpose flomap-rb-superimpose + flomap-vl-append flomap-vc-append flomap-vr-append + flomap-ht-append flomap-hc-append flomap-hb-append) + +(: flomap-pin (flomap Real Real flomap Real Real -> flomap)) +(define (flomap-pin fm1 x1 y1 fm2 x2 y2) + (cond + [(not (and (zero? x2) (zero? y2))) + (flomap-pin fm1 (- x1 x2) (- y1 y2) fm2 0 0)] + [else + (let ([x1 (exact->inexact x1)] [y1 (exact->inexact y1)]) + (match-define (flomap argb1-vs 4 w1 h1) fm1) + (match-define (flomap argb2-vs 4 w2 h2) fm2) + + ;; fm1 and fm2 offsets, in final image coordinates + (define dx1 (fl->fx (round (max 0.0 (- x1))))) + (define dy1 (fl->fx (round (max 0.0 (- y1))))) + (define dx2 (fl->fx (round (max 0.0 x1)))) + (define dy2 (fl->fx (round (max 0.0 y1)))) + + ;; final image size + (define w (fxmax (fx+ dx1 w1) (fx+ dx2 w2))) + (define h (fxmax (fx+ dy1 h1) (fx+ dy2 h2))) + + (define-syntax-rule (get-argb-pixel argb-vs dx dy w h x y) + (let ([x (fx- x dx)] [y (fx- y dy)]) + (cond [(and (x . fx>= . 0) (x . fx< . w) (y . fx>= . 0) (y . fx< . h)) + (define i (coords->index 4 w 0 x y)) + (values (unsafe-flvector-ref argb-vs i) + (unsafe-flvector-ref argb-vs (fx+ i 1)) + (unsafe-flvector-ref argb-vs (fx+ i 2)) + (unsafe-flvector-ref argb-vs (fx+ i 3)))] + [else (values 0.0 0.0 0.0 0.0)]))) + + (define argb-vs (make-flvector (* 4 w h))) + (let: y-loop : Void ([y : Nonnegative-Fixnum 0]) + (when (y . fx< . h) + (let: x-loop : Void ([x : Nonnegative-Fixnum 0]) + (cond + [(x . fx< . w) + (define-values (a1 r1 g1 b1) (get-argb-pixel argb1-vs dx1 dy1 w1 h1 x y)) + (define-values (a2 r2 g2 b2) (get-argb-pixel argb2-vs dx2 dy2 w2 h2 x y)) + (define i (coords->index 4 w 0 x y)) + (unsafe-flvector-set! argb-vs i (fl-alpha-blend a1 a2 a2)) + (unsafe-flvector-set! argb-vs (fx+ i 1) (fl-alpha-blend r1 r2 a2)) + (unsafe-flvector-set! argb-vs (fx+ i 2) (fl-alpha-blend g1 g2 a2)) + (unsafe-flvector-set! argb-vs (fx+ i 3) (fl-alpha-blend b1 b2 a2)) + (x-loop (fx+ x 1))] + [else (y-loop (fx+ y 1))])))) + (flomap argb-vs 4 w h))])) + +(: flomap-pin* (Real Real Real Real flomap flomap * -> flomap)) +(define (flomap-pin* x1-frac y1-frac x2-frac y2-frac fm . fms) + (for/fold ([fm1 fm]) ([fm2 (in-list fms)]) + (define-values (w1 h1) (flomap-size fm1)) + (define-values (w2 h2) (flomap-size fm2)) + (flomap-pin fm1 (* x1-frac w1) (* y1-frac h1) + fm2 (* x2-frac w2) (* y2-frac h2)))) + +(: flomap-lt-superimpose (flomap flomap * -> flomap)) +(: flomap-lc-superimpose (flomap flomap * -> flomap)) +(: flomap-lb-superimpose (flomap flomap * -> flomap)) +(: flomap-ct-superimpose (flomap flomap * -> flomap)) +(: flomap-cc-superimpose (flomap flomap * -> flomap)) +(: flomap-cb-superimpose (flomap flomap * -> flomap)) +(: flomap-rt-superimpose (flomap flomap * -> flomap)) +(: flomap-rc-superimpose (flomap flomap * -> flomap)) +(: flomap-rb-superimpose (flomap flomap * -> flomap)) + +(define (flomap-lt-superimpose fm . fms) (apply flomap-pin* 0 0 0 0 fm fms)) +(define (flomap-lc-superimpose fm . fms) (apply flomap-pin* 0 1/2 0 1/2 fm fms)) +(define (flomap-lb-superimpose fm . fms) (apply flomap-pin* 0 1 0 1 fm fms)) +(define (flomap-ct-superimpose fm . fms) (apply flomap-pin* 1/2 0 1/2 0 fm fms)) +(define (flomap-cc-superimpose fm . fms) (apply flomap-pin* 1/2 1/2 1/2 1/2 fm fms)) +(define (flomap-cb-superimpose fm . fms) (apply flomap-pin* 1/2 1 1/2 1 fm fms)) +(define (flomap-rt-superimpose fm . fms) (apply flomap-pin* 1 0 1 0 fm fms)) +(define (flomap-rc-superimpose fm . fms) (apply flomap-pin* 1 1/2 1 1/2 fm fms)) +(define (flomap-rb-superimpose fm . fms) (apply flomap-pin* 1 1 1 1 fm fms)) + +(: flomap-vl-append (flomap flomap * -> flomap)) +(: flomap-vc-append (flomap flomap * -> flomap)) +(: flomap-vr-append (flomap flomap * -> flomap)) +(: flomap-ht-append (flomap flomap * -> flomap)) +(: flomap-hc-append (flomap flomap * -> flomap)) +(: flomap-hb-append (flomap flomap * -> flomap)) + +(define (flomap-vl-append fm . fms) (apply flomap-pin* 0 1 0 0 fm fms)) +(define (flomap-vc-append fm . fms) (apply flomap-pin* 1/2 1 1/2 0 fm fms)) +(define (flomap-vr-append fm . fms) (apply flomap-pin* 1 1 1 0 fm fms)) +(define (flomap-ht-append fm . fms) (apply flomap-pin* 1 0 0 0 fm fms)) +(define (flomap-hc-append fm . fms) (apply flomap-pin* 1 1/2 0 1/2 fm fms)) +(define (flomap-hb-append fm . fms) (apply flomap-pin* 1 1 0 1 fm fms)) diff --git a/collects/images/private/flomap-convert.rkt b/collects/images/private/flomap-convert.rkt new file mode 100644 index 0000000000..47d359ce89 --- /dev/null +++ b/collects/images/private/flomap-convert.rkt @@ -0,0 +1,87 @@ +#lang racket/base + +(require racket/draw racket/class racket/match + racket/unsafe/ops + "flomap-struct.rkt" + "flomap-pointwise.rkt" + "flomap-resize.rkt") + +(provide bitmap->flomap flomap->bitmap draw-flomap) + +(define-syntax-rule (unsafe-fl->byte y) + (let ([x (unsafe-flmax 0.0 (unsafe-flmin 255.0 y))]) + (cond [(and (x . unsafe-fl> . -inf.0) (x . unsafe-fl< . +inf.0)) + (unsafe-fl->fx (unsafe-flround x))] + [else 0.0]))) + +(define (bitmap->flomap bm) + (define w (send bm get-width)) + (define h (send bm get-height)) + (define bs (make-bytes (* 4 w h))) + ;; get bytes without premultiplying alpha because doing it in flonums maintains precision + ;; (if RGB bytes are stored without premultiplying alpha) + (send bm get-argb-pixels 0 0 w h bs #t) + (send bm get-argb-pixels 0 0 w h bs #f) + + (define argb-fm (make-flomap 4 w h)) + (define argb-vs (flomap-values argb-fm)) + (for ([i0 (in-range 0 (* 4 w h) 4)]) + (define i1 (unsafe-fx+ i0 1)) + (define i2 (unsafe-fx+ i0 2)) + (define i3 (unsafe-fx+ i0 3)) + (define a (unsafe-bytes-ref bs i0)) + (define r (unsafe-bytes-ref bs i1)) + (define g (unsafe-bytes-ref bs i2)) + (define b (unsafe-bytes-ref bs i3)) + (unsafe-flvector-set! argb-vs i0 (unsafe-fl/ (unsafe-fx->fl a) 255.0)) + (unsafe-flvector-set! argb-vs i1 (unsafe-fl/ (unsafe-fx->fl r) 255.0)) + (unsafe-flvector-set! argb-vs i2 (unsafe-fl/ (unsafe-fx->fl g) 255.0)) + (unsafe-flvector-set! argb-vs i3 (unsafe-fl/ (unsafe-fx->fl b) 255.0))) + + (flomap-multiply-alpha argb-fm)) + +(define (flomap->bitmap fm) + (match-define (flomap vs c w h) fm) + (let* ([fm (case c + [(0) (make-flomap 4 w h)] + [(1) (flomap-append-components (make-flomap 1 w h 1.0) fm fm fm)] + [(2) (define alpha-fm (flomap-ref-component fm 0)) + (define value-fm (flomap-drop-components fm 1)) + (flomap-append-components alpha-fm value-fm value-fm value-fm)] + [(3) (flomap-append-components (make-flomap 1 w h 1.0) fm)] + [(4) fm] + [else (raise-type-error 'flomap->bitmap "flomap with 1, 2, 3 or 4 components" fm)])] + ;; inset if zero (bitmaps can't have zero size) + [fm (flomap-inset fm 0 0 (if (= w 0) 1 0) (if (= h 0) 1 0))] + ;; divide alphas before converting + [fm (flomap-divide-alpha fm)]) + ;; guaranteed an ARGB flomap now + (match-define (flomap vs 4 w h) fm) + (define bs (make-bytes (* 4 w h))) + (for ([i0 (in-range 0 (* 4 w h) 4)]) + (define i1 (unsafe-fx+ i0 1)) + (define i2 (unsafe-fx+ i0 2)) + (define i3 (unsafe-fx+ i0 3)) + (define a (unsafe-flvector-ref vs i0)) + (define r (unsafe-flvector-ref vs i1)) + (define g (unsafe-flvector-ref vs i2)) + (define b (unsafe-flvector-ref vs i3)) + (unsafe-bytes-set! bs i0 (unsafe-fl->byte (unsafe-fl* 255.0 a))) + (unsafe-bytes-set! bs i1 (unsafe-fl->byte (unsafe-fl* 255.0 r))) + (unsafe-bytes-set! bs i2 (unsafe-fl->byte (unsafe-fl* 255.0 g))) + (unsafe-bytes-set! bs i3 (unsafe-fl->byte (unsafe-fl* 255.0 b)))) + + (define bm (make-bitmap w h)) + (send bm set-argb-pixels 0 0 w h bs #t) + (send bm set-argb-pixels 0 0 w h bs #f) + bm)) + +(define (draw-flomap w h draw-proc) + (unless (w . >= . 0) (raise-type-error 'draw-flomap "nonnegative fixnum" 0 w h draw-proc)) + (unless (h . >= . 0) (raise-type-error 'draw-flomap "nonnegative fixnum" 1 w h draw-proc)) + + (define bm (make-bitmap (max w 1) (max h 1))) + (define dc (make-object bitmap-dc% bm)) + (send dc set-smoothing 'smoothed) + (draw-proc dc) + (flomap-inset (bitmap->flomap bm) 0 0 (if (= w 0) -1 0) (if (= h 0) -1 0))) diff --git a/collects/images/private/flomap-effects.rkt b/collects/images/private/flomap-effects.rkt new file mode 100644 index 0000000000..d0222bc49b --- /dev/null +++ b/collects/images/private/flomap-effects.rkt @@ -0,0 +1,67 @@ +#lang typed/racket/base + +(require racket/flonum + (except-in racket/fixnum fl->fx fx->fl) + racket/match racket/list + "flonum.rkt" + "flomap-struct.rkt" + "flomap-pointwise.rkt" + "flomap-blur.rkt" + "flomap-composite.rkt") + +(provide flomap-outline flomap-outlined + flomap-shadow flomap-shadowed) + +(: colorize-alpha (flomap (Listof Real) -> flomap)) +(define (colorize-alpha fm color) + (match-define (flomap _ 1 w h) fm) + (flomap-append-components fm (fm* fm (make-flomap/components w h color)))) + +(: flomap-shadow (case-> (flomap Real -> flomap) + (flomap Real (Option (Listof Real)) -> flomap))) +(define flomap-shadow + (case-lambda + [(fm σ) (flomap-shadow fm σ #f)] + [(fm σ color) + (match-define (flomap _ c w h) fm) + (cond [(c . = . 0) fm] + [else (define alpha-fm (flomap-ref-component fm 0)) + (define color-vs (if (list? color) color (make-list (- c 1) 0.0))) + (colorize-alpha (flomap-blur alpha-fm σ) color-vs)])])) + +(: flomap-shadowed (case-> (flomap Real -> flomap) + (flomap Real (Option (Listof Real)) -> flomap))) +(define flomap-shadowed + (case-lambda + [(fm σ) (flomap-shadowed fm σ #f)] + [(fm σ c) (flomap-cc-superimpose (flomap-shadow fm σ c) fm)])) + +(: flomap-outline (case-> (flomap Real -> flomap) + (flomap Real (Option (Listof Real)) -> flomap))) +(define flomap-outline + (case-lambda + [(fm amt) (flomap-outline fm amt #f)] + [(fm amt color) + (match-define (flomap _ c w h) fm) + (let ([amt (exact->inexact amt)]) + (define σ (* 0.5 (max 1.0 amt))) + (define ceiling-amt (fl->fx (ceiling amt))) + (define test-size (fx* 2 (fx+ 1 ceiling-amt))) + (define test-mid (fxquotient test-size 2)) + (define test-fm (inline-build-flomap 1 test-size test-size + (λ (k x y i) (if (x . fx>= . test-mid) 1.0 0.0)))) + (define blur-fm (flomap-blur test-fm σ)) + (define v-max (flomap-bilinear-ref blur-fm 0 (+ 0.5 (- test-mid amt)) test-mid)) + (define v-min (flomap-bilinear-ref blur-fm 0 (+ 0.5 (- test-mid amt 1)) test-mid)) + (define alpha-fm (flomap-ref-component fm 0)) + (define new-alpha-fm (fmmax 0.0 (fmmin 1.0 (fm/ (fm- (flomap-blur alpha-fm σ) v-min) + (- v-max v-min))))) + (define color-vs (if (list? color) color (make-list (- c 1) 0.0))) + (colorize-alpha new-alpha-fm color-vs))])) + +(: flomap-outlined (case-> (flomap Real -> flomap) + (flomap Real (Option (Listof Real)) -> flomap))) +(define flomap-outlined + (case-lambda + [(fm amt) (flomap-outlined fm amt #f)] + [(fm amt c) (flomap-cc-superimpose (flomap-outline fm amt c) fm)])) diff --git a/collects/images/private/flomap-gradient.rkt b/collects/images/private/flomap-gradient.rkt new file mode 100644 index 0000000000..29986297fc --- /dev/null +++ b/collects/images/private/flomap-gradient.rkt @@ -0,0 +1,74 @@ +#lang typed/racket/base + +(require racket/flonum + (except-in racket/fixnum fl->fx fx->fl) + racket/match + "flonum.rkt" + "flomap-struct.rkt") + +(provide flomap-gradient-x flomap-gradient-y flomap-gradient flomap-gradient-normal) + +;; =================================================================================================== +;; Derivatives (Schurr operator) + +(: flomap-gradient-x (flomap -> flomap)) +(define (flomap-gradient-x fm) + (match-define (flomap vs c w h) fm) + (define cw (fx* c w)) + (define d20 (fx- 1 cw)) + (define d22 (fx+ cw 1)) + (define w-1 (fx- w 1)) + (define h-1 (fx- h 1)) + (inline-build-flomap + c w h + (λ (_k x y i) + (cond [(and (x . fx> . 0) (x . fx< . w-1) + (y . fx> . 0) (y . fx< . h-1)) + (+ (- (* 0.1875 (unsafe-flvector-ref vs (fx+ i d20))) + (* 0.1875 (unsafe-flvector-ref vs (fx- i d22)))) + (- (* 0.6250 (unsafe-flvector-ref vs (fx+ i 1))) + (* 0.6250 (unsafe-flvector-ref vs (fx- i 1)))) + (- (* 0.1875 (unsafe-flvector-ref vs (fx+ i d22))) + (* 0.1875 (unsafe-flvector-ref vs (fx- i d20)))))] + [else 0.0])))) + +(: flomap-gradient-y (flomap -> flomap)) +(define (flomap-gradient-y fm) + (match-define (flomap vs c w h) fm) + (define cw (fx* c w)) + (define d02 (fx- cw 1)) + (define d22 (fx+ cw 1)) + (define w-1 (fx- w 1)) + (define h-1 (fx- h 1)) + (inline-build-flomap + c w h + (λ (_k x y i) + (cond [(and (x . fx> . 0) (x . fx< . w-1) + (y . fx> . 0) (y . fx< . h-1)) + (+ (- (* 0.1875 (unsafe-flvector-ref vs (fx+ i d02))) + (* 0.1875 (unsafe-flvector-ref vs (fx- i d22)))) + (- (* 0.6250 (unsafe-flvector-ref vs (fx+ i cw))) + (* 0.6250 (unsafe-flvector-ref vs (fx- i cw)))) + (- (* 0.1875 (unsafe-flvector-ref vs (fx+ i d22))) + (* 0.1875 (unsafe-flvector-ref vs (fx- i d02)))))] + [else 0.0])))) + +(: flomap-gradient (flomap -> (values flomap flomap))) +(define (flomap-gradient fm) + (values (flomap-gradient-x fm) (flomap-gradient-y fm))) + +(: flomap-gradient-normal (flomap -> flomap)) +(define (flomap-gradient-normal z-fm) + (define-values (dx-fm dy-fm) (flomap-gradient z-fm)) + (match-define (flomap dx-vs 1 w h) dx-fm) + (match-define (flomap dy-vs 1 _w _h) dy-fm) + (define normal-vs (make-flvector (* 3 w h))) + (for ([i (in-range (* w h))]) + (define dx (unsafe-flvector-ref dx-vs i)) + (define dy (unsafe-flvector-ref dy-vs i)) + (define-values (nx ny nz) (fl3normalize (- dx) (- dy) 2.0)) + (define j (fx* 3 i)) + (unsafe-flvector-set! normal-vs j nx) + (unsafe-flvector-set! normal-vs (fx+ j 1) ny) + (unsafe-flvector-set! normal-vs (fx+ j 2) nz)) + (flomap normal-vs 3 w h)) diff --git a/collects/images/private/flomap-pointwise.rkt b/collects/images/private/flomap-pointwise.rkt new file mode 100644 index 0000000000..ae2eb1513b --- /dev/null +++ b/collects/images/private/flomap-pointwise.rkt @@ -0,0 +1,121 @@ +#lang typed/racket/base + +(require racket/flonum + (except-in racket/fixnum fl->fx fx->fl) + racket/match racket/math + "flonum.rkt" + "flomap-struct.rkt" + "flomap-stats.rkt") + +(provide flomap-lift flomap-lift2 inline-flomap-lift inline-flomap-lift2 + fmneg fmabs fmsqr fmsin fmcos fmtan fmlog fmexp fmsqrt fmasin fmacos fmatan + fmround fmfloor fmceiling fmtruncate fmzero + fm+ fm- fm* fm/ fmmin fmmax + flomap-normalize flomap-multiply-alpha flomap-divide-alpha) + +;; =================================================================================================== +;; Unary + +(define-syntax-rule (inline-flomap-lift f) + (λ: ([fm : flomap]) + (match-define (flomap vs c w h) fm) + (flomap (inline-build-flvector (* c w h) (λ (i) (f (unsafe-flvector-ref vs i)))) + c w h))) + +(: flomap-lift ((Flonum -> Real) -> (flomap -> flomap))) +(define (flomap-lift op) + (inline-flomap-lift (λ (x) (exact->inexact (op x))))) + +(define fmneg (inline-flomap-lift -)) +(define fmabs (inline-flomap-lift abs)) +(define fmsqr (inline-flomap-lift sqr)) +(define fmsin (inline-flomap-lift sin)) +(define fmcos (inline-flomap-lift cos)) +(define fmtan (inline-flomap-lift tan)) +(define fmlog (inline-flomap-lift fllog)) +(define fmexp (inline-flomap-lift exp)) +(define fmsqrt (inline-flomap-lift flsqrt)) +(define fmasin (inline-flomap-lift asin)) +(define fmacos (inline-flomap-lift acos)) +(define fmatan (inline-flomap-lift atan)) +(define fmround (inline-flomap-lift round)) +(define fmfloor (inline-flomap-lift floor)) +(define fmceiling (inline-flomap-lift ceiling)) +(define fmtruncate (inline-flomap-lift truncate)) +(define fmzero (inline-flomap-lift (λ (x) (if (x . = . 0.0) 1.0 0.0)))) + +;; =================================================================================================== +;; Binary + +(define-syntax-rule (inline-flomap-lift2 name f) + (let: () + (λ: ([fm1 : (U Real flomap)] [fm2 : (U Real flomap)]) + (cond + [(and (real? fm1) (real? fm2)) + (error name "expected at least one flomap argument; given ~e and ~e" fm1 fm2)] + [(real? fm1) (let ([fm1 (exact->inexact fm1)]) + ((inline-flomap-lift (λ (v) (f fm1 v))) fm2))] + [(real? fm2) (let ([fm2 (exact->inexact fm2)]) + ((inline-flomap-lift (λ (v) (f v fm2))) fm1))] + [else + (match-define (flomap vs1 c1 w h) fm1) + (match-define (flomap vs2 c2 w2 h2) fm2) + (cond + [(not (and (= w w2) (= h h2))) + (error name "expected same-size flomaps; given sizes ~e×~e and ~e×~e" w h w2 h2)] + [(= c1 c2) (define n (* c1 w h)) + (define res-vs (make-flvector n)) + (flomap (inline-build-flvector n (λ (i) (f (unsafe-flvector-ref vs1 i) + (unsafe-flvector-ref vs2 i)))) + c1 w h)] + [(= c1 1) (inline-build-flomap + c2 w h + (λ (k x y i) (f (unsafe-flvector-ref vs1 (coords->index 1 w 0 x y)) + (unsafe-flvector-ref vs2 i))))] + [(= c2 1) (inline-build-flomap + c1 w h + (λ (k x y i) (f (unsafe-flvector-ref vs1 i) + (unsafe-flvector-ref vs2 (coords->index 1 w 0 x y)))))] + [else + (error name (string-append "expected flomaps with the same number of components, " + "or a flomap with 1 component and any same-size flomap; " + "given flomaps with ~e and ~e components") + c1 c2)])])))) + +(: flomap-lift2 (Symbol (Flonum Flonum -> Real) -> ((U Real flomap) (U Real flomap) -> flomap))) +(define (flomap-lift2 name f) + (inline-flomap-lift2 name (λ (x y) (exact->inexact (f x y))))) + +(define fm+ (inline-flomap-lift2 'fm+ +)) +(define fm- (inline-flomap-lift2 'fm- -)) +(define fm* (inline-flomap-lift2 'fm* *)) +(define fm/ (inline-flomap-lift2 'fm/ /)) +(define fmmin (inline-flomap-lift2 'fmmin min)) +(define fmmax (inline-flomap-lift2 'fmmax max)) + +(: flomap-normalize (flomap -> flomap)) +(define (flomap-normalize fm) + (define-values (v-min v-max) (flomap-extreme-values fm)) + (define v-size (- v-max v-min)) + (let* ([fm (fm- fm v-min)] + [fm (if (v-size . = . 0.0) fm (fm/ fm v-size))]) + fm)) + +(define fmdiv/zero + (inline-flomap-lift2 'fmdiv/zero (λ (x y) (if (y . = . 0.0) 0.0 (/ x y))))) + +(: flomap-divide-alpha (flomap -> flomap)) +(define (flomap-divide-alpha fm) + (match-define (flomap _ c w h) fm) + (cond [(c . <= . 1) fm] + [else + (define alpha-fm (flomap-ref-component fm 0)) + (flomap-append-components alpha-fm (fmdiv/zero (flomap-drop-components fm 1) alpha-fm))])) + +(: flomap-multiply-alpha (flomap -> flomap)) +(define (flomap-multiply-alpha fm) + (match-define (flomap _ c w h) fm) + (cond [(c . > . 1) + (define alpha-fm (flomap-ref-component fm 0)) + (flomap-append-components alpha-fm (fm* (flomap-drop-components fm 1) alpha-fm))] + [else fm])) diff --git a/collects/images/private/flomap-resize.rkt b/collects/images/private/flomap-resize.rkt new file mode 100644 index 0000000000..84969621e1 --- /dev/null +++ b/collects/images/private/flomap-resize.rkt @@ -0,0 +1,221 @@ +#lang typed/racket/base + +(require racket/flonum + (except-in racket/fixnum fl->fx fx->fl) + racket/match racket/math + "flonum.rkt" + "flomap-struct.rkt" + "flomap-stats.rkt" + "flomap-blur.rkt") + +(provide flomap-inset flomap-trim flomap-crop + flomap-lt-crop flomap-lc-crop flomap-lb-crop + flomap-ct-crop flomap-cc-crop flomap-cb-crop + flomap-rt-crop flomap-rc-crop flomap-rb-crop + flomap-scale flomap-resize) + +(: flomap-inset (case-> (flomap Integer -> flomap) + (flomap Integer Integer -> flomap) + (flomap Integer Integer Integer Integer -> flomap))) +(define flomap-inset + (case-lambda + [(fm amt) (flomap-inset fm amt amt amt amt)] + [(fm h-amt v-amt) (flomap-inset fm h-amt v-amt h-amt v-amt)] + [(fm l-amt t-amt r-amt b-amt) + (cond [(and (= l-amt 0) (= t-amt 0) (= r-amt 0) (= b-amt 0)) fm] + [else + (match-define (flomap src-vs c src-w src-h) fm) + (define dst-w (fxmax 0 (fx+ src-w (fx+ l-amt r-amt)))) + (define dst-h (fxmax 0 (fx+ src-h (fx+ t-amt b-amt)))) + (define dst-vs (make-flvector (* c dst-w dst-h))) + (cond + [(or (dst-w . fx= . 0) (dst-h . fx= . 0)) + (flomap dst-vs c dst-w dst-h)] + [else + (let: y-loop : Void ([dst-y : Nonnegative-Fixnum 0]) + (when (dst-y . fx< . dst-h) + (define src-y (fx- dst-y t-amt)) + (when (and (src-y . fx>= . 0) (src-y . fx< . src-h)) + (let: x-loop : Void ([dst-x : Nonnegative-Fixnum 0]) + (when (dst-x . fx< . dst-w) + (define src-x (fx- dst-x l-amt)) + (when (and (src-x . fx>= . 0) (src-x . fx< . src-w)) + (let: k-loop : Void ([k : Nonnegative-Fixnum 0]) + (when (k . fx< . c) + (define src-i (coords->index c src-w k src-x src-y)) + (define dst-i (coords->index c dst-w k dst-x dst-y)) + (unsafe-flvector-set! dst-vs dst-i (unsafe-flvector-ref src-vs src-i)) + (k-loop (fx+ k 1))))) + (x-loop (fx+ dst-x 1))))) + (y-loop (fx+ dst-y 1)))) + (flomap dst-vs c dst-w dst-h)])])])) + +(: flomap-trim (flomap -> flomap)) +(define (flomap-trim fm) + (match-define (flomap _ c w h) fm) + (cond [(c . = . 0) (make-flomap 0 0 0)] + [else (define-values (_k-min x-min y-min _k-max x-max y-max) + (flomap-nonzero-rect (flomap-ref-component fm 0))) + (flomap-inset fm (- x-min) (- y-min) (- x-max w) (- y-max h))])) + +(: flomap-crop (flomap Integer Integer Real Real -> flomap)) +(define (flomap-crop fm width height x-frac y-frac) + (unless (width . >= . 0) + (raise-type-error 'flomap-crop "nonnegative integer" 1 fm width height x-frac y-frac)) + (unless (height . >= . 0) + (raise-type-error 'flomap-crop "nonnegative integer" 2 fm width height x-frac y-frac)) + (let ([x-frac (exact->inexact x-frac)] + [y-frac (exact->inexact y-frac)]) + (match-define (flomap _ c w h) fm) + (define l-amt (fl->fx (round (* x-frac (fx->fl (fx- width w)))))) + (define r-amt (fx- (fx- width w) l-amt)) + (define t-amt (fl->fx (round (* y-frac (fx->fl (fx- height h)))))) + (define b-amt (fx- (fx- height h) t-amt)) + (flomap-inset fm l-amt t-amt r-amt b-amt))) + +(: flomap-lt-crop (flomap Integer Integer -> flomap)) +(: flomap-lc-crop (flomap Integer Integer -> flomap)) +(: flomap-lb-crop (flomap Integer Integer -> flomap)) +(: flomap-ct-crop (flomap Integer Integer -> flomap)) +(: flomap-cc-crop (flomap Integer Integer -> flomap)) +(: flomap-cb-crop (flomap Integer Integer -> flomap)) +(: flomap-rt-crop (flomap Integer Integer -> flomap)) +(: flomap-rc-crop (flomap Integer Integer -> flomap)) +(: flomap-rb-crop (flomap Integer Integer -> flomap)) + +(define (flomap-lt-crop fm w h) (flomap-crop fm w h 0 0)) +(define (flomap-lc-crop fm w h) (flomap-crop fm w h 0 1/2)) +(define (flomap-lb-crop fm w h) (flomap-crop fm w h 0 1)) +(define (flomap-ct-crop fm w h) (flomap-crop fm w h 1/2 0)) +(define (flomap-cc-crop fm w h) (flomap-crop fm w h 1/2 1/2)) +(define (flomap-cb-crop fm w h) (flomap-crop fm w h 1/2 1)) +(define (flomap-rt-crop fm w h) (flomap-crop fm w h 1 0)) +(define (flomap-rc-crop fm w h) (flomap-crop fm w h 1 1/2)) +(define (flomap-rb-crop fm w h) (flomap-crop fm w h 1 1)) + +(: flomap-scale (case-> (flomap Real -> flomap) + (flomap Real Real -> flomap))) +(define flomap-scale + (case-lambda + [(fm scale) + (cond [(< scale 0) (raise-type-error 'flomap-scale "nonnegative real" 1 fm scale)] + [else (flomap-scale fm scale scale)])] + [(fm x-scale y-scale) + (cond [(< x-scale 0) (raise-type-error 'flomap-scale "nonnegative real" 1 fm x-scale y-scale)] + [(< y-scale 0) (raise-type-error 'flomap-scale "nonnegative real" 2 fm x-scale y-scale)] + [else (flomap-scale-x (flomap-scale-y fm (exact->inexact y-scale)) + (exact->inexact x-scale))])])) + +(: flomap-resize (flomap (Option Integer) (Option Integer) -> flomap)) +(define (flomap-resize fm width height) + (when (and width (width . < . 0)) + (raise-type-error 'flomap-resize "nonnegative integer" 1 fm width height)) + (when (and height (height . < . 0)) + (raise-type-error 'flomap-resize "nonnegative integer" 2 fm width height)) + (match-define (flomap _ c w h) fm) + (cond [(and width height) (flomap-resize-x (flomap-resize-y fm height) width)] + [width (cond [(= w 0) (error 'flomap-resize + "cannot proportionally scale ~e×~e flomap's height" + w h)] + [else (define s (exact->inexact (/ width w))) + (flomap-resize-x (flomap-scale-y fm s) width)])] + [height (cond [(= h 0) (error 'flomap-resize + "cannot proportionally scale ~e×~e flomap's width" + w h)] + [else (define s (exact->inexact (/ height h))) + (flomap-scale-x (flomap-resize-y fm height) s)])] + [else (error 'flomap-resize "can't happen")])) + +(: flomap-scale-x (flomap Flonum -> flomap)) +(define (flomap-scale-x fm scale) + (match-define (flomap _ c w h) fm) + (cond [(= 0 scale) (make-flomap c 0 h)] + [else (let ([scale (abs scale)]) + (flomap-scale*-x fm scale (abs (fl->fx (ceiling (* (exact->inexact w) scale))))))])) + +(: flomap-scale-y (flomap Flonum -> flomap)) +(define (flomap-scale-y fm scale) + (match-define (flomap _ c w h) fm) + (cond [(= 0 scale) (make-flomap c w 0)] + [else (let ([scale (abs scale)]) + (flomap-scale*-y fm scale (abs (fl->fx (ceiling (* (exact->inexact h) scale))))))])) + +(: flomap-resize-x (flomap Integer -> flomap)) +(define (flomap-resize-x fm width) + (match-define (flomap _ c w h) fm) + (cond [(= 0 width) (make-flomap c 0 h)] + [else (let ([width (abs width)]) + (flomap-scale*-x fm (abs (exact->inexact (/ width w))) width))])) + +(: flomap-resize-y (flomap Integer -> flomap)) +(define (flomap-resize-y fm height) + (match-define (flomap _ c w h) fm) + (cond [(= 0 height) (make-flomap c w 0)] + [else (let ([height (abs height)]) + (flomap-scale*-y fm (abs (exact->inexact (/ height h))) height))])) + +;; standard deviation of an unscaled box filter (i.e. f([-1/2,1/2]) = {1}, zero elsewhere) +(define box-filter-variance (/ 1.0 12.0)) +;; standard deviation of an unscaled triangle filter (simulates effect of linear interpolation) +(define triangle-filter-variance (/ 1.0 24.0)) + +;; calculates the standard deviation of downscaling blur, assuming linear interpolation will be +;; carried out on the blurred image +(: stddev-for-scale (Nonnegative-Flonum -> Nonnegative-Flonum)) +(define (stddev-for-scale scale) + (define var (- (/ box-filter-variance (sqr scale)) + triangle-filter-variance)) + (abs (flsqrt (max 0.0 var)))) + +(: flomap-scale*-x (flomap Nonnegative-Flonum Exact-Nonnegative-Integer -> flomap)) +(define (flomap-scale*-x fm scale width) + (cond [(scale . = . 1.0) fm] + [(scale . > . 1.0) (flomap-scale*-x/linear fm scale width)] + [else (define low-res-fm + (flomap-gaussian-blur-x fm (stddev-for-scale scale))) + (flomap-scale*-x/linear low-res-fm scale width)])) + +(: flomap-scale*-y (flomap Nonnegative-Flonum Exact-Nonnegative-Integer -> flomap)) +(define (flomap-scale*-y fm scale height) + (cond [(scale . = . 1.0) fm] + [(scale . > . 1.0) (flomap-scale*-y/linear fm scale height)] + [else (define low-res-fm + (flomap-gaussian-blur-y fm (stddev-for-scale scale))) + (flomap-scale*-y/linear low-res-fm scale height)])) + +(: flomap-scale*-x/linear (flomap Nonnegative-Flonum Exact-Nonnegative-Integer -> flomap)) +(define (flomap-scale*-x/linear fm s new-w) + (match-define (flomap vs c w h) fm) + (define w-1 (fx- w 1)) + (inline-build-flomap + c new-w h + (λ (k new-x y _i) + (define scaled-x (- (/ (+ (fx->fl new-x) 0.5) s) 0.5)) + (define floor-scaled-x (floor scaled-x)) + (define x0 (fl->fx floor-scaled-x)) + (cond [(or (x0 . fx< . 0) (x0 . fx>= . w)) 0.0] + [else + (define i0 (coords->index c w k x0 y)) + (define v0 (unsafe-flvector-ref vs i0)) + (define v1 (cond [(x0 . fx= . w-1) 0.0] + [else (unsafe-flvector-ref vs (fx+ i0 c))])) + (fl-convex-combination v0 v1 (- scaled-x floor-scaled-x))])))) + +(: flomap-scale*-y/linear (flomap Nonnegative-Flonum Exact-Nonnegative-Integer -> flomap)) +(define (flomap-scale*-y/linear fm s new-h) + (match-define (flomap vs c w h) fm) + (define h-1 (fx- h 1)) + (define cw (* c w)) + (inline-build-flomap + c w new-h + (λ (k x new-y _i) + (define scaled-y (- (/ (+ (fx->fl new-y) 0.5) s) 0.5)) + (define floor-scaled-y (floor scaled-y)) + (define y0 (fl->fx floor-scaled-y)) + (cond [(or (y0 . fx< . 0) (y0 . fx>= . h)) 0.0] + [else + (define i0 (coords->index c w k x y0)) + (define v0 (unsafe-flvector-ref vs i0)) + (define v1 (cond [(y0 . fx= . h-1) 0.0] + [else (unsafe-flvector-ref vs (fx+ i0 cw))])) + (fl-convex-combination v0 v1 (- scaled-y floor-scaled-y))])))) diff --git a/collects/images/private/flomap-stats.rkt b/collects/images/private/flomap-stats.rkt new file mode 100644 index 0000000000..3a8edeb96a --- /dev/null +++ b/collects/images/private/flomap-stats.rkt @@ -0,0 +1,55 @@ +#lang typed/racket/base + +(require racket/flonum + (except-in racket/fixnum fl->fx fx->fl) + racket/match + "flonum.rkt" + "flomap-struct.rkt") + +(provide flomap-min-value flomap-max-value flomap-extreme-values + flomap-nonzero-rect) + +(: flomap-min-value (flomap -> Flonum)) +(define (flomap-min-value fm) + (for/fold ([v-min +inf.0]) ([v (in-flvector (flomap-values fm))]) + (min v-min v))) + +(: flomap-max-value (flomap -> Flonum)) +(define (flomap-max-value fm) + (for/fold ([v-max -inf.0]) ([v (in-flvector (flomap-values fm))]) + (max v-max v))) + +(: flomap-extreme-values (flomap -> (values Flonum Flonum))) +(define (flomap-extreme-values fm) + (for/fold: ([v-min : Flonum +inf.0] [v-max : Flonum -inf.0] + ) ([v : Flonum (in-flvector (flomap-values fm))]) + (values (min v-min v) (max v-max v)))) + +(: flomap-nonzero-rect (flomap -> (values Nonnegative-Fixnum Nonnegative-Fixnum Nonnegative-Fixnum + Nonnegative-Fixnum Nonnegative-Fixnum Nonnegative-Fixnum))) +(define (flomap-nonzero-rect fm) + (match-define (flomap vs c w h) fm) + (with-asserts ([c nonnegative-fixnum?] [w nonnegative-fixnum?] [h nonnegative-fixnum?]) + (define: k-min : Nonnegative-Fixnum c) + (define: x-min : Nonnegative-Fixnum w) + (define: y-min : Nonnegative-Fixnum h) + (define: k-max : Nonnegative-Fixnum 0) + (define: x-max : Nonnegative-Fixnum 0) + (define: y-max : Nonnegative-Fixnum 0) + (let: y-loop : Void ([y : Nonnegative-Fixnum 0] [i : Nonnegative-Fixnum 0]) + (when (y . fx< . h) + (let: x-loop : Void ([x : Nonnegative-Fixnum 0] [i : Nonnegative-Fixnum i]) + (cond [(x . fx< . w) + (let: k-loop : Void ([k : Nonnegative-Fixnum 0] [i : Nonnegative-Fixnum i]) + (cond [(k . fx< . c) (define v (unsafe-flvector-ref vs i)) + (when (not (v . = . 0.0)) + (set! k-min (fxmin k-min k)) + (set! x-min (fxmin x-min x)) + (set! y-min (fxmin y-min y)) + (set! k-max (fxmax k-max (fx+ 1 k))) + (set! x-max (fxmax x-max (fx+ 1 x))) + (set! y-max (fxmax y-max (fx+ 1 y)))) + (k-loop (fx+ k 1) (fx+ i 1))] + [else (x-loop (fx+ x 1) i)]))] + [else (y-loop (fx+ y 1) i)])))) + (values k-min x-min y-min k-max x-max y-max))) diff --git a/collects/images/private/flomap-struct.rkt b/collects/images/private/flomap-struct.rkt new file mode 100644 index 0000000000..8d38544f24 --- /dev/null +++ b/collects/images/private/flomap-struct.rkt @@ -0,0 +1,160 @@ +#lang typed/racket/base + +(require racket/flonum + (except-in racket/fixnum fl->fx fx->fl) + racket/match + (except-in racket/unsafe/ops unsafe-flvector-ref unsafe-flvector-set!) + "flonum.rkt") + +(provide flomap flomap? flomap-values flomap-components flomap-width flomap-height + ;; Accessors + flomap-size flomap-ref flomap-bilinear-ref coords->index + ;; Basic constructors + make-flomap make-flomap/components build-flomap inline-build-flomap + flomap-ref-component flomap-take-components flomap-drop-components flomap-append-components) + +(struct: flomap ([values : FlVector] [components : Integer] [width : Integer] [height : Integer]) + #:transparent + #:guard + (λ (vs c w h name) + (with-asserts ([c nonnegative-fixnum?] [w nonnegative-fixnum?] [h nonnegative-fixnum?]) + (unless (= (flvector-length vs) (* c w h)) + (error 'flomap "expected flvector of length ~e; given one of length ~e" + (* c w h) (flvector-length vs))) + (values vs c w h)))) + +(: flomap-size (flomap -> (values Nonnegative-Fixnum Nonnegative-Fixnum))) +(define (flomap-size fm) + (match-define (flomap _vs _c w h) fm) + (with-asserts ([w nonnegative-fixnum?] [h nonnegative-fixnum?]) + (values w h))) + +#;;(: coords->index (Integer Integer Integer Integer Integer -> Fixnum)) +(define (coords->index c w k x y) + (fx+ k (fx* c (fx+ x (fx* y w))))) + +(define-syntax-rule (coords->index c w k x y) + (fx+ k (fx* c (fx+ x (fx* y w))))) + +(: unsafe-flomap-ref (FlVector Integer Integer Integer Integer Integer Integer -> Flonum)) +(define (unsafe-flomap-ref vs c w h k x y) + (cond [(and (x . fx>= . 0) (x . fx< . w) + (y . fx>= . 0) (y . fx< . h)) + (unsafe-flvector-ref vs (coords->index c w k x y))] + [else 0.0])) + +(: flomap-ref (flomap Integer Integer Integer -> Flonum)) +(define (flomap-ref fm k x y) + (match-define (flomap vs c w h) fm) + (unless (and (k . >= . 0) (k . < . c)) + (raise-type-error 'flomap-ref (format "nonnegative fixnum < ~e" c) k)) + (unsafe-flomap-ref vs c w h k x y)) + +(: flomap-bilinear-ref (flomap Integer Real Real -> Flonum)) +(define (flomap-bilinear-ref fm k x y) + (match-define (flomap vs c w h) fm) + (unless (and (k . >= . 0) (k . < . c)) + (raise-type-error 'flomap-bilinear-ref (format "nonnegative fixnum < ~e" c) k)) + (let ([x (- (exact->inexact x) 0.5)] + [y (- (exact->inexact y) 0.5)]) + (define floor-x (floor x)) + (define floor-y (floor y)) + (define x0 (fl->fx floor-x)) + (define y0 (fl->fx floor-y)) + (define x1 (fx+ x0 1)) + (define y1 (fx+ y0 1)) + (define v00 (unsafe-flomap-ref vs c w h k x0 y0)) + (define v10 (unsafe-flomap-ref vs c w h k x1 y0)) + (define v01 (unsafe-flomap-ref vs c w h k x0 y1)) + (define v11 (unsafe-flomap-ref vs c w h k x1 y1)) + (define xα (- x floor-x)) + (fl-convex-combination (fl-convex-combination v00 v10 xα) + (fl-convex-combination v01 v11 xα) + (- y floor-y)))) + +;; =================================================================================================== +;; Construction and conversion + +(: make-flomap (case-> (Integer Integer Integer -> flomap) + (Integer Integer Integer Real -> flomap))) +(define make-flomap + (case-lambda + [(c w h) (flomap (make-flvector (* c w h)) c w h)] + [(c w h v) (flomap (make-flvector (* c w h) (exact->inexact v)) c w h)])) + +(define-syntax-rule (inline-build-flomap components width height f) + (let: ([c : Integer components] + [w : Integer width] + [h : Integer height]) + (with-asserts ([c nonnegative-fixnum?] [w nonnegative-fixnum?] [h nonnegative-fixnum?]) + (define vs (make-flvector (* c w h))) + (let: y-loop : flomap ([y : Nonnegative-Fixnum 0] [i : Nonnegative-Fixnum 0]) + (cond + [(y . fx< . h) + (let: x-loop : flomap ([x : Nonnegative-Fixnum 0] [i : Nonnegative-Fixnum i]) + (cond + [(x . fx< . w) + (let: k-loop : flomap ([k : Nonnegative-Fixnum 0] [i : Nonnegative-Fixnum i]) + (cond + [(k . fx< . c) (unsafe-flvector-set! vs i (f k x y i)) + (k-loop (unsafe-fx+ k 1) (unsafe-fx+ i 1))] + [else (x-loop (unsafe-fx+ x 1) i)]))] + [else (y-loop (unsafe-fx+ y 1) i)]))] + [else (flomap vs c w h)]))))) + +(: build-flomap (Integer Integer Integer + (Nonnegative-Fixnum Nonnegative-Fixnum Nonnegative-Fixnum + Nonnegative-Fixnum -> Real) + -> flomap)) +(define (build-flomap components width height fun) + (inline-build-flomap components width height (λ (k x y i) (exact->inexact (fun k x y i))))) + +(: make-flomap/components (Integer Integer (Listof Real) -> flomap)) +(define (make-flomap/components w h vs) + (let ([vs (apply flvector (map exact->inexact vs))]) + (define c (flvector-length vs)) + (inline-build-flomap c w h (λ (k _x _y _i) (unsafe-flvector-ref vs k))))) + +(: flomap-ref-component (flomap Integer -> flomap)) +(define (flomap-ref-component fm k) + (match-define (flomap vs c w h) fm) + (unless (and (k . >= . 0) (k . < . c)) + (raise-type-error 'flomap-ref-components (format "nonnegative fixnum < ~e" c) k)) + (inline-build-flomap 1 w h (λ (_k x y _i) (unsafe-flvector-ref vs (coords->index c w k x y))))) + +(: flomap-take-components (flomap Integer -> flomap)) +(define (flomap-take-components fm c) + (match-define (flomap vs old-c w h) fm) + (unless (and (c . >= . 0) (c . <= . old-c)) + (raise-type-error 'flomap-take-components (format "nonnegative fixnum <= ~e" old-c) c)) + (inline-build-flomap c w h (λ (k x y _i) (unsafe-flvector-ref vs (coords->index old-c w k x y))))) + +(: flomap-drop-components (flomap Integer -> flomap)) +(define (flomap-drop-components fm c) + (match-define (flomap vs old-c w h) fm) + (unless (and (c . >= . 0) (c . <= . old-c)) + (raise-type-error 'flomap-drop-components (format "nonnegative fixnum <= ~e" old-c) c)) + (define new-c (fx- old-c c)) + (with-asserts + ([new-c nonnegative-fixnum?]) + (inline-build-flomap new-c w h (λ (k x y _i) + (unsafe-flvector-ref vs (coords->index old-c w (fx+ k c) x y)))))) + +(: flomap-append-components2 (flomap flomap -> flomap)) +(define (flomap-append-components2 fm1 fm2) + (match-define (flomap vs1 d1 w1 h1) fm1) + (match-define (flomap vs2 d2 w2 h2) fm2) + (unless (and (= w1 w2) (= h1 h2)) + (error 'flomap-append-components + "expected flomaps with equal dimension; given dimensions ~e×~e and ~e×~e" + w1 h1 w2 h2)) + (inline-build-flomap (fx+ d1 d2) w1 h1 + (λ (k x y _i) + (define k2 (fx- k d1)) + (cond [(k2 . fx< . 0) (unsafe-flvector-ref vs1 (coords->index d1 w1 k x y))] + [else (unsafe-flvector-ref vs2 (coords->index d2 w2 k2 x y))])))) + +(: flomap-append-components (flomap flomap * -> flomap)) +(define (flomap-append-components fm . fms) + (for/fold ([fm1 fm]) ([fm2 (in-list fms)]) + (flomap-append-components2 fm1 fm2))) diff --git a/collects/images/private/flomap-transform.rkt b/collects/images/private/flomap-transform.rkt new file mode 100644 index 0000000000..f9d3860a25 --- /dev/null +++ b/collects/images/private/flomap-transform.rkt @@ -0,0 +1,40 @@ +#lang typed/racket/base + +(require racket/flonum + (except-in racket/fixnum fl->fx fx->fl) + racket/match + "flonum.rkt" + "flomap-struct.rkt") + +(provide flomap-flip-horizontal flomap-flip-vertical flomap-transpose + flomap-cw-rotate flomap-ccw-rotate) + +(: flomap-flip-horizontal (flomap -> flomap)) +(define (flomap-flip-horizontal fm) + (match-define (flomap vs c w h) fm) + (define w-1 (fx- w 1)) + (inline-build-flomap c w h (λ (k x y _i) + (unsafe-flvector-ref vs (coords->index c w k (fx- w-1 x) y))))) + +(define (flomap-flip-vertical fm) + (match-define (flomap vs c w h) fm) + (define h-1 (fx- h 1)) + (inline-build-flomap c w h (λ (k x y _i) + (unsafe-flvector-ref vs (coords->index c w k x (fx- h-1 y)))))) + +(define (flomap-transpose fm) + (match-define (flomap vs c w h) fm) + (inline-build-flomap c h w (λ (k x y _i) + (unsafe-flvector-ref vs (coords->index c w k y x))))) + +(define (flomap-cw-rotate fm) + (match-define (flomap vs c w h) fm) + (define h-1 (fx- h 1)) + (inline-build-flomap c h w (λ (k x y _i) + (unsafe-flvector-ref vs (coords->index c w k (fx- h-1 y) x))))) + +(define (flomap-ccw-rotate fm) + (match-define (flomap vs c w h) fm) + (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)))))) diff --git a/collects/images/private/flomap.rkt b/collects/images/private/flomap.rkt index fb986fcfa3..122230a9e5 100644 --- a/collects/images/private/flomap.rkt +++ b/collects/images/private/flomap.rkt @@ -1,1147 +1,34 @@ -#lang racket/base - -(require racket/flonum racket/math racket/list racket/match racket/contract racket/class racket/draw - "unsafe.rkt") - -(provide - (contract-out - ;; Contracts - [fx>=/c (fixnum? . -> . contract?)] - ;; Data types - [struct flomap ([values flvector?] - [components (fx>=/c 0)] - [width (fx>=/c 0)] - [height (fx>=/c 0)])] - [flomap-size (flomap? . -> . (values (fx>=/c 0) (fx>=/c 0)))] - [flomap-ref (flomap? (fx>=/c 0) fixnum? fixnum? . -> . flonum?)] - [flomap-bilinear-ref (flomap? (fx>=/c 0) real? real? . -> . flonum?)] - ;; Construction and conversion - [make-flomap (((fx>=/c 0) (fx>=/c 0) (fx>=/c 0)) (real?) . ->* . flomap?)] - [build-flomap ((fx>=/c 0) (fx>=/c 0) (fx>=/c 0) - ((fx>=/c 0) (fx>=/c 0) (fx>=/c 0) . -> . real?) - . -> . flomap?)] - [make-flomap/components ((fx>=/c 0) (fx>=/c 0) (listof real?) . -> . flomap?)] - [flomap-ref-component (flomap? (fx>=/c 0) . -> . flomap?)] - [flomap-take-components (flomap? (fx>=/c 0) . -> . flomap?)] - [flomap-drop-components (flomap? (fx>=/c 0) . -> . flomap?)] - [flomap-append-components ((flomap?) #:rest (listof flomap?) . ->* . flomap?)] - [flomap-multiply-alpha (flomap? . -> . flomap?)] - [flomap-divide-alpha (flomap? . -> . flomap?)] - [bitmap->flomap ((is-a?/c bitmap%) . -> . flomap?)] - [flomap->bitmap (flomap? . -> . (is-a?/c bitmap%))] - [draw-flomap ((fx>=/c 0) (fx>=/c 0) ((is-a?/c bitmap-dc%) . -> . any/c) . -> . flomap?)] - ;; Pointwise unary operations - [flomap-lift ((flonum? . -> . real?) . -> . (flomap? . -> . flomap?))] - [fmneg (flomap? . -> . flomap?)] - [fmabs (flomap? . -> . flomap?)] - [fmsqr (flomap? . -> . flomap?)] - [fmsin (flomap? . -> . flomap?)] - [fmcos (flomap? . -> . flomap?)] - [fmtan (flomap? . -> . flomap?)] - [fmlog (flomap? . -> . flomap?)] - [fmexp (flomap? . -> . flomap?)] - [fmsqrt (flomap? . -> . flomap?)] - [fmasin (flomap? . -> . flomap?)] - [fmacos (flomap? . -> . flomap?)] - [fmatan (flomap? . -> . flomap?)] - [fmround (flomap? . -> . flomap?)] - [fmfloor (flomap? . -> . flomap?)] - [fmceiling (flomap? . -> . flomap?)] - [fmtruncate (flomap? . -> . flomap?)] - [flomap-normalize (flomap? . -> . flomap?)] - ;; Pointwise binary operations - [flomap-lift2 (symbol? (flonum? flonum? . -> . real?) - . -> . ((or/c flomap? real?) (or/c flomap? real?) . -> . flomap?))] - [fm+ ((or/c flomap? real?) (or/c flomap? real?) . -> . flomap?)] - [fm- ((or/c flomap? real?) (or/c flomap? real?) . -> . flomap?)] - [fm* ((or/c flomap? real?) (or/c flomap? real?) . -> . flomap?)] - [fm/ ((or/c flomap? real?) (or/c flomap? real?) . -> . flomap?)] - [fmmin ((or/c flomap? real?) (or/c flomap? real?) . -> . flomap?)] - [fmmax ((or/c flomap? real?) (or/c flomap? real?) . -> . flomap?)] - ;; Blur - [flomap-gaussian-blur ((flomap? real?) (real? real? real?) . ->* . flomap?)] - [flomap-box-blur ((flomap? real?) (real?) . ->* . flomap?)] - [flomap-blur ((flomap? real?) (real?) . ->* . flomap?)] - ;[flomap-integral (flomap? . -> . flomap?)] - ;; Derivatives - [flomap-gradient-x (flomap? . -> . flomap?)] - [flomap-gradient-y (flomap? . -> . flomap?)] - [flomap-gradient (flomap? . -> . (values flomap? flomap?))] - [flomap-gradient-normal (flomap? . -> . flomap?)] - ;; Statistics - [flomap-extreme-values (flomap? . -> . (values flonum? flonum?))] - [flomap-min-value (flomap? . -> . flonum?)] - [flomap-max-value (flomap? . -> . flonum?)] - [flomap-nonzero-rect (flomap? . -> . (values (fx>=/c 0) (fx>=/c 0) (fx>=/c 0) - (fx>=/c 0) (fx>=/c 0) (fx>=/c 0)))] - ;; Sizing - [flomap-inset (case-> (flomap? fixnum? . -> . flomap?) - (flomap? fixnum? fixnum? . -> . flomap?) - (flomap? fixnum? fixnum? fixnum? fixnum? . -> . flomap?))] - [flomap-trim (flomap? . -> . flomap?)] - [flomap-crop (flomap? (fx>=/c 0) (fx>=/c 0) real? real? . -> . flomap?)] - [flomap-lt-crop (flomap? (fx>=/c 0) (fx>=/c 0) . -> . flomap?)] - [flomap-lc-crop (flomap? (fx>=/c 0) (fx>=/c 0) . -> . flomap?)] - [flomap-lb-crop (flomap? (fx>=/c 0) (fx>=/c 0) . -> . flomap?)] - [flomap-ct-crop (flomap? (fx>=/c 0) (fx>=/c 0) . -> . flomap?)] - [flomap-cc-crop (flomap? (fx>=/c 0) (fx>=/c 0) . -> . flomap?)] - [flomap-cb-crop (flomap? (fx>=/c 0) (fx>=/c 0) . -> . flomap?)] - [flomap-rt-crop (flomap? (fx>=/c 0) (fx>=/c 0) . -> . flomap?)] - [flomap-rc-crop (flomap? (fx>=/c 0) (fx>=/c 0) . -> . flomap?)] - [flomap-rb-crop (flomap? (fx>=/c 0) (fx>=/c 0) . -> . flomap?)] - [flomap-scale (case-> (flomap? (>=/c 0.0) . -> . flomap?) - (flomap? (>=/c 0.0) (>=/c 0.0) . -> . flomap?))] - [flomap-resize (flomap? (or/c (fx>=/c 0) #f) (or/c (fx>=/c 0) #f) . -> . flomap?)] - ;; Transforms - [flomap-flip-horizontal (flomap? . -> . flomap?)] - [flomap-flip-vertical (flomap? . -> . flomap?)] - [flomap-transpose (flomap? . -> . flomap?)] - [flomap-cw-rotate (flomap? . -> . flomap?)] - [flomap-ccw-rotate (flomap? . -> . flomap?)] - ;; Compositing - [flomap-pin (flomap? real? real? flomap? real? real? . -> . flomap?)] - [flomap-pin* ([real? real? real? real? flomap?] #:rest (listof flomap?) . ->* . flomap?)] - [flomap-lt-superimpose ([flomap?] #:rest (listof flomap?) . ->* . flomap?)] - [flomap-lc-superimpose ([flomap?] #:rest (listof flomap?) . ->* . flomap?)] - [flomap-lb-superimpose ([flomap?] #:rest (listof flomap?) . ->* . flomap?)] - [flomap-ct-superimpose ([flomap?] #:rest (listof flomap?) . ->* . flomap?)] - [flomap-cc-superimpose ([flomap?] #:rest (listof flomap?) . ->* . flomap?)] - [flomap-cb-superimpose ([flomap?] #:rest (listof flomap?) . ->* . flomap?)] - [flomap-rt-superimpose ([flomap?] #:rest (listof flomap?) . ->* . flomap?)] - [flomap-rc-superimpose ([flomap?] #:rest (listof flomap?) . ->* . flomap?)] - [flomap-rb-superimpose ([flomap?] #:rest (listof flomap?) . ->* . flomap?)] - [flomap-vl-append ([flomap?] #:rest (listof flomap?) . ->* . flomap?)] - [flomap-vc-append ([flomap?] #:rest (listof flomap?) . ->* . flomap?)] - [flomap-vr-append ([flomap?] #:rest (listof flomap?) . ->* . flomap?)] - [flomap-ht-append ([flomap?] #:rest (listof flomap?) . ->* . flomap?)] - [flomap-hc-append ([flomap?] #:rest (listof flomap?) . ->* . flomap?)] - [flomap-hb-append ([flomap?] #:rest (listof flomap?) . ->* . flomap?)] - ;; Effects - [flomap-outline ([flomap? real?] [#:color (or/c #f (listof real?))] . ->* . flomap?)] - [flomap-outlined ([flomap? real?] [#:color (or/c #f (listof real?))] . ->* . flomap?)] - [flomap-shadow ([flomap? real?] [#:color (or/c #f (listof real?))] . ->* . flomap?)] - [flomap-shadowed ([flomap? real?] [#:color (or/c #f (listof real?))] . ->* . flomap?)] - ) - unsafe-build-flomap - flomap-lift/unsafe - flomap-lift2/unsafe) - -(struct flomap (values components width height) - #:transparent - #:guard (λ (vs c w h name) - (unless (= (flvector-length vs) (* c w h)) - (error 'flomap "expected flvector of length ~e; given one of length ~e" - (* c w h) (flvector-length vs))) - (values vs c w h))) - -(define (fx>=/c n) (and/c fixnum? (>=/c n))) - -(define (flomap-size fm) - (match-define (flomap _vs _c w h) fm) - (values w h)) - -(define-syntax-rule (unsafe-coords->index c w k x y) - (unsafe-fx+ k (unsafe-fx* c (unsafe-fx+ x (unsafe-fx* y w))))) - -(define (flomap-ref* vs c w h k x y) - (cond [(and (x . unsafe-fx>= . 0) (x . unsafe-fx< . w) - (y . unsafe-fx>= . 0) (y . unsafe-fx< . h)) - (unsafe-flvector-ref vs (unsafe-coords->index c w k x y))] - [else 0.0])) - -(define (flomap-ref fm k x y) - (match-define (flomap vs c w h) fm) - (unless (k . < . c) - (raise-type-error 'flomap-ref (format "nonnegative fixnum < ~e" c) k)) - (flomap-ref* vs c w h k x y)) - -(define (flomap-bilinear-ref fm k x y) - (match-define (flomap vs c w h) fm) - (unless (k . < . c) - (raise-type-error 'flomap-bilinear-ref (format "nonnegative fixnum < ~e" c) k)) - (let ([x (unsafe-fl- (exact->inexact x) 0.5)] - [y (unsafe-fl- (exact->inexact y) 0.5)]) - (define floor-x (unsafe-flfloor x)) - (define floor-y (unsafe-flfloor y)) - (define x0 (unsafe-fl->fx floor-x)) - (define y0 (unsafe-fl->fx floor-y)) - (define x1 (unsafe-fx+ x0 1)) - (define y1 (unsafe-fx+ y0 1)) - (define v00 (flomap-ref* vs c w h k x0 y0)) - (define v10 (flomap-ref* vs c w h k x1 y0)) - (define v01 (flomap-ref* vs c w h k x0 y1)) - (define v11 (flomap-ref* vs c w h k x1 y1)) - (define xα (unsafe-fl- x floor-x)) - (unsafe-fl-convex-combination (unsafe-fl-convex-combination v00 v10 xα) - (unsafe-fl-convex-combination v01 v11 xα) - (unsafe-fl- y floor-y)))) - -;; =================================================================================================== -;; Construction and conversion - -(define (make-flomap c w h [v 0.0]) - (flomap (make-flvector (* c w h) (exact->inexact v)) - c w h)) - -(define (make-flomap/components w h vs) - (let ([vs (apply flvector (map exact->inexact vs))]) - (define c (flvector-length vs)) - (define new-vs - (for*/flvector #:length (* c w h) ([y (in-range h)] [x (in-range w)] [v (in-flvector vs)]) - v)) - (flomap new-vs c w h))) - -(define-syntax-rule (unsafe-build-flomap components width height image-fun) - (let ([c components] [w width] [h height] [f image-fun]) - (define vs (make-flvector (* c w h))) - (let y-loop ([y 0] [i 0]) - (cond - [(y . unsafe-fx< . h) - (let x-loop ([x 0] [i i]) - (cond - [(x . unsafe-fx< . w) - (let k-loop ([k 0] [i i]) - (cond - [(k . unsafe-fx< . c) - (unsafe-flvector-set! vs i (f k x y)) - (k-loop (unsafe-fx+ k 1) (unsafe-fx+ i 1))] - [else - (x-loop (unsafe-fx+ x 1) i)]))] - [else - (y-loop (unsafe-fx+ y 1) i)]))] - [else - (flomap vs c w h)])))) - -(define (build-flomap c w h f) - (unsafe-build-flomap c w h (λ (k x y) (exact->inexact (f k x y))))) - -(define (flomap-ref-component fm k) - (match-define (flomap vs c w h) fm) - (unless (k . < . c) - (error 'flomap-ref-component "expected component index < ~e; given index ~e" c k)) - (unsafe-build-flomap - 1 w h - (λ (_ x y) (unsafe-flvector-ref vs (unsafe-coords->index c w k x y))))) - -(define (flomap-take-components fm c) - (match-define (flomap vs old-c w h) fm) - (unless (c . <= . old-c) - (error 'flomap-take-components "can only take <= ~e components; given ~e" old-c c)) - (unsafe-build-flomap - c w h - (λ (k x y) (unsafe-flvector-ref vs (unsafe-coords->index old-c w k x y))))) - -(define (flomap-drop-components fm c) - (match-define (flomap vs old-c w h) fm) - (unless (c . <= . old-c) - (error 'flomap-drop-components "can only drop <= ~e components; given ~e" old-c c)) - (unsafe-build-flomap - (- old-c c) w h - (λ (k x y) (unsafe-flvector-ref vs (unsafe-coords->index old-c w (unsafe-fx+ k c) x y))))) - -(define (flomap-append-components2 fm1 fm2) - (match-define (flomap vs1 d1 w1 h1) fm1) - (match-define (flomap vs2 d2 w2 h2) fm2) - (unless (and (= w1 w2) (= h1 h2)) - (error 'flomap-append-components - "expected flomaps with equal dimension; given dimensions ~e×~e and ~e×~e" - w1 h1 w2 h2)) - (unsafe-build-flomap - (+ d1 d2) w1 h1 - (λ (k x y) - (cond [(k . unsafe-fx< . d1) (unsafe-flvector-ref vs1 (unsafe-coords->index d1 w1 k x y))] - [else (unsafe-flvector-ref vs2 (unsafe-coords->index d2 w2 (unsafe-fx- k d1) x y))])))) - -(define (flomap-append-components fm . fms) - (for/fold ([fm1 fm]) ([fm2 (in-list fms)]) - (flomap-append-components2 fm1 fm2))) - -(define (fldivide x y) - (if (y . unsafe-fl= . 0.0) 0.0 (unsafe-fl/ x y))) - -(define (flomap-divide-alpha fm) - (match-define (flomap _ c w h) fm) - (cond [(c . <= . 1) fm] - [else - (define alpha-fm (flomap-ref-component fm 0)) - (flomap-append-components alpha-fm ((flomap-lift2/unsafe 'flomap-divide-alpha fldivide) - (flomap-drop-components fm 1) alpha-fm))])) - -(define (flomap-multiply-alpha fm) - (match-define (flomap _ c w h) fm) - (cond [(c . > . 1) - (define alpha-fm (flomap-ref-component fm 0)) - (flomap-append-components alpha-fm (fm* (flomap-drop-components fm 1) alpha-fm))] - [else fm])) - -(define (bitmap->flomap bm) - (define w (send bm get-width)) - (define h (send bm get-height)) - (define bs (make-bytes (* 4 w h))) - ;; get bytes without premultiplying alpha because doing it in flonums maintains precision - ;; (if RGB bytes are stored without premultiplying alpha) - (send bm get-argb-pixels 0 0 w h bs #t) - (send bm get-argb-pixels 0 0 w h bs #f) - - (define argb-fm (make-flomap 4 w h)) - (define argb-vs (flomap-values argb-fm)) - (for ([i0 (in-range 0 (* 4 w h) 4)]) - (define i1 (unsafe-fx+ i0 1)) - (define i2 (unsafe-fx+ i0 2)) - (define i3 (unsafe-fx+ i0 3)) - (define a (unsafe-bytes-ref bs i0)) - (define r (unsafe-bytes-ref bs i1)) - (define g (unsafe-bytes-ref bs i2)) - (define b (unsafe-bytes-ref bs i3)) - (unsafe-flvector-set! argb-vs i0 (unsafe-fl/ (unsafe-fx->fl a) 255.0)) - (unsafe-flvector-set! argb-vs i1 (unsafe-fl/ (unsafe-fx->fl r) 255.0)) - (unsafe-flvector-set! argb-vs i2 (unsafe-fl/ (unsafe-fx->fl g) 255.0)) - (unsafe-flvector-set! argb-vs i3 (unsafe-fl/ (unsafe-fx->fl b) 255.0))) - (flomap-multiply-alpha argb-fm)) - -(define (flomap->bitmap fm) - (match-define (flomap vs c w h) fm) - (let* ([fm (case c - [(1) (flomap-append-components (make-flomap 1 w h 1.0) fm fm fm)] - [(2) (define alpha-fm (flomap-ref-component fm 0)) - (define value-fm (flomap-drop-components fm 1)) - (flomap-append-components alpha-fm value-fm value-fm value-fm)] - [(3) (flomap-append-components (make-flomap 1 w h 1.0) fm)] - [(4) fm] - [else (raise-type-error 'flomap->bitmap "flomap with 1, 2, 3 or 4 components" fm)])] - ;; inset if zero (bitmaps can't have zero size) - [fm (flomap-inset fm 0 0 (if (= w 0) 1 0) (if (= h 0) 1 0))] - ;; divide alphas before converting - [fm (flomap-divide-alpha fm)]) - ;; guaranteed an ARGB flomap now - (match-define (flomap vs 4 w h) fm) - (define bs (make-bytes (* 4 w h))) - (for ([i0 (in-range 0 (* 4 w h) 4)]) - (define i1 (unsafe-fx+ i0 1)) - (define i2 (unsafe-fx+ i0 2)) - (define i3 (unsafe-fx+ i0 3)) - (define a (unsafe-flvector-ref vs i0)) - (define r (unsafe-flvector-ref vs i1)) - (define g (unsafe-flvector-ref vs i2)) - (define b (unsafe-flvector-ref vs i3)) - (unsafe-bytes-set! bs i0 (unsafe-fl->byte (unsafe-fl* 255.0 a))) - (unsafe-bytes-set! bs i1 (unsafe-fl->byte (unsafe-fl* 255.0 r))) - (unsafe-bytes-set! bs i2 (unsafe-fl->byte (unsafe-fl* 255.0 g))) - (unsafe-bytes-set! bs i3 (unsafe-fl->byte (unsafe-fl* 255.0 b)))) - - (define bm (make-bitmap w h)) - (send bm set-argb-pixels 0 0 w h bs #t) - (send bm set-argb-pixels 0 0 w h bs #f) - bm)) - -(define (draw-flomap w h draw-proc) - (define bm (make-bitmap (max w 1) (max h 1))) - (define dc (make-object bitmap-dc% bm)) - (send dc set-smoothing 'smoothed) - (draw-proc dc) - (flomap-inset (bitmap->flomap bm) 0 0 (if (= w 0) -1 0) (if (= h 0) -1 0))) - -;; =================================================================================================== -;; Unary pointwise operations - -(define-syntax-rule (flomap-lift/unsafe f) - (λ (fm) - (match-define (flomap vs c w h) fm) - (define n (* c w h)) - (define res-vs (make-flvector n)) - (flomap (let loop ([i 0]) - (cond [(i . unsafe-fx< . n) - (unsafe-flvector-set! res-vs i (f (unsafe-flvector-ref vs i))) - (loop (unsafe-fx+ i 1))] - [else res-vs])) - c w h))) - -(define (flomap-lift op) - (flomap-lift/unsafe (λ (x) (exact->inexact (op x))))) - -(define fmneg (flomap-lift/unsafe unsafe-flneg)) -(define fmabs (flomap-lift/unsafe unsafe-flabs)) -(define fmsqr (flomap-lift/unsafe (λ (x) (unsafe-fl* x x)))) -(define fmsin (flomap-lift/unsafe unsafe-flsin)) -(define fmcos (flomap-lift/unsafe unsafe-flcos)) -(define fmtan (flomap-lift/unsafe unsafe-fltan)) -(define fmlog (flomap-lift/unsafe unsafe-fllog)) -(define fmexp (flomap-lift/unsafe unsafe-flexp)) -(define fmsqrt (flomap-lift/unsafe unsafe-flsqrt)) -(define fmasin (flomap-lift/unsafe unsafe-flasin)) -(define fmacos (flomap-lift/unsafe unsafe-flacos)) -(define fmatan (flomap-lift/unsafe unsafe-flatan)) -(define fmround (flomap-lift/unsafe unsafe-flround)) -(define fmfloor (flomap-lift/unsafe unsafe-flfloor)) -(define fmceiling (flomap-lift/unsafe unsafe-flceiling)) -(define fmtruncate (flomap-lift/unsafe unsafe-fltruncate)) - -;; =================================================================================================== -;; Binary pointwise operations - -(define-syntax-rule (flomap-lift2/unsafe name unsafe-op) - (λ (fm1 fm2) - (cond - [(and (real? fm1) (real? fm2)) - (error name "expected at least one flomap argument; given ~e and ~e" fm1 fm2)] - [(real? fm1) (let ([fm1 (exact->inexact fm1)]) - ((flomap-lift/unsafe (λ (v) (unsafe-op fm1 v))) fm2))] - [(real? fm2) (let ([fm2 (exact->inexact fm2)]) - ((flomap-lift/unsafe (λ (v) (unsafe-op v fm2))) fm1))] - [else - (match-define (flomap vs1 c1 w h) fm1) - (match-define (flomap vs2 c2 w2 h2) fm2) - (cond - [(not (and (= w w2) (= h h2))) - (error name "expected flomaps of equal size; given sizes ~e×~e and ~e×~e" w h w2 h2)] - [(= c1 c2) - (define n (* c1 w h)) - (define res-vs (make-flvector n)) - (flomap (let loop ([i 0]) - (cond [(i . unsafe-fx< . n) - (unsafe-flvector-set! res-vs i (unsafe-op (unsafe-flvector-ref vs1 i) - (unsafe-flvector-ref vs2 i))) - (loop (unsafe-fx+ i 1))] - [else res-vs])) - c1 w h)] - [(= c1 1) - (unsafe-build-flomap - c2 w h - (λ (k x y) - (unsafe-op (unsafe-flvector-ref vs1 (unsafe-coords->index 1 w 0 x y)) - (unsafe-flvector-ref vs2 (unsafe-coords->index c2 w k x y)))))] - [(= c2 1) - (unsafe-build-flomap - c1 w h - (λ (k x y) - (unsafe-op (unsafe-flvector-ref vs1 (unsafe-coords->index c1 w k x y)) - (unsafe-flvector-ref vs2 (unsafe-coords->index 1 w 0 x y)))))] - [else - (error name (string-append "expected flomaps with the same number of components, " - "or a flomap with 1 component and a flomap with n components; " - "given flomaps with ~e and ~e components") - c1 c2)])]))) - -(define (flomap-lift2 name op) - (flomap-lift2/unsafe name (λ (x y) (exact->inexact (op x y))))) - -(define fm+ (flomap-lift2/unsafe 'fm+ unsafe-fl+)) -(define fm- (flomap-lift2/unsafe 'fm- unsafe-fl-)) -(define fm* (flomap-lift2/unsafe 'fm* unsafe-fl*)) -(define fm/ (flomap-lift2/unsafe 'fm/ unsafe-fl/)) -(define fmmin (flomap-lift2/unsafe 'fmmin unsafe-flmin)) -(define fmmax (flomap-lift2/unsafe 'fmmax unsafe-flmax)) - -(define (flomap-normalize fm) - (match-define (flomap _ _c w h) fm) - (define-values (v-min v-max) (flomap-extreme-values fm)) - (define v-size (- v-max v-min)) - (let* ([fm (fm- fm v-min)] - [fm (if (zero? v-size) fm (fm/ fm (- v-max v-min)))]) - fm)) - -;; =================================================================================================== -;; Gaussian blur - -(define (flomap-gaussian-blur fm xσ [yσ xσ] [x-stddevs 3.0] [y-stddevs 3.0]) - (flomap-gaussian-blur-y - (flomap-gaussian-blur-x fm (abs (exact->inexact xσ)) (abs (exact->inexact x-stddevs))) - (abs (exact->inexact yσ)) (abs (exact->inexact y-stddevs)))) - -(define (flomap-gaussian-blur-x fm σ stddevs) - (let ([σ (abs (exact->inexact σ))] - [stddevs (abs (exact->inexact stddevs))]) - (cond - [(or (σ . = . 0.0) (stddevs . = . 0.0)) fm] - [else - (define dx-min (inexact->exact (floor (* (- stddevs) σ)))) - (define dx-max (+ 1 (inexact->exact (ceiling (* stddevs σ))))) - (define ss (gaussian-kernel-1d dx-min dx-max σ)) - - (match-define (flomap vs c w h) fm) - (unsafe-build-flomap - c w h - (λ (k x y) - (define dx-start (unsafe-fx- (unsafe-fxmax (unsafe-fx+ x dx-min) 0) x)) - (define dx-end (unsafe-fx- (unsafe-fxmin (unsafe-fx+ x dx-max) w) x)) - (define i (unsafe-fx+ k (unsafe-fx* c (unsafe-fx+ x (unsafe-fx* w y))))) - (define j (unsafe-fx+ i (unsafe-fx* c dx-start))) - ;; this inner loop has to be *tight*, so no `for'; seems to speed it up by about 50% - (let src-loop ([sum 0.0] [dx dx-start] [j j]) - (cond [(dx . unsafe-fx< . dx-end) - (define s (unsafe-flvector-ref ss (unsafe-fx- dx dx-min))) - (src-loop (unsafe-fl+ sum (unsafe-fl* s (unsafe-flvector-ref vs j))) - (unsafe-fx+ dx 1) - (unsafe-fx+ j c))] - [else sum]))))]))) - -(define (flomap-gaussian-blur-y fm σ stddevs) - (let ([σ (abs (exact->inexact σ))] - [stddevs (abs (exact->inexact stddevs))]) - (cond - [(or (σ . = . 0.0) (stddevs . = . 0.0)) fm] - [else - (define dy-min (inexact->exact (floor (* (- stddevs) σ)))) - (define dy-max (+ 1 (inexact->exact (ceiling (* stddevs σ))))) - (define ss (gaussian-kernel-1d dy-min dy-max σ)) - - (match-define (flomap vs c w h) fm) - (define cw (* c w)) - (unsafe-build-flomap - c w h - (λ (k x y) - (define dy-start (unsafe-fx- (unsafe-fxmax (unsafe-fx+ y dy-min) 0) y)) - (define dy-end (unsafe-fx- (unsafe-fxmin (unsafe-fx+ y dy-max) h) y)) - (define i (unsafe-fx+ k (unsafe-fx* c (unsafe-fx+ x (unsafe-fx* w y))))) - (define j (unsafe-fx+ i (unsafe-fx* cw dy-start))) - ;; this inner loop has to be *tight*, so no `for'; seems to speed it up by about 50% - (let src-loop ([sum 0.0] [dy dy-start] [j j]) - (cond [(dy . unsafe-fx< . dy-end) - (define s (unsafe-flvector-ref ss (unsafe-fx- dy dy-min))) - (src-loop (unsafe-fl+ sum (unsafe-fl* s (unsafe-flvector-ref vs j))) - (unsafe-fx+ dy 1) - (unsafe-fx+ j cw))] - [else sum]))))]))) - -(define (gaussian-kernel-1d mn mx σ) - (define n (- mx mn)) - (define ys - (for/flvector #:length n ([x (in-range mn mx)]) - (unsafe-flgaussian (unsafe-fx->fl x) σ))) - (define s (unsafe-flvector-sum ys)) - (for/flvector #:length n ([y (in-flvector ys)]) - (unsafe-fl/ y s))) - -;; =================================================================================================== -;; Integral images - -(define (flomap-integral fm) - (match-define (flomap vs c w h) fm) - (define w+1 (+ w 1)) - (define c*w+1 (* c w+1)) - (define h+1 (+ h 1)) - (define new-vs (make-flvector (* c w+1 h+1))) - (for* ([y (in-range h)] [x (in-range w)] [k (in-range c)]) - (define i (unsafe-coords->index c w k x y)) - (define j00 (unsafe-coords->index c w+1 k x y)) - (define j01 (unsafe-fx+ j00 c*w+1)) - (unsafe-flvector-set! new-vs (unsafe-fx+ j01 c) - (unsafe-fl- (unsafe-flsum (unsafe-flvector-ref vs i) - (unsafe-flvector-ref new-vs j01) - (unsafe-flvector-ref new-vs (unsafe-fx+ j00 c))) - (unsafe-flvector-ref new-vs j00)))) - (flomap new-vs c w+1 h+1)) - -(define (unsafe-flomap-integral-sum vs c w h k x-start y-start x-end y-end) - (define w-1 (unsafe-fx- w 1)) - (define h-1 (unsafe-fx- h 1)) - (define x1 (unsafe-fxmax 0 (unsafe-fxmin x-start w-1))) - (define x2 (unsafe-fxmax 0 (unsafe-fxmin x-end w-1))) - (define y1 (unsafe-fxmax 0 (unsafe-fxmin y-start h-1))) - (define y2 (unsafe-fxmax 0 (unsafe-fxmin y-end h-1))) - (unsafe-fl- (unsafe-fl+ (unsafe-flvector-ref vs (unsafe-coords->index c w k x1 y1)) - (unsafe-flvector-ref vs (unsafe-coords->index c w k x2 y2))) - (unsafe-fl+ (unsafe-flvector-ref vs (unsafe-coords->index c w k x1 y2)) - (unsafe-flvector-ref vs (unsafe-coords->index c w k x2 y1))))) - -(define (flomap-integral-x fm) - (match-define (flomap vs c w h) fm) - (define w+1 (+ w 1)) - (define new-vs (make-flvector (* c w+1 h))) - (for* ([y (in-range h)] [x (in-range w)] [k (in-range c)]) - (define i (unsafe-coords->index c w k x y)) - (define j0 (unsafe-coords->index c w+1 k x y)) - (define j1 (unsafe-fx+ j0 c)) - (unsafe-flvector-set! new-vs j1 - (unsafe-fl+ (unsafe-flvector-ref vs i) - (unsafe-flvector-ref new-vs j0)))) - (flomap new-vs c w+1 h)) - -(define (flomap-integral-y fm) - (match-define (flomap vs c w h) fm) - (define h+1 (+ h 1)) - (define cw (* c w)) - (define new-vs (make-flvector (* c w h+1))) - (for* ([y (in-range h)] [x (in-range w)] [k (in-range c)]) - (define j0 (unsafe-coords->index c w k x y)) - (define j1 (unsafe-fx+ j0 cw)) - (unsafe-flvector-set! new-vs j1 - (unsafe-fl+ (unsafe-flvector-ref vs j0) - (unsafe-flvector-ref new-vs j0)))) - (flomap new-vs c w h+1)) - -(define (unsafe-flomap-integral-x-sum vs c w k x-start x-end y) - (define w-1 (unsafe-fx- w 1)) - (define x1 (unsafe-fxmax 0 (unsafe-fxmin x-start w-1))) - (define x2 (unsafe-fxmax 0 (unsafe-fxmin x-end w-1))) - (unsafe-fl- (unsafe-flvector-ref vs (unsafe-coords->index c w k x2 y)) - (unsafe-flvector-ref vs (unsafe-coords->index c w k x1 y)))) - -(define (unsafe-flomap-integral-y-sum vs c w h k x y-start y-end) - (define h-1 (unsafe-fx- h 1)) - (define y1 (unsafe-fxmax 0 (unsafe-fxmin y-start h-1))) - (define y2 (unsafe-fxmax 0 (unsafe-fxmin y-end h-1))) - (unsafe-fl- (unsafe-flvector-ref vs (unsafe-coords->index c w k x y2)) - (unsafe-flvector-ref vs (unsafe-coords->index c w k x y1)))) - -;; =================================================================================================== -;; Box blur - -(define (flomap-box-blur fm xr [yr xr]) - (let ([xr (abs xr)] [yr (abs yr)]) - (cond [(and (integer? xr) (integer? yr)) - (flomap-box-blur/int fm (inexact->exact xr) (inexact->exact yr))] - [else - (flomap-box-blur-y (flomap-box-blur-x fm xr) yr)]))) - -(define (flomap-box-blur-x fm r) - (cond - [(integer? r) (flomap-box-blur-x/int fm (inexact->exact r))] - [else - (define r1 (inexact->exact (floor r))) - (define r2 (+ r1 1)) - (define s (+ 1 (* 2 r))) - (define s1 (+ 1 (* 2 r1))) - (define s2 (+ 1 (* 2 r2))) - (define α (exact->inexact (/ (- (sqr s2) (sqr s)) (- (sqr s2) (sqr s1))))) - (define norm1 (/ α s1)) - (define norm2 (/ (- 1 α) s2)) - (define r1+1 (+ r1 1)) - (define r2+1 (+ r2 1)) - (match-define (flomap _ c w h) fm) - (match-define (flomap int-vs int-c int-w int-h) (flomap-integral-x fm)) - (unsafe-build-flomap - c w h - (λ (k x y) - (unsafe-fl+ - (unsafe-fl* norm1 (unsafe-flomap-integral-x-sum - int-vs int-c int-w k - (unsafe-fx- x r1) (unsafe-fx+ x r1+1) y)) - (unsafe-fl* norm2 (unsafe-flomap-integral-x-sum - int-vs int-c int-w k - (unsafe-fx- x r2) (unsafe-fx+ x r2+1) y)))))])) - -(define (flomap-box-blur-y fm r) - (cond - [(integer? r) (flomap-box-blur-y/int fm (inexact->exact r))] - [else - (define r1 (inexact->exact (floor r))) - (define r2 (+ r1 1)) - (define s (+ 1 (* 2 r))) - (define s1 (+ 1 (* 2 r1))) - (define s2 (+ 1 (* 2 r2))) - (define α (exact->inexact (/ (- (sqr s2) (sqr s)) (- (sqr s2) (sqr s1))))) - (define norm1 (/ α s1)) - (define norm2 (/ (- 1 α) s2)) - (define r1+1 (+ r1 1)) - (define r2+1 (+ r2 1)) - (match-define (flomap _ c w h) fm) - (match-define (flomap int-vs int-c int-w int-h) (flomap-integral-y fm)) - (unsafe-build-flomap - c w h - (λ (k x y) - (unsafe-fl+ - (unsafe-fl* norm1 (unsafe-flomap-integral-y-sum - int-vs int-c int-w int-h k x - (unsafe-fx- y r1) (unsafe-fx+ y r1+1))) - (unsafe-fl* norm2 (unsafe-flomap-integral-y-sum - int-vs int-c int-w int-h k x - (unsafe-fx- y r2) (unsafe-fx+ y r2+1))))))])) - -(define (flomap-box-blur/int fm xr yr) - (define norm (/ 1.0 (* (+ 1 (* 2 xr)) (+ 1 (* 2 yr))))) - (define xr+1 (+ xr 1)) - (define yr+1 (+ yr 1)) - (match-define (flomap _ c w h) fm) - (match-define (flomap int-vs int-c int-w int-h) (flomap-integral fm)) - (unsafe-build-flomap - c w h - (λ (k x y) - (unsafe-fl* norm (unsafe-flomap-integral-sum - int-vs int-c int-w int-h k - (unsafe-fx- x xr) (unsafe-fx- y yr) - (unsafe-fx+ x xr+1) (unsafe-fx+ y yr+1)))))) - -(define (flomap-box-blur-x/int fm r) - (define norm (/ 1.0 (+ 1 (* 2 r)))) - (define r+1 (+ r 1)) - (match-define (flomap _ c w h) fm) - (match-define (flomap int-vs int-c int-w int-h) (flomap-integral-x fm)) - (unsafe-build-flomap - c w h - (λ (k x y) - (unsafe-fl* norm (unsafe-flomap-integral-x-sum - int-vs int-c int-w k - (unsafe-fx- x r) (unsafe-fx+ x r+1) y))))) - -(define (flomap-box-blur-y/int fm r) - (define norm (/ 1.0 (+ 1 (* 2 r)))) - (define r+1 (+ r 1)) - (match-define (flomap _ c w h) fm) - (match-define (flomap int-vs int-c int-w int-h) (flomap-integral-y fm)) - (unsafe-build-flomap - c w h - (λ (k x y) - (unsafe-fl* norm (unsafe-flomap-integral-y-sum - int-vs int-c int-w int-h k x - (unsafe-fx- y r) (unsafe-fx+ y r+1)))))) - -;; =================================================================================================== -;; Default blur - -(define (flomap-blur fm xσ [yσ xσ]) - (let ([xσ (abs xσ)] [yσ (abs yσ)]) - (cond - [(and (xσ . >= . 1.5) (yσ . >= . 1.5)) - (define xσ^2 (sqr xσ)) - (define yσ^2 (sqr yσ)) - (define xr (floor (variance->box-radius (* 1/3 xσ^2)))) - (define yr (floor (variance->box-radius (* 1/3 yσ^2)))) - (flomap-box-blur (flomap-box-blur (flomap-box-blur fm xr yr) xr yr) - (variance->box-radius (- xσ^2 (* 2 (box-radius->variance xr)))) - (variance->box-radius (- yσ^2 (* 2 (box-radius->variance yr)))))] - [else - (flomap-blur-x (flomap-blur-y fm yσ) xσ)]))) - -(define (box-radius->variance r) - (* 1/12 (sqr (+ 1 (* 2 r))))) - -(define (variance->box-radius σ^2) - (* 1/2 (- (sqrt (* 12 σ^2)) 1))) - -(define ((make-flomap-blur-dimension gaussian-blur box-blur) fm σ) - (cond - [(σ . = . 0.0) fm] - [(σ . < . 1.5) (gaussian-blur fm σ 3.0)] - [else - (define σ^2 (sqr σ)) - (define r (floor (variance->box-radius (* 1/3 σ^2)))) - (box-blur (box-blur (box-blur fm r) r) - (variance->box-radius (- σ^2 (* 2 (box-radius->variance r)))))])) - -(define flomap-blur-x (make-flomap-blur-dimension flomap-gaussian-blur-x flomap-box-blur-x)) -(define flomap-blur-y (make-flomap-blur-dimension flomap-gaussian-blur-y flomap-box-blur-y)) - -;; =================================================================================================== -;; Derivatives (Schurr operator) - -(define (flomap-gradient-x fm) - (match-define (flomap vs c w h) fm) - (define cw (* c w)) - (define d00 (+ (- cw) -1)) - (define d20 (+ (- cw) 1)) - (define d02 (+ cw -1)) - (define d22 (+ cw 1)) - (define w-1 (- w 1)) - (define h-1 (- h 1)) - (unsafe-build-flomap - c w h - (λ (k x y) - (cond [(and (x . unsafe-fx> . 0) (x . unsafe-fx< . w-1) - (y . unsafe-fx> . 0) (y . unsafe-fx< . h-1)) - (define i (unsafe-fx+ k (unsafe-fx* c (unsafe-fx+ x (unsafe-fx* w y))))) - (unsafe-flsum - (unsafe-fl- (unsafe-fl* 0.1875 (unsafe-flvector-ref vs (unsafe-fx+ i d20))) - (unsafe-fl* 0.1875 (unsafe-flvector-ref vs (unsafe-fx+ i d00)))) - (unsafe-fl- (unsafe-fl* 0.6250 (unsafe-flvector-ref vs (unsafe-fx+ i 1))) - (unsafe-fl* 0.6250 (unsafe-flvector-ref vs (unsafe-fx- i 1)))) - (unsafe-fl- (unsafe-fl* 0.1875 (unsafe-flvector-ref vs (unsafe-fx+ i d22))) - (unsafe-fl* 0.1875 (unsafe-flvector-ref vs (unsafe-fx+ i d02)))))] - [else 0.0])))) - -(define (flomap-gradient-y fm) - (match-define (flomap vs c w h) fm) - (define cw (* c w)) - (define d00 (+ (- cw) -1)) - (define d02 (+ cw -1)) - (define d20 (+ (- cw) 1)) - (define d22 (+ cw 1)) - (define w-1 (- w 1)) - (define h-1 (- h 1)) - (unsafe-build-flomap - c w h - (λ (k x y) - (cond [(and (x . unsafe-fx> . 0) (x . unsafe-fx< . w-1) - (y . unsafe-fx> . 0) (y . unsafe-fx< . h-1)) - (define i (unsafe-fx+ k (unsafe-fx* c (unsafe-fx+ x (unsafe-fx* w y))))) - (unsafe-flsum - (unsafe-fl- (unsafe-fl* 0.1875 (unsafe-flvector-ref vs (unsafe-fx+ i d02))) - (unsafe-fl* 0.1875 (unsafe-flvector-ref vs (unsafe-fx+ i d00)))) - (unsafe-fl- (unsafe-fl* 0.6250 (unsafe-flvector-ref vs (unsafe-fx+ i cw))) - (unsafe-fl* 0.6250 (unsafe-flvector-ref vs (unsafe-fx- i cw)))) - (unsafe-fl- (unsafe-fl* 0.1875 (unsafe-flvector-ref vs (unsafe-fx+ i d22))) - (unsafe-fl* 0.1875 (unsafe-flvector-ref vs (unsafe-fx+ i d20)))))] - [else 0.0])))) - -(define (flomap-gradient fm) - (values (flomap-gradient-x fm) (flomap-gradient-y fm))) - -(define (flomap-gradient-normal z-fm) - (define-values (dx-bm dy-bm) (flomap-gradient z-fm)) - (match-define (flomap dxs 1 w h) dx-bm) - (match-define (flomap dys 1 _w _h) dy-bm) - (define normal-vs (make-flvector (* 3 w h))) - (for ([i (in-range (* w h))]) - (define j (unsafe-fx* 3 i)) - (define dx (unsafe-flvector-ref dxs i)) - (define dy (unsafe-flvector-ref dys i)) - (define-values (nx ny nz) (unsafe-fl3normalize (unsafe-flneg dx) (unsafe-flneg dy) 2.0)) - (unsafe-flvector-3set! normal-vs j nx ny nz)) - (flomap normal-vs 3 w h)) - -;; =================================================================================================== -;; Statistics - -(define (flomap-min-value fm) - (define vs (flomap-values fm)) - (for/fold ([v-min 0.0]) ([v (in-flvector vs)]) - (unsafe-flmin v-min v))) - -(define (flomap-max-value fm) - (define vs (flomap-values fm)) - (for/fold ([v-max 0.0]) ([v (in-flvector vs)]) - (unsafe-flmax v-max v))) - -(define (flomap-extreme-values fm) - (define vs (flomap-values fm)) - (for/fold ([v-min 0.0] [v-max 0.0]) ([v (in-flvector vs)]) - (values (unsafe-flmin v-min v) - (unsafe-flmax v-max v)))) - -(define (flomap-nonzero-rect fm) - (match-define (flomap vs c w h) fm) - (for*/fold ([k-min c] [x-min w] [y-min h] [k-max 0] [x-max 0] [y-max 0] - ) ([y (in-range h)] [x (in-range w)] [k (in-range c)]) - (define i (unsafe-fx+ k (unsafe-fx* c (unsafe-fx+ x (unsafe-fx* y w))))) - (define v (unsafe-flvector-ref vs i)) - (cond [(not (v . unsafe-fl= . 0.0)) - (values (unsafe-fxmin k-min k) - (unsafe-fxmin x-min x) - (unsafe-fxmin y-min y) - (unsafe-fxmax k-max (unsafe-fx+ 1 k)) - (unsafe-fxmax x-max (unsafe-fx+ 1 x)) - (unsafe-fxmax y-max (unsafe-fx+ 1 y)))] - [else (values k-min x-min y-min k-max x-max y-max)]))) - -;; =================================================================================================== -;; Sizing - -(define flomap-inset - (case-lambda - [(fm amt) - (flomap-inset fm amt amt amt amt)] - [(fm h-amt v-amt) - (flomap-inset fm h-amt v-amt h-amt v-amt)] - [(fm l-amt t-amt r-amt b-amt) - (cond [(and (= l-amt 0) (= t-amt 0) (= r-amt 0) (= b-amt 0)) fm] - [else - (match-define (flomap vs c w h) fm) - (define new-w (+ w l-amt r-amt)) - (define new-h (+ h t-amt b-amt)) - (define new-vs (make-flvector (* c new-w new-h))) - (for ([new-y (in-range new-h)]) - (define y (- new-y t-amt)) - (when (and (y . >= . 0) (y . < . h)) - (for ([new-x (in-range new-w)]) - (define x (- new-x l-amt)) - (when (and (x . >= . 0) (x . < . w)) - (for ([k (in-range c)]) - (define i (unsafe-coords->index c w k x y)) - (define new-i (unsafe-coords->index c new-w k new-x new-y)) - (unsafe-flvector-set! new-vs new-i (unsafe-flvector-ref vs i))))))) - (flomap new-vs c new-w new-h)])])) - -(define (flomap-trim fm) - (match-define (flomap _ c w h) fm) - (unless (c . > . 0) - (raise-type-error 'flomap-shadow "flomap with at least 1 component" fm)) - (define-values (_k-min x-min y-min _k-max x-max y-max) - (flomap-nonzero-rect (flomap-ref-component fm 0))) - (flomap-inset fm (- x-min) (- y-min) (- x-max w) (- y-max h))) - -(define (flomap-crop fm width height x-frac y-frac) - (match-define (flomap _ c w h) fm) - (define l-amt (round (* x-frac (- width w)))) - (define r-amt (- (- width w) l-amt)) - (define t-amt (round (* y-frac (- height h)))) - (define b-amt (- (- height h) t-amt)) - (flomap-inset fm l-amt t-amt r-amt b-amt)) - -(define (flomap-lt-crop fm w h) (flomap-crop fm w h 0 0)) -(define (flomap-lc-crop fm w h) (flomap-crop fm w h 0 1/2)) -(define (flomap-lb-crop fm w h) (flomap-crop fm w h 0 1)) -(define (flomap-ct-crop fm w h) (flomap-crop fm w h 1/2 0)) -(define (flomap-cc-crop fm w h) (flomap-crop fm w h 1/2 1/2)) -(define (flomap-cb-crop fm w h) (flomap-crop fm w h 1/2 1)) -(define (flomap-rt-crop fm w h) (flomap-crop fm w h 1 0)) -(define (flomap-rc-crop fm w h) (flomap-crop fm w h 1 1/2)) -(define (flomap-rb-crop fm w h) (flomap-crop fm w h 1 1)) - -(define flomap-scale - (case-lambda - [(fm scale) (flomap-scale fm scale scale)] - [(fm x-scale y-scale) (flomap-scale-x (flomap-scale-y fm (exact->inexact y-scale)) - (exact->inexact x-scale))])) - -(define (flomap-resize fm width height) - (cond [(and width height) (flomap-resize-x (flomap-resize-y fm height) width)] - [width (define s (exact->inexact (/ width (flomap-width fm)))) - (flomap-resize-x (flomap-scale-y fm s) width)] - [height (define s (exact->inexact (/ height (flomap-height fm)))) - (flomap-scale-x (flomap-resize-y fm height) s)])) - -(define (flomap-scale-x fm scale) - (cond [(= 0 scale) (match-define (flomap _ c w h) fm) - (make-flomap c 0 h)] - [else (flomap-scale*-x fm scale (inexact->exact (ceiling (* (flomap-width fm) scale))))])) - -(define (flomap-scale-y fm scale) - (cond [(= 0 scale) (match-define (flomap _ c w h) fm) - (make-flomap c w 0)] - [else (flomap-scale*-y fm scale (inexact->exact (ceiling (* (flomap-height fm) scale))))])) - -(define (flomap-resize-x fm width) - (cond [(= 0 width) (match-define (flomap _ c w h) fm) - (make-flomap c 0 h)] - [else (flomap-scale*-x fm (exact->inexact (/ width (flomap-width fm))) width)])) - -(define (flomap-resize-y fm height) - (cond [(= 0 height) (match-define (flomap _ c w h) fm) - (make-flomap c w 0)] - [else (flomap-scale*-y fm (exact->inexact (/ height (flomap-height fm))) height)])) - -;; standard deviation of an unscaled box filter (i.e. f([-1/2,1/2]) = {1}, zero elsewhere) -(define box-filter-variance 1/12) -;; standard deviation of an unscaled triangle filter (simualtes effect of linear interpolation) -(define triangle-filter-variance 1/24) - -;; calculates the standard deviation of downscaling blur, assuming linear interpolation will be -;; carried out on the blurred image -(define (stddev-for-scale scale) - (define var (- (/ box-filter-variance (sqr scale)) - triangle-filter-variance)) - (sqrt (max 0 var))) - -(define (flomap-scale*-x fm scale width) - (cond [(scale . = . 1.0) fm] - [(scale . > . 1.0) (flomap-scale*-x/linear fm scale width)] - [else (define low-res-fm - (flomap-gaussian-blur-x fm (stddev-for-scale scale) 2.0)) - (flomap-scale*-x/linear low-res-fm scale width)])) - -(define (flomap-scale*-y fm scale height) - (cond [(scale . = . 1.0) fm] - [(scale . > . 1.0) (flomap-scale*-y/linear fm scale height)] - [else (define low-res-fm - (flomap-gaussian-blur-y fm (stddev-for-scale scale) 2.0)) - (flomap-scale*-y/linear low-res-fm scale height)])) - -(define (flomap-scale*-x/linear fm s new-w) - (match-define (flomap vs c w h) fm) - (define w-1 (unsafe-fx- w 1)) - (unsafe-build-flomap - c new-w h - (λ (k new-x y) - (define scaled-x (unsafe-fl- (unsafe-fl/ (unsafe-fl+ (unsafe-fx->fl new-x) 0.5) s) 0.5)) - (define floor-scaled-x (unsafe-flfloor scaled-x)) - (define x0 (unsafe-fl->fx floor-scaled-x)) - (cond [(or (x0 . unsafe-fx< . 0) (x0 . unsafe-fx>= . w)) 0.0] - [else - (define i0 (unsafe-coords->index c w k x0 y)) - (define v0 (unsafe-flvector-ref vs i0)) - (define v1 (cond [(x0 . unsafe-fx= . w-1) 0.0] - [else (unsafe-flvector-ref vs (unsafe-fx+ i0 c))])) - (unsafe-fl-convex-combination v0 v1 (unsafe-fl- scaled-x floor-scaled-x))])))) - -(define (flomap-scale*-y/linear fm s new-h) - (match-define (flomap vs c w h) fm) - (define h-1 (unsafe-fx- h 1)) - (define cw (* c w)) - (unsafe-build-flomap - c w new-h - (λ (k x new-y) - (define orig-y (unsafe-fl+ (unsafe-fx->fl new-y) 0.5)) - (define scaled-y (unsafe-fl/ orig-y s)) - (define half-floor-y (unsafe-fl- (unsafe-flfloor (unsafe-fl+ scaled-y 0.5)) 0.5)) - (define y0 (unsafe-fl->fx (unsafe-flfloor half-floor-y))) - (cond [(or (y0 . unsafe-fx< . 0) (y0 . unsafe-fx>= . h)) 0.0] - [else - (define i0 (unsafe-coords->index c w k x y0)) - (define v0 (unsafe-flvector-ref vs i0)) - (define v1 (cond [(y0 . unsafe-fx= . h-1) 0.0] - [else (unsafe-flvector-ref vs (unsafe-fx+ i0 cw))])) - (unsafe-fl-convex-combination v0 v1 (unsafe-fl- scaled-y half-floor-y))])))) - -;; =================================================================================================== -;; Pinning and standard pin-derived combiners - -(define (flomap-pin fm1 x1 y1 fm2 x2 y2) - (cond - [(not (and (zero? x2) (zero? y2))) - (flomap-pin fm1 (- x1 x2) (- y1 y2) fm2 0 0)] - [else - (match-define (flomap argb1-vs 4 w1 h1) fm1) - (match-define (flomap argb2-vs 4 w2 h2) fm2) - - ;; fm1 and fm2 offsets, in final image coordinates - (define dx1 (inexact->exact (round (max 0 (- x1))))) - (define dy1 (inexact->exact (round (max 0 (- y1))))) - (define dx2 (inexact->exact (round (max 0 x1)))) - (define dy2 (inexact->exact (round (max 0 y1)))) - - ;; final image size - (define w (max (+ dx1 w1) (+ dx2 w2))) - (define h (max (+ dy1 h1) (+ dy2 h2))) - - (define-syntax-rule (get-argb-pixel argb-vs dx dy w h x y) - (let ([x (unsafe-fx- x dx)] - [y (unsafe-fx- y dy)]) - (cond [(and (x . unsafe-fx>= . 0) (x . unsafe-fx< . w) - (y . unsafe-fx>= . 0) (y . unsafe-fx< . h)) - (unsafe-flvector-4ref argb-vs (unsafe-coords->index 4 w 0 x y))] - [else - (values 0.0 0.0 0.0 0.0)]))) - - (define argb-vs (make-flvector (* 4 w h))) - (for* ([y (in-range h)] [x (in-range w)]) - (define-values (a1 r1 g1 b1) (get-argb-pixel argb1-vs dx1 dy1 w1 h1 x y)) - (define-values (a2 r2 g2 b2) (get-argb-pixel argb2-vs dx2 dy2 w2 h2 x y)) - (unsafe-flvector-4set! argb-vs (unsafe-coords->index 4 w 0 x y) - (unsafe-fl-alpha-blend a1 a2 a2) - (unsafe-fl-alpha-blend r1 r2 a2) - (unsafe-fl-alpha-blend g1 g2 a2) - (unsafe-fl-alpha-blend b1 b2 a2))) - - (flomap argb-vs 4 w h)])) - -(define (flomap-pin* x1-frac y1-frac x2-frac y2-frac fm . fms) - (for/fold ([fm1 fm]) ([fm2 (in-list fms)]) - (define-values (w1 h1) (flomap-size fm1)) - (define-values (w2 h2) (flomap-size fm2)) - (flomap-pin fm1 (* x1-frac w1) (* y1-frac h1) - fm2 (* x2-frac w2) (* y2-frac h2)))) - -(define (flomap-lt-superimpose fm . fms) - (apply flomap-pin* 0 0 0 0 fm fms)) - -(define (flomap-lc-superimpose fm . fms) - (apply flomap-pin* 0 1/2 0 1/2 fm fms)) - -(define (flomap-lb-superimpose fm . fms) - (apply flomap-pin* 0 1 0 1 fm fms)) - -(define (flomap-ct-superimpose fm . fms) - (apply flomap-pin* 1/2 0 1/2 0 fm fms)) - -(define (flomap-cc-superimpose fm . fms) - (apply flomap-pin* 1/2 1/2 1/2 1/2 fm fms)) - -(define (flomap-cb-superimpose fm . fms) - (apply flomap-pin* 1/2 1 1/2 1 fm fms)) - -(define (flomap-rt-superimpose fm . fms) - (apply flomap-pin* 1 0 1 0 fm fms)) - -(define (flomap-rc-superimpose fm . fms) - (apply flomap-pin* 1 1/2 1 1/2 fm fms)) - -(define (flomap-rb-superimpose fm . fms) - (apply flomap-pin* 1 1 1 1 fm fms)) - -(define (flomap-vl-append fm . fms) - (apply flomap-pin* 0 1 0 0 fm fms)) - -(define (flomap-vc-append fm . fms) - (apply flomap-pin* 1/2 1 1/2 0 fm fms)) - -(define (flomap-vr-append fm . fms) - (apply flomap-pin* 1 1 1 0 fm fms)) - -(define (flomap-ht-append fm . fms) - (apply flomap-pin* 1 0 0 0 fm fms)) - -(define (flomap-hc-append fm . fms) - (apply flomap-pin* 1 1/2 0 1/2 fm fms)) - -(define (flomap-hb-append fm . fms) - (apply flomap-pin* 1 1 0 1 fm fms)) - -;; =================================================================================================== -;; Transforms - -(define (flomap-flip-horizontal fm) - (match-define (flomap vs c w h) fm) - (define w-1 (- w 1)) - (unsafe-build-flomap - c w h - (λ (k x y) - (unsafe-flvector-ref vs (unsafe-coords->index c w k (unsafe-fx- w-1 x) y))))) - -(define (flomap-flip-vertical fm) - (match-define (flomap vs c w h) fm) - (define h-1 (- h 1)) - (unsafe-build-flomap - c w h - (λ (k x y) - (unsafe-flvector-ref vs (unsafe-coords->index c w k x (unsafe-fx- h-1 y)))))) - -(define (flomap-transpose fm) - (match-define (flomap vs c w h) fm) - (unsafe-build-flomap - c h w - (λ (k x y) - (unsafe-flvector-ref vs (unsafe-coords->index c w k y x))))) - -(define (flomap-cw-rotate fm) - (match-define (flomap vs c w h) fm) - (define h-1 (- h 1)) - (unsafe-build-flomap - c h w - (λ (k x y) - (unsafe-flvector-ref vs (unsafe-coords->index c w k (unsafe-fx- h-1 y) x))))) - -(define (flomap-ccw-rotate fm) - (match-define (flomap vs c w h) fm) - (define w-1 (- w 1)) - (unsafe-build-flomap - c h w - (λ (k x y) - (unsafe-flvector-ref vs (unsafe-coords->index c w k y (unsafe-fx- w-1 x)))))) - - -;; =================================================================================================== -;; Effects - -(define (colorize-alpha fm color) - (match-define (flomap _ 1 w h) fm) - (flomap-append-components fm (fm* fm (make-flomap/components w h color)))) - -(define (flomap-outline fm amt #:color [color #f]) - (match-define (flomap _ c w h) fm) - (define σ (* 0.5 (max 1.0 amt))) - (define ceiling-amt (inexact->exact (ceiling amt))) - (define test-size (* 2 (+ 1 ceiling-amt))) - (define test-mid (quotient test-size 2)) - (define test-fm (build-flomap 1 test-size test-size - (λ (k x y) (if (x . >= . test-mid) 1.0 0.0)))) - (define blur-fm (flomap-blur test-fm σ)) - (define v-max (flomap-bilinear-ref blur-fm 0 (+ 0.5 (- test-mid amt)) test-mid)) - (define v-min (flomap-bilinear-ref blur-fm 0 (+ 0.5 (- test-mid amt 1)) test-mid)) - (define alpha-fm (flomap-ref-component fm 0)) - (define new-alpha-fm (fmmax 0.0 (fmmin 1.0 (fm/ (fm- (flomap-blur alpha-fm σ) v-min) - (- v-max v-min))))) - (define color-vs (if (list? color) color (make-list (- c 1) 0.0))) - (colorize-alpha new-alpha-fm color-vs)) - -(define (flomap-outlined fm amt #:color [color #f]) - (flomap-cc-superimpose (flomap-outline fm amt #:color color) fm)) - -(define (flomap-shadow fm σ #:color [color #f]) - (match-define (flomap _ c w h) fm) - (cond [(c . = . 0) fm] - [else (define alpha-fm (flomap-ref-component fm 0)) - (define color-vs (if (list? color) color (make-list (- c 1) 0.0))) - (colorize-alpha (flomap-blur alpha-fm σ) color-vs)])) - -(define (flomap-shadowed fm σ #:color [color #f]) - (flomap-cc-superimpose (flomap-shadow fm σ #:color color) fm)) +#lang typed/racket/base + +(require "flomap-struct.rkt" + "flomap-stats.rkt" + "flomap-pointwise.rkt" + "flomap-transform.rkt" + "flomap-gradient.rkt" + "flomap-effects.rkt" + "flomap-blur.rkt" + "flomap-composite.rkt" + "flomap-resize.rkt") + +(require/typed + "draw-predicates.rkt" + [opaque Bitmap bitmap?] + [opaque DC dc?]) + +(require/typed + "flomap-convert.rkt" + [bitmap->flomap (Bitmap -> flomap)] + [flomap->bitmap (flomap -> Bitmap)] + [draw-flomap (Integer Integer (DC -> Any) -> flomap)]) + +(provide (all-from-out "flomap-struct.rkt" + "flomap-stats.rkt" + "flomap-pointwise.rkt" + "flomap-transform.rkt" + "flomap-gradient.rkt" + "flomap-effects.rkt" + "flomap-blur.rkt" + "flomap-composite.rkt" + "flomap-resize.rkt") + Bitmap DC + bitmap->flomap flomap->bitmap draw-flomap) diff --git a/collects/images/private/flonum.rkt b/collects/images/private/flonum.rkt new file mode 100644 index 0000000000..7396fcf080 --- /dev/null +++ b/collects/images/private/flonum.rkt @@ -0,0 +1,102 @@ +#lang typed/racket/base + +(require (for-syntax typed/racket/base) + racket/flonum + (except-in racket/fixnum fl->fx fx->fl) + racket/math + (except-in racket/unsafe/ops unsafe-flvector-ref unsafe-flvector-set!) + (prefix-in old- (only-in racket/unsafe/ops unsafe-flvector-ref unsafe-flvector-set!)) + ) + +(provide (all-defined-out)) + +(define-predicate nonnegative-fixnum? Nonnegative-Fixnum) + +(: unsafe-flvector-ref (FlVector Integer -> Flonum)) +(define unsafe-flvector-ref flvector-ref) + +(: unsafe-flvector-set! (FlVector Integer Flonum -> Void)) +(define unsafe-flvector-set! flvector-set!) + +(define-syntax-rule (fl->fx x) + (let ([i (fl->exact-integer x)]) + (with-asserts ([i fixnum?]) + i))) + +(define-syntax-rule (fx->fl i) + (->fl i)) + +(define-syntax-rule (flrational? x) + (let: ([x* : Flonum x]) + ;; if x = +nan.0, both tests return #f + (and (x . > . -inf.0) (x . < . +inf.0)))) + +(define-syntax-rule (fl-convex-combination dv sv sa) + (let: ([sa* : Flonum sa]) + (+ (fl* sv sa*) (fl* dv (- 1.0 sa*))))) + +(define-syntax-rule (fl-alpha-blend dca sca sa) + (+ sca (* dca (- 1.0 sa)))) + +(define-syntax-rule (flgaussian x s) + (let: ([x/s : Flonum (fl/ x s)]) + (/ (exp (* -0.5 (* x/s x/s))) + (fl* (sqrt (* 2.0 pi)) s)))) + +(define-syntax-rule (flsigmoid x) + (/ 1.0 (+ 1.0 (exp (fl- 0.0 x))))) + +(define-syntax-rule (inline-build-flvector size f) + (let: ([n : Integer size]) + (with-asserts ([n nonnegative-fixnum?]) + (let: ([vs : FlVector (make-flvector n)]) + (let: loop : FlVector ([i : Nonnegative-Fixnum 0]) + (cond [(i . fx< . n) (old-unsafe-flvector-set! vs i (f i)) + (loop (unsafe-fx+ i 1))] + [else vs])))))) + +;; =================================================================================================== +;; 3-vectors + +(define-syntax-rule (fl3dot x1 y1 z1 x2 y2 z2) + (+ (fl* x1 x2) (fl* y1 y2) (fl* z1 z2))) + +(define-syntax (fl3* stx) + (syntax-case stx () + [(_ x y z c) + (syntax/loc stx + (let: ([c* : Flonum c]) + (values (fl* x c*) (fl* y c*) (fl* z c*))))] + [(_ x1 y1 z1 x2 y2 z2) + (syntax/loc stx + (values (fl* x1 x2) (fl* y1 y2) (fl* z1 z2)))])) + +(define-syntax-rule (fl3+ x1 y1 z1 x2 y2 z2) + (values (fl+ x1 x2) (fl+ y1 y2) (fl+ z1 z2))) + +(define-syntax (fl3- stx) + (syntax-case stx () + [(_ x y z) + (syntax/loc stx + (values (fl- 0.0 x) (fl- 0.0 y) (fl- 0.0 z)))] + [(_ x1 y1 z1 x2 y2 z2) + (syntax/loc stx + (values (fl- x1 x2) (fl- y1 y2) (fl- z1 z2)))])) + +(define-syntax-rule (fl3mag^2 x y z) + (let: ([x* : Flonum x] [y* : Flonum y] [z* : Flonum z]) + (+ (* x* x*) (* y* y*) (* z* z*)))) + +(define-syntax-rule (fl3mag x y z) + (flsqrt (fl3mag^2 x y z))) + +(define-syntax-rule (fl3dist x1 y1 z1 x2 y2 z2) + (fl3mag (fl- x1 x2) (fl- y1 y2) (fl- z1 z2))) + +(define-syntax-rule (fl3normalize x y z) + (let: ([x* : Flonum x] [y* : Flonum y] [z* : Flonum z]) + (let: ([d : Flonum (fl3mag x* y* z*)]) + (values (/ x* d) (/ y* d) (/ z* d))))) + +(define-syntax-rule (fl3-half-norm x1 y1 z1 x2 y2 z2) + (fl3normalize (fl+ x1 x2) (fl+ y1 y2) (fl+ z1 z2))) diff --git a/collects/images/private/renderfx.rkt b/collects/images/private/renderfx.rkt deleted file mode 100644 index 3980695d8b..0000000000 --- a/collects/images/private/renderfx.rkt +++ /dev/null @@ -1,640 +0,0 @@ -#lang racket/base - -(require racket/match racket/math racket/provide unstable/parameter-group racket/flonum - "unsafe.rkt" - "flomap.rkt" - "deep-flomap.rkt") - -(provide - ;; lighting parameters - light-direction - light-intensity - ambient-intensity - reflected-intensity - deep-flomap-lighting - (struct-out deep-flomap-lighting-value) - ;; material parameters - refractive-indexes - ->refractive-index - refractive-index - ideal-reflectance - ideal-transmission - transmission-density - specular-reflectance - specular-roughness - specular-purity - diffuse-reflectance - ambient-reflectance - ambient-transmission - shadow-blur - deep-flomap-material - (struct-out deep-flomap-material-value) - (matching-identifiers-out #rx".*-material" (all-defined-out)) - ;; ray tracing functions - deep-flomap-render - ) - -;; =================================================================================================== -;; Rendering parameters - -;; Hacks -(define specular-blur 1/2) -(define diffuse-blur 1/2) -(define ideal-transmission-blur 1) -(define ambient-transmission-blur-fraction 1/32) - -(define refractive-indexes - #hash((diamond . 2.42) - (cubic-zirconia . 2.15) - (ruby . 1.76) - (enamel . 1.63) - (glass . 1.54) - (wax . 1.43) - (water . 1.33) - (vacuum . 1.0))) - -(define (->refractive-index idx) - (cond [(symbol? idx) - (hash-ref refractive-indexes idx - (λ () (error 'refractive-index - "`refractive-indexes' does not have a refractive index for ~e" - idx)))] - [(rational? idx) (exact->inexact idx)])) - -(define (list-exact->inexact vs) - (map exact->inexact vs)) - -;; light parameters -(define light-direction (make-parameter '(0.0 -1.0 1.0) list-exact->inexact)) -(define light-intensity (make-parameter '(1.0 1.0 1.0) list-exact->inexact)) -(define ambient-intensity (make-parameter '(1.0 1.0 1.0) list-exact->inexact)) -(define reflected-intensity (make-parameter '(1.0 1.0 1.0) list-exact->inexact)) - -(define-parameter-group deep-flomap-lighting - (light-direction light-intensity ambient-intensity reflected-intensity)) - -;; material parameters -(define refractive-index (make-parameter (->refractive-index 'glass) ->refractive-index)) -(define ideal-reflectance (make-parameter 1.0 exact->inexact)) -(define ideal-transmission (make-parameter 1.0 exact->inexact)) -(define transmission-density (make-parameter 0.65 exact->inexact)) -(define specular-reflectance (make-parameter 0.15 exact->inexact)) -(define specular-roughness (make-parameter 0.15 exact->inexact)) -(define specular-purity (make-parameter 1.0 exact->inexact)) -(define diffuse-reflectance (make-parameter 0.25 exact->inexact)) -(define ambient-reflectance (make-parameter 0.1 exact->inexact)) -(define ambient-transmission (make-parameter 0.7 exact->inexact)) -(define shadow-blur (make-parameter 0.02 exact->inexact)) - -(define-parameter-group deep-flomap-material - (refractive-index ideal-reflectance ideal-transmission transmission-density - specular-reflectance specular-roughness specular-purity - diffuse-reflectance ambient-reflectance ambient-transmission - shadow-blur)) - -(define matte-material - (deep-flomap-material-value - 'vacuum 0.0 0.0 1.0 - 0.0 1.0 1.0 - 1.0 0.25 0.0 - 0.0)) - -(define dull-plastic-material - (deep-flomap-material-value - 'glass 0.0 0.0 1.0 - 1.0 0.25 1.0 - 1.0 0.25 0.0 - 0.0)) - -(define wax-material - (deep-flomap-material-value - 'wax 1.0 0.5 1.25 - 0.5 0.5 0.5 - 0.5 0.5 0.5 - 0.04)) - -(define plastic-material - (deep-flomap-material-value - 'glass 0.375 1.0 2.0 - 0.25 0.15 1.0 - 0.6 0.5 0.1 - 0.03)) - -(define metal-material - (deep-flomap-material-value - 3.0 0.3 0.0 1.0 - 0.8 0.1 0.2 - 0.2 0.8 0.0 - 0.0)) - -(define porcelain-material - (deep-flomap-material-value - 'enamel 0.9 0.5 1.5 - 0.4 0.2 1.0 - 0.5 0.5 0.5 - 0.04)) - -(define frosted-glass-material - (deep-flomap-material-value - 'glass 0.9 1.0 0.8 - 0.4 0.2 1.0 - 0.5 0.1 0.5 - 0.04)) - -(define glass-material - (deep-flomap-material-value - 'glass 1.0 1.0 0.65 - 0.15 0.15 1.0 - 0.25 0.1 0.7 - 0.02)) - -(define diamond-material - (deep-flomap-material-value - 'diamond 1.0 1.0 0.5 - 0.15 0.15 1.0 - 0.15 0.1 0.7 - 0.02)) - -;; =================================================================================================== -;; Ray tracing ops - -;; assumes direction to viewer is 0.0 0.0 1.0 (i.e. viewer above at infinity) -(define (unsafe-reflect-view-ray nx ny nz) - (values (unsafe-fl* 2.0 (unsafe-fl* nz nx)) - (unsafe-fl* 2.0 (unsafe-fl* nz ny)) - (unsafe-fl- (unsafe-fl* 2.0 (unsafe-fl* nz nz)) 1.0))) - -(define (unsafe-transmission-intensity cos-i η1 η2) - ;; Fresnel's equation - (define n1/n2 (unsafe-fl/ η1 η2)) - (define cos^2-i (unsafe-fl* cos-i cos-i)) - (define sin^2-t (unsafe-fl* (unsafe-fl* n1/n2 n1/n2) (unsafe-fl- 1.0 cos^2-i))) - (define cos-t (unsafe-flsqrt (unsafe-fl- 1.0 sin^2-t))) - (define n1-cos-i (unsafe-fl* η1 cos-i)) - (define n2-cos-t (unsafe-fl* η2 cos-t)) - (define n1-cos-t (unsafe-fl* η1 cos-t)) - (define n2-cos-i (unsafe-fl* η2 cos-i)) - (define perp (unsafe-fl/ (unsafe-fl- n1-cos-i n2-cos-t) - (unsafe-fl+ n1-cos-i n2-cos-t))) - (define parl (unsafe-fl/ (unsafe-fl- n2-cos-i n1-cos-t) - (unsafe-fl+ n2-cos-i n1-cos-t))) - (unsafe-fl- 1.0 (unsafe-fl* 0.5 (unsafe-fl+ (unsafe-fl* perp perp) (unsafe-fl* parl parl))))) - -(define (unsafe-transmitted-vector nx ny nz ix iy iz η1 η2) - (define η1/η2 (unsafe-fl/ η1 η2)) - (define cos-i (unsafe-flneg (unsafe-fl3dot nx ny nz ix iy iz))) - (define cos^2-i (unsafe-fl* cos-i cos-i)) - (define sin^2-t (unsafe-fl* (unsafe-fl* η1/η2 η1/η2) (unsafe-fl- 1.0 cos^2-i))) - (define c (unsafe-fl- (unsafe-fl* η1/η2 cos-i) (unsafe-flsqrt (unsafe-fl- 1.0 sin^2-t)))) - (define-values (tx1 ty1 tz1) (unsafe-fl3* ix iy iz η1/η2)) - (define-values (tx2 ty2 tz2) (unsafe-fl3* nx ny nz c)) - (unsafe-fl3+ tx1 ty1 tz1 tx2 ty2 tz2)) - -(define-syntax-rule (unsafe-transmit opacity dist) - (let* ([o (unsafe-fl+ (unsafe-fl* opacity 0.99) 0.005)]) - (cond [(unsafe-fl= 0.0 o) 0.0] - [else (unsafe-flexp (unsafe-flproduct (unsafe-fllog o) dist))]))) - -(define-syntax-rule (unsafe-beckmann-distribution n-dot-h surface-roughness) - (let ([cos-θ n-dot-h] - [m surface-roughness]) - (define x (unsafe-fl/ (unsafe-fltan (unsafe-flacos cos-θ)) m)) - (define m*cos^2-θ (unsafe-flproduct m cos-θ cos-θ)) - (unsafe-fl/ (unsafe-flexp (unsafe-flneg (unsafe-fl* x x))) - (unsafe-flproduct pi m*cos^2-θ m*cos^2-θ)))) - -;; =================================================================================================== -;; Pass 1: tracing from a directional light source - -(define (trace-directional-light alpha-fm rgb-fm z-fm normal-fm) - (match-define (flomap alpha-vs 1 w h) alpha-fm) - (match-define (list rgb-vs z-vs normal-vs) (map flomap-values (list rgb-fm z-fm normal-fm))) - - (define z-max (flomap-max-value z-fm)) - (define opacity-z (/ z-max (transmission-density))) - ;; max coordinates of the shadow image - (define sx-max (- w 1.0)) - (define sy-max (- h 1.0)) - ;; vector pointing toward light source, incident vector, and light color - (define-values (lx ly lz) (match-let ([(list lx ly lz) (light-direction)]) - (unsafe-fl3normalize lx ly lz))) - (define-values (ix iy iz) (unsafe-fl3neg lx ly lz)) - (match-define (list lr lg lb) (light-intensity)) - ;; view and "half" directions - (define-values (hx hy hz) (unsafe-fl3-half-norm lx ly lz 0.0 0.0 1.0)) - ;; material properties - (define η2 (exact->inexact (refractive-index))) - (define η1/η2 (/ 1.0 η2)) - ;; proportion of diffracted reflection - (define 0.5*v-dot-h (* 0.5 hz)) - (define Ra (ambient-reflectance)) - (define Ta (ambient-transmission)) - (define Rd (diffuse-reflectance)) - (define Rs (specular-reflectance)) - (define Ti (ideal-transmission)) - (define roughness (specular-roughness)) - (define purity (specular-purity)) - - (match-define (list ar ag ab) (ambient-intensity)) - (define-values (Tar Tag Tab) (unsafe-fl3* ar ag ab Ta)) - (define-values (Rar Rag Rab) (unsafe-fl3* ar ag ab Ra)) - - (define intensity-fm (make-flomap 3 w h)) - (define intensity-vs (flomap-values intensity-fm)) - (define specular-fm (make-flomap 1 w h)) - (define specular-vs (flomap-values specular-fm)) - (define diffuse-fm (make-flomap 3 w h lz)) - (define diffuse-vs (flomap-values diffuse-fm)) - - (define sx-vs (make-flvector (* w h) +nan.0)) - (define sy-vs (make-flvector (* w h) +nan.0)) - (define Irgb-vs (make-flvector (* 3 w h))) - - (for* ([int-y (in-range h)] [int-x (in-range w)]) - (define i (unsafe-fx+ int-x (unsafe-fx* int-y w))) - (define a (unsafe-flvector-ref alpha-vs i)) - (when (a . unsafe-fl> . 0.0) - (define j (unsafe-fx* 3 i)) - ;; altitude and surface normal - (define z (unsafe-flvector-ref z-vs i)) - (define-values (nx ny nz) (unsafe-flvector-3ref normal-vs j)) - ;; cosine of angle between light and surface normal - (define n-dot-l (unsafe-fl3dot nx ny nz lx ly lz)) - ;; intensity of incident light (Lambert's cosine law) - (define-values (Ilr Ilg Ilb) (unsafe-fl3* lr lg lb n-dot-l)) - (unsafe-flvector-3set! intensity-vs j Ilr Ilg Ilb) - ;; diffraction intensity due to specular, diffuse and ambient reflection - (cond - [(n-dot-l . unsafe-fl> . 0.0) ; does the microfacet face the light? - (define Is - (cond - #;; just Beckmann's distribution - [(Rs . unsafe-fl> . 0.0) - (define n-dot-h (unsafe-fl3dot nx ny nz hx hy hz)) - (unsafe-fl* Rs (unsafe-beckmann-distribution n-dot-h roughness))] - ;; Cook-Torrance specular reflection intensity - [(Rs . unsafe-fl> . 0.0) - (define n-dot-h (unsafe-fl3dot nx ny nz hx hy hz)) - (define n-dot-v nz) - ;; geometrical attenuation factor (has something to do with local reflections) - (define G (unsafe-flmin - 1.0 (unsafe-flmin (unsafe-fl/ (unsafe-fl* n-dot-h n-dot-v) 0.5*v-dot-h) - (unsafe-fl/ (unsafe-fl* n-dot-h n-dot-l) 0.5*v-dot-h)))) - ;; scatter distribution - (define D (unsafe-beckmann-distribution n-dot-h roughness)) - ;; Fresnel term - (define F (unsafe-fl- 1.0 (unsafe-transmission-intensity n-dot-l 1.0 η2))) - (unsafe-flproduct Rs F (unsafe-fl/ D n-dot-l) (unsafe-fl/ G n-dot-v))] - [else 0.0])) - (unsafe-flvector-set! specular-vs i Is) - - (let*-values ([(Idr Idg Idb) (unsafe-fl3* Ilr Ilg Ilb Rd)] - [(Idr Idg Idb) (unsafe-fl3+ Idr Idg Idb Rar Rag Rab)]) - (unsafe-flvector-3set! diffuse-vs j Idr Idg Idb))] - [else - (unsafe-flvector-3set! diffuse-vs j Rar Rag Rab)]) - - (when (and (Ti . unsafe-fl> . 0.0) (n-dot-l . unsafe-fl> . 0.0)) - ;; ideal transmission vector - (define-values (tx ty tz) (unsafe-transmitted-vector nx ny nz ix iy iz 1.0 η2)) - ;; sz = z + dist * tz, so dist = (sz - z) / tz - (define dist (unsafe-fl/ (unsafe-fl- 0.0 z) tz)) - (when (and (dist . unsafe-fl>= . 0.0) (dist . unsafe-fl< . +inf.0)) - ;; transmitted ray intersects with shadow plane at sx sy 0.0 - (define sx (unsafe-flsum 0.5 (unsafe-fx->fl int-x) (unsafe-fl* dist tx))) - (define sy (unsafe-flsum 0.5 (unsafe-fx->fl int-y) (unsafe-fl* dist ty))) - ;; actual transmission proportion (Fresnel's law) - (define T (unsafe-fl* Ti (unsafe-transmission-intensity n-dot-l 1.0 η2))) - ;; intensity of incident light (Lambert's cosine law) - (define-values (Ilr Ilg Ilb) (unsafe-fl3* lr lg lb n-dot-l)) - ;; normalized distance to the surface - (define norm-dist (unsafe-fl/ dist opacity-z)) - ;; intensity of the light that strikes the surface - (define-values (r g b) (unsafe-flvector-3ref rgb-vs j)) - (define-values (Ir Ig Ib) - ;; unsafe-transmit calculates intensity using color as absorption rate - (values (unsafe-flproduct T Ilr (unsafe-transmit r norm-dist)) - (unsafe-flproduct T Ilg (unsafe-transmit g norm-dist)) - (unsafe-flproduct T Ilb (unsafe-transmit b norm-dist)))) - (unsafe-flvector-set! sx-vs i sx) - (unsafe-flvector-set! sy-vs i sy) - (unsafe-flvector-3set! Irgb-vs j Ir Ig Ib))))) - - (define diffracted-fm (fm+ (fm* rgb-fm (flomap-blur diffuse-fm diffuse-blur)) - (fm* (flomap-blur specular-fm specular-blur) - (fm+ (fm* (- 1.0 purity) rgb-fm) - (fm* purity intensity-fm))))) - - ;; approximate ambient transmission by casting light downward with no refraction, then blurring - (define ambient-shadow-fm (make-flomap 3 w h)) - (define ambient-shadow-vs (flomap-values ambient-shadow-fm)) - (when (Ta . unsafe-fl> . 0.0) - (for* ([int-y (in-range h)] [int-x (in-range w)]) - (define i (unsafe-fx+ int-x (unsafe-fx* int-y w))) - (define a (unsafe-flvector-ref alpha-vs i)) - (when (a . unsafe-fl> . 0.0) - (define z (unsafe-flvector-ref z-vs i)) - (define j (unsafe-fx* 3 i)) - (define-values (r g b) (unsafe-flvector-3ref rgb-vs j)) - (define norm-dist (unsafe-fl/ z opacity-z)) - (define-values (Ir Ig Ib) - ;; note: unsafe-transmit converts colors to absorption rates - (values (unsafe-fl* Tar (unsafe-transmit r norm-dist)) - (unsafe-fl* Tag (unsafe-transmit g norm-dist)) - (unsafe-fl* Tab (unsafe-transmit b norm-dist)))) - (unsafe-flvector-3set! ambient-shadow-vs j Ir Ig Ib)))) - - ;; cast approximate shadow volumes - (define shadow-fm (flomap-blur ambient-shadow-fm (* ambient-transmission-blur-fraction (min w h)))) - (define shadow-vs (flomap-values shadow-fm)) - (when (Ti . unsafe-fl> . 0.0) - ;; Gaussian kernels - make as wide as possible to keep from having to reallocate - (define kxs (make-flvector w)) - (define kys (make-flvector h)) - (for* ([int-y (in-range (- h 1))] [int-x (in-range (- w 1))]) - (define i00 (unsafe-fx+ int-x (unsafe-fx* int-y w))) - (define i01 (unsafe-fx+ i00 1)) - (define i10 (unsafe-fx+ i00 w)) - (define i11 (unsafe-fx+ i10 1)) - (define sx00 (unsafe-flvector-ref sx-vs i00)) - (define sx01 (unsafe-flvector-ref sx-vs i01)) - (define sx10 (unsafe-flvector-ref sx-vs i10)) - (define sx11 (unsafe-flvector-ref sx-vs i11)) - (when (and (unsafe-flrational? sx00) (unsafe-flrational? sx01) - (unsafe-flrational? sx10) (unsafe-flrational? sx11)) - (define sy00 (unsafe-flvector-ref sy-vs i00)) - (define sy01 (unsafe-flvector-ref sy-vs i01)) - (define sy10 (unsafe-flvector-ref sy-vs i10)) - (define sy11 (unsafe-flvector-ref sy-vs i11)) - (define sx-min (unsafe-flmin* sx00 sx01 sx10 sx11)) - (define sy-min (unsafe-flmin* sy00 sy01 sy10 sy11)) - (define sx-max (unsafe-flmax* sx00 sx01 sx10 sx11)) - (define sy-max (unsafe-flmax* sy00 sy01 sy10 sy11)) - - (define sx-mid (unsafe-fl* 0.25 (unsafe-flsum sx00 sx01 sx10 sx11))) - (define sy-mid (unsafe-fl* 0.25 (unsafe-flsum sy00 sy01 sy10 sy11))) - (define sx-mid^2 (unsafe-fl* 0.25 (unsafe-flsum (unsafe-flsqr sx00) (unsafe-flsqr sx01) - (unsafe-flsqr sx10) (unsafe-flsqr sx11)))) - (define sy-mid^2 (unsafe-fl* 0.25 (unsafe-flsum (unsafe-flsqr sy00) (unsafe-flsqr sy01) - (unsafe-flsqr sy10) (unsafe-flsqr sy11)))) - (define sx-stddev (unsafe-flsqrt (unsafe-fl- sx-mid^2 (unsafe-flsqr sx-mid)))) - (define sy-stddev (unsafe-flsqrt (unsafe-fl- sy-mid^2 (unsafe-flsqr sy-mid)))) - (define x-min (unsafe-fxmax 0 (unsafe-fl->fx (unsafe-flfloor sx-min)))) - (define x-max (unsafe-fxmin w (unsafe-fx+ 1 (unsafe-fl->fx (unsafe-flfloor sx-max))))) - (define y-min (unsafe-fxmax 0 (unsafe-fl->fx (unsafe-flfloor sy-min)))) - (define y-max (unsafe-fxmin h (unsafe-fx+ 1 (unsafe-fl->fx (unsafe-flfloor sy-max))))) - (define x-size (unsafe-fx- x-max x-min)) - (define y-size (unsafe-fx- y-max y-min)) - (when (and (x-size . unsafe-fx> . 0) (y-size . unsafe-fx> . 0)) - ;; average the color - (define-values (r00 g00 b00) (unsafe-flvector-3ref Irgb-vs (unsafe-fx* 3 i00))) - (define-values (r01 g01 b01) (unsafe-flvector-3ref Irgb-vs (unsafe-fx* 3 i01))) - (define-values (r10 g10 b10) (unsafe-flvector-3ref Irgb-vs (unsafe-fx* 3 i10))) - (define-values (r11 g11 b11) (unsafe-flvector-3ref Irgb-vs (unsafe-fx* 3 i11))) - (define r (unsafe-fl* 0.25 (unsafe-flsum r00 r01 r10 r11))) - (define g (unsafe-fl* 0.25 (unsafe-flsum g00 g01 g10 g11))) - (define b (unsafe-fl* 0.25 (unsafe-flsum b00 b01 b10 b11))) - ;; precalculate the Gaussian kernel for the x direction - (for ([dx (in-range x-size)]) - (define x (unsafe-fx+ dx x-min)) - (define d (unsafe-fl/ (unsafe-fl- (unsafe-fl+ 0.5 (unsafe-fx->fl x)) sx-mid) sx-stddev)) - (define kx (unsafe-flexp (unsafe-fl* -0.5 (unsafe-fl* d d)))) - (unsafe-flvector-set! kxs dx kx)) - ;; precalculate the Gaussian kernel for the y direction - ;; this shouldn't help because it's used only once per y iteration, but it reduces allocs - ;; within the loop (unsafe-flexp has no bytecode op yet, so its args and return are boxed) - (for ([dy (in-range y-size)]) - (define y (unsafe-fx+ dy y-min)) - (define d (unsafe-fl/ (unsafe-fl- (unsafe-fl+ 0.5 (unsafe-fx->fl y)) sy-mid) sy-stddev)) - (define ky (unsafe-flexp (unsafe-fl* -0.5 (unsafe-fl* d d)))) - (unsafe-flvector-set! kys dy ky)) - ;; normalization constant for a 2D Gaussian kernel - (define c (unsafe-flproduct 2.0 pi sx-stddev sy-stddev)) - ;; cast the approximate shadow volume - ;; this loop doesn't use the nice unsafe-fl3 macros or define-values, which (currently) - ;; makes it about 2x faster - (let y-loop ([dy 0]) - (when (dy . unsafe-fx< . y-size) - (define ky (unsafe-flvector-ref kys dy)) - (cond [(ky . unsafe-fl> . 0.1) - (define a (unsafe-fl/ ky c)) - (define Ir (unsafe-fl* r a)) - (define Ig (unsafe-fl* g a)) - (define Ib (unsafe-fl* b a)) - (define i (unsafe-fx* 3 (unsafe-fx+ x-min (unsafe-fx* (unsafe-fx+ dy y-min) w)))) - (let x-loop ([dx 0] [i i]) - (cond [(dx . unsafe-fx< . x-size) - (define kx (unsafe-flvector-ref kxs dx)) - (when (kx . unsafe-fl> . 0.1) - (unsafe-flvector-set! - shadow-vs i (unsafe-fl+ (unsafe-fl* Ir kx) - (unsafe-flvector-ref shadow-vs i))) - (define i1 (unsafe-fx+ i 1)) - (unsafe-flvector-set! - shadow-vs i1 (unsafe-fl+ (unsafe-fl* Ig kx) - (unsafe-flvector-ref shadow-vs i1))) - (define i2 (unsafe-fx+ i 2)) - (unsafe-flvector-set! - shadow-vs i2 (unsafe-fl+ (unsafe-fl* Ib kx) - (unsafe-flvector-ref shadow-vs i2)))) - (x-loop (unsafe-fx+ 1 dx) (unsafe-fx+ 3 i))] - [else - (y-loop (unsafe-fx+ 1 dy))]))] - [else - (y-loop (unsafe-fx+ 1 dy))])))) - ))) - - ;; blur the shadow a bit to make up for approximating it with Gaussians - (values diffracted-fm (flomap-box-blur shadow-fm 1))) - -;; =================================================================================================== -;; Pass 2: tracing from a directional viewer - -(define (trace-directional-view alpha-fm rgb-fm z-fm normal-fm shadow-fm) - (match-define (flomap alpha-vs 1 w h) alpha-fm) - (match-define (list rgb-vs z-vs normal-vs shadow-vs) - (map flomap-values (list rgb-fm z-fm normal-fm shadow-fm))) - - (define w-1 (unsafe-fx- w 1)) - (define h-1 (unsafe-fx- h 1)) - (define x-size (exact->inexact w)) - (define y-size (exact->inexact h)) - (define z-size (flomap-max-value z-fm)) - (define x-mid (* 0.5 x-size)) - (define y-mid (* 0.5 y-size)) - (define opacity-z (/ z-size (transmission-density))) - - ;; reflected wall is tilted a bit toward the viewer - (define wall-tilt-θ (* 1/8 pi)) - (define cos-wall-tilt-θ (cos wall-tilt-θ)) - (define sin-wall-tilt-θ (sin wall-tilt-θ)) - (match-define (list Irr Irg Irb) (reflected-intensity)) - - ;; max coords of the shadow image - ;; subtract epsilon to ensure that sx < (w - 1) so that (flfloor sx) < (w - 1) (similarly for sy) - (define sx-max (- w 1.00001)) - (define sy-max (- h 1.00001)) - ;; material properties - (define η2 (exact->inexact (refractive-index))) - (define η1/η2 (/ 1.0 η2)) - (define Ri (ideal-reflectance)) - (define Ti (ideal-transmission)) - - (define reflected-fm (make-flomap 3 w h)) - (define reflected-vs (flomap-values reflected-fm)) - (define transmitted-fm (make-flomap 3 w h)) - (define transmitted-vs (flomap-values transmitted-fm)) - - (when (or (Ri . unsafe-fl> . 0.0) (Ti . unsafe-fl> . 0.0)) - (for* ([int-y (in-range h)] [int-x (in-range w)]) - (define i (unsafe-fx+ int-x (unsafe-fx* int-y w))) - (define a (unsafe-flvector-ref alpha-vs i)) - (when (a . unsafe-fl> . 0.0) - (define j (unsafe-fx* 3 i)) - ;; surface normal - (define-values (nx ny nz) (unsafe-flvector-3ref normal-vs j)) - ;; cosine of angle between viewer and surface normal - ;; with gradient inferred from z flomap, this is always > 0.0 - (define cos-i nz) - ;; transmitted intensity - (define orig-T (unsafe-transmission-intensity cos-i 1.0 η2)) - (define T (unsafe-fl* Ti orig-T)) - (define R (unsafe-fl* Ri (unsafe-fl- 1.0 orig-T))) - ;; surface coordinates - (define x (unsafe-fl+ 0.5 (unsafe-fx->fl int-x))) - (define y (unsafe-fl+ 0.5 (unsafe-fx->fl int-y))) - (define z (unsafe-flvector-ref z-vs i)) - - ;; reflection - (when (and (Ri . unsafe-fl> . 0.0) - (int-x . unsafe-fx> . 0) (int-x . unsafe-fx< . w-1) - (int-y . unsafe-fx> . 0) (int-y . unsafe-fx< . h-1)) - (define-values (rx ry rz) (unsafe-reflect-view-ray nx ny nz)) - ;; tilt the wall a little so flat surfaces reflect something - (define ry* (- (* ry cos-wall-tilt-θ) (* rz sin-wall-tilt-θ))) - ;(define rz* (+ (* ry sin-wall-tilt-θ) (* rz cos-wall-tilt-θ))) - ;; distance to the wall - (define rdist (unsafe-fl/ (unsafe-fl- (- z-size) y) ry*)) - (define sx (unsafe-fl+ x (unsafe-fl* rx rdist))) - (define sy (unsafe-fl+ y (unsafe-fl* ry rdist))) - (define sz (unsafe-fl+ z (unsafe-fl* rz rdist))) - (when (rdist . unsafe-fl>= . 0.0) - (define cdist (unsafe-fl3dist sx sy sz x-mid y-mid 0.0)) - (define v (unsafe-flsigmoid (unsafe-fl* 0.25 (unsafe-fl- (* 4.5 z-size) cdist)))) - (let-values ([(r g b) (unsafe-fl3* Irr Irg Irb (* R v))]) - (unsafe-flvector-3set! reflected-vs j r g b)))) - - ;; transmission (refraction) - (when (Ti . unsafe-fl> . 0.0) - (define-values (tx ty tz) (unsafe-transmitted-vector nx ny nz 0.0 0.0 -1.0 1.0 η2)) - ;; sz = z + dist * tz, so dist = (sz - z) / tz - (define dist (unsafe-fl/ (unsafe-fl- 0.0 z) tz)) - (when (and (dist . unsafe-fl>= . 0.0) (dist . unsafe-fl< . +inf.0)) - ;; Find the color of the point on the shadow that the ray struck - (define sx (unsafe-flmax 0.0 (unsafe-flmin sx-max (unsafe-fl+ x (unsafe-fl* dist tx))))) - (define sy (unsafe-flmax 0.0 (unsafe-flmin sy-max (unsafe-fl+ y (unsafe-fl* dist ty))))) - (define floor-sx (unsafe-flfloor sx)) - (define floor-sy (unsafe-flfloor sy)) - (define bx (unsafe-fl->fx floor-sx)) - (define by (unsafe-fl->fx floor-sy)) - ;; Bilinearly interpolate the four colors nearest the point on the shadow - (define 1-αx (unsafe-fl- sx floor-sx)) - (define 1-αy (unsafe-fl- sy floor-sy)) - (define αx (unsafe-fl- 1.0 1-αx)) - (define αy (unsafe-fl- 1.0 1-αy)) - ;; upper-left weighted values - (define j1 (unsafe-fx* 3 (unsafe-fx+ bx (unsafe-fx* by w)))) - (define-values (r1 g1 b1) (unsafe-flvector-3ref shadow-vs j1)) - (define-values (sr1 sg1 sb1) (unsafe-fl3* r1 g1 b1 (unsafe-fl* αx αy))) - ;; upper-right weighted values - (define j2 (unsafe-fx+ j1 3)) - (define-values (r2 g2 b2) (unsafe-flvector-3ref shadow-vs j2)) - (define-values (sr2 sg2 sb2) (unsafe-fl3* r2 g2 b2 (unsafe-fl* 1-αx αy))) - ;; lower-left weighted values - (define j3 (unsafe-fx+ j1 (unsafe-fx* 3 w))) - (define-values (r3 g3 b3) (unsafe-flvector-3ref shadow-vs j3)) - (define-values (sr3 sg3 sb3) (unsafe-fl3* r3 g3 b3 (unsafe-fl* αx 1-αy))) - ;; lower-right weighted values - (define j4 (unsafe-fx+ j3 3)) - (define-values (r4 g4 b4) (unsafe-flvector-3ref shadow-vs j4)) - (define-values (sr4 sg4 sb4) (unsafe-fl3* r4 g4 b4 (unsafe-fl* 1-αx 1-αy))) - ;; final interpolated shadow color - (define-values (sr sg sb) - (values (unsafe-flsum sr1 sr2 sr3 sr4) - (unsafe-flsum sg1 sg2 sg3 sg4) - (unsafe-flsum sb1 sb2 sb3 sb4))) - ;; normalized distance to the surface - (define norm-dist (unsafe-fl/ dist opacity-z)) - ;; intensities of each r g b by the time the light emerges from the surface - (define-values (r g b) - ;; colors represent absorption rates - (let-values ([(r g b) (unsafe-flvector-3ref rgb-vs j)]) - (values (unsafe-flproduct T sr (unsafe-transmit r norm-dist)) - (unsafe-flproduct T sg (unsafe-transmit g norm-dist)) - (unsafe-flproduct T sb (unsafe-transmit b norm-dist))))) - (unsafe-flvector-3set! transmitted-vs j r g b)))))) - - ;; blur to cut down on sparklies (poor man's supersampling) - (values reflected-fm - (flomap-blur transmitted-fm ideal-transmission-blur))) - -;; =================================================================================================== -;; Full rendering - -(define (prep-background fm w h) - (let loop ([fm (flomap-cc-crop fm w h)]) - (case (flomap-components fm) - [(0) #f] - [(1) (flomap-append-components fm fm fm)] - [(2) (define value-fm (flomap-ref-component fm 1)) - (loop (flomap-append-components fm value-fm value-fm))] - [(3) fm] - [(4) (flomap-drop-components (flomap-cc-superimpose (make-flomap 4 w h 1.0) fm) 1)] - [else (raise-type-error 'deep-flomap-render "flomap with 0, 1, 2, 3 or 4 components" fm)]))) - -(define (deep-flomap-render dfm [background-fm #f]) - (define-values (w h) (deep-flomap-size dfm)) - (define argb-fm (flomap-divide-alpha (deep-flomap-argb dfm))) - (define alpha-fm (flomap-ref-component argb-fm 0)) - (define rgb-fm (flomap-drop-components argb-fm 1)) - (define z-fm (fmmax 0.0 (deep-flomap-z dfm))) - (define normal-fm (flomap-gradient-normal z-fm)) - ;(printf "~v~n" (flomap->bitmap (fm* 0.5 (fm+ 1.0 normal-fm)))) - (define bg-fm (if background-fm (prep-background background-fm) #f)) - - ;; pass 1: trace from the light source - (define-values (diffracted-fm raw-shadow-fm) - (trace-directional-light alpha-fm rgb-fm z-fm normal-fm)) - #; - (printf "diffracted: ~v~nraw shadow: ~v~n" - (flomap->bitmap diffracted-fm #;(flomap-normalize diffracted-fm)) - (flomap->bitmap raw-shadow-fm #;(flomap-normalize raw-shadow-fm))) - - ;; blur the shadow to simulate internal scatter - (define σ (* (min w h) (shadow-blur))) - (define shadow-fm - (cond [bg-fm - ;; two Gaussian blurs by half-σ is equivalent to one Gaussian blur by σ - (define half-σ (* (/ 1 (sqrt 2)) σ)) - (let* ([fm (flomap-blur raw-shadow-fm half-σ)] - [fm (fm* fm bg-fm)] - [fm (flomap-blur fm half-σ)]) - fm)] - [else - (flomap-blur raw-shadow-fm σ)])) - ;(printf "~v~n" (flomap->bitmap (flomap-normalize scattered-shadow-fm))) - - ;; pass 2: trace from the viewer - (define-values (reflected-fm transmitted-fm) - (trace-directional-view alpha-fm rgb-fm z-fm normal-fm shadow-fm)) - #; - (printf "reflected: ~v~ntransmitted: ~v~n" - (flomap->bitmap (flomap-normalize reflected-fm)) - (flomap->bitmap (flomap-normalize transmitted-fm))) - - ;; add all the light together, convert to premultiplied-alpha flomap - (let* ([fm (fm+ (fm+ diffracted-fm transmitted-fm) reflected-fm)] - [fm (flomap-append-components alpha-fm fm)] - [fm (flomap-multiply-alpha fm)] - ) - fm)) diff --git a/collects/images/private/unsafe.rkt b/collects/images/private/unsafe.rkt deleted file mode 100644 index bf1350a216..0000000000 --- a/collects/images/private/unsafe.rkt +++ /dev/null @@ -1,243 +0,0 @@ -#lang racket - -(require racket/flonum - ;racket/unsafe/ops - (prefix-in unsafe- (combine-in racket/flonum racket/fixnum racket/base)) - ) - -(provide (all-defined-out) - ;(all-from-out racket/unsafe/ops) - (combine-out (all-from-out racket/flonum racket/fixnum) - unsafe-bytes-ref unsafe-bytes-set! unsafe-bytes-length - unsafe-flvector-ref unsafe-flvector-set! unsafe-flvector-length - unsafe-vector-ref unsafe-vector-set! unsafe-vector-length)) - -;; =================================================================================================== -;; flonum ops - -(define-syntax-rule (unsafe-flneg x) (unsafe-fl- 0.0 x)) -(define-syntax-rule (unsafe-flsqr x) (let ([y x]) (unsafe-fl* y y))) - -(define-syntax-rule (unsafe-flrational? x) - ;; if x = +nan.0, both tests return #f - (and (unsafe-fl> x -inf.0) (unsafe-fl< x +inf.0))) - -(define-syntax unsafe-flsum - (syntax-rules () - [(_) 0.0] - [(_ v1) v1] - [(_ v1 vs ...) (unsafe-fl+ v1 (unsafe-flsum vs ...))])) - -(define-syntax unsafe-flproduct - (syntax-rules () - [(_) 1.0] - [(_ v1) v1] - [(_ v1 vs ...) (unsafe-fl* v1 (unsafe-flproduct vs ...))])) - -(define-syntax unsafe-flmin* - (syntax-rules () - [(_) 1.0] - [(_ v1) v1] - [(_ v1 vs ...) (unsafe-flmin v1 (unsafe-flmin* vs ...))])) - -(define-syntax unsafe-flmax* - (syntax-rules () - [(_) 1.0] - [(_ v1) v1] - [(_ v1 vs ...) (unsafe-flmax v1 (unsafe-flmax* vs ...))])) - -(define-syntax-rule (unsafe-fl->byte x) - (unsafe-fl->fx* (unsafe-flround (unsafe-flmax (unsafe-flmin x 255.0) 0.0)))) - -(define-syntax-rule (unsafe-fl-convex-combination dv sv sa) - (let ([sa* sa]) - (unsafe-fl+ (unsafe-fl* sa* sv) (unsafe-fl* dv (unsafe-fl- 1.0 sa*))))) - -(define-syntax-rule (unsafe-fl-alpha-blend dca sca sa) - (unsafe-fl+ sca (unsafe-fl* dca (unsafe-fl- 1.0 sa)))) - -(define-syntax-rule (unsafe-flsigmoid x) - (unsafe-fl/ 1.0 (unsafe-fl+ 1.0 (unsafe-flexp (unsafe-fl- 0.0 x))))) - -(define-syntax-rule (unsafe-flgaussian x s) - (let* ([s* s] [x* (unsafe-fl/ x s*)]) - (unsafe-fl/ (unsafe-flexp (unsafe-fl* -0.5 (unsafe-fl* x* x*))) - (unsafe-fl* (sqrt (* 2.0 pi)) s*)))) - -;; =================================================================================================== -;; flvector ops - -(define-syntax-rule (unsafe-flvector-3ref vs i) - (let ([j i]) - (values (unsafe-flvector-ref vs j) - (unsafe-flvector-ref vs (unsafe-fx+ j 1)) - (unsafe-flvector-ref vs (unsafe-fx+ j 2))))) - -(define-syntax-rule (unsafe-flvector-3set! vs i x y z) - (let ([j i]) - (unsafe-flvector-set! vs j x) - (unsafe-flvector-set! vs (unsafe-fx+ j 1) y) - (unsafe-flvector-set! vs (unsafe-fx+ j 2) z))) - -(define-syntax-rule (unsafe-flvector-4ref vs i) - (let ([j i]) - (values (unsafe-flvector-ref vs j) - (unsafe-flvector-ref vs (unsafe-fx+ j 1)) - (unsafe-flvector-ref vs (unsafe-fx+ j 2)) - (unsafe-flvector-ref vs (unsafe-fx+ j 3))))) - -(define-syntax-rule (unsafe-flvector-4set! vs i a r g b) - (let ([j i]) - (unsafe-flvector-set! vs j a) - (unsafe-flvector-set! vs (unsafe-fx+ j 1) r) - (unsafe-flvector-set! vs (unsafe-fx+ j 2) g) - (unsafe-flvector-set! vs (unsafe-fx+ j 3) b))) - -(define-syntax-rule (unsafe-build-flvector len f) - (let ([n len]) - (define vs (make-flvector n)) - (let loop ([i 0]) - (cond [(i . unsafe-fx< . n) (unsafe-flvector-set! vs i (f i)) - (loop (unsafe-fx+ i 1))] - [else vs])))) - -(define-syntax-rule (unsafe-flvector-sum vs) - (let ([vs* vs]) - (let ([n (unsafe-flvector-length vs*)]) - (let loop ([i 0] [sum 0.0]) - (cond [(unsafe-fx= i n) sum] - [else (loop (unsafe-fx+ i 1) (unsafe-fl+ sum (unsafe-flvector-ref vs* i)))]))))) - -;; =================================================================================================== -;; fixnum ops - -(define (unsafe-fl->fx* x) (if (unsafe-flrational? x) (unsafe-fl->fx x) 0)) - -(define-syntax-rule (unsafe-fxneg x) (unsafe-fx- 0 x)) - -(define-syntax unsafe-fxsum - (syntax-rules () - [(_) 0] - [(_ v1) v1] - [(_ v1 vs ...) (unsafe-fx+ v1 (unsafe-fxsum vs ...))])) - -(define-syntax unsafe-fxproduct - (syntax-rules () - [(_) 1] - [(_ v1) v1] - [(_ v1 vs ...) (unsafe-fx* v1 (unsafe-fxproduct vs ...))])) - -(define-syntax-rule (unsafe-byte-blend x y α) - (unsafe-fxquotient (unsafe-fx+ (unsafe-fx* x α) (unsafe-fx* (unsafe-fx- 255 α) y)) 255)) - -(define-syntax-rule (unsafe-fx->byte x) - (unsafe-fxmax (unsafe-fxmin x 255) 0)) - -(define-syntax-rule (unsafe-fx-dst-over-alpha sa da) - (let ([sa* sa] [da* da]) - (unsafe-fxquotient (unsafe-fx+ 127 (unsafe-fx- (unsafe-fx* (unsafe-fx+ sa* da*) 255) - (unsafe-fx* sa* da*))) - 255))) - -(define-syntax-rule (unsafe-fx-dst-over-color sa sc da dc) - (let ([da* da]) - (unsafe-fxquotient (unsafe-fxsum 32512 - (unsafe-fxproduct da* dc 255) - (unsafe-fxproduct sa sc (unsafe-fx- 255 da*))) - 65025))) - -;; =================================================================================================== -;; bytes ops - -(define-syntax-rule (unsafe-bytes-3ref bs i) - (let ([j i]) - (values (unsafe-bytes-ref bs j) - (unsafe-bytes-ref bs (unsafe-fx+ j 1)) - (unsafe-bytes-ref bs (unsafe-fx+ j 2))))) - -(define-syntax-rule (unsafe-bytes-3set! bs i r g b) - (let ([j i]) - (unsafe-bytes-set! bs j r) - (unsafe-bytes-set! bs (unsafe-fx+ j 1) g) - (unsafe-bytes-set! bs (unsafe-fx+ j 2) b))) - -(define-syntax-rule (unsafe-bytes-4ref bs i) - (let ([j i]) - (values (unsafe-bytes-ref bs j) - (unsafe-bytes-ref bs (unsafe-fx+ j 1)) - (unsafe-bytes-ref bs (unsafe-fx+ j 2)) - (unsafe-bytes-ref bs (unsafe-fx+ j 3))))) - -(define-syntax-rule (unsafe-bytes-4set! bs i a r g b) - (let ([j i]) - (unsafe-bytes-set! bs j a) - (unsafe-bytes-set! bs (unsafe-fx+ j 1) r) - (unsafe-bytes-set! bs (unsafe-fx+ j 2) g) - (unsafe-bytes-set! bs (unsafe-fx+ j 3) b))) - -;; =================================================================================================== -;; 2-flonum-values ops - -(define-syntax-rule (unsafe-fl2dot x1 y1 x2 y2) - (unsafe-fl+ (unsafe-fl* x1 x2) (unsafe-fl* y1 y2))) - -;; =================================================================================================== -;; 3-flonum-values ops - -(define-syntax-rule (unsafe-fl3+ x1 y1 z1 x2 y2 z2) - (values (unsafe-fl+ x1 x2) (unsafe-fl+ y1 y2) (unsafe-fl+ z1 z2))) - -(define-syntax-rule (unsafe-fl3- x1 y1 z1 x2 y2 z2) - (values (unsafe-fl- x1 x2) (unsafe-fl- y1 y2) (unsafe-fl- z1 z2))) - -(define-syntax unsafe-fl3* - (syntax-rules () - [(_ x y z c) (values (unsafe-fl* x c) (unsafe-fl* y c) (unsafe-fl* z c))] - [(_ x1 y1 z1 x2 y2 z2) (values (unsafe-fl* x1 x2) (unsafe-fl* y1 y2) (unsafe-fl* z1 z2))])) - -(define-syntax unsafe-fl3/ - (syntax-rules () - [(_ x y z c) (values (unsafe-fl/ x c) (unsafe-fl/ y c) (unsafe-fl/ z c))] - [(_ x1 y1 z1 x2 y2 z2) (values (unsafe-fl/ x1 x2) (unsafe-fl/ y1 y2) (unsafe-fl/ z1 z2))])) - -(define-syntax unsafe-fl3ma - (syntax-rules () - [(_ x y z dx dy dz t) - (values (unsafe-fl+ x (unsafe-fl* dx t)) - (unsafe-fl+ y (unsafe-fl* dy t)) - (unsafe-fl+ z (unsafe-fl* dz t)))] - [(_ x y z dx dy dz tx ty tz) - (values (unsafe-fl+ x (unsafe-fl* dx tx)) - (unsafe-fl+ y (unsafe-fl* dy ty)) - (unsafe-fl+ z (unsafe-fl* dz tz)))])) - -(define-syntax-rule (unsafe-fl3neg x y z) - (values (unsafe-flneg x) (unsafe-flneg y) (unsafe-flneg z))) - -(define-syntax-rule (unsafe-fl3dot x1 y1 z1 x2 y2 z2) - (unsafe-fl+ (unsafe-fl+ (unsafe-fl* x1 x2) (unsafe-fl* y1 y2)) - (unsafe-fl* z1 z2))) - -(define-syntax-rule (unsafe-fl3mag^2 dx dy dz) - (unsafe-fl3dot dx dy dz dx dy dz)) - -(define-syntax-rule (unsafe-fl3mag dx dy dz) - (unsafe-flsqrt (unsafe-fl3mag^2 dx dy dz))) - -(define-syntax-rule (unsafe-fl3dist x1 y1 z1 x2 y2 z2) - (unsafe-fl3mag (unsafe-fl- x1 x2) (unsafe-fl- y1 y2) (unsafe-fl- z1 z2))) - -(define-syntax-rule (unsafe-fl3normalize x1 y1 z1) - (let ([i1 x1] [j1 y1] [k1 z1]) - (define d (unsafe-fl3mag i1 j1 k1)) - (values (unsafe-fl/ i1 d) (unsafe-fl/ j1 d) (unsafe-fl/ k1 d)))) - -(define-syntax-rule (unsafe-fl3-half-norm x1 y1 z1 x2 y2 z2) - (unsafe-fl3normalize (unsafe-fl+ x1 x2) (unsafe-fl+ y1 y2) (unsafe-fl+ z1 z2))) - -(define-syntax-rule (unsafe-fl3-convex-combination x1 y1 z1 x2 y2 z2 α) - (let* ([a α] - [1-a (unsafe-fl- 1.0 a)]) - (values (unsafe-fl+ (unsafe-fl* 1-a x1) (unsafe-fl* a x2)) - (unsafe-fl+ (unsafe-fl* 1-a y1) (unsafe-fl* a y2)) - (unsafe-fl+ (unsafe-fl* 1-a z1) (unsafe-fl* a z2))))) diff --git a/collects/images/private/utils.rkt b/collects/images/private/utils.rkt index 48794567ec..033313818e 100644 --- a/collects/images/private/utils.rkt +++ b/collects/images/private/utils.rkt @@ -6,37 +6,41 @@ (provide (all-defined-out)) +(define num-callbacks 0) +(define (get-num-callbacks) num-callbacks) + (define (register-gc-callback proc) - (define val (box 0)) - (register-finalizer val (λ (_) - (define again? (proc)) - (when again? (register-gc-callback proc))))) + (printf "registering~n") + (register-finalizer (malloc 4) (λ (val) + (set! num-callbacks (+ 1 num-callbacks)) + (printf "here~n") + (when (proc) (register-gc-callback proc))))) (define (weak-value-hash-clean! h) (define ks (for*/list ([(k bx) (in-hash h)] - [val (in-value (weak-box-value bx))] + [val (in-value (weak-box-value (car bx)))] #:when (not val)) k)) (for ([k (in-list ks)]) (hash-remove! h k))) -;(define total-time-saved 0) -;(define total-time-spent 0) +(define total-time-saved 0) +(define total-time-spent 0) ;; Can't simply wrap hash-ref! with weak-box-value and thnk with make-weak-box, because ;; 1. If weak-box-value returns #f, we need to regenerate the value ;; 2. We need to keep a handle to the generated value while it's being stored in the hash (define (weak-value-hash-ref! h k thnk) (define (cache-ref!) - ;(define start (current-milliseconds)) + (define start (current-milliseconds)) (define val (thnk)) - ;(define time (- (current-milliseconds) start)) - ;(set! total-time-spent (+ total-time-spent time)) + (define time (- (current-milliseconds) start)) + (set! total-time-spent (+ total-time-spent time)) ;(printf "total-time-spent = ~v~n" total-time-spent) - (hash-set! h k (cons (make-weak-box val) 0)) + (hash-set! h k (cons (make-weak-box val) time)) val) - (cond [(hash-has-key? h k) (define p (hash-ref h k)) - (define val (weak-box-value (car p))) - (cond [val ;(set! total-time-saved (+ total-time-saved (cdr p))) + (cond [(hash-has-key? h k) (define bx (hash-ref h k)) + (define val (weak-box-value (car bx))) + (cond [val (set! total-time-saved (+ total-time-saved (cdr bx))) ;(printf "total-time-saved = ~v~n" total-time-saved) val] [else (cache-ref!)])] @@ -45,13 +49,17 @@ (define flomap-cache (make-hash)) (define (clean-flomap-cache!) - (weak-value-hash-clean! flomap-cache)) + (weak-value-hash-clean! flomap-cache) + #t) (register-gc-callback clean-flomap-cache!) -(define (read-flomap-cache) +(define (get-flomap-cache) (for/list ([(k bx) (in-hash flomap-cache)]) - (cons k (weak-box-value bx)))) + (cons k (cons (weak-box-value (car bx)) (cdr bx))))) + +(define (get-total-time-saved) total-time-saved) +(define (get-total-time-spent) total-time-spent) (define (make-cached-flomap* name proc size . args) (define rendered-size diff --git a/collects/images/tests/icon-tests.rkt b/collects/images/tests/icon-tests.rkt index 01572d9bf2..cc751ff404 100644 --- a/collects/images/tests/icon-tests.rkt +++ b/collects/images/tests/icon-tests.rkt @@ -7,7 +7,8 @@ images/icons/misc images/icons/tool images/icons/style - images/private/renderfx) + images/private/deep-flomap-render + images/private/utils) (default-icon-height 16) ;(default-icon-material glass-icon-material) diff --git a/collects/images/tests/logo-tests.rkt b/collects/images/tests/logo-tests.rkt index fda2057ef8..08ceb56088 100644 --- a/collects/images/tests/logo-tests.rkt +++ b/collects/images/tests/logo-tests.rkt @@ -3,3 +3,4 @@ (require images/logos) (time (plt-logo 256)) +(time (planet-logo 256))