-
Notifications
You must be signed in to change notification settings - Fork 5
/
VSM.hs
175 lines (153 loc) · 6.8 KB
/
VSM.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
{-# LANGUAGE OverloadedStrings, PackageImports, TypeOperators, DataKinds, FlexibleContexts #-}
module VSM where
import Data.ByteString.Char8 (ByteString)
import LambdaCube.GL
import Utility
-- blur
blur' :: (Exp F V2F -> FragmentOut (Depth Float :+: Color V2F :+: ZZ)) -> Exp Obj (FrameBuffer 1 (Float,V2F))
blur' frag = Accumulate fragCtx PassAll frag rast clear
where
fragCtx = AccumulationContext Nothing $ DepthOp Always False:.ColorOp NoBlending (one' :: V2B):.ZT
clear = FrameBuffer (DepthImage n1 1000:.ColorImage n1 (V2 0 0):.ZT)
rast = Rasterize triangleCtx prims
prims = Transform vert input
input = Fetch "postSlot" Triangles (IV2F "position")
vert :: Exp V V2F -> VertexOut () V2F
vert uv = VertexOut v4 (Const 1) ZT (NoPerspective uv:.ZT)
where
v4 = pack' $ V4 u v (floatV 1) (floatV 1)
V2 u v = unpack' uv
gaussFilter7 :: [(Float,Float)]
gaussFilter7 =
[ (-3.0, 0.015625)
, (-2.0, 0.09375)
, (-1.0, 0.234375)
, (0.0, 0.3125)
, (1.0, 0.234375)
, (2.0, 0.09375)
, (3.0, 0.015625)
]
gaussFilter9 :: [(Float,Float)]
gaussFilter9 =
[ (-4.0, 0.05)
, (-3.0, 0.09)
, (-2.0, 0.12)
, (-1.0, 0.15)
, (0.0, 0.16)
, (1.0, 0.15)
, (2.0, 0.12)
, (3.0, 0.09)
, (4.0, 0.05)
]
blurVH :: Exp Obj (Image 1 V2F) -> Exp Obj (FrameBuffer 1 (Float,V2F))
blurVH img = blur' fragH
where
sizeT = 512
sizeI = floor sizeT
uvH v = Const (V2 (v/sizeT) 0) :: Exp F V2F
uvV v = Const (V2 0 (v/sizeT)) :: Exp F V2F
fragH :: Exp F V2F -> FragmentOut (Depth Float :+: Color V2F :+: ZZ)
fragH uv' = FragmentOutRastDepth $ (sampleH gaussFilter9) :. ZT
where
sampleH ((o,c):[]) = texture' smp (uv @+ uvH o) @* floatF c
sampleH ((o,c):xs) = (texture' smp (uv @+ uvH o) @* floatF c) @+ sampleH xs
V2 u v = unpack' uv
uv = uv' @* floatF 0.5 @+ floatF 0.5
smp = Sampler LinearFilter ClampToEdge tex
tex = Texture (Texture2D (Float RG) n1) (V2 sizeI sizeI) NoMip [PrjFrameBuffer "" tix0 (blur' fragV)]
fragV :: Exp F V2F -> FragmentOut (Depth Float :+: Color V2F :+: ZZ)
fragV uv' = FragmentOutRastDepth $ (sampleV gaussFilter9) :. ZT
where
sampleV ((o,c):[]) = texture' smp (uv @+ uvV o) @* floatF c
sampleV ((o,c):xs) = (texture' smp (uv @+ uvV o) @* floatF c) @+ sampleV xs
V2 u v = unpack' uv
uv = uv' @* floatF 0.5 @+ floatF 0.5
smp = Sampler LinearFilter ClampToEdge tex
tex = Texture (Texture2D (Float RG) n1) (V2 sizeI sizeI) NoMip [img]
----------
-- VSM ---
----------
moments :: Exp Obj (FrameBuffer 1 (Float,V2F))
moments = Accumulate fragCtx PassAll storeDepth rast clear
where
fragCtx = AccumulationContext Nothing $ DepthOp Less True:.ColorOp NoBlending (one' :: V2B):.ZT
clear = FrameBuffer (DepthImage n1 1000:.ColorImage n1 (V2 0 0):.ZT)
rast = Rasterize triangleCtx prims
prims = Transform vert input
input = Fetch "streamSlot" Triangles (IV3F "position")
lightViewProj = Uni (IM44F "lightViewProj")
vert :: Exp V V3F -> VertexOut () Float
vert p = VertexOut v4 (floatV 1) ZT (Smooth depth:.ZT)
where
v4 = lightViewProj @*. snoc p 1
V4 _ _ depth _ = unpack' v4
storeDepth :: Exp F Float -> FragmentOut (Depth Float :+: Color V2F :+: ZZ)
--storeDepth depth' = FragmentOutRastDepth $ (Const $ V2 1 0.2) :. ZT
storeDepth depth = FragmentOutRastDepth $ pack' (V2 moment1 moment2) :. ZT
where
dx = dFdx' depth
dy = dFdy' depth
moment1 = depth
moment2 = depth @* depth @+ floatF 0.25 @* (dx @* dx @+ dy @* dy)
vsm :: Exp Obj (FrameBuffer 1 (Float,V4F))
vsm = Accumulate fragCtx PassAll calcLuminance rast clear
where
fragCtx = AccumulationContext Nothing $ DepthOp Less True:.ColorOp NoBlending (one' :: V4B):.ZT
clear = FrameBuffer (DepthImage n1 1000:.ColorImage n1 (V4 0.1 0 0.9 1):.ZT)
rast = Rasterize triangleCtx prims
prims = Transform vert input
input = Fetch "streamSlot" Triangles (IV3F "position", IV3F "normal")
worldViewProj = Uni (IM44F "worldViewProj")
lightViewProj = Uni (IM44F "lightViewProj")
scaleU = Uni (IFloat "scaleU")
scaleV = Uni (IFloat "scaleV")
trimV4 :: Exp s V4F -> Exp s V3F
trimV4 v = let V4 x y z _ = unpack' v in pack' $ V3 x y z
trimM4 :: Exp s M44F -> Exp s M33F
trimM4 v = let V4 i j k _ = unpack' v in pack' $ V3 (trimV4 i) (trimV4 j) (trimV4 k)
vert :: Exp V (V3F, V3F) -> VertexOut () (V4F, V3F)
vert attr = VertexOut v4 (floatV 1) ZT (Smooth v4l:.Smooth n:.ZT)
where
v4 = worldViewProj @*. snoc p 1
v4l = lightViewProj @*. snoc p 1
n3 = normalize' (trimM4 worldViewProj @*. n)
(p,n) = untup2 attr
calcLuminance :: Exp F (V4F, V3F) -> FragmentOut (Depth Float :+: Color V4F :+: ZZ)
calcLuminance attr = FragmentOutRastDepth $ ({- amb @+ -}p_max):. ZT
where
amb :: Exp F V4F
amb = Const $ V4 0.1 0.1 0.3 1
V4 tx ty tz tw = unpack' l
clampUV x = clamp' x (floatF 0) (floatF 1)
scale x = x @* floatF 0.5 @+ floatF 0.5
u = clampUV (scale (tx @/ tw)) @* (scaleU :: Exp F Float)
v = clampUV (scale (ty @/ tw)) @* (scaleV :: Exp F Float)
V2 m1 m2 = unpack' $ texture' sampler (pack' $ V2 u v)
variance = max' (floatF 0.002) (m2 @- m1 @* m1)
d = max' (floatF 0) (tz @- m1)
u' = u @- floatF 0.5
v' = v @- floatF 0.5
-- assuming light direction of (0 0 -1)
V3 _ _ nz = unpack' n
nz' = max' (floatF 0) nz
intensity = max' (floatF 0) ((floatF 1 @- sqrt' (u' @* u' @+ v' @* v') @* floatF 4) @* nz')
ltr = (round' (u' @* floatF 10) @* floatF 0.5 @+ floatF 0.5) @* intensity
ltg = (round' (v' @* floatF 10) @* floatF 0.5 @+ floatF 0.5) @* intensity
p_max = pack' (V4 ltr ltg intensity (floatF 1)) @* (variance @/ (variance @+ d @* d))
(l,n) = untup2 attr
sampler = Sampler LinearFilter ClampToEdge shadowMapBlur
--Texture (Exp Obj) dim arr t ar
shadowMap :: Exp Obj (Texture Tex2D SingleTex (Regular Float) RG)
shadowMap = Texture (Texture2D (Float RG) n1) (V2 512 512) NoMip [PrjFrameBuffer "shadowMap" tix0 moments]
shadowMapBlur :: Exp Obj (Texture Tex2D SingleTex (Regular Float) RG)
shadowMapBlur = Texture (Texture2D (Float RG) n1) (V2 512 512) NoMip [PrjFrameBuffer "shadowMap" tix0 $ blurVH $ PrjFrameBuffer "blur" tix0 moments]
{-
tx :: Exp Obj (Image 1 (V2 Float))
tx = PrjFrameBuffer "" tix0 moments
tex :: Exp Obj (Image 1 Float)
tex = undefined
sm :: Texture (Exp Obj) Tex2D SingleTex (Regular Float) RG
sm = Texture (Texture2D (Float RG) 1) AutoMip [tx]
smp :: Exp stage (Sampler Tex2D SingleTex (Regular Float) RG)
smp = Sampler LinearFilter ClampToEdge sm
-}