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

Rewrote flomaps and rendering in Typed Racket for speed and safety

Browse Source
This commit is contained in:
Neil Toronto 2012-01-10 13:29:00 -07:00
parent be4bfdff4c
commit daf3ed55ba
29 changed files with 2628 additions and 2572 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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")

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

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

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

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

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

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

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

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

36
collects/images/logos.rkt
View File

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

33
collects/images/private/deep-flomap-parameters.rkt Normal file
View File

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

530
collects/images/private/deep-flomap-render.rkt Normal file
View File

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

482
collects/images/private/deep-flomap-struct.rkt Normal file
View File

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

117
collects/images/private/deep-flomap-untyped-parameters.rkt Normal file
View File

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

491
collects/images/private/deep-flomap.rkt
View File

@ -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"))

11
collects/images/private/draw-predicates.rkt Normal file
View File

@ -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<%>))

338
collects/images/private/flomap-blur.rkt Normal file
View File

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

103
collects/images/private/flomap-composite.rkt Normal file
View File

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

87
collects/images/private/flomap-convert.rkt Normal file
View File

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

67
collects/images/private/flomap-effects.rkt Normal file
View File

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

74
collects/images/private/flomap-gradient.rkt Normal file
View File

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

121
collects/images/private/flomap-pointwise.rkt Normal file
View File

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

221
collects/images/private/flomap-resize.rkt Normal file
View File

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

55
collects/images/private/flomap-stats.rkt Normal file
View File

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

160
collects/images/private/flomap-struct.rkt Normal file
View File

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

40
collects/images/private/flomap-transform.rkt Normal file
View File

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

1181
collects/images/private/flomap.rkt
View File

File diff suppressed because it is too large Load Diff

102
collects/images/private/flonum.rkt Normal file
View File

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

640
collects/images/private/renderfx.rkt
View File

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

243
collects/images/private/unsafe.rkt
View File

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

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

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

3
collects/images/tests/icon-tests.rkt
View File

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

1
collects/images/tests/logo-tests.rkt
View File

@ -3,3 +3,4 @@
(require images/logos)
(time (plt-logo 256))
(time (planet-logo 256))