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
|
coordmap (cam::Mat 4 4 Float) (p::Vec 4 Float)
= cam *. p
blendplane = -- NoBlending -- BlendLogicOp Xor
Blend (FuncAdd,FuncAdd)
((OneBF,SrcAlpha),(DstAlpha,DstAlpha))
(V4 0 0 0 0)
point :: Vec 3 Float -> Vec 4 Float
point p = V4 p%x p%y p%z 1
makeFrame (cubemap :: TextureCube)
(skybox :: PrimitiveStream Triangle ((Vec 3 Float)))
(cameraPosition :: Vec 3 Float)
(cam :: Mat 4 4 Float)
(color :: Vec 4 Float)
(texture :: Texture)
(prims :: PrimitiveStream Triangle (Vec 4 Float, Vec 3 Float, Vec 3 Float))
(plane :: PrimitiveStream Triangle ((Vec 4 Float)))
(lines :: PrimitiveStream Line (Vec 3 Float, Vec 3 Float))
(points :: PrimitiveStream Point (Vec 3 Float, Vec 3 Float))
(plane_mat :: Mat 4 4 Float)
= imageFrame (emptyDepthImage 1, emptyColorImage (V4 0 0 0.4 1))
`overlay`
skybox
& mapPrimitives (\((p)) -> let texcoord = V3 p%x (p%y) (p%z)
p' = cam *. point (p + cameraPosition)
in (p', texcoord))
& rasterizePrimitives (TriangleCtx CullNone PolygonFill NoOffset LastVertex) ((Smooth))
& mapFragments (\((d)) -> (( textureCube cubemap d )))
& accumulateWith (DepthOp Always False, ColorOp NoBlending (V4 True True True True))
`overlay`
prims
& mapPrimitives (\(p,n,uvw) -> ( coordmap cam p, V2 uvw%x (1 - uvw%y) ))
& rasterizePrimitives (TriangleCtx CullBack PolygonFill NoOffset LastVertex) ((Smooth))
& mapFragments (\((uv)) -> ((color * texture2D (Sampler PointFilter MirroredRepeat texture) uv )))
& accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))
`overlay`
plane
& mapPrimitives (\((p)) -> let p' = coordmap cam $ plane_mat *. p in (p', p%xz))
& rasterizePrimitives (TriangleCtx CullNone PolygonFill NoOffset LastVertex) ((Smooth))
& mapFragments (\((uv)) -> let c = mixB zero one (fract uv >= (one *! (0.95::Float)))
r = V4 1 1 1 0 *! (max c%x c%y)
in ((r + V4 0 0 0 (0.8))))
& accumulateWith (DepthOp Less True, ColorOp blendplane (V4 True True True True))
`overlay`
lines
& mapPrimitives (\(p,c) -> let p' = coordmap cam $ point p
w = p'%w
yellowish = normalize c `dot` V3 1 1 0
p2 = if yellowish >= 0.9*sqrt 2
then V4 p'%x p'%y 0.1 w
else V4 p'%x p'%y 0.11 w
in (p2, point c))
& renderPoints cam (LineCtx 1.0 LastVertex)
`overlay`
points
& mapPrimitives (\(p,c) -> let p' = coordmap cam $ point p
w = p'%w
yellowish = normalize c `dot` V3 1 1 0
p2 = if yellowish >= 0.9*sqrt 2
then V4 p'%x p'%y 0.1 w
else V4 p'%x p'%y 0.11 w
in (p2, point c))
& renderPoints cam (PointCtx (PointSize 5.0) 1.0 LowerLeft)
renderPoints ::
Mat 4 4 Float
-> RasterContext (Vec 4 Float, Vec 4 Float) pr
-> PrimitiveStream pr (Vec 4 Float, Vec 4 Float)
-> ( (FragmentOperation Depth, FragmentOperation (Color (VecScalar 4 Float)))
, FragmentStream 1 ((Vec 4 Float)) )
renderPoints cam ctx points =
points
& rasterizePrimitives ctx ((Flat))
& mapFragments (\((c)) -> ((c)))
& accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))
main :: Output
main = renderFrame $
makeFrame (TextureCubeSlot "CubeMap")
(fetch "SkyCube" ((Attribute "position")))
(Uniform "CameraPosition")
(Uniform "ViewProjection")
(Uniform "diffuseColor")
(Texture2DSlot "diffuseTexture")
(fetch "objects" (Attribute "position", Attribute "normal", Attribute "uvw"))
(fetch "plane" ((Attribute "position")))
(fetch "Curve" (Attribute "position", Attribute "color"))
(fetch "Points" (Attribute "position", Attribute "color"))
(Uniform "PlaneModel")
|
