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

Refactoring

Browse Source
This commit is contained in:
Neil Toronto 2012-03-03 22:01:08 -07:00
parent a81f7f289a
commit 54c8b51c32
12 changed files with 264 additions and 259 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

162
collects/images/private/deep-flomap-render.rkt
View File

@ -1,8 +1,6 @@
#lang typed/racket/base #lang typed/racket/base
(require racket/flonum (require racket/match racket/math
(except-in racket/fixnum fl->fx fx->fl)
racket/match racket/math
"flonum.rkt" "flonum.rkt"
"flomap.rkt" "flomap.rkt"
"deep-flomap-struct.rkt" "deep-flomap-struct.rkt"
@ -124,21 +122,21 @@
(for*: ([int-y : Integer (in-range y-min y-max)] (for*: ([int-y : Integer (in-range y-min y-max)]
[int-x : Integer (in-range x-min x-max)]) [int-x : Integer (in-range x-min x-max)])
(define i (fx+ int-x (fx* int-y w))) (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) (when (a . > . 0.0)
(define j (fx* 3 i)) (define j (fx* 3 i))
;; altitude and surface normal ;; altitude and surface normal
(define z (unsafe-flvector-ref z-vs i)) (define z (flvector-ref z-vs i))
(define nx (unsafe-flvector-ref normal-vs j)) (define nx (flvector-ref normal-vs j))
(define ny (unsafe-flvector-ref normal-vs (fx+ j 1))) (define ny (flvector-ref normal-vs (fx+ j 1)))
(define nz (unsafe-flvector-ref normal-vs (fx+ j 2))) (define nz (flvector-ref normal-vs (fx+ j 2)))
;; cosine of angle between light and surface normal ;; cosine of angle between light and surface normal
(define n-dot-l (fl3dot nx ny nz lx ly lz)) (define n-dot-l (fl3dot nx ny nz lx ly lz))
;; intensity of incident light (Lambert's cosine law) ;; intensity of incident light (Lambert's cosine law)
(define-values (Ilr Ilg Ilb) (fl3* lr lg lb n-dot-l)) (define-values (Ilr Ilg Ilb) (fl3* lr lg lb n-dot-l))
(unsafe-flvector-set! intensity-vs j Ilr) (flvector-set! intensity-vs j Ilr)
(unsafe-flvector-set! intensity-vs (fx+ j 1) Ilg) (flvector-set! intensity-vs (fx+ j 1) Ilg)
(unsafe-flvector-set! intensity-vs (fx+ j 2) Ilb) (flvector-set! intensity-vs (fx+ j 2) Ilb)
;; diffraction intensity due to specular, diffuse and ambient reflection ;; diffraction intensity due to specular, diffuse and ambient reflection
(cond (cond
[(n-dot-l . > . 0.0) ; does the microfacet face the light? [(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))) (define F (- 1.0 (transmission-intensity n-dot-l 1.0 η2)))
(* Rs F (/ D n-dot-l) (/ G n-dot-v))] (* Rs F (/ D n-dot-l) (/ G n-dot-v))]
[else 0.0])) [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)] (let*-values ([(Idr Idg Idb) (fl3* Ilr Ilg Ilb Rd)]
[(Idr Idg Idb) (fl3+ Idr Idg Idb Rar Rag Rab)]) [(Idr Idg Idb) (fl3+ Idr Idg Idb Rar Rag Rab)])
(unsafe-flvector-set! diffuse-vs j Idr) (flvector-set! diffuse-vs j Idr)
(unsafe-flvector-set! diffuse-vs (fx+ j 1) Idg) (flvector-set! diffuse-vs (fx+ j 1) Idg)
(unsafe-flvector-set! diffuse-vs (fx+ j 2) Idb))] (flvector-set! diffuse-vs (fx+ j 2) Idb))]
[else [else
(unsafe-flvector-set! diffuse-vs j Rar) (flvector-set! diffuse-vs j Rar)
(unsafe-flvector-set! diffuse-vs (fx+ j 1) Rag) (flvector-set! diffuse-vs (fx+ j 1) Rag)
(unsafe-flvector-set! diffuse-vs (fx+ j 2) Rab)]) (flvector-set! diffuse-vs (fx+ j 2) Rab)])
(when (and (Ti . > . 0.0) (n-dot-l . > . 0.0)) (when (and (Ti . > . 0.0) (n-dot-l . > . 0.0))
;; ideal transmission vector ;; ideal transmission vector
@ -186,18 +184,18 @@
;; normalized distance to the surface ;; normalized distance to the surface
(define norm-dist (/ dist opacity-z)) (define norm-dist (/ dist opacity-z))
;; intensity of the light that strikes the surface ;; intensity of the light that strikes the surface
(define r (unsafe-flvector-ref rgb-vs j)) (define r (flvector-ref rgb-vs j))
(define g (unsafe-flvector-ref rgb-vs (fx+ j 1))) (define g (flvector-ref rgb-vs (fx+ j 1)))
(define b (unsafe-flvector-ref rgb-vs (fx+ j 2))) (define b (flvector-ref rgb-vs (fx+ j 2)))
(define-values (Ir Ig Ib) (define-values (Ir Ig Ib)
(values (* T Ilr (absorb-intensity r norm-dist)) (values (* T Ilr (absorb-intensity r norm-dist))
(* T Ilg (absorb-intensity g norm-dist)) (* T Ilg (absorb-intensity g norm-dist))
(* T Ilb (absorb-intensity b norm-dist)))) (* T Ilb (absorb-intensity b norm-dist))))
(unsafe-flvector-set! sx-vs i sx) (flvector-set! sx-vs i sx)
(unsafe-flvector-set! sy-vs i sy) (flvector-set! sy-vs i sy)
(unsafe-flvector-set! Irgb-vs j Ir) (flvector-set! Irgb-vs j Ir)
(unsafe-flvector-set! Irgb-vs (fx+ j 1) Ig) (flvector-set! Irgb-vs (fx+ j 1) Ig)
(unsafe-flvector-set! Irgb-vs (fx+ j 2) Ib))))) (flvector-set! Irgb-vs (fx+ j 2) Ib)))))
(define diffracted-fm (fm+ (fm* (flomap-blur diffuse-fm diffuse-blur) (define diffracted-fm (fm+ (fm* (flomap-blur diffuse-fm diffuse-blur)
rgb-fm) rgb-fm)
@ -212,21 +210,21 @@
(for*: ([int-y : Integer (in-range y-min y-max)] (for*: ([int-y : Integer (in-range y-min y-max)]
[int-x : Integer (in-range x-min x-max)]) [int-x : Integer (in-range x-min x-max)])
(define i (fx+ int-x (fx* int-y w))) (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) (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 j (fx* 3 i))
(define r (unsafe-flvector-ref rgb-vs j)) (define r (flvector-ref rgb-vs j))
(define g (unsafe-flvector-ref rgb-vs (fx+ j 1))) (define g (flvector-ref rgb-vs (fx+ j 1)))
(define b (unsafe-flvector-ref rgb-vs (fx+ j 2))) (define b (flvector-ref rgb-vs (fx+ j 2)))
(define norm-dist (/ z opacity-z)) (define norm-dist (/ z opacity-z))
(define-values (Ir Ig Ib) (define-values (Ir Ig Ib)
(values (* Tar (absorb-intensity r norm-dist)) (values (* Tar (absorb-intensity r norm-dist))
(* Tag (absorb-intensity g norm-dist)) (* Tag (absorb-intensity g norm-dist))
(* Tab (absorb-intensity b norm-dist)))) (* Tab (absorb-intensity b norm-dist))))
(unsafe-flvector-set! ambient-shadow-vs j Ir) (flvector-set! ambient-shadow-vs j Ir)
(unsafe-flvector-set! ambient-shadow-vs (fx+ j 1) Ig) (flvector-set! ambient-shadow-vs (fx+ j 1) Ig)
(unsafe-flvector-set! ambient-shadow-vs (fx+ j 2) Ib)))) (flvector-set! ambient-shadow-vs (fx+ j 2) Ib))))
;; cast approximate shadow volumes ;; cast approximate shadow volumes
(define shadow-fm (flomap-blur ambient-shadow-fm (* ambient-transmission-blur-fraction (min w h)))) (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 i01 (fx+ i00 1))
(define i10 (fx+ i00 w)) (define i10 (fx+ i00 w))
(define i11 (fx+ i10 1)) (define i11 (fx+ i10 1))
(define sx00 (unsafe-flvector-ref sx-vs i00)) (define sx00 (flvector-ref sx-vs i00))
(define sx01 (unsafe-flvector-ref sx-vs i01)) (define sx01 (flvector-ref sx-vs i01))
(define sx10 (unsafe-flvector-ref sx-vs i10)) (define sx10 (flvector-ref sx-vs i10))
(define sx11 (unsafe-flvector-ref sx-vs i11)) (define sx11 (flvector-ref sx-vs i11))
(when (and (flrational? sx00) (flrational? sx01) (when (and (flrational? sx00) (flrational? sx01)
(flrational? sx10) (flrational? sx11)) (flrational? sx10) (flrational? sx11))
(define sy00 (unsafe-flvector-ref sy-vs i00)) (define sy00 (flvector-ref sy-vs i00))
(define sy01 (unsafe-flvector-ref sy-vs i01)) (define sy01 (flvector-ref sy-vs i01))
(define sy10 (unsafe-flvector-ref sy-vs i10)) (define sy10 (flvector-ref sy-vs i10))
(define sy11 (unsafe-flvector-ref sy-vs i11)) (define sy11 (flvector-ref sy-vs i11))
(define sx-min (min sx00 sx01 sx10 sx11)) (define sx-min (min sx00 sx01 sx10 sx11))
(define sy-min (min sy00 sy01 sy10 sy11)) (define sy-min (min sy00 sy01 sy10 sy11))
(define sx-max (max sx00 sx01 sx10 sx11)) (define sx-max (max sx00 sx01 sx10 sx11))
@ -274,24 +272,24 @@
(define j01 (fx* 3 i01)) (define j01 (fx* 3 i01))
(define j10 (fx* 3 i10)) (define j10 (fx* 3 i10))
(define j11 (fx* 3 i11)) (define j11 (fx* 3 i11))
(define r (* 0.25 (+ (unsafe-flvector-ref Irgb-vs j00) (define r (* 0.25 (+ (flvector-ref Irgb-vs j00)
(unsafe-flvector-ref Irgb-vs j01) (flvector-ref Irgb-vs j01)
(unsafe-flvector-ref Irgb-vs j10) (flvector-ref Irgb-vs j10)
(unsafe-flvector-ref Irgb-vs j11)))) (flvector-ref Irgb-vs j11))))
(define g (* 0.25 (+ (unsafe-flvector-ref Irgb-vs (fx+ j00 1)) (define g (* 0.25 (+ (flvector-ref Irgb-vs (fx+ j00 1))
(unsafe-flvector-ref Irgb-vs (fx+ j01 1)) (flvector-ref Irgb-vs (fx+ j01 1))
(unsafe-flvector-ref Irgb-vs (fx+ j10 1)) (flvector-ref Irgb-vs (fx+ j10 1))
(unsafe-flvector-ref Irgb-vs (fx+ j11 1))))) (flvector-ref Irgb-vs (fx+ j11 1)))))
(define b (* 0.25 (+ (unsafe-flvector-ref Irgb-vs (fx+ j00 2)) (define b (* 0.25 (+ (flvector-ref Irgb-vs (fx+ j00 2))
(unsafe-flvector-ref Irgb-vs (fx+ j01 2)) (flvector-ref Irgb-vs (fx+ j01 2))
(unsafe-flvector-ref Irgb-vs (fx+ j10 2)) (flvector-ref Irgb-vs (fx+ j10 2))
(unsafe-flvector-ref Irgb-vs (fx+ j11 2))))) (flvector-ref Irgb-vs (fx+ j11 2)))))
;; precalculate the Gaussian kernel for the x direction ;; precalculate the Gaussian kernel for the x direction
(for ([dx (in-range x-size)]) (for ([dx (in-range x-size)])
(define x (fx+ dx x-min)) (define x (fx+ dx x-min))
(define d (/ (- (+ 0.5 (fx->fl x)) sx-mid) sx-stddev)) (define d (/ (- (+ 0.5 (fx->fl x)) sx-mid) sx-stddev))
(define kx (exp (* -0.5 (* d d)))) (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 ;; 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 ;; 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) ;; 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 y (fx+ dy y-min))
(define d (/ (- (+ 0.5 (fx->fl y)) sy-mid) sy-stddev)) (define d (/ (- (+ 0.5 (fx->fl y)) sy-mid) sy-stddev))
(define ky (exp (* -0.5 (* d d)))) (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 ;; normalization constant for a 2D Gaussian kernel
(define c (* 2.0 pi sx-stddev sy-stddev)) (define c (* 2.0 pi sx-stddev sy-stddev))
;; cast the approximate shadow volume ;; cast the approximate shadow volume
(let y-loop ([dy 0]) (let y-loop ([dy 0])
(when (dy . fx< . y-size) (when (dy . fx< . y-size)
(define ky (unsafe-flvector-ref kys dy)) (define ky (flvector-ref kys dy))
(cond [(ky . > . 0.1) (cond [(ky . > . 0.1)
(define a (/ ky c)) (define a (/ ky c))
(define Ir (* r a)) (define Ir (* r a))
@ -314,16 +312,16 @@
(define i (fx* 3 (fx+ x-min (fx* (fx+ dy y-min) w)))) (define i (fx* 3 (fx+ x-min (fx* (fx+ dy y-min) w))))
(let x-loop ([dx 0] [i i]) (let x-loop ([dx 0] [i i])
(cond [(dx . fx< . x-size) (cond [(dx . fx< . x-size)
(define kx (unsafe-flvector-ref kxs dx)) (define kx (flvector-ref kxs dx))
(when (kx . > . 0.1) (when (kx . > . 0.1)
(unsafe-flvector-set! (flvector-set!
shadow-vs i (+ (* Ir kx) (unsafe-flvector-ref shadow-vs i))) shadow-vs i (+ (* Ir kx) (flvector-ref shadow-vs i)))
(define i1 (fx+ i 1)) (define i1 (fx+ i 1))
(unsafe-flvector-set! (flvector-set!
shadow-vs i1 (+ (* Ig kx) (unsafe-flvector-ref shadow-vs i1))) shadow-vs i1 (+ (* Ig kx) (flvector-ref shadow-vs i1)))
(define i2 (fx+ i 2)) (define i2 (fx+ i 2))
(unsafe-flvector-set! (flvector-set!
shadow-vs i2 (+ (* Ib kx) (unsafe-flvector-ref shadow-vs i2)))) shadow-vs i2 (+ (* Ib kx) (flvector-ref shadow-vs i2))))
(x-loop (fx+ 1 dx) (fx+ 3 i))] (x-loop (fx+ 1 dx) (fx+ 3 i))]
[else [else
(y-loop (fx+ 1 dy))]))] (y-loop (fx+ 1 dy))]))]
@ -374,13 +372,13 @@
(for*: ([int-y : Integer (in-range y-min y-max)] (for*: ([int-y : Integer (in-range y-min y-max)]
[int-x : Integer (in-range x-min x-max)]) [int-x : Integer (in-range x-min x-max)])
(define i (fx+ int-x (fx* int-y w))) (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) (when (a . > . 0.0)
(define j (fx* 3 i)) (define j (fx* 3 i))
;; surface normal ;; surface normal
(define nx (unsafe-flvector-ref normal-vs j)) (define nx (flvector-ref normal-vs j))
(define ny (unsafe-flvector-ref normal-vs (fx+ j 1))) (define ny (flvector-ref normal-vs (fx+ j 1)))
(define nz (unsafe-flvector-ref normal-vs (fx+ j 2))) (define nz (flvector-ref normal-vs (fx+ j 2)))
;; cosine of angle between viewer and surface normal ;; cosine of angle between viewer and surface normal
;; with gradient inferred from z flomap, this is always > 0.0 ;; with gradient inferred from z flomap, this is always > 0.0
(define cos-i nz) (define cos-i nz)
@ -391,7 +389,7 @@
;; surface coordinates ;; surface coordinates
(define x (+ 0.5 (fx->fl int-x))) (define x (+ 0.5 (fx->fl int-x)))
(define y (+ 0.5 (fx->fl int-y))) (define y (+ 0.5 (fx->fl int-y)))
(define z (unsafe-flvector-ref z-vs i)) (define z (flvector-ref z-vs i))
;; reflection ;; reflection
(when (and (Ri . > . 0.0) (when (and (Ri . > . 0.0)
(int-x . fx> . 0) (int-x . fx< . w-1) (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 cdist (fl3dist sx sy sz x-mid y-mid 0.0))
(define v (flsigmoid (* 0.25 (- (* 4.5 z-size) cdist)))) (define v (flsigmoid (* 0.25 (- (* 4.5 z-size) cdist))))
(let-values ([(r g b) (fl3* Irr Irg Irb (* R v))]) (let-values ([(r g b) (fl3* Irr Irg Irb (* R v))])
(unsafe-flvector-set! reflected-vs j r) (flvector-set! reflected-vs j r)
(unsafe-flvector-set! reflected-vs (fx+ j 1) g) (flvector-set! reflected-vs (fx+ j 1) g)
(unsafe-flvector-set! reflected-vs (fx+ j 2) b)))) (flvector-set! reflected-vs (fx+ j 2) b))))
;; transmission (refraction) ;; transmission (refraction)
(when (Ti . > . 0.0) (when (Ti . > . 0.0)
(define snx (unsafe-flvector-ref normal-vs j)) (define snx (flvector-ref normal-vs j))
(define sny (unsafe-flvector-ref normal-vs (fx+ j 1))) (define sny (flvector-ref normal-vs (fx+ j 1)))
(define snz (unsafe-flvector-ref normal-vs (fx+ j 2))) (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)) (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 ;; sz = z + dist * tz, so dist = (sz - z) / tz
(define dist (/ (- 0.0 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 ;; intensities of each r g b by the time the light emerges from the surface
(define-values (r g b) (define-values (r g b)
;; colors represent absorption rates ;; colors represent absorption rates
(let ([r (unsafe-flvector-ref rgb-vs j)] (let ([r (flvector-ref rgb-vs j)]
[g (unsafe-flvector-ref rgb-vs (fx+ j 1))] [g (flvector-ref rgb-vs (fx+ j 1))]
[b (unsafe-flvector-ref rgb-vs (fx+ j 2))]) [b (flvector-ref rgb-vs (fx+ j 2))])
(values (* T sr (absorb-intensity r norm-dist)) (values (* T sr (absorb-intensity r norm-dist))
(* T sg (absorb-intensity g norm-dist)) (* T sg (absorb-intensity g norm-dist))
(* T sb (absorb-intensity b norm-dist))))) (* T sb (absorb-intensity b norm-dist)))))
(unsafe-flvector-set! transmitted-vs j r) (flvector-set! transmitted-vs j r)
(unsafe-flvector-set! transmitted-vs (fx+ j 1) g) (flvector-set! transmitted-vs (fx+ j 1) g)
(unsafe-flvector-set! transmitted-vs (fx+ j 2) b)))))) (flvector-set! transmitted-vs (fx+ j 2) b))))))
(values reflected-fm transmitted-fm)) (values reflected-fm transmitted-fm))
@ -475,7 +473,7 @@
(define normal-fm (flomap-gradient-normal z-fm)) (define normal-fm (flomap-gradient-normal z-fm))
(define bg-fm (if background-fm (prep-background background-fm w h) #f)) (define bg-fm (if background-fm (prep-background background-fm w h) #f))
(define-values (x-min y-min x-max y-max) (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)) (values (max 0 (- x-min 1)) (max 0 (- y-min 1))
(min w (+ x-max 1)) (min h (+ y-max 1))))) (min w (+ x-max 1)) (min h (+ y-max 1)))))

71
collects/images/private/deep-flomap-struct.rkt
View File

@ -1,8 +1,6 @@
#lang typed/racket/base #lang typed/racket/base
(require racket/flonum (require racket/match racket/math
(except-in racket/fixnum fx->fl fl->fx)
racket/match racket/math
"flonum.rkt" "flonum.rkt"
"flomap.rkt") "flomap.rkt")
@ -201,7 +199,7 @@
(: deep-flomap-trim (deep-flomap -> deep-flomap)) (: deep-flomap-trim (deep-flomap -> deep-flomap))
(define (deep-flomap-trim dfm) (define (deep-flomap-trim dfm)
(define-values (w h) (deep-flomap-size 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))) (flomap-nonzero-rect (deep-flomap-alpha dfm)))
(deep-flomap-inset dfm (- x-min) (- y-min) (- x-max w) (- y-max h))) (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 z1-vs (flomap-values z1-fm))
(define z2-vs (flomap-values z2-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)]) (let ([x (fx- x dx)] [y (fx- y dy)])
(cond [(and (x . fx>= . 0) (x . fx< . w) (y . fx>= . 0) (y . fx< . h)) (cond [(and (x . fx>= . 0) (x . fx< . w) (y . fx>= . 0) (y . fx< . h))
(define i (fx+ x (fx* y w))) (define i (fx+ x (fx* y w)))
(define j (fx* 4 i)) (define j (fx* 4 i))
(values (unsafe-flvector-ref argb-vs j) (values (flvector-ref argb-vs j)
(unsafe-flvector-ref argb-vs (fx+ j 1)) (flvector-ref argb-vs (fx+ j 1))
(unsafe-flvector-ref argb-vs (fx+ j 2)) (flvector-ref argb-vs (fx+ j 2))
(unsafe-flvector-ref argb-vs (fx+ j 3)) (flvector-ref argb-vs (fx+ j 3))
(unsafe-flvector-ref z-vs i))] (flvector-ref z-vs i))]
[else [else
(values 0.0 0.0 0.0 0.0 0.0)]))) (values 0.0 0.0 0.0 0.0 0.0)])))
@ -297,11 +297,11 @@
(define i (fx+ x (fx* y w))) (define i (fx+ x (fx* y w)))
(define j (fx* 4 i)) (define j (fx* 4 i))
(unsafe-flvector-set! argb-vs j (fl-alpha-blend a1 a2 a2)) (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)) (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)) (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)) (flvector-set! argb-vs (fx+ j 3) (fl-alpha-blend b1 b2 a2))
(unsafe-flvector-set! z-vs i (case z-mode (flvector-set! z-vs i (case z-mode
[(replace) (fl-alpha-blend z1 z2 a2)] [(replace) (fl-alpha-blend z1 z2 a2)]
[else (+ z1 z2)])) [else (+ z1 z2)]))
(x-loop (fx+ x 1))] (x-loop (fx+ x 1))]
@ -322,16 +322,20 @@
(match-define (flomap z1-vs 1 z1-w z1-h) z1-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) (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)]) (let ([x (fx- x dx)] [y (fx- y dy)])
(cond [(and (x . fx>= . 0) (x . fx< . w) (y . fx>= . 0) (y . fx< . h)) (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]))) [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)]) (let ([x (fx- x dx)] [y (fx- y dy)])
(cond [(and (x . fx>= . 0) (x . fx< . w) (y . fx>= . 0) (y . fx< . h)) (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]))) [else 0.0])))
(define z1-max -inf.0) (define z1-max -inf.0)
@ -369,18 +373,21 @@
(define u2-vs (flomap-values u2-fm)) (define u2-vs (flomap-values u2-fm))
(define v2-vs (flomap-values v2-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)]) (let ([x (fx- x dx)] [y (fx- y dy)])
(cond [(and (x . fx>= . 0) (x . fx< . w) (y . fx>= . 0) (y . fx< . h)) (cond [(and (x . fx>= . 0) (x . fx< . w) (y . fx>= . 0) (y . fx< . h))
(define i (fx+ x (fx* y w))) (define i (fx+ x (fx* y w)))
(define j (fx* 4 i)) (define j (fx* 4 i))
(values (unsafe-flvector-ref argb-vs j) (values (flvector-ref argb-vs j)
(unsafe-flvector-ref argb-vs (fx+ j 1)) (flvector-ref argb-vs (fx+ j 1))
(unsafe-flvector-ref argb-vs (fx+ j 2)) (flvector-ref argb-vs (fx+ j 2))
(unsafe-flvector-ref argb-vs (fx+ j 3)) (flvector-ref argb-vs (fx+ j 3))
(unsafe-flvector-ref z-vs i) (flvector-ref z-vs i)
(unsafe-flvector-ref u-vs i) (flvector-ref u-vs i)
(unsafe-flvector-ref v-vs i))] (flvector-ref v-vs i))]
[else [else
(values 0.0 0.0 0.0 0.0 0.0 0.0 0.0)]))) (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 i (fx+ x (fx* y w)))
(define j (fx* 4 i)) (define j (fx* 4 i))
(unsafe-flvector-set! argb-vs j (fl-convex-combination a1 a2 α)) (flvector-set! argb-vs j (fl-convex-combination a1 a2 α))
(unsafe-flvector-set! argb-vs (fx+ j 1) (fl-convex-combination r1 r2 α)) (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 α)) (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 α)) (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! z-vs i (fl-convex-combination z1 z2 α))
(x-loop (fx+ x 1))] (x-loop (fx+ x 1))]
[else [else
(y-loop (fx+ y 1))])))) (y-loop (fx+ y 1))]))))

