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
|
module Vivant.Terrain
(Terrain(..), initTerrain)
where
import Vivant.Renderer
import qualified Data.Vector.Storable as V
import qualified Graphics.Rendering.OpenGL as GL
import SDL (($=))
import Foreign.Marshal.Alloc (free, malloc)
import Foreign.Ptr
import Vivant.Common (vectorSize, uncurry3)
import Foreign.Storable (poke)
import Linear
data Terrain = Terrain
{
terrainWidth :: Int,
terrainHeight :: Int,
terrainGeometry :: [[Float]],
terrainRenderer :: Renderer
} deriving (Show)
normal :: Num c => (c, c, c) -> (c, c, c) -> (c, c, c) -> (c, c, c)
normal a b c =
transform $ cross (uncurry3 V3 b ^-^ uncurry3 V3 a) (uncurry3 V3 c ^-^ uncurry3 V3 a)
where
transform (V3 a b c) = (a, b, c)
partition
:: (V.Storable a1, Enum a1, Num a1) => [[a1]] -> V.Vector a1
partition r =
V.fromList . concat . concat .
fmap (\(e, y) -> fmap (generateP y) $ zip (zip (uncurry zip e) $ tail (uncurry zip e)) [0..])
$ zip (zip r $ tail r) [0..]
where
generateP y (((z1, z2), (z3, z4)), x) =
let (n1x, n1y, n1z) = normal (x, y, z1) (x, y+1, z2) (x+1, y, z3)
(n2x, n2y, n2z) = normal (x+1, y+1, z4) (x, y+1, z2) (x+1, y, z3)
in
[ x, y, z1
, -n1x, -n1y, -n1z
, x, y+1, z2
, -n1x, -n1y, -n1z
, x+1, y, z3
, -n1x, -n1y, -n1z
, x, y+1, z2
, n2x, n2y, n2z
, x+1, y, z3
, n2x, n2y, n2z
, x+1, y+1, z4
, n2x, n2y, n2z
]
initTerrain :: [[Float]] -> GL.Program -> IO Terrain
initTerrain g p = do
vao <- GL.genObjectName
GL.bindVertexArrayObject $= Just vao
vbo <- GL.genObjectName
GL.bindBuffer GL.ArrayBuffer $= Just vbo
let g' = partition g :: V.Vector Float
V.unsafeWith g' $ \ptr ->
GL.bufferData GL.ArrayBuffer $= (vectorSize g', castPtr ptr, GL.StaticDraw)
setVertexAttribute p "position" 3 6 0
setVertexAttribute p "normal" 3 6 3
GL.bindVertexArrayObject $= Nothing
let h = length g
w = length (head g)
modelMatrix = mkTransformation (axisAngle (V3 0 0 0) 0)
(V3 (- fromIntegral w / 2) (- fromIntegral h / 2) 0)
modelP <- malloc
poke modelP modelMatrix
return $ Terrain w h g (Renderer (Just p) (Just vao) modelP ((w + 2) * (h + 2) * 8))
destroyTerrain :: Terrain -> IO ()
destroyTerrain t =
destroyRenderer $ terrainRenderer t
|
