490 lines
22 KiB
Racket
490 lines
22 KiB
Racket
#lang typed/racket/base
|
||
|
||
(require 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 (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)))
|
||
|
||
(: 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))
|
||
|
||
(: 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 (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)])))
|
||
|
||
(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))
|
||
(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))]))))
|
||
|
||
(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)
|
||
|
||
(: 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))
|
||
(flvector-ref vs (fx* 4 (fx+ x (fx* y w))))]
|
||
[else 0.0])))
|
||
|
||
(: 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))
|
||
(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))
|
||
|
||
(: 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 (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)])))
|
||
|
||
(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))
|
||
(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))]))))
|
||
|
||
(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))
|