43
collects/images/private/flomap-blur.rkt
View File

@ -1,8 +1,7 @@
#lang typed/racket/base #lang typed/racket/base
(require racket/flonum (require racket/match racket/math
(except-in racket/fixnum fl->fx fx->fl) (only-in racket/unsafe/ops unsafe-flvector-ref)
racket/match racket/math
"flonum.rkt" "flonum.rkt"
"flomap-struct.rkt") "flomap-struct.rkt")
@ -76,11 +75,11 @@
(define sum (define sum
(let: loop : Flonum ([i : Fixnum 0] [sum : Flonum 0.0]) (let: loop : Flonum ([i : Fixnum 0] [sum : Flonum 0.0])
(cond [(i . fx< . n) (define v (flgaussian (fx->fl (fx+ i mn)) σ)) (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))] (loop (fx+ i 1) (+ sum v))]
[else sum]))) [else sum])))
(let: loop : FlVector ([i : Integer 0]) (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))] (loop (fx+ i 1))]
[else ys]))) [else ys])))
@ -103,11 +102,11 @@
(cond [(k . fx< . c) (cond [(k . fx< . c)
(define j00 (coords->index c w+1 k x y)) (define j00 (coords->index c w+1 k x y))
(define j01 (fx+ j00 c*w+1)) (define j01 (fx+ j00 c*w+1))
(unsafe-flvector-set! new-vs (fx+ j01 c) (flvector-set! new-vs (fx+ j01 c)
(- (+ (unsafe-flvector-ref vs i) (- (+ (flvector-ref vs i)
(unsafe-flvector-ref new-vs j01) (flvector-ref new-vs j01)
(unsafe-flvector-ref new-vs (fx+ j00 c))) (flvector-ref new-vs (fx+ j00 c)))
(unsafe-flvector-ref new-vs j00))) (flvector-ref new-vs j00)))
(k-loop (fx+ k 1) (fx+ i 1))] (k-loop (fx+ k 1) (fx+ i 1))]
[else (x-loop (fx+ x 1) i)]))] [else (x-loop (fx+ x 1) i)]))]
[else (y-loop (fx+ y 1) i)])))) [else (y-loop (fx+ y 1) i)]))))
@ -126,8 +125,8 @@
(cond [(k . fx< . c) (cond [(k . fx< . c)
(define j0 (coords->index c w+1 k x y)) (define j0 (coords->index c w+1 k x y))
(define j1 (fx+ j0 c)) (define j1 (fx+ j0 c))
(unsafe-flvector-set! new-vs j1 (+ (unsafe-flvector-ref vs i) (flvector-set! new-vs j1 (+ (flvector-ref vs i)
(unsafe-flvector-ref new-vs j0))) (flvector-ref new-vs j0)))
(k-loop (fx+ k 1) (fx+ i 1))] (k-loop (fx+ k 1) (fx+ i 1))]
[else (x-loop (fx+ x 1) i)]))] [else (x-loop (fx+ x 1) i)]))]
[else (y-loop (fx+ y 1) i)])))) [else (y-loop (fx+ y 1) i)]))))
@ -147,8 +146,8 @@
(cond [(k . fx< . c) (cond [(k . fx< . c)
(define j0 (coords->index c w k x y)) (define j0 (coords->index c w k x y))
(define j1 (fx+ j0 cw)) (define j1 (fx+ j0 cw))
(unsafe-flvector-set! new-vs j1 (+ (unsafe-flvector-ref vs j0) (flvector-set! new-vs j1 (+ (flvector-ref vs j0)
(unsafe-flvector-ref new-vs j0))) (flvector-ref new-vs j0)))
(k-loop (fx+ k 1))] (k-loop (fx+ k 1))]
[else (x-loop (fx+ x 1))]))] [else (x-loop (fx+ x 1))]))]
[else (y-loop (fx+ y 1))])))) [else (y-loop (fx+ y 1))]))))
@ -164,10 +163,10 @@
(define x2 (fxmax 0 (fxmin x-end w-1))) (define x2 (fxmax 0 (fxmin x-end w-1)))
(define y1 (fxmax 0 (fxmin y-start h-1))) (define y1 (fxmax 0 (fxmin y-start h-1)))
(define y2 (fxmax 0 (fxmin y-end h-1))) (define y2 (fxmax 0 (fxmin y-end h-1)))
(- (+ (unsafe-flvector-ref vs (coords->index c w k x1 y1)) (- (+ (flvector-ref vs (coords->index c w k x1 y1))
(unsafe-flvector-ref vs (coords->index c w k x2 y2))) (flvector-ref vs (coords->index c w k x2 y2)))
(+ (unsafe-flvector-ref vs (coords->index c w k x1 y2)) (+ (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 x2 y1)))))
(: raw-flomap-integral-x-sum (FlVector Integer Integer (: raw-flomap-integral-x-sum (FlVector Integer Integer
Integer Integer Integer Integer -> Flonum)) Integer Integer Integer Integer -> Flonum))
@ -175,8 +174,8 @@
(define w-1 (fx- w 1)) (define w-1 (fx- w 1))
(define x1 (fxmax 0 (fxmin x-start w-1))) (define x1 (fxmax 0 (fxmin x-start w-1)))
(define x2 (fxmax 0 (fxmin x-end w-1))) (define x2 (fxmax 0 (fxmin x-end w-1)))
(- (unsafe-flvector-ref vs (coords->index c w k x2 y)) (- (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 x1 y))))
(: raw-flomap-integral-y-sum (FlVector Integer Integer Integer (: raw-flomap-integral-y-sum (FlVector Integer Integer Integer
Integer Integer Integer Integer -> Flonum)) Integer Integer Integer Integer -> Flonum))
@ -184,8 +183,8 @@
(define h-1 (fx- h 1)) (define h-1 (fx- h 1))
(define y1 (fxmax 0 (fxmin y-start h-1))) (define y1 (fxmax 0 (fxmin y-start h-1)))
(define y2 (fxmax 0 (fxmin y-end h-1))) (define y2 (fxmax 0 (fxmin y-end h-1)))
(- (unsafe-flvector-ref vs (coords->index c w k x y2)) (- (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 y1))))
;; =================================================================================================== ;; ===================================================================================================
;; Box blur ;; Box blur

