Skip to content
This repository
Browse code

Cleaned up VSM example shader code.

  • Loading branch information...
commit 59082e23a1da39a92dec2d449a9c7ce81680c1a9 1 parent 3c0cdc1
Patai Gergely authored October 08, 2012

Showing 1 changed file with 77 additions and 82 deletions. Show diff stats Hide diff stats

  1. 159  samples/shadow-mapping/VSM.hs
159  samples/shadow-mapping/VSM.hs
@@ -10,22 +10,10 @@ import GraphicsUtils
10 10
 shadowMapSize :: Num a => a
11 11
 shadowMapSize = 512
12 12
 
13  
-blur' :: (Exp F V2F -> FragmentOut (Depth Float :+: Color V2F :+: ZZ)) -> Exp Obj (FrameBuffer N1 (Float,V2F))
14  
-blur' frag = Accumulate fragCtx PassAll frag rast clear
15  
-  where
16  
-    fragCtx = AccumulationContext Nothing $ DepthOp Always False:.ColorOp NoBlending (one' :: V2B):.ZT
17  
-    clear   = FrameBuffer (DepthImage n1 1000:.ColorImage n1 (V2 0 0):.ZT)
18  
-    rast    = Rasterize triangleCtx prims
19  
-    prims   = Transform vert input
20  
-    input   = Fetch "postSlot" Triangle (IV2F "position")
21  
-
22  
-    vert :: Exp V V2F -> VertexOut V2F
23  
-    vert uv = VertexOut v4 (Const 1) (NoPerspective uv:.ZT)
24  
-      where
25  
-        v4      = pack' $ V4 u v (floatV 1) (floatV 1)
26  
-        V2 u v  = unpack' uv
  13
+blurCoefficients :: [(Float, Float)]
  14
+blurCoefficients = gaussFilter9
27 15
 
28  
-gaussFilter7 :: [(Float,Float)]
  16
+gaussFilter7 :: [(Float, Float)]
29 17
 gaussFilter7 = 
30 18
     [ (-3.0,   0.015625)
31 19
     , (-2.0,   0.09375)
@@ -36,7 +24,7 @@ gaussFilter7 =
36 24
     , (3.0,    0.015625)
37 25
     ]
38 26
 
39  
-gaussFilter9 :: [(Float,Float)]
  27
+gaussFilter9 :: [(Float, Float)]
40 28
 gaussFilter9 = 
41 29
     [ (-4.0,   0.05)
42 30
     , (-3.0,   0.09)
@@ -49,50 +37,52 @@ gaussFilter9 =
49 37
     , (4.0,    0.05)
50 38
     ]
51 39
 
52  
-blurVH :: Exp Obj (Image N1 V2F) -> Exp Obj (FrameBuffer N1 (Float,V2F))
53  
-blurVH img = blur' fragH
  40
+blur :: [(Float, Float)] -> Exp Obj (Image N1 V2F) -> Exp Obj (FrameBuffer N1 V2F)
  41
+blur coefficients img = filter1D dirH (PrjFrameBuffer "" tix0 (filter1D dirV img))
54 42
   where
55  
-    uvH v = Const (V2 (v/shadowMapSize) 0) :: Exp F V2F
56  
-    uvV v = Const (V2 0 (v/shadowMapSize)) :: Exp F V2F
57  
-    fragH :: Exp F V2F -> FragmentOut (Depth Float :+: Color V2F :+: ZZ)
58  
-    fragH uv' = FragmentOutRastDepth $ (sampleH gaussFilter9) :. ZT
59  
-      where
60  
-        sampleH ((o,c):[])  = texture' smp (uv @+ uvH o) @* floatF c
61  
-        sampleH ((o,c):xs)  = (texture' smp (uv @+ uvH o) @* floatF c) @+ sampleH xs
62  
-        V2 u v = unpack' uv
63  
-        uv = uv' @* floatF 0.5 @+ floatF 0.5
64  
-        smp = Sampler LinearFilter Clamp tex
65  
-        tex = Texture (Texture2D (Float RG) n1) (V2 shadowMapSize shadowMapSize) NoMip [PrjFrameBuffer "" tix0 (blur' fragV)]
66  
-
67  
-    fragV :: Exp F V2F -> FragmentOut (Depth Float :+: Color V2F :+: ZZ)
68  
-    fragV uv' = FragmentOutRastDepth $ (sampleV gaussFilter9) :. ZT
  43
+    dirH v = Const (V2 (v / shadowMapSize) 0) :: Exp F V2F
  44
+    dirV v = Const (V2 0 (v / shadowMapSize)) :: Exp F V2F
  45
+    
  46
+    filter1D :: (Float -> Exp F V2F) -> Exp Obj (Image N1 V2F) -> Exp Obj (FrameBuffer N1 V2F)
  47
+    filter1D dir img = Accumulate accCtx PassAll frag (Rasterize triangleCtx prims) clearBuf
69 48
       where
70  
-        sampleV ((o,c):[])  = texture' smp (uv @+ uvV o) @* floatF c
71  
-        sampleV ((o,c):xs)  = (texture' smp (uv @+ uvV o) @* floatF c) @+ sampleV xs
72  
-        V2 u v = unpack' uv
73  
-        uv = uv' @* floatF 0.5 @+ floatF 0.5
74  
-        smp = Sampler LinearFilter Clamp tex
75  
-        tex = Texture (Texture2D (Float RG) n1) (V2 shadowMapSize shadowMapSize) NoMip [img]
  49
+        accCtx = AccumulationContext Nothing (ColorOp NoBlending (one' :: V2B) :. ZT)
  50
+        clearBuf = FrameBuffer (ColorImage n1 (V2 0 0) :. ZT)
  51
+        prims = Transform vert (Fetch "postSlot" Triangle (IV2F "position"))
  52
+
  53
+        vert :: Exp V V2F -> VertexOut V2F
  54
+        vert uv = VertexOut pos (Const 1) (NoPerspective uv' :. ZT)
  55
+          where
  56
+            uv'    = uv @* floatV 0.5 @+ floatV 0.5
  57
+            pos    = pack' (V4 u v (floatV 1) (floatV 1))
  58
+            V2 u v = unpack' uv
  59
+
  60
+        frag :: Exp F V2F -> FragmentOut (Color V2F :+: ZZ)
  61
+        frag uv = FragmentOut (sample :. ZT)
  62
+          where
  63
+            sample = foldr1 (@+) [texture' smp (uv @+ dir ofs) @* floatF coeff | (ofs, coeff) <- coefficients]
  64
+            smp = Sampler LinearFilter Clamp tex
  65
+            tex = Texture (Texture2D (Float RG) n1) (V2 shadowMapSize shadowMapSize) NoMip [img]
  66
+    
76 67
 
77 68
 moments :: Exp Obj (FrameBuffer N1 (Float,V2F))
78  
-moments = Accumulate fragCtx PassAll storeDepth rast clear
  69
+moments = Accumulate accCtx PassAll frag (Rasterize triangleCtx prims) clearBuf
79 70
   where
80  
-    fragCtx = AccumulationContext Nothing $ DepthOp Less True:.ColorOp NoBlending (one' :: V2B):.ZT
81  
-    clear   = FrameBuffer (DepthImage n1 1000:.ColorImage n1 (V2 0 0):.ZT)
82  
-    rast    = Rasterize triangleCtx prims
83  
-    prims   = Transform vert input
84  
-    input   = Fetch "geometrySlot" Triangle (IV3F "position")
  71
+    accCtx = AccumulationContext Nothing (DepthOp Less True :. ColorOp NoBlending (one' :: V2B) :. ZT)
  72
+    clearBuf = FrameBuffer (DepthImage n1 1000 :. ColorImage n1 (V2 0 0) :. ZT)
  73
+    prims = Transform vert (Fetch "geometrySlot" Triangle (IV3F "position"))
  74
+    
85 75
     lightMatrix = Uni (IM44F "lightMatrix")
86 76
     modelMatrix = Uni (IM44F "modelMatrix")
87 77
 
88 78
     vert :: Exp V V3F -> VertexOut Float
89  
-    vert p = VertexOut v4 (floatV 1) (Smooth depth:.ZT)
  79
+    vert pos = VertexOut lightPos (floatV 1) (Smooth depth :. ZT)
90 80
       where
91  
-        v4    = lightMatrix @*. modelMatrix @*. v3v4 p
92  
-        V4 _ _ depth _ = unpack' v4
  81
+        lightPos = lightMatrix @*. modelMatrix @*. v3v4 pos
  82
+        V4 _ _ depth _ = unpack' lightPos
93 83
 
94  
-    storeDepth :: Exp F Float -> FragmentOut (Depth Float :+: Color V2F :+: ZZ)
95  
-    storeDepth depth = FragmentOutRastDepth $ pack' (V2 moment1 moment2) :. ZT
  84
+    frag :: Exp F Float -> FragmentOut (Depth Float :+: Color V2F :+: ZZ)
  85
+    frag depth = FragmentOutRastDepth (pack' (V2 moment1 moment2) :. ZT)
96 86
       where
97 87
         dx = dFdx' depth
98 88
         dy = dFdy' depth
@@ -100,48 +90,51 @@ moments = Accumulate fragCtx PassAll storeDepth rast clear
100 90
         moment2 = depth @* depth @+ floatF 0.25 @* (dx @* dx @+ dy @* dy)
101 91
 
102 92
 vsm :: Exp Obj (FrameBuffer N1 (Float,V4F))
103  
-vsm = Accumulate fragCtx PassAll calcLuminance rast clear
  93
+vsm = Accumulate accCtx PassAll frag (Rasterize triangleCtx prims) clearBuf
104 94
   where
105  
-    fragCtx = AccumulationContext Nothing $ DepthOp Less True:.ColorOp NoBlending (one' :: V4B):.ZT
106  
-    clear   = FrameBuffer (DepthImage n1 1000:.ColorImage n1 (V4 0.1 0.2 0.6 1):.ZT)
107  
-    rast    = Rasterize triangleCtx prims
108  
-    prims   = Transform vert input
109  
-    input   = Fetch "geometrySlot" Triangle (IV3F "position", IV3F "normal")
  95
+    accCtx = AccumulationContext Nothing (DepthOp Less True :. ColorOp NoBlending (one' :: V4B) :. ZT)
  96
+    clearBuf = FrameBuffer (DepthImage n1 1000 :. ColorImage n1 (V4 0.1 0.2 0.6 1) :. ZT)
  97
+    prims = Transform vert (Fetch "geometrySlot" Triangle (IV3F "position", IV3F "normal"))
  98
+
110 99
     cameraMatrix = Uni (IM44F "cameraMatrix")
111 100
     lightMatrix = Uni (IM44F "lightMatrix")
112 101
     modelMatrix = Uni (IM44F "modelMatrix")
113 102
     lightPosition = Uni (IV3F "lightPosition")
114 103
 
115 104
     vert :: Exp V (V3F, V3F) -> VertexOut (V3F, V4F, V3F)
116  
-    vert attr = VertexOut v4 (floatV 1) (Smooth (v4v3 p'):.Smooth v4l:.Smooth n3:.ZT)
  105
+    vert attr = VertexOut viewPos (floatV 1) (Smooth (v4v3 worldPos) :. Smooth lightPos :. Smooth worldNormal :. ZT)
117 106
       where
118  
-        p' = modelMatrix @*. v3v4 p
119  
-        v4 = cameraMatrix @*. p'
120  
-        v4l = lightMatrix @*. p'
121  
-        n3 = normalize' (v4v3 (modelMatrix @*. n3v4 n))
122  
-        (p,n) = untup2 attr
123  
-
124  
-    calcLuminance :: Exp F (V3F, V4F, V3F) -> FragmentOut (Depth Float :+: Color V4F :+: ZZ)
125  
-    calcLuminance attr = FragmentOutRastDepth $ ({- amb @+ -}p_max):. ZT
  107
+        worldPos = modelMatrix @*. v3v4 localPos
  108
+        viewPos = cameraMatrix @*. worldPos
  109
+        lightPos = lightMatrix @*. worldPos
  110
+        worldNormal = normalize' (v4v3 (modelMatrix @*. n3v4 localNormal))
  111
+        (localPos, localNormal) = untup2 attr
  112
+
  113
+    frag :: Exp F (V3F, V4F, V3F) -> FragmentOut (Depth Float :+: Color V4F :+: ZZ)
  114
+    frag attr = FragmentOutRastDepth (luminance :. ZT)
126 115
       where
127  
-        amb :: Exp F V4F
128  
-        amb = Const $ V4 0.1 0.1 0.3 1
129  
-        V4 tx ty tz tw = unpack' l
  116
+        V4 lightU lightV lightDepth lightW = unpack' lightPos
  117
+        uv = clampUV (scaleUV (pack' (V2 lightU lightV) @/ lightW))
  118
+        
  119
+        V2 moment1 moment2 = unpack' (texture' sampler uv)
  120
+        variance = max' (floatF 0.002) (moment2 @- moment1 @* moment1)
  121
+        distance = max' (floatF 0) (lightDepth @- moment1)
  122
+        shadowProbMax = variance @/ (variance @+ distance @* distance)
  123
+        
  124
+        lambert = max' (floatF 0) (dot' worldNormal (normalize' (lightPosition @- worldPos)))
  125
+        
  126
+        uv' = uv @- floatF 0.5
  127
+        spotShape = floatF 1 @- length' uv' @* floatF 4
  128
+        intensity = max' (floatF 0) (spotShape @* lambert)
  129
+        
  130
+        V2 spotR spotG = unpack' (scaleUV (round' (uv' @* floatF 10)) @* intensity)
  131
+        
  132
+        luminance = pack' (V4 spotR spotG intensity (floatF 1)) @* pow' shadowProbMax (floatF 2)
  133
+        
130 134
         clampUV x = clamp' x (floatF 0) (floatF 1)
131  
-        scale x = x @* floatF 0.5 @+ floatF 0.5
132  
-        u = clampUV (scale (tx @/ tw))
133  
-        v = clampUV (scale (ty @/ tw))
134  
-        V2 m1 m2 = unpack' $ texture' sampler (pack' $ V2 u v)
135  
-        variance = max' (floatF 0.002) (m2 @- m1 @* m1)
136  
-        d = max' (floatF 0) (tz @- m1)
137  
-        u' = u @- floatF 0.5
138  
-        v' = v @- floatF 0.5
139  
-        lt = max' (floatF 0) (dot' n (normalize' ((lightPosition :: Exp F V3F) @- wp)))
140  
-        intensity = max' (floatF 0) ((floatF 1 @- sqrt' (u' @* u' @+ v' @* v') @* floatF 4) @* lt)
141  
-        ltr = scale (round' (u' @* floatF 10)) @* intensity
142  
-        ltg = scale (round' (v' @* floatF 10)) @* intensity
143  
-        p_max = pack' (V4 ltr ltg intensity (floatF 1)) @* (variance @/ (variance @+ d @* d))
144  
-        (wp,l,n) = untup3 attr
  135
+        scaleUV x = x @* floatF 0.5 @+ floatF 0.5
  136
+        
  137
+        (worldPos, lightPos, worldNormal) = untup3 attr
145 138
 
146 139
     sampler = Sampler LinearFilter Clamp shadowMapBlur
147 140
     
@@ -149,4 +142,6 @@ vsm = Accumulate fragCtx PassAll calcLuminance rast clear
149 142
     shadowMap = Texture (Texture2D (Float RG) n1) (V2 512 512) NoMip [PrjFrameBuffer "shadowMap" tix0 moments]
150 143
 
151 144
     shadowMapBlur :: Texture (Exp Obj) DIM2 SingleTex (Regular Float) RG
152  
-    shadowMapBlur = Texture (Texture2D (Float RG) n1) (V2 512 512) NoMip [PrjFrameBuffer "shadowMap" tix0 $ blurVH $ PrjFrameBuffer "blur" tix0 moments]
  145
+    shadowMapBlur = Texture (Texture2D (Float RG) n1) (V2 512 512) NoMip [PrjFrameBuffer "shadowMap" tix0 blurredMoments]
  146
+      where
  147
+        blurredMoments = blur blurCoefficients (PrjFrameBuffer "blur" tix0 moments)

0 notes on commit 59082e2

Please sign in to comment.
Something went wrong with that request. Please try again.