Refactoring
This commit is contained in:
Neil Toronto
parent
a81f7f289a
commit
54c8b51c32
|
|
@ -1,8 +1,6 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require racket/flonum
|
||||
(except-in racket/fixnum fl->fx fx->fl)
|
||||
racket/match racket/math
|
||||
(require racket/match racket/math
|
||||
"flonum.rkt"
|
||||
"flomap.rkt"
|
||||
"deep-flomap-struct.rkt"
|
||||
|
|
@ -124,21 +122,21 @@
|
|||
(for*: ([int-y : Integer (in-range y-min y-max)]
|
||||
[int-x : Integer (in-range x-min x-max)])
|
||||
(define i (fx+ int-x (fx* int-y w)))
|
||||
(define a (unsafe-flvector-ref alpha-vs i))
|
||||
(define a (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)))
|
||||
(define z (flvector-ref z-vs i))
|
||||
(define nx (flvector-ref normal-vs j))
|
||||
(define ny (flvector-ref normal-vs (fx+ j 1)))
|
||||
(define nz (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)
|
||||
(flvector-set! intensity-vs j Ilr)
|
||||
(flvector-set! intensity-vs (fx+ j 1) Ilg)
|
||||
(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?
|
||||
|
|
@ -158,17 +156,17 @@
|
|||
(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)
|
||||
(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))]
|
||||
(flvector-set! diffuse-vs j Idr)
|
||||
(flvector-set! diffuse-vs (fx+ j 1) Idg)
|
||||
(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)])
|
||||
(flvector-set! diffuse-vs j Rar)
|
||||
(flvector-set! diffuse-vs (fx+ j 1) Rag)
|
||||
(flvector-set! diffuse-vs (fx+ j 2) Rab)])
|
||||
|
||||
(when (and (Ti . > . 0.0) (n-dot-l . > . 0.0))
|
||||
;; ideal transmission vector
|
||||
|
|
@ -186,18 +184,18 @@
|
|||
;; 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 r (flvector-ref rgb-vs j))
|
||||
(define g (flvector-ref rgb-vs (fx+ j 1)))
|
||||
(define b (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)))))
|
||||
(flvector-set! sx-vs i sx)
|
||||
(flvector-set! sy-vs i sy)
|
||||
(flvector-set! Irgb-vs j Ir)
|
||||
(flvector-set! Irgb-vs (fx+ j 1) Ig)
|
||||
(flvector-set! Irgb-vs (fx+ j 2) Ib)))))
|
||||
|
||||
(define diffracted-fm (fm+ (fm* (flomap-blur diffuse-fm diffuse-blur)
|
||||
rgb-fm)
|
||||
|
|
@ -212,21 +210,21 @@
|
|||
(for*: ([int-y : Integer (in-range y-min y-max)]
|
||||
[int-x : Integer (in-range x-min x-max)])
|
||||
(define i (fx+ int-x (fx* int-y w)))
|
||||
(define a (unsafe-flvector-ref alpha-vs i))
|
||||
(define a (flvector-ref alpha-vs i))
|
||||
(when (a . > . 0.0)
|
||||
(define z (unsafe-flvector-ref z-vs i))
|
||||
(define z (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 r (flvector-ref rgb-vs j))
|
||||
(define g (flvector-ref rgb-vs (fx+ j 1)))
|
||||
(define b (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))))
|
||||
(flvector-set! ambient-shadow-vs j Ir)
|
||||
(flvector-set! ambient-shadow-vs (fx+ j 1) Ig)
|
||||
(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))))
|
||||
|
|
@ -241,16 +239,16 @@
|
|||
(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))
|
||||
(define sx00 (flvector-ref sx-vs i00))
|
||||
(define sx01 (flvector-ref sx-vs i01))
|
||||
(define sx10 (flvector-ref sx-vs i10))
|
||||
(define sx11 (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 sy00 (flvector-ref sy-vs i00))
|
||||
(define sy01 (flvector-ref sy-vs i01))
|
||||
(define sy10 (flvector-ref sy-vs i10))
|
||||
(define sy11 (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))
|
||||
|
|
@ -274,24 +272,24 @@
|
|||
(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)))))
|
||||
(define r (* 0.25 (+ (flvector-ref Irgb-vs j00)
|
||||
(flvector-ref Irgb-vs j01)
|
||||
(flvector-ref Irgb-vs j10)
|
||||
(flvector-ref Irgb-vs j11))))
|
||||
(define g (* 0.25 (+ (flvector-ref Irgb-vs (fx+ j00 1))
|
||||
(flvector-ref Irgb-vs (fx+ j01 1))
|
||||
(flvector-ref Irgb-vs (fx+ j10 1))
|
||||
(flvector-ref Irgb-vs (fx+ j11 1)))))
|
||||
(define b (* 0.25 (+ (flvector-ref Irgb-vs (fx+ j00 2))
|
||||
(flvector-ref Irgb-vs (fx+ j01 2))
|
||||
(flvector-ref Irgb-vs (fx+ j10 2))
|
||||
(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))
|
||||
(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)
|
||||
|
|
@ -299,13 +297,13 @@
|
|||
(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))
|
||||
(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))
|
||||
(define ky (flvector-ref kys dy))
|
||||
(cond [(ky . > . 0.1)
|
||||
(define a (/ ky c))
|
||||
(define Ir (* r a))
|
||||
|
|
@ -314,16 +312,16 @@
|
|||
(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))
|
||||
(define kx (flvector-ref kxs dx))
|
||||
(when (kx . > . 0.1)
|
||||
(unsafe-flvector-set!
|
||||
shadow-vs i (+ (* Ir kx) (unsafe-flvector-ref shadow-vs i)))
|
||||
(flvector-set!
|
||||
shadow-vs i (+ (* Ir kx) (flvector-ref shadow-vs i)))
|
||||
(define i1 (fx+ i 1))
|
||||
(unsafe-flvector-set!
|
||||
shadow-vs i1 (+ (* Ig kx) (unsafe-flvector-ref shadow-vs i1)))
|
||||
(flvector-set!
|
||||
shadow-vs i1 (+ (* Ig kx) (flvector-ref shadow-vs i1)))
|
||||
(define i2 (fx+ i 2))
|
||||
(unsafe-flvector-set!
|
||||
shadow-vs i2 (+ (* Ib kx) (unsafe-flvector-ref shadow-vs i2))))
|
||||
(flvector-set!
|
||||
shadow-vs i2 (+ (* Ib kx) (flvector-ref shadow-vs i2))))
|
||||
(x-loop (fx+ 1 dx) (fx+ 3 i))]
|
||||
[else
|
||||
(y-loop (fx+ 1 dy))]))]
|
||||
|
|
@ -374,13 +372,13 @@
|
|||
(for*: ([int-y : Integer (in-range y-min y-max)]
|
||||
[int-x : Integer (in-range x-min x-max)])
|
||||
(define i (fx+ int-x (fx* int-y w)))
|
||||
(define a (unsafe-flvector-ref alpha-vs i))
|
||||
(define a (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)))
|
||||
(define nx (flvector-ref normal-vs j))
|
||||
(define ny (flvector-ref normal-vs (fx+ j 1)))
|
||||
(define nz (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)
|
||||
|
|
@ -391,7 +389,7 @@
|
|||
;; 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))
|
||||
(define z (flvector-ref z-vs i))
|
||||
;; reflection
|
||||
(when (and (Ri . > . 0.0)
|
||||
(int-x . fx> . 0) (int-x . fx< . w-1)
|
||||
|
|
@ -409,14 +407,14 @@
|
|||
(define cdist (fl3dist sx sy sz x-mid y-mid 0.0))
|
||||
(define v (flsigmoid (* 0.25 (- (* 4.5 z-size) cdist))))
|
||||
(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))))
|
||||
(flvector-set! reflected-vs j r)
|
||||
(flvector-set! reflected-vs (fx+ j 1) g)
|
||||
(flvector-set! reflected-vs (fx+ j 2) b))))
|
||||
;; transmission (refraction)
|
||||
(when (Ti . > . 0.0)
|
||||
(define snx (unsafe-flvector-ref normal-vs j))
|
||||
(define sny (unsafe-flvector-ref normal-vs (fx+ j 1)))
|
||||
(define snz (unsafe-flvector-ref normal-vs (fx+ j 2)))
|
||||
(define snx (flvector-ref normal-vs j))
|
||||
(define sny (flvector-ref normal-vs (fx+ j 1)))
|
||||
(define snz (flvector-ref normal-vs (fx+ j 2)))
|
||||
(define-values (tx ty tz) (transmitted-vector snx sny snz 0.0 0.0 -1.0 1.0 η2))
|
||||
;; sz = z + dist * tz, so dist = (sz - z) / tz
|
||||
(define dist (/ (- 0.0 z) tz))
|
||||
|
|
@ -433,15 +431,15 @@
|
|||
;; 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))])
|
||||
(let ([r (flvector-ref rgb-vs j)]
|
||||
[g (flvector-ref rgb-vs (fx+ j 1))]
|
||||
[b (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))))))
|
||||
(flvector-set! transmitted-vs j r)
|
||||
(flvector-set! transmitted-vs (fx+ j 1) g)
|
||||
(flvector-set! transmitted-vs (fx+ j 2) b))))))
|
||||
|
||||
(values reflected-fm transmitted-fm))
|
||||
|
||||
|
|
@ -475,7 +473,7 @@
|
|||
(define normal-fm (flomap-gradient-normal z-fm))
|
||||
(define bg-fm (if background-fm (prep-background background-fm w h) #f))
|
||||
(define-values (x-min y-min x-max y-max)
|
||||
(let-values ([(_1 x-min y-min _2 x-max y-max) (flomap-nonzero-rect alpha-fm)])
|
||||
(let-values ([(x-min y-min x-max y-max) (flomap-nonzero-rect alpha-fm)])
|
||||
(values (max 0 (- x-min 1)) (max 0 (- y-min 1))
|
||||
(min w (+ x-max 1)) (min h (+ y-max 1)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,6 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require racket/flonum
|
||||
(except-in racket/fixnum fx->fl fl->fx)
|
||||
racket/match racket/math
|
||||
(require racket/match racket/math
|
||||
"flonum.rkt"
|
||||
"flomap.rkt")
|
||||
|
||||
|
|
@ -201,7 +199,7 @@
|
|||
(: 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)
|
||||
(define-values (x-min y-min 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)))
|
||||
|
||||
|
|
@ -273,16 +271,18 @@
|
|||
(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)
|
||||
(: get-argbz-pixel (FlVector FlVector Integer Integer Integer Integer Integer Integer
|
||||
-> (values Flonum Flonum Flonum Flonum Flonum)))
|
||||
(define (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))]
|
||||
(values (flvector-ref argb-vs j)
|
||||
(flvector-ref argb-vs (fx+ j 1))
|
||||
(flvector-ref argb-vs (fx+ j 2))
|
||||
(flvector-ref argb-vs (fx+ j 3))
|
||||
(flvector-ref z-vs i))]
|
||||
[else
|
||||
(values 0.0 0.0 0.0 0.0 0.0)])))
|
||||
|
||||
|
|
@ -297,13 +297,13 @@
|
|||
|
||||
(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)]))
|
||||
(flvector-set! argb-vs j (fl-alpha-blend a1 a2 a2))
|
||||
(flvector-set! argb-vs (fx+ j 1) (fl-alpha-blend r1 r2 a2))
|
||||
(flvector-set! argb-vs (fx+ j 2) (fl-alpha-blend g1 g2 a2))
|
||||
(flvector-set! argb-vs (fx+ j 3) (fl-alpha-blend b1 b2 a2))
|
||||
(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))]))))
|
||||
|
|
@ -322,16 +322,20 @@
|
|||
(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)
|
||||
(: get-alpha-pixel (FlVector Integer Integer Integer Integer Integer Integer
|
||||
-> Flonum))
|
||||
(define (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))))]
|
||||
(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)
|
||||
(: get-z-pixel (FlVector Integer Integer Integer Integer Integer Integer
|
||||
-> Flonum))
|
||||
(define (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)))]
|
||||
(flvector-ref vs (fx+ x (fx* y w)))]
|
||||
[else 0.0])))
|
||||
|
||||
(define z1-max -inf.0)
|
||||
|
|
@ -369,18 +373,21 @@
|
|||
(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)
|
||||
(: get-argbzuv-pixel (FlVector FlVector FlVector FlVector
|
||||
Integer Integer Integer Integer Integer Integer
|
||||
-> (values Flonum Flonum Flonum Flonum Flonum Flonum Flonum)))
|
||||
(define (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))]
|
||||
(values (flvector-ref argb-vs j)
|
||||
(flvector-ref argb-vs (fx+ j 1))
|
||||
(flvector-ref argb-vs (fx+ j 2))
|
||||
(flvector-ref argb-vs (fx+ j 3))
|
||||
(flvector-ref z-vs i)
|
||||
(flvector-ref u-vs i)
|
||||
(flvector-ref v-vs i))]
|
||||
[else
|
||||
(values 0.0 0.0 0.0 0.0 0.0 0.0 0.0)])))
|
||||
|
||||
|
|
@ -409,11 +416,11 @@
|
|||
|
||||
(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 α))
|
||||
(flvector-set! argb-vs j (fl-convex-combination a1 a2 α))
|
||||
(flvector-set! argb-vs (fx+ j 1) (fl-convex-combination r1 r2 α))
|
||||
(flvector-set! argb-vs (fx+ j 2) (fl-convex-combination g1 g2 α))
|
||||
(flvector-set! argb-vs (fx+ j 3) (fl-convex-combination b1 b2 α))
|
||||
(flvector-set! z-vs i (fl-convex-combination z1 z2 α))
|
||||
(x-loop (fx+ x 1))]
|
||||
[else
|
||||
(y-loop (fx+ y 1))]))))
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require racket/flonum
|
||||
(except-in racket/fixnum fl->fx fx->fl)
|
||||
racket/match racket/math
|
||||
(require racket/match racket/math
|
||||
(only-in racket/unsafe/ops unsafe-flvector-ref)
|
||||
"flonum.rkt"
|
||||
"flomap-struct.rkt")
|
||||
|
||||
|
|
@ -76,11 +75,11 @@
|
|||
(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)
|
||||
(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))
|
||||
(cond [(i . fx< . n) (flvector-set! ys i (/ (flvector-ref ys i) sum))
|
||||
(loop (fx+ i 1))]
|
||||
[else ys])))
|
||||
|
||||
|
|
@ -103,11 +102,11 @@
|
|||
(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)))
|
||||
(flvector-set! new-vs (fx+ j01 c)
|
||||
(- (+ (flvector-ref vs i)
|
||||
(flvector-ref new-vs j01)
|
||||
(flvector-ref new-vs (fx+ j00 c)))
|
||||
(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)]))))
|
||||
|
|
@ -126,8 +125,8 @@
|
|||
(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)))
|
||||
(flvector-set! new-vs j1 (+ (flvector-ref vs i)
|
||||
(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)]))))
|
||||
|
|
@ -147,8 +146,8 @@
|
|||
(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)))
|
||||
(flvector-set! new-vs j1 (+ (flvector-ref vs j0)
|
||||
(flvector-ref new-vs j0)))
|
||||
(k-loop (fx+ k 1))]
|
||||
[else (x-loop (fx+ x 1))]))]
|
||||
[else (y-loop (fx+ y 1))]))))
|
||||
|
|
@ -164,10 +163,10 @@
|
|||
(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)))))
|
||||
(- (+ (flvector-ref vs (coords->index c w k x1 y1))
|
||||
(flvector-ref vs (coords->index c w k x2 y2)))
|
||||
(+ (flvector-ref vs (coords->index c w k x1 y2))
|
||||
(flvector-ref vs (coords->index c w k x2 y1)))))
|
||||
|
||||
(: raw-flomap-integral-x-sum (FlVector Integer Integer
|
||||
Integer Integer Integer Integer -> Flonum))
|
||||
|
|
@ -175,8 +174,8 @@
|
|||
(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))))
|
||||
(- (flvector-ref vs (coords->index c w k x2 y))
|
||||
(flvector-ref vs (coords->index c w k x1 y))))
|
||||
|
||||
(: raw-flomap-integral-y-sum (FlVector Integer Integer Integer
|
||||
Integer Integer Integer Integer -> Flonum))
|
||||
|
|
@ -184,8 +183,8 @@
|
|||
(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))))
|
||||
(- (flvector-ref vs (coords->index c w k x y2))
|
||||
(flvector-ref vs (coords->index c w k x y1))))
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Box blur
|
||||
|
|
|
|||
|
|
@ -1,8 +1,6 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require racket/flonum
|
||||
(except-in racket/fixnum fl->fx fx->fl)
|
||||
racket/match
|
||||
(require racket/match
|
||||
"flonum.rkt"
|
||||
"flomap-struct.rkt")
|
||||
|
||||
|
|
@ -33,14 +31,16 @@
|
|||
(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)
|
||||
(: get-argb-pixel (FlVector Integer Integer Integer Integer Integer Integer
|
||||
-> (values Flonum Flonum Flonum Flonum)))
|
||||
(define (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)))]
|
||||
(values (flvector-ref argb-vs i)
|
||||
(flvector-ref argb-vs (fx+ i 1))
|
||||
(flvector-ref argb-vs (fx+ i 2))
|
||||
(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)))
|
||||
|
|
@ -52,10 +52,10 @@
|
|||
(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))
|
||||
(flvector-set! argb-vs i (fl-alpha-blend a1 a2 a2))
|
||||
(flvector-set! argb-vs (fx+ i 1) (fl-alpha-blend r1 r2 a2))
|
||||
(flvector-set! argb-vs (fx+ i 2) (fl-alpha-blend g1 g2 a2))
|
||||
(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))]))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require racket/flonum racket/math racket/match racket/list
|
||||
(except-in racket/fixnum fl->fx fx->fl)
|
||||
(require racket/math racket/match racket/list
|
||||
"flonum.rkt"
|
||||
"flomap-struct.rkt"
|
||||
"flomap-pointwise.rkt"
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require racket/flonum
|
||||
(except-in racket/fixnum fl->fx fx->fl)
|
||||
racket/match
|
||||
(require racket/match
|
||||
(only-in racket/unsafe/ops unsafe-flvector-ref)
|
||||
"flonum.rkt"
|
||||
"flomap-struct.rkt")
|
||||
|
||||
|
|
@ -76,11 +75,11 @@
|
|||
(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 dx (flvector-ref dx-vs i))
|
||||
(define dy (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))
|
||||
(flvector-set! normal-vs j nx)
|
||||
(flvector-set! normal-vs (fx+ j 1) ny)
|
||||
(flvector-set! normal-vs (fx+ j 2) nz))
|
||||
(flomap normal-vs 3 w h))
|
||||
|
|
|
|||
|
|
@ -1,86 +1,83 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require racket/flonum
|
||||
(except-in racket/fixnum fl->fx fx->fl)
|
||||
racket/match racket/math
|
||||
(require 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
|
||||
fmsqrt fm+ fm- fm* fm/ fmmin fmmax
|
||||
flomap-normalize flomap-multiply-alpha flomap-divide-alpha)
|
||||
|
||||
;; ===================================================================================================
|
||||
;; Unary
|
||||
|
||||
;(: inline-flomap-lift ((Flonum -> Flonum) -> (flomap -> flomap)))
|
||||
(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))))
|
||||
(flomap (inline-build-flvector (* c w h) (λ (i) (f (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
|
||||
|
||||
(: raise-two-reals-error (Symbol Real Real -> flomap))
|
||||
(define (raise-two-reals-error name r1 r2)
|
||||
(error name "expected at least one flomap argument; given ~e and ~e" r1 r2))
|
||||
|
||||
(: raise-size-error (Symbol Integer Integer Integer Integer -> flomap))
|
||||
(define (raise-size-error name w h w2 h2)
|
||||
(error name "expected same-size flomaps; given sizes ~e×~e and ~e×~e" w h w2 h2))
|
||||
|
||||
(: raise-component-error (Symbol Integer Integer -> flomap))
|
||||
(define (raise-component-error name c1 c2)
|
||||
(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))
|
||||
|
||||
#;
|
||||
(: inline-flomap-lift2* (Symbol (Flonum Flonum -> Flonum)
|
||||
-> (flomap flomap -> flomap)))
|
||||
(define-syntax-rule (inline-flomap-lift2* name f)
|
||||
(λ: ([fm1 : flomap] [fm2 : flomap])
|
||||
(match-define (flomap vs1 c1 w h) fm1)
|
||||
(match-define (flomap vs2 c2 w2 h2) fm2)
|
||||
(cond
|
||||
[(not (and (= w w2) (= h h2))) (raise-size-error name w h w2 h2)]
|
||||
[(= c1 c2) (flomap (inline-build-flvector (* c1 w h)
|
||||
(λ (i) (f (flvector-ref vs1 i)
|
||||
(flvector-ref vs2 i))))
|
||||
c1 w h)]
|
||||
[(= c1 1) (inline-build-flomap
|
||||
c2 w h
|
||||
(λ (k x y i) (f (flvector-ref vs1 (coords->index 1 w 0 x y))
|
||||
(flvector-ref vs2 i))))]
|
||||
[(= c2 1) (inline-build-flomap
|
||||
c1 w h
|
||||
(λ (k x y i) (f (flvector-ref vs1 i)
|
||||
(flvector-ref vs2 (coords->index 1 w 0 x y)))))]
|
||||
[else (raise-component-error name c1 c2)])))
|
||||
|
||||
#;
|
||||
(: inline-flomap-lift2 (Symbol (Flonum Flonum -> Flonum)
|
||||
-> ((U Real flomap) (U Real flomap) -> flomap)))
|
||||
(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)])]))))
|
||||
(λ: ([fm1 : (U Real flomap)] [fm2 : (U Real flomap)])
|
||||
(cond
|
||||
[(and (real? fm1) (real? fm2)) (raise-two-reals-error name 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 ((inline-flomap-lift2* name f) fm1 fm2)])))
|
||||
|
||||
(: flomap-lift2 (Symbol (Flonum Flonum -> Real) -> ((U Real flomap) (U Real flomap) -> flomap)))
|
||||
(define (flomap-lift2 name f)
|
||||
|
|
@ -102,7 +99,7 @@
|
|||
fm))
|
||||
|
||||
(define fmdiv/zero
|
||||
(inline-flomap-lift2 'fmdiv/zero (λ (x y) (if (y . = . 0.0) 0.0 (/ x y)))))
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require racket/flonum
|
||||
(except-in racket/fixnum fl->fx fx->fl)
|
||||
racket/match racket/math
|
||||
(require racket/match racket/math
|
||||
(only-in racket/unsafe/ops unsafe-fx+)
|
||||
"flonum.rkt"
|
||||
"flomap-struct.rkt"
|
||||
"flomap-stats.rkt"
|
||||
|
|
@ -44,17 +43,17 @@
|
|||
(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))))
|
||||
(flvector-set! dst-vs dst-i (flvector-ref src-vs src-i))
|
||||
(k-loop (unsafe-fx+ k 1)))))
|
||||
(x-loop (unsafe-fx+ dst-x 1)))))
|
||||
(y-loop (unsafe-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)
|
||||
[else (define-values (x-min y-min 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))]))
|
||||
|
||||
|
|
@ -196,9 +195,9 @@
|
|||
(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 v0 (flvector-ref vs i0))
|
||||
(define v1 (cond [(x0 . fx= . w-1) 0.0]
|
||||
[else (unsafe-flvector-ref vs (fx+ i0 c))]))
|
||||
[else (flvector-ref vs (unsafe-fx+ i0 c))]))
|
||||
(fl-convex-combination v0 v1 (- scaled-x floor-scaled-x))]))))
|
||||
|
||||
(: flomap-scale*-y/linear (flomap Nonnegative-Flonum Exact-Nonnegative-Integer -> flomap))
|
||||
|
|
@ -215,7 +214,7 @@
|
|||
(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 v0 (flvector-ref vs i0))
|
||||
(define v1 (cond [(y0 . fx= . h-1) 0.0]
|
||||
[else (unsafe-flvector-ref vs (fx+ i0 cw))]))
|
||||
[else (flvector-ref vs (unsafe-fx+ i0 cw))]))
|
||||
(fl-convex-combination v0 v1 (- scaled-y floor-scaled-y))]))))
|
||||
|
|
|
|||
|
|
@ -1,8 +1,6 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require racket/flonum
|
||||
(except-in racket/fixnum fl->fx fx->fl)
|
||||
racket/match
|
||||
(require racket/match
|
||||
"flonum.rkt"
|
||||
"flomap-struct.rkt")
|
||||
|
||||
|
|
@ -25,15 +23,13 @@
|
|||
) ([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)))
|
||||
(: flomap-nonzero-rect (flomap -> (values 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])
|
||||
|
|
@ -41,15 +37,13 @@
|
|||
(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))
|
||||
(cond [(k . fx< . c) (define v (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)))
|
||||
(values x-min y-min x-max y-max)))
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
#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!)
|
||||
(require racket/match
|
||||
(only-in racket/unsafe/ops
|
||||
unsafe-flvector-ref unsafe-flvector-set!
|
||||
unsafe-fx+)
|
||||
"flonum.rkt")
|
||||
|
||||
(provide flomap flomap? flomap-values flomap-components flomap-width flomap-height
|
||||
|
|
@ -86,6 +86,11 @@
|
|||
[(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)]))
|
||||
|
||||
#;
|
||||
(: inline-build-flomap (Integer Integer Integer
|
||||
(Nonnegative-Fixnum Nonnegative-Fixnum Nonnegative-Fixnum
|
||||
Nonnegative-Fixnum -> Flonum)
|
||||
-> flomap))
|
||||
(define-syntax-rule (inline-build-flomap components width height f)
|
||||
(let: ([c : Integer components]
|
||||
[w : Integer width]
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require racket/match racket/math racket/flonum
|
||||
(except-in racket/fixnum fl->fx fx->fl)
|
||||
(require racket/match racket/math
|
||||
(only-in racket/unsafe/ops unsafe-flvector-ref)
|
||||
"flonum.rkt"
|
||||
"flomap-struct.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -1,22 +1,29 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require (for-syntax typed/racket/base)
|
||||
racket/flonum
|
||||
(except-in racket/fixnum fl->fx fx->fl)
|
||||
(rename-in racket/flonum
|
||||
[flvector-ref old:flvector-ref]
|
||||
[flvector-set! old:flvector-set!])
|
||||
(except-in racket/fixnum fl->fx fx->fl) ; these two functions are untyped
|
||||
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!))
|
||||
)
|
||||
(only-in racket/unsafe/ops unsafe-flvector-set! unsafe-fx+))
|
||||
|
||||
(provide (all-defined-out))
|
||||
(provide (all-defined-out)
|
||||
(except-out (all-from-out racket/flonum
|
||||
racket/fixnum)
|
||||
old:flvector-ref
|
||||
old:flvector-set!))
|
||||
|
||||
(define-predicate nonnegative-fixnum? Nonnegative-Fixnum)
|
||||
|
||||
(: unsafe-flvector-ref (FlVector Integer -> Flonum))
|
||||
(define unsafe-flvector-ref flvector-ref)
|
||||
;; This looks stupid, but it avoids an optimization TR does that is actually a pessimization, by
|
||||
;; keeping it from recognizing flvector-ref
|
||||
(: flvector-ref (FlVector Integer -> Flonum))
|
||||
(define flvector-ref old:flvector-ref)
|
||||
|
||||
(: unsafe-flvector-set! (FlVector Integer Flonum -> Void))
|
||||
(define unsafe-flvector-set! flvector-set!)
|
||||
;; Ditto above
|
||||
(: flvector-set! (FlVector Integer Flonum -> Void))
|
||||
(define flvector-set! old:flvector-set!)
|
||||
|
||||
(define-syntax (fl->fx stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -42,9 +49,10 @@
|
|||
(+ sca (* dca (- 1.0 sa))))
|
||||
|
||||
(define-syntax-rule (flgaussian x s)
|
||||
(let: ([x/s : Flonum (fl/ x s)])
|
||||
(let*: ([sigma : Flonum s]
|
||||
[x/s : Flonum (fl/ x sigma)])
|
||||
(/ (exp (* -0.5 (* x/s x/s)))
|
||||
(fl* (sqrt (* 2.0 pi)) s))))
|
||||
(* (sqrt (* 2.0 pi)) sigma))))
|
||||
|
||||
(define-syntax-rule (flsigmoid x)
|
||||
(/ 1.0 (+ 1.0 (exp (fl- 0.0 x)))))
|
||||
|
|
@ -54,7 +62,7 @@
|
|||
(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))
|
||||
(cond [(i . fx< . n) (unsafe-flvector-set! vs i (f i))
|
||||
(loop (unsafe-fx+ i 1))]
|
||||
[else vs]))))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user