24
collects/images/private/flomap-composite.rkt
View File

@ -1,8 +1,6 @@
#lang typed/racket/base #lang typed/racket/base
(require racket/flonum (require racket/match
(except-in racket/fixnum fl->fx fx->fl)
racket/match
"flonum.rkt" "flonum.rkt"
"flomap-struct.rkt") "flomap-struct.rkt")
@ -33,14 +31,16 @@
(define w (fxmax (fx+ dx1 w1) (fx+ dx2 w2))) (define w (fxmax (fx+ dx1 w1) (fx+ dx2 w2)))
(define h (fxmax (fx+ dy1 h1) (fx+ dy2 h2))) (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)]) (let ([x (fx- x dx)] [y (fx- y dy)])
(cond [(and (x . fx>= . 0) (x . fx< . w) (y . fx>= . 0) (y . fx< . h)) (cond [(and (x . fx>= . 0) (x . fx< . w) (y . fx>= . 0) (y . fx< . h))
(define i (coords->index 4 w 0 x y)) (define i (coords->index 4 w 0 x y))
(values (unsafe-flvector-ref argb-vs i) (values (flvector-ref argb-vs i)
(unsafe-flvector-ref argb-vs (fx+ i 1)) (flvector-ref argb-vs (fx+ i 1))
(unsafe-flvector-ref argb-vs (fx+ i 2)) (flvector-ref argb-vs (fx+ i 2))
(unsafe-flvector-ref argb-vs (fx+ i 3)))] (flvector-ref argb-vs (fx+ i 3)))]
[else (values 0.0 0.0 0.0 0.0)]))) [else (values 0.0 0.0 0.0 0.0)])))
(define argb-vs (make-flvector (* 4 w h))) (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 (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-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)) (define i (coords->index 4 w 0 x y))
(unsafe-flvector-set! argb-vs i (fl-alpha-blend a1 a2 a2)) (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)) (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)) (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 (fx+ i 3) (fl-alpha-blend b1 b2 a2))
(x-loop (fx+ x 1))] (x-loop (fx+ x 1))]
[else (y-loop (fx+ y 1))])))) [else (y-loop (fx+ y 1))]))))
(flomap argb-vs 4 w h))])) (flomap argb-vs 4 w h))]))

3
collects/images/private/flomap-effects.rkt
View File

@ -1,7 +1,6 @@
#lang typed/racket/base #lang typed/racket/base
(require racket/flonum racket/math racket/match racket/list (require racket/math racket/match racket/list
(except-in racket/fixnum fl->fx fx->fl)
"flonum.rkt" "flonum.rkt"
"flomap-struct.rkt" "flomap-struct.rkt"
"flomap-pointwise.rkt" "flomap-pointwise.rkt"

15
collects/images/private/flomap-gradient.rkt
View File

@ -1,8 +1,7 @@
#lang typed/racket/base #lang typed/racket/base
(require racket/flonum (require racket/match
(except-in racket/fixnum fl->fx fx->fl) (only-in racket/unsafe/ops unsafe-flvector-ref)
racket/match
"flonum.rkt" "flonum.rkt"
"flomap-struct.rkt") "flomap-struct.rkt")
@ -76,11 +75,11 @@
(match-define (flomap dy-vs 1 _w _h) dy-fm) (match-define (flomap dy-vs 1 _w _h) dy-fm)
(define normal-vs (make-flvector (* 3 w h))) (define normal-vs (make-flvector (* 3 w h)))
(for ([i (in-range (* w h))]) (for ([i (in-range (* w h))])
(define dx (unsafe-flvector-ref dx-vs i)) (define dx (flvector-ref dx-vs i))
(define dy (unsafe-flvector-ref dy-vs i)) (define dy (flvector-ref dy-vs i))
(define-values (nx ny nz) (fl3normalize (- dx) (- dy) 2.0)) (define-values (nx ny nz) (fl3normalize (- dx) (- dy) 2.0))
(define j (fx* 3 i)) (define j (fx* 3 i))
(unsafe-flvector-set! normal-vs j nx) (flvector-set! normal-vs j nx)
(unsafe-flvector-set! normal-vs (fx+ j 1) ny) (flvector-set! normal-vs (fx+ j 1) ny)
(unsafe-flvector-set! normal-vs (fx+ j 2) nz)) (flvector-set! normal-vs (fx+ j 2) nz))
(flomap normal-vs 3 w h)) (flomap normal-vs 3 w h))

99
collects/images/private/flomap-pointwise.rkt
View File

@ -1,86 +1,83 @@
#lang typed/racket/base #lang typed/racket/base
(require racket/flonum (require racket/match racket/math
(except-in racket/fixnum fl->fx fx->fl)
racket/match racket/math
"flonum.rkt" "flonum.rkt"
"flomap-struct.rkt" "flomap-struct.rkt"
"flomap-stats.rkt") "flomap-stats.rkt")
(provide flomap-lift flomap-lift2 inline-flomap-lift inline-flomap-lift2 (provide flomap-lift flomap-lift2 inline-flomap-lift inline-flomap-lift2
fmneg fmabs fmsqr fmsin fmcos fmtan fmlog fmexp fmsqrt fmasin fmacos fmatan fmsqrt fm+ fm- fm* fm/ fmmin fmmax
fmround fmfloor fmceiling fmtruncate fmzero
fm+ fm- fm* fm/ fmmin fmmax
flomap-normalize flomap-multiply-alpha flomap-divide-alpha) flomap-normalize flomap-multiply-alpha flomap-divide-alpha)
;; =================================================================================================== ;; ===================================================================================================
;; Unary ;; Unary
;(: inline-flomap-lift ((Flonum -> Flonum) -> (flomap -> flomap)))
(define-syntax-rule (inline-flomap-lift f) (define-syntax-rule (inline-flomap-lift f)
(λ: ([fm : flomap]) (λ: ([fm : flomap])
(match-define (flomap vs c w h) fm) (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))) c w h)))
(: flomap-lift ((Flonum -> Real) -> (flomap -> flomap))) (: flomap-lift ((Flonum -> Real) -> (flomap -> flomap)))
(define (flomap-lift op) (define (flomap-lift op)
(inline-flomap-lift (λ (x) (exact->inexact (op x))))) (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 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 ;; 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) (define-syntax-rule (inline-flomap-lift2 name f)
(let: ()
(λ: ([fm1 : (U Real flomap)] [fm2 : (U Real flomap)]) (λ: ([fm1 : (U Real flomap)] [fm2 : (U Real flomap)])
(cond (cond
[(and (real? fm1) (real? fm2)) [(and (real? fm1) (real? fm2)) (raise-two-reals-error name fm1 fm2)]
(error name "expected at least one flomap argument; given ~e and ~e" fm1 fm2)]
[(real? fm1) (let ([fm1 (exact->inexact fm1)]) [(real? fm1) (let ([fm1 (exact->inexact fm1)])
((inline-flomap-lift (λ (v) (f fm1 v))) fm2))] ((inline-flomap-lift (λ (v) (f fm1 v))) fm2))]
[(real? fm2) (let ([fm2 (exact->inexact fm2)]) [(real? fm2) (let ([fm2 (exact->inexact fm2)])
((inline-flomap-lift (λ (v) (f v fm2))) fm1))] ((inline-flomap-lift (λ (v) (f v fm2))) fm1))]
[else [else ((inline-flomap-lift2* name f) fm1 fm2)])))
(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))) (: flomap-lift2 (Symbol (Flonum Flonum -> Real) -> ((U Real flomap) (U Real flomap) -> flomap)))
(define (flomap-lift2 name f) (define (flomap-lift2 name f)
@ -102,7 +99,7 @@
fm)) fm))
(define fmdiv/zero (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)) (: flomap-divide-alpha (flomap -> flomap))
(define (flomap-divide-alpha fm) (define (flomap-divide-alpha fm)

23
collects/images/private/flomap-resize.rkt
View File

@ -1,8 +1,7 @@
#lang typed/racket/base #lang typed/racket/base
(require racket/flonum (require racket/match racket/math
(except-in racket/fixnum fl->fx fx->fl) (only-in racket/unsafe/ops unsafe-fx+)
racket/match racket/math
"flonum.rkt" "flonum.rkt"
"flomap-struct.rkt" "flomap-struct.rkt"
"flomap-stats.rkt" "flomap-stats.rkt"
@ -44,17 +43,17 @@
(when (k . fx< . c) (when (k . fx< . c)
(define src-i (coords->index c src-w k src-x src-y)) (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)) (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)) (flvector-set! dst-vs dst-i (flvector-ref src-vs src-i))
(k-loop (fx+ k 1))))) (k-loop (unsafe-fx+ k 1)))))
(x-loop (fx+ dst-x 1))))) (x-loop (unsafe-fx+ dst-x 1)))))
(y-loop (fx+ dst-y 1)))) (y-loop (unsafe-fx+ dst-y 1))))
(flomap dst-vs c dst-w dst-h)])])])) (flomap dst-vs c dst-w dst-h)])])]))
(: flomap-trim (flomap -> flomap)) (: flomap-trim (flomap -> flomap))
(define (flomap-trim fm) (define (flomap-trim fm)
(match-define (flomap _ c w h) fm) (match-define (flomap _ c w h) fm)
(cond [(c . = . 0) (make-flomap 0 0 0)] (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-nonzero-rect (flomap-ref-component fm 0)))
(flomap-inset fm (- x-min) (- y-min) (- x-max w) (- y-max h))])) (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] (cond [(or (x0 . fx< . 0) (x0 . fx>= . w)) 0.0]
[else [else
(define i0 (coords->index c w k x0 y)) (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] (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))])))) (fl-convex-combination v0 v1 (- scaled-x floor-scaled-x))]))))
(: flomap-scale*-y/linear (flomap Nonnegative-Flonum Exact-Nonnegative-Integer -> flomap)) (: 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] (cond [(or (y0 . fx< . 0) (y0 . fx>= . h)) 0.0]
[else [else
(define i0 (coords->index c w k x y0)) (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] (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))])))) (fl-convex-combination v0 v1 (- scaled-y floor-scaled-y))]))))

16
collects/images/private/flomap-stats.rkt
View File

@ -1,8 +1,6 @@
#lang typed/racket/base #lang typed/racket/base
(require racket/flonum (require racket/match
(except-in racket/fixnum fl->fx fx->fl)
racket/match
"flonum.rkt" "flonum.rkt"
"flomap-struct.rkt") "flomap-struct.rkt")
@ -25,15 +23,13 @@
) ([v : Flonum (in-flvector (flomap-values fm))]) ) ([v : Flonum (in-flvector (flomap-values fm))])
(values (min v-min v) (max v-max v)))) (values (min v-min v) (max v-max v))))
(: flomap-nonzero-rect (flomap -> (values Nonnegative-Fixnum Nonnegative-Fixnum Nonnegative-Fixnum (: flomap-nonzero-rect (flomap -> (values Nonnegative-Fixnum Nonnegative-Fixnum
Nonnegative-Fixnum Nonnegative-Fixnum Nonnegative-Fixnum))) Nonnegative-Fixnum Nonnegative-Fixnum)))
(define (flomap-nonzero-rect fm) (define (flomap-nonzero-rect fm)
(match-define (flomap vs c w h) fm) (match-define (flomap vs c w h) fm)
(with-asserts ([c nonnegative-fixnum?] [w nonnegative-fixnum?] [h nonnegative-fixnum?]) (with-asserts ([c nonnegative-fixnum?] [w nonnegative-fixnum?] [h nonnegative-fixnum?])
(define: k-min : Nonnegative-Fixnum c)
(define: x-min : Nonnegative-Fixnum w) (define: x-min : Nonnegative-Fixnum w)
(define: y-min : Nonnegative-Fixnum h) (define: y-min : Nonnegative-Fixnum h)
(define: k-max : Nonnegative-Fixnum 0)
(define: x-max : Nonnegative-Fixnum 0) (define: x-max : Nonnegative-Fixnum 0)
(define: y-max : Nonnegative-Fixnum 0) (define: y-max : Nonnegative-Fixnum 0)
(let: y-loop : Void ([y : Nonnegative-Fixnum 0] [i : 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]) (let: x-loop : Void ([x : Nonnegative-Fixnum 0] [i : Nonnegative-Fixnum i])
(cond [(x . fx< . w) (cond [(x . fx< . w)
(let: k-loop : Void ([k : Nonnegative-Fixnum 0] [i : Nonnegative-Fixnum i]) (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)) (when (not (v . = . 0.0))
(set! k-min (fxmin k-min k))
(set! x-min (fxmin x-min x)) (set! x-min (fxmin x-min x))
(set! y-min (fxmin y-min y)) (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! x-max (fxmax x-max (fx+ 1 x)))
(set! y-max (fxmax y-max (fx+ 1 y)))) (set! y-max (fxmax y-max (fx+ 1 y))))
(k-loop (fx+ k 1) (fx+ i 1))] (k-loop (fx+ k 1) (fx+ i 1))]
[else (x-loop (fx+ x 1) i)]))] [else (x-loop (fx+ x 1) i)]))]
[else (y-loop (fx+ y 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)))

13
collects/images/private/flomap-struct.rkt
View File

@ -1,9 +1,9 @@
#lang typed/racket/base #lang typed/racket/base
(require racket/flonum (require racket/match
(except-in racket/fixnum fl->fx fx->fl) (only-in racket/unsafe/ops
racket/match unsafe-flvector-ref unsafe-flvector-set!
(except-in racket/unsafe/ops unsafe-flvector-ref unsafe-flvector-set!) unsafe-fx+)
"flonum.rkt") "flonum.rkt")
(provide flomap flomap? flomap-values flomap-components flomap-width flomap-height (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) (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)])) [(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) (define-syntax-rule (inline-build-flomap components width height f)
(let: ([c : Integer components] (let: ([c : Integer components]
[w : Integer width] [w : Integer width]

4
collects/images/private/flomap-transform.rkt
View File

@ -1,7 +1,7 @@
#lang typed/racket/base #lang typed/racket/base
(require racket/match racket/math racket/flonum (require racket/match racket/math
(except-in racket/fixnum fl->fx fx->fl) (only-in racket/unsafe/ops unsafe-flvector-ref)
"flonum.rkt" "flonum.rkt"
"flomap-struct.rkt") "flomap-struct.rkt")

34
collects/images/private/flonum.rkt
View File

@ -1,22 +1,29 @@
#lang typed/racket/base #lang typed/racket/base
(require (for-syntax typed/racket/base) (require (for-syntax typed/racket/base)
racket/flonum (rename-in racket/flonum
(except-in racket/fixnum fl->fx fx->fl) [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 racket/math
(except-in racket/unsafe/ops unsafe-flvector-ref unsafe-flvector-set!) (only-in racket/unsafe/ops unsafe-flvector-set! unsafe-fx+))
(prefix-in old- (only-in racket/unsafe/ops unsafe-flvector-ref unsafe-flvector-set!))
)
(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) (define-predicate nonnegative-fixnum? Nonnegative-Fixnum)
(: unsafe-flvector-ref (FlVector Integer -> Flonum)) ;; This looks stupid, but it avoids an optimization TR does that is actually a pessimization, by
(define unsafe-flvector-ref flvector-ref) ;; keeping it from recognizing flvector-ref
(: flvector-ref (FlVector Integer -> Flonum))
(define flvector-ref old:flvector-ref)
(: unsafe-flvector-set! (FlVector Integer Flonum -> Void)) ;; Ditto above
(define unsafe-flvector-set! flvector-set!) (: flvector-set! (FlVector Integer Flonum -> Void))
(define flvector-set! old:flvector-set!)
(define-syntax (fl->fx stx) (define-syntax (fl->fx stx)
(syntax-case stx () (syntax-case stx ()
@ -42,9 +49,10 @@
(+ sca (* dca (- 1.0 sa)))) (+ sca (* dca (- 1.0 sa))))
(define-syntax-rule (flgaussian x s) (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))) (/ (exp (* -0.5 (* x/s x/s)))
(fl* (sqrt (* 2.0 pi)) s)))) (* (sqrt (* 2.0 pi)) sigma))))
(define-syntax-rule (flsigmoid x) (define-syntax-rule (flsigmoid x)
(/ 1.0 (+ 1.0 (exp (fl- 0.0 x))))) (/ 1.0 (+ 1.0 (exp (fl- 0.0 x)))))
@ -54,7 +62,7 @@
(with-asserts ([n nonnegative-fixnum?]) (with-asserts ([n nonnegative-fixnum?])
(let: ([vs : FlVector (make-flvector n)]) (let: ([vs : FlVector (make-flvector n)])
(let: loop : FlVector ([i : Nonnegative-Fixnum 0]) (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))] (loop (unsafe-fx+ i 1))]
[else vs])))))) [else vs]))))))