-
Notifications
You must be signed in to change notification settings - Fork 4
/
Billion.hs
executable file
·308 lines (246 loc) · 10.9 KB
/
Billion.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
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
{-
Sample: Billion, the number 1000.000.000
HGamer3D Library (A project to enable 3D game development in Haskell)
Copyright 2011-2015 Peter Althainz
Distributed under the Apache License, Version 2.0
(See attached file LICENSE or copy at
http://www.apache.org/licenses/LICENSE-2.0)
file: Samples/Billion.hs
-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import HGamer3D
import qualified Data.Text as T
import Control.Concurrent
import Control.Monad
import Data.List
-- CH3-2e
-- CH3-3s
-- small tool, to create entities
creator w l = newE w l
-- entity creation tools
camera w pos = creator w [
ctCamera #: FullViewCamera,
ctPosition #: pos
]
item w pos shape mat = creator w [
ctMaterial #: mat,
ctGeometry #: ShapeGeometry shape,
ctPosition #: pos,
ctScale #: unitVec3,
ctOrientation #: unitU
]
light w pos = creator w [
ctLight #: Light PointLight 1.0 1000.0 1.0,
ctPosition #: pos,
ctColour #: white
]
textOne w = creator w [
ctText #: "Billion\n"
, ctScreenRect #: Rectangle 10 10 120 25
]
textTwo w = creator w [
ctText #: ""
, ctScreenRect #: Rectangle 10 50 200 500
]
showText e t = setC e ctText t
type Cube = [[[Entity]]]
itemCube w shape offset mat = do
let r = [2.5, 5.0 .. 25.0]
cubes <-
mapM (\z ->
mapM (\y ->
mapM (\x -> item w ((Vec3 x y z) &+ offset) shape mat) r
) r
) r
return cubes
itemFromCube :: Cube -> Int -> Int -> Int -> Entity
itemFromCube cube x y z = (((cube !! z) !! y) !! x)
lineFromCube :: Cube -> Int -> Int -> [Entity]
lineFromCube cube y z = ((cube !! y) !! z)
planeFromCube :: Cube -> Int -> [[Entity]]
planeFromCube cube z = (cube !! z)
coordFromN n = (x, y, z) where
z = n `div` 100
y = (n - z*100) `div` 10
x = (n - z*100 - y*10)
data CameraSpeed = Slow
| Fast
deriving (Eq, Show)
data CameraDirection = PosX | NegX | PosY | NegY | PosZ | NegZ deriving (Eq, Show)
data Command = MoveCamera [(CameraSpeed, CameraDirection)] GameTime
| SetText T.Text
| Cubes Shape Vec3 Material
| SelectCube Int
| MaterialLine Int Int Material
| MaterialPlane Int Material
| Material Int Int Int Material
| Wait GameTime
deriving (Eq, Show)
mUX = Vec3 0.02 0.0 0.0
mUY = Vec3 0.0 0.02 0.0
mUZ = Vec3 0.0 0.0 0.02
fUX = Vec3 0.05 0.0 0.0
fUY = Vec3 0.0 0.05 0.0
fUZ = Vec3 0.0 0.0 0.05
commandInterpreter w cam t2 refCubes refSel cmd = do
case cmd of
MoveCamera listOfMoves deltaTime -> do
let oneMove (s, d) = do
case (s, d) of
(Slow, PosX) -> updateC cam ctPosition (\v -> v &+ mUX)
(Slow, NegX) -> updateC cam ctPosition (\v -> v &- mUX)
(Slow, PosY) -> updateC cam ctPosition (\v -> v &- mUY)
(Slow, NegY) -> updateC cam ctPosition (\v -> v &+ mUY)
(Slow, PosZ) -> updateC cam ctPosition (\v -> v &+ mUZ)
(Slow, NegZ) -> updateC cam ctPosition (\v -> v &- mUZ)
(Fast, PosX) -> updateC cam ctPosition (\v -> v &+ fUX)
(Fast, NegX) -> updateC cam ctPosition (\v -> v &- fUX)
(Fast, PosY) -> updateC cam ctPosition (\v -> v &- fUY)
(Fast, NegY) -> updateC cam ctPosition (\v -> v &+ fUY)
(Fast, PosZ) -> updateC cam ctPosition (\v -> v &+ fUZ)
(Fast, NegZ) -> updateC cam ctPosition (\v -> v &- fUZ)
let moves startT = do
t <- getTime
if t < (startT + deltaTime) then do
mapM oneMove listOfMoves
sleepFor (msecT 50)
moves startT
else
return ()
tNow <- getTime
forkIO (moves tNow)
return ()
SetText t -> showText t2 t
Cubes shape off mat -> do
cubes <- readVar refCubes
newCube <- itemCube w shape off mat
writeVar refCubes (cubes ++ [newCube])
writeVar refSel newCube
return ()
SelectCube i -> do
cubes <- readVar refCubes
writeVar refSel (cubes !! i)
return ()
MaterialLine y z mat -> do
cube <- readVar refSel
mapM (\c -> setC c ctMaterial mat) (lineFromCube cube y z)
return ()
MaterialPlane z mat -> do
cube <- readVar refSel
mapM (\c -> setC c ctMaterial mat) (concat (planeFromCube cube z))
return ()
Material x y z mat -> do
cube <- readVar refSel
setC (itemFromCube cube x y z) ctMaterial mat
return ()
Wait time -> do
sleepFor time
-- CAMERA MOVEMENT
installKeyPressed :: HG3D -> Entity -> Var [T.Text] -> IO ()
installKeyPressed w eventHandler varKeysPressed = do
let handleKeys ke = do
case ke of
KeyUp _ _ k -> updateVar varKeysPressed (\keys -> (filter (\k' -> k' /= k) keys, ()))
KeyDown _ _ k -> updateVar varKeysPressed (\keys -> (if not (k `elem` keys) then k:keys else keys, ()))
_ -> return ()
registerCallback w eventHandler ctKeyEvent (\key -> handleKeys key)
installMoveCamera cam varKeysPressed = do
let move = do
keys <- readVar varKeysPressed
if "A" `elem` keys then updateC cam ctPosition (\v -> v &- mUX) else return ()
if "D" `elem` keys then updateC cam ctPosition (\v -> v &+ mUX) else return ()
if "W" `elem` keys then updateC cam ctPosition (\v -> v &+ mUY) else return ()
if "S" `elem` keys then updateC cam ctPosition (\v -> v &- mUY) else return ()
if "E" `elem` keys then updateC cam ctPosition (\v -> v &+ mUZ) else return ()
if "C" `elem` keys then updateC cam ctPosition (\v -> v &- mUZ) else return ()
return ()
forkIO $ forever $ move >> sleepFor (msecT 50)
return()
installChangeCubes w ieh cubes = do
let handleKeys k = do
case k of
KeyUp _ _ "Right" -> mapM (\c -> setC c ctMaterial matYellow) (lineFromCube cubes 0 0) >> return ()
KeyUp _ _ "Up" -> mapM (\c -> setC c ctMaterial matRed) (concat (planeFromCube cubes 0)) >> return ()
KeyUp _ _ "G" -> setC (((cubes !! 3) !! 4) !! 5) ctMaterial matGreen >> return ()
KeyUp _ _ k -> return ()
_ -> return ()
registerCallback w ieh ctKeyEvent (\key -> handleKeys key)
installText w ieh t2 = do
let handleKeys k = do
case k of
KeyUp _ _ "F1" -> showText t2 "imagine each cube is one year ...\n"
KeyUp _ _ "F2" -> showText t2 "imagine each cube is one year\nthere are 10 yellow cubes, 10 years ...\n"
KeyUp _ _ "F3" -> showText t2 "imagine each cube is one year\nthere are 10 yellow cubes, 10 years\nthere are 100 yellow and red cubes, 100 years ...\n"
KeyUp _ _ "F4" -> showText t2 "imagine each cube is one year\nthere are 10 yellow cubes, 10 years\nthere are 100 yellow and red cubes, 100 years\nthere are 1000 cubes in total, 1000 years ..."
_ -> return ()
registerCallback w ieh ctKeyEvent (\key -> handleKeys key)
gameLogic w = do
c <- camera w (Vec3 0.0 0.0 0.0)
cubes <- itemCube w Pyramid zeroVec3 matBlue
l <- light w (Vec3 10.0 10.0 0.0)
ieh <- creator w [ctInputEventHandler #: DefaultEventHandler, ctKeyEvent #: NoKeyEvent]
t1 <- textOne w
t2 <- textTwo w
refK <- makeVar []
installKeyPressed w ieh refK
installMoveCamera c refK
installChangeCubes w ieh cubes
installText w ieh t2
refCubes <- makeVar [cubes]
refSel <- makeVar cubes
mapM (\cmd -> commandInterpreter w c t2 refCubes refSel cmd) (
[
-- Intro
MoveCamera [(Slow, NegZ)] (secT 30),
Wait (secT 10),
SetText "imagine each pyramid is one year ...\n",
Wait (secT 10),
MaterialLine 0 0 matYellow,
SetText "imagine each pyramid is one year\nthere are 10 yellow pyramids, 10 years ...\n",
Wait (secT 10),
MoveCamera [(Slow, NegZ), (Slow, NegY), (Slow, PosX)] (secT 35),
Wait (secT 35),
MoveCamera [(Slow, NegZ)] (secT 10),
SetText "imagine each cube is one year\nthere are 100 red pyramids, 100 years ...\n",
MaterialPlane 0 matRed,
Wait (secT 10),
SetText "imagine each cube is one year\nthere are 1000 blue pyramids, 1000 years ...",
MaterialPlane 0 matBlue,
Wait (secT 10),
-- How to count years
SetText "imagine each cube is one year\nthere are 1000 blue pyramids, 1000 years ...\n\ncounting starts at lower left front corner"
] ++
concatMap (\n -> let
(x, y, z) = coordFromN (n-1)
in
[
Wait (msecT 300),
SetText (T.pack ("imagine each cube is one year\nthere are 1000 blue pyramids, 1000 years ...\n\ncounting starts at lower left front corner\nYear " ++ (show n))),
Material x y z matGreen
] ) [1..200]
++
[
MoveCamera [(Slow, NegZ)] (secT 40)
] ++
concatMap (\n -> let
(x, y, z) = coordFromN (n-1)
in
[
Wait (msecT 50),
SetText (T.pack ("imagine each cube is one year\nthere are 1000 blue pyramids, 1000 years ...\n\ncounting starts at lower left front corner\nYear " ++ (show n))),
Material x y z matGreen
] ) [201..1000]
++
[
SetText ("to be continued ..."),
Wait (secT 30)
]
--
)
exitHG3D w
return ()
-- CH3-4e
main = do
runGame standardGraphics3DConfig gameLogic (msecT 20)
return ()