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
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
|
module Graphics where
import Material hiding (Blending)
import SampleMaterial
--texture' _ _ = V4 0.0 0.0 0.0 0.0 --PrimTexture
texture' = texture2D
singT = id
-- specialized snoc
v3v4 :: Vec 3 Float -> Vec 4 Float
v3v4 v = V4 v%x v%y v%z 1.0
v4v3 :: Vec 4 Float -> Vec 3 Float
v4v3 v = V3 v%x v%y v%z
-- specialized snoc
snoc :: Vec 3 Float -> Float -> Vec 4 Float
snoc v s = V4 v%x v%y v%z s
snoc' :: Vec 3 Float -> Float -> Vec 4 Float
snoc' v s = V4 v%x v%y v%z s
drop4 :: Vec 4 Float -> Vec 3 Float
drop4 v = V3 v%x v%y v%z
drop3 :: Vec 3 Float -> Vec 2 Float
drop3 v = V2 v%x v%y
mkRasterContext :: CommonAttrs -> RasterContext a Triangle
mkRasterContext ca = TriangleCtx cull PolygonFill offset LastVertex
where
offset = if caPolygonOffset ca then Offset (-1) (-2) else NoOffset
cull = case caCull ca of
CT_FrontSided -> CullFront
CT_BackSided -> CullBack
CT_TwoSided -> CullNone
mkaccumulationContext :: StageAttrs -> (FragmentOperation (Depth Float), FragmentOperation (Color (Vec 4 Float)))
mkaccumulationContext sa = (DepthOp depthFunc depthWrite, ColorOp blend (one :: Vec 4 Bool))
where
depthWrite = saDepthWrite sa
depthFunc = case saDepthFunc sa of
D_Equal -> Equal
D_Lequal -> Lequal
cvt b = case b of
B_DstAlpha -> DstAlpha
B_DstColor -> DstColor
B_One -> One
B_OneMinusDstAlpha -> OneMinusDstAlpha
B_OneMinusDstColor -> OneMinusDstColor
B_OneMinusSrcAlpha -> OneMinusSrcAlpha
B_OneMinusSrcColor -> OneMinusSrcColor
B_SrcAlpha -> SrcAlpha
B_SrcAlphaSaturate -> SrcAlphaSaturate
B_SrcColor -> SrcColor
B_Zero -> Zero'
blend = case saBlend sa of
Nothing -> NoBlending
Just (src,dst) -> Blend (FuncAdd,FuncAdd) ((srcF,dstF),(srcF,dstF)) one
where
srcF = cvt src
dstF = cvt dst
mkWave' :: Float -> Wave -> Float
mkWave' off (Wave wFunc base amplitude phase freq) = base +! (a *! amplitude)
where
time = Uniform "time" :: Float
u = off +! phase +! (freq *! time)
uv = V2 u 0
name = case wFunc of
WT_Sin -> "SinTable"
WT_Triangle -> "TriangleTable"
WT_Square -> "SquareTable"
WT_Sawtooth -> "SawToothTable"
WT_InverseSawtooth -> "InverseSawToothTable"
WT_Noise -> "Noise"
sampler = Sampler LinearFilter Repeat (Texture2DSlot name) -- (Texture2D (Float RGBA) n1)
v = (texture' sampler uv)%x
a = (v *! 2) -! 1
mkWave :: Wave -> Float
mkWave = mkWave' 0
mkColor :: CommonAttrs -> StageAttrs -> Vec 4 Float -> Vec 4 Float -- V frequency
mkColor ca sa = \rgbaV ->
let
entityRGB = Uniform "entityRGB" :: Vec 3 Float
entityAlpha = Uniform "entityAlpha" :: Float
identityLight' = Uniform "identityLight" :: Float
--red = V3 1 0 0
white' = V3 1 1 1.0
rV = rgbaV%r
gV = rgbaV%g
bV = rgbaV%b
aV = rgbaV%a
rgb' :: Vec 3 Float
rgb' = case saRGBGen sa of
RGB_Wave w -> let c = mkWave w in V3 c c c :: Vec 3 Float
RGB_Const r g b -> V3 r g b
RGB_Identity -> one
RGB_IdentityLighting -> V3 identityLight' identityLight' identityLight'
RGB_Entity -> entityRGB
RGB_OneMinusEntity -> one - entityRGB
RGB_ExactVertex -> V3 rV gV bV
RGB_Vertex -> (V3 rV gV bV) *! identityLight'
RGB_LightingDiffuse -> white' -- TODO
{- input:
entity: ambientLight
directedLight
lightDir
model: position
normal
-}
RGB_OneMinusVertex -> one - ((V3 rV gV bV) *! identityLight')
alpha = case saAlphaGen sa of
A_Wave w -> let a = mkWave w in clamp a 0 1
A_Const a -> a
A_Portal -> 1 -- TODO
A_Identity -> 1
A_Entity -> entityAlpha
A_OneMinusEntity -> 1 -! entityAlpha
A_Vertex -> aV
A_LightingSpecular -> 1 -- TODO
{- input:
model: position
normal
user: viewOrigin
-}
A_OneMinusVertex -> 1 -! aV
in snoc' rgb' alpha
mkDeform :: Vec 2 Float -> Vec 3 Float -> Vec 3 Float -> Deform {-CPU-} -> Vec 3 Float
mkDeform uv normal pos = \d -> case d of
D_Move v w -> pos + (v *! mkWave w)
D_Wave spread w -- todo @(Wave _ _ _ _ f)
-> if (\(Wave _ _ _ _ f) -> f) w < 0.000001 then pos + (normal *! mkWave w)
else
let off = (pos%x +! pos%y +! pos%z) *! spread
in pos + (normal *! mkWave' off w)
{- todo
| f < 0.000001 -> pos + (normal *! mkWave w)
| otherwise ->
let off = (pos%x +! pos%y +! pos%z) *! spread
in pos + (normal *! mkWave' off w)
-}
D_Bulge w h s -> let time = Uniform "time" :: Float
now = time *! s
off = (uv%x *! w) +! now
in pos + (normal *! sin off *! h)
_ -> pos
{-
data TCMod
= TM_EntityTranslate
-}
mkTCMod :: Vec 3 Float -> Vec 2 Float -> TCMod -> Vec 2 Float
mkTCMod pos uv = \m -> {- trace (show m) $ -} case m of
TM_Scroll su sv -> uv + ((V2 su sv :: Vec 2 Float) *! (Uniform "time" :: Float))
TM_Scale su sv -> uv * (V2 su sv :: Vec 2 Float)
TM_Stretch w -> let p = 1 /! mkWave w
v0_5 = 0.5
off = v0_5 -! (v0_5 *! p)
in (uv *! p) +! off
TM_Rotate speed -> let time = Uniform "time" :: Float
fi = (-speed *! pi /! 180) *! time
s = sin fi
ms = s *! (-1)
c = cos fi
mA = V2 c s
mB = V2 ms c
m' = M22F mA mB
v0_5 = 0.5
off = V2 (v0_5 -! (v0_5 *! c) +! (v0_5 *! s)) (v0_5 -! (v0_5 *! s) -! (v0_5 *! c))
in (m' *. uv) + off
TM_Transform m00 m01 m10 m11 t0 t1 -> let u = uv%x
v = uv%y
u' = (u *! m00) +! (v *! m10) +! t0
v' = (u *! m01) +! (v *! m11) +! t1
in V2 u' v'
TM_Turb base amp phase freq -> let u = uv%x
v = uv%y
x = pos%x
y = pos%y
z = pos%z
time = Uniform "time" :: Float
now = phase +! time *! freq
offU = (2 *! pi) *! (((x +! z) *! (0.125 /! 128)) +! now)
offV = (2 *! pi) *! ((y *! (0.125 /! 128)) +! now)
in uv + (sin (V2 offU offV) *! amp)
_ -> uv
mkTexCoord :: Vec 3 Float -> Vec 3 Float -> StageAttrs -> Vec 2 Float -> Vec 2 Float -> Vec 2 Float
mkTexCoord pos normal = \sa -> \uvD uvL -> let
uv = case saTCGen sa of
TG_Base -> uvD
TG_Lightmap -> uvL
TG_Environment -> let viewOrigin = Uniform "viewOrigin" :: Vec 3 Float
viewer = normalize (viewOrigin - pos)
d = normal `PrimDot` viewer
reflected = (normal *! (2 *! d)) - viewer
y = reflected%y
z = reflected%z
v0_5 = 0.5
in V2 (v0_5 +! (y *! v0_5)) (v0_5 -! (z *! v0_5))
TG_Vector (V3 sx sy sz) (V3 tx ty tz) -> let s = V3 sx sy sz :: Vec 3 Float
t = V3 tx ty tz :: Vec 3 Float
in V2 (pos `PrimDot` s) (pos `PrimDot` t)
in foldl' (mkTCMod pos) uv (saTCMod sa)
--mkVertexShader :: CommonAttrs -> StageAttrs -> (Vec 3 Float,Vec 3 Float,Vec 2 Float,Vec 2 Float,Vec 4 Float) -> VertexOut (Vec 2 Float,Vec 4 Float)
mkVertexShader ca sa = \(p,n,d,l,c) ->
let
worldMat = Uniform "worldMat" :: Mat 4 4 Float
viewMat = Uniform "viewMat" :: Mat 4 4 Float
viewProj = Uniform "viewProj" :: Mat 4 4 Float
pos = foldl' (mkDeform d n) p (caDeformVertexes ca)
screenPos = viewProj *. (worldMat *. snoc pos 1)
norm = drop4 (viewMat *. (worldMat *. snoc n 0))
uv = mkTexCoord pos n sa d l
color = mkColor ca sa c
in (screenPos, uv, color)
--saTxName sa = saTextureUniform sa
saTextureUniform' (StageAttrs _ _ _ _ _ _ _ _ _ _ a) = a
mkFragmentShader :: StageAttrs -> (Vec 2 Float,Vec 4 Float) -> ((Vec 4 Float))
mkFragmentShader sa{- @(StageAttrs _ _ _ _ _ _ _ _ _ _ texName)-} = \(uv,rgba) ->
let
texName = saTextureUniform' sa
texColor em name = texture2D (Sampler LinearFilter em (Texture2DSlot name)) uv
color = case saTexture sa of
ST_WhiteImage -> rgba
ST_Lightmap -> rgba * texColor ClampToEdge "LightMap"
ST_Map _ -> rgba * texColor Repeat texName
ST_ClampMap _ -> rgba * texColor ClampToEdge texName
ST_AnimMap _ _ -> rgba * texColor Repeat texName
in ((color))
mkFilterFunction :: StageAttrs -> Maybe ((Vec 2 Float,Vec 4 Float) -> Bool)
mkFilterFunction sa = case saAlphaFunc sa of
Nothing -> Nothing
Just f -> Just (\(uv,rgba) ->
let
texName = saTextureUniform' sa
stageTex = saTexture sa
texColor em name = texture' sampler uv
where
sampler = Sampler LinearFilter em (Texture2DSlot name) -- (Texture2D (Float RGBA) n1)
color = case stageTex of
ST_WhiteImage -> rgba
ST_Lightmap -> rgba * texColor ClampToEdge "LightMap"
ST_Map _ -> rgba * texColor Repeat texName
ST_ClampMap _ -> rgba * texColor ClampToEdge texName
ST_AnimMap _ _ -> rgba * texColor Repeat texName
-- TODO: V4 _ _ _ a = color
a = color%a
in case {- trace ("alpha filter: " ++ show f) -} f of
A_Gt0 -> a > 0
A_Lt128 -> a < 0.5
A_Ge128 -> a >= 0.5
)
maybe a b Nothing = a
maybe a b (Just x) = b x
type FB = FrameBuffer 1 '[Depth 'Float,Color '(Vec 4 Float)]
mkStage :: String -> CommonAttrs -> FB -> StageAttrs -> FB
mkStage name ca prevFB sa = Accumulate aCtx (mapFragments fSh (maybe id filterFragments fFun (rasterizePrimitives rCtx (Smooth, Smooth) (mapPrimitives vSh input)))) prevFB
where
input = fetch name Triangle ( Attribute "position" :: Vec 3 Float
, Attribute "normal" :: Vec 3 Float
, Attribute "diffuseUV" :: Vec 2 Float
, Attribute "lightmapUV" :: Vec 2 Float
, Attribute "color" :: Vec 4 Float
)
rCtx = mkRasterContext ca
aCtx = mkaccumulationContext sa
vSh = mkVertexShader ca sa
fSh = mkFragmentShader sa
fFun = mkFilterFunction sa
mkShader :: FB -> (String,CommonAttrs) -> FB
mkShader fb (name,ca) = foldl' (mkStage name ca) fb (caStages ca)
errorShaderFill :: FB -> FB
errorShaderFill fb = accumulate fragCtx frag rast fb
where
worldMat = Uniform "worldMat" :: Mat 4 4 Float
viewProj = Uniform "viewProj" :: Mat 4 4 Float
-- vert :: (Vec 3 Float,Vec 4 Float) -> VertexOut (Vec 4 Float)
vert (p,c) = (v4, c')
where
v4 = viewProj *. (worldMat *. snoc p 1)
c' = V4 c%r c%g c%b 0.5
blend = Blend (FuncAdd,Min) ((One,One),(One,One)) one
fragCtx = accumulationContext (DepthOp Less False, ColorOp blend (one :: Vec 4 Bool))
rastCtx = TriangleCtx CullNone PolygonFill NoOffset LastVertex
input = fetch "missing shader" Triangle (Attribute "position" :: Vec 3 Float, Attribute "color" :: Vec 4 Float)
prims = mapPrimitives vert input
rast = rasterizePrimitives rastCtx ((Smooth)) prims
-- frag :: Vec 4 Float -> (Depth Float, Color (Vec 4 Float))
frag = \((v)) -> ((v))
errorShader :: FB -> FB
errorShader fb = accumulate fragCtx frag rast (errorShaderFill fb)
where
viewProj = Uniform "viewProj" :: Mat 4 4 Float
worldMat = Uniform "worldMat" :: Mat 4 4 Float
-- vert :: (Vec 3 Float,Vec 4 Float) -> VertexOut (Vec 4 Float)
vert (p,c) = (v4, c)
where
v4 = viewProj *. (worldMat *. snoc p 1)
offset = NoOffset--Offset (0) (-10)
fragCtx = accumulationContext (DepthOp Lequal True, ColorOp NoBlending (one :: Vec 4 Bool))
rastCtx = TriangleCtx CullNone (PolygonLine 1) offset LastVertex
input = fetch "missing shader" Triangle (Attribute "position" :: Vec 3 Float, Attribute "color" :: Vec 4 Float)
prims = mapPrimitives vert input
rast = rasterizePrimitives rastCtx ((Smooth)) prims
-- frag :: Vec 4 Float -> (Depth Float, Color (Vec 4 Float))
frag = \((v)) -> ((V4 (1 - v%r) (1 - v%g) (1 - v%b) 1))
q3GFX :: [(String,CommonAttrs)] -> FB
q3GFX shl = {-blurVH $ PrjFrameBuffer "" tix0 $ -}errorShader (foldl' mkShader clear ordered)
where
ordered = sortBy (\(_,a) (_,b) -> caSort a `compare` caSort b) shl
clear = FrameBuffer (depthImage1 1000, colorImage1 (zero :: Vec 4 Float))
--main :: Output
main = ScreenOut (q3GFX sampleMaterial)
|