aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMarc Sunet <jeannekamikaze@gmail.com>2012-08-06 13:25:57 +0200
committerMarc Sunet <jeannekamikaze@gmail.com>2012-08-06 13:25:57 +0200
commit134f9d6cf39cf3e7d3d405fd268a85b55442cc3b (patch)
tree7dcd00e77d98a4e29639bfb0a9a46d24430fda68
parent4d622a038f7a4e34a3252843aacfa70fd072f502 (diff)
Added physics module
Diffstat
-rw-r--r--Spear.cabal131
-rw-r--r--Spear.lkshs12
-rw-r--r--Spear.lkshw2
-rw-r--r--Spear/Physics.hs12
-rw-r--r--Spear/Physics/Rigid.hs122
-rw-r--r--Spear/Physics/Types.hs11
-rw-r--r--Spear/Physics/World.hs177
7 files changed, 364 insertions, 103 deletions
diff --git a/Spear.cabal b/Spear.cabal
index ab8f6b9..dc462ae 100644
--- a/Spear.cabal
+++ b/Spear.cabal
@@ -7,7 +7,6 @@ license-file: LICENSE
7maintainer: jeannekamikaze@gmail.com 7maintainer: jeannekamikaze@gmail.com
8homepage: http://spear.shellblade.net 8homepage: http://spear.shellblade.net
9synopsis: A 3D game framework. 9synopsis: A 3D game framework.
10description:
11category: Game 10category: Game
12author: Marc Sunet 11author: Marc Sunet
13data-dir: "" 12data-dir: ""
@@ -15,106 +14,46 @@ data-dir: ""
15library 14library
16 build-depends: GLFW -any, OpenGL -any, OpenGLRaw -any, 15 build-depends: GLFW -any, OpenGL -any, OpenGLRaw -any,
17 StateVar -any, base -any, bytestring -any, directory -any, 16 StateVar -any, base -any, bytestring -any, directory -any,
18 mtl -any, transformers -any, resource-simple -any, parsec >= 3.1.3, containers, 17 mtl -any, transformers -any, resource-simple -any, parsec >=3.1.3,
19 ansi-terminal, vector 18 containers -any, ansi-terminal -any, vector -any, array -any
20 19 exposed-modules: Spear.Physics.Types Spear.Physics.World Spear.App
21 exposed-modules: 20 Spear.App.Application Spear.App.Input Spear.Assets.Image
22 Spear.App 21 Spear.Assets.Model Spear.Collision Spear.Collision.AABB
23 Spear.App.Application 22 Spear.Collision.Collision Spear.Collision.Collisioner
24 Spear.App.Input 23 Spear.Collision.Sphere Spear.Collision.Triangle
25 24 Spear.Collision.Types Spear.Game Spear.GLSL Spear.GLSL.Buffer
26 Spear.Assets.Image 25 Spear.GLSL.Error Spear.GLSL.Management Spear.GLSL.Texture
27 Spear.Assets.Model 26 Spear.GLSL.Uniform Spear.GLSL.VAO Spear.Math.Camera
28 27 Spear.Math.Entity Spear.Math.Matrix3 Spear.Math.Matrix4
29 Spear.Collision 28 Spear.Math.MatrixUtils Spear.Math.Octree Spear.Math.Plane
30 Spear.Collision.AABB 29 Spear.Math.Quaternion Spear.Math.Spatial Spear.Math.Vector3
31 Spear.Collision.Collision 30 Spear.Math.Vector4 Spear.Physics Spear.Physics.Rigid
32 Spear.Collision.Collisioner
33 Spear.Collision.Sphere
34 Spear.Collision.Triangle
35 Spear.Collision.Types
36
37 Spear.Game
38
39 Spear.GLSL
40 Spear.GLSL.Buffer
41 Spear.GLSL.Error
42 Spear.GLSL.Management
43 Spear.GLSL.Texture
44 Spear.GLSL.Uniform
45 Spear.GLSL.VAO
46
47 Spear.Math.Camera
48 Spear.Math.Entity
49 Spear.Math.Matrix3
50 Spear.Math.Matrix4
51 Spear.Math.MatrixUtils
52 Spear.Math.Octree
53 Spear.Math.Plane
54 Spear.Math.Spatial
55 Spear.Math.Vector3
56 Spear.Math.Vector4
57
58 Spear.Render.AnimatedModel 31 Spear.Render.AnimatedModel
59 Spear.Render.Material 32 Spear.Render.Material Spear.Render.Model Spear.Render.Program
60 Spear.Render.Model 33 Spear.Render.Renderable Spear.Render.StaticModel
61 Spear.Render.Program 34 Spear.Render.Texture Spear.Scene.Graph Spear.Scene.Light
62 Spear.Render.Renderable 35 Spear.Scene.Loader Spear.Scene.Scene Spear.Scene.SceneResources
63 Spear.Render.StaticModel 36 Spear.Setup Spear.Sys.Timer Spear.Updatable
64 Spear.Render.Texture
65
66 Spear.Scene.Graph
67 Spear.Scene.Light
68 Spear.Scene.Loader
69 Spear.Scene.Scene
70 Spear.Scene.SceneResources
71
72 Spear.Setup
73
74 Spear.Sys.Timer
75
76 Spear.Updatable
77 exposed: True 37 exposed: True
78
79 buildable: True 38 buildable: True
80
81 build-tools: hsc2hs -any 39 build-tools: hsc2hs -any
82 40 cc-options: -O2 -g -Wno-unused-result
83 c-sources: 41 c-sources: Spear/Assets/Image/Image.c
84 Spear/Assets/Image/Image.c 42 Spear/Assets/Image/BMP/BMP_load.c Spear/Assets/Model/Model.c
85 Spear/Assets/Image/BMP/BMP_load.c 43 Spear/Assets/Model/MD2/MD2_load.c
86 Spear/Assets/Model/Model.c 44 Spear/Assets/Model/OBJ/OBJ_load.cc Spear/Render/RenderModel.c
87 Spear/Assets/Model/MD2/MD2_load.c 45 Spear/Sys/Timer/ctimer.c
88 Spear/Assets/Model/OBJ/OBJ_load.cc
89 Spear/Render/RenderModel.c
90 Spear/Sys/Timer/ctimer.c
91
92 extensions: TypeFamilies 46 extensions: TypeFamilies
93 47 extra-libraries: stdc++
94 includes: 48 includes: Spear/Assets/Image/BMP/BMP_load.h
95 Spear/Assets/Image/BMP/BMP_load.h 49 Spear/Assets/Image/Image.h Spear/Assets/Image/Image_error_code.h
96 Spear/Assets/Image/Image.h 50 Spear/Assets/Image/sys_types.h Spear/Assets/Model/MD2/MD2_load.h
97 Spear/Assets/Image/Image_error_code.h 51 Spear/Assets/Model/OBJ/OBJ_load.h Spear/Assets/Model/Model.h
98 Spear/Assets/Image/sys_types.h 52 Spear/Assets/Model/Model_error_code.h
99 Spear/Assets/Model/MD2/MD2_load.h 53 Spear/Assets/Model/sys_types.h Spear/Render/RenderModel.h
100 Spear/Assets/Model/OBJ/OBJ_load.h 54 Timer/Timer.h
101 Spear/Assets/Model/Model.h 55 include-dirs: Spear/Assets/Image Spear/Assets/Model Spear/Render
102 Spear/Assets/Model/Model_error_code.h 56 Spear/Sys
103 Spear/Assets/Model/sys_types.h
104 Spear/Render/RenderModel.h
105 Timer/Timer.h
106
107 include-dirs:
108 Spear/Assets/Image
109 Spear/Assets/Model
110 Spear/Render
111 Spear/Sys
112
113 hs-source-dirs: . 57 hs-source-dirs: .
114
115 ghc-options: -O2 -rtsopts 58 ghc-options: -O2 -rtsopts
116
117 cc-options: -O2 -g -Wno-unused-result
118
119 extra-libraries: stdc++
120 59
diff --git a/Spear.lkshs b/Spear.lkshs
index 1427d7f..9fbb082 100644
--- a/Spear.lkshs
+++ b/Spear.lkshs
@@ -1,18 +1,18 @@
1Version of session file format: 1Version of session file format:
2 1 2 1
3Time of storage: 3Time of storage:
4 "Thu Aug 2 15:35:02 CEST 2012" 4 "Mon Aug 6 13:19:58 CEST 2012"
5Layout: VerticalP (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = 4, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [("Browser",HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 308) 219)], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 756) 953 5Layout: VerticalP (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = 7, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [("Browser",HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 289) 214)], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 738) 954
6Population: [(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Collision/Collision.hs" 61)),[SplitP LeftP]),(Just (ErrorsSt ErrorsState),[SplitP RightP,SplitP TopP]),(Just (FilesSt FilesState),[SplitP RightP,SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/GameObject.hs" 2483)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/GameState.hs" 893)),[SplitP LeftP]),(Just (InfoSt (InfoState Nothing)),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP BottomP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Scene/Loader.hs" 10609)),[SplitP LeftP]),(Just (LogSt LogState),[SplitP RightP,SplitP BottomP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Assets/Model/Model.c" 1772)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Assets/Model/Model.h" 0)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Assets/Model.hsc" 10563)),[SplitP LeftP]),(Just (ModulesSt (ModulesState 286 (PackageScope False,False) (Nothing,Nothing) (ExpanderState {packageExp = ([],[]), packageExpNoBlack = ([],[]), packageDExp = ([],[]), packageDExpNoBlack = ([],[]), workspaceExp = ([],[]), workspaceExpNoBlack = ([],[]), workspaceDExp = ([],[]), workspaceDExpNoBlack = ([],[]), systemExp = ([],[]), systemExpNoBlack = ([],[])}))),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP TopP]),(Just (WorkspaceSt WorkspaceState),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/main.hs" 1249)),[SplitP LeftP])] 6Population: [(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Collision/Collision.hs" 75)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Collision/Collisioner.hs" 551)),[SplitP LeftP]),(Just (ErrorsSt ErrorsState),[SplitP RightP,SplitP TopP]),(Just (FilesSt FilesState),[SplitP RightP,SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/GameObject.hs" 1411)),[SplitP LeftP]),(Just (InfoSt (InfoState Nothing)),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP BottomP]),(Just (LogSt LogState),[SplitP RightP,SplitP BottomP]),(Just (ModulesSt (ModulesState 286 (PackageScope False,False) (Nothing,Nothing) (ExpanderState {packageExp = ([],[]), packageExpNoBlack = ([],[]), packageDExp = ([],[]), packageDExpNoBlack = ([],[]), workspaceExp = ([],[]), workspaceExpNoBlack = ([],[]), workspaceDExp = ([],[]), workspaceDExpNoBlack = ([],[]), systemExp = ([],[]), systemExpNoBlack = ([],[])}))),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Physics.hs" 133)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Physics/Rigid.hs" 447)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Math/Spatial.hs" 0)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Physics/Types.hs" 142)),[SplitP LeftP]),(Just (WorkspaceSt WorkspaceState),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Physics/World.hs" 196)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/main.hs" 1603)),[SplitP LeftP])]
7Window size: (1796,979) 7Window size: (1796,979)
8Completion size: 8Completion size:
9 (750,400) 9 (750,400)
10Workspace: Just "/home/jeanne/programming/haskell/Spear/Spear.lkshw" 10Workspace: Just "/home/jeanne/programming/haskell/Spear/Spear.lkshw"
11Active pane: Just "Model.c" 11Active pane: Just "World.hs"
12Toolbar visible: 12Toolbar visible:
13 True 13 True
14FindbarState: (False,FindState {entryStr = "asd", entryHist = ["mandatory","mandao","col","forward","asd","MouseButton"], replaceStr = "mandatory'", replaceHist = [], caseSensitive = False, entireWord = False, wrapAround = False, regex = False, lineNr = 1}) 14FindbarState: (False,FindState {entryStr = "asd", entryHist = ["gravity","asdad","rotSpeed","azimuth","mandatory","mandao","col","forward","MouseButton"], replaceStr = "mandatory'", replaceHist = [], caseSensitive = False, entireWord = False, wrapAround = False, regex = False, lineNr = 1})
15Recently opened files: 15Recently opened files:
16 ["/home/jeanne/programming/haskell/Spear/Spear/Scene/Loader.hs","/home/jeanne/programming/haskell/Spear/Spear/Assets/Model.hsc","/home/jeanne/programming/haskell/Spear/Spear/Assets/Model/Model.h","/home/jeanne/programming/haskell/Spear/Spear/Scene/Graph.hs","/home/jeanne/programming/haskell/Spear/Spear/Scene/SceneResources.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Matrix4.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Vector3.hs","/home/jeanne/programming/haskell/Spear/demos/simple-scene/simple.scene","/home/jeanne/programming/haskell/Spear/Spear/Assets/Model/Model.c","/home/jeanne/programming/haskell/Spear/demos/simple-scene/GameMessage.hs","/home/jeanne/programming/haskell/Spear/demos/simple-scene/GameState.hs","/home/jeanne/programming/haskell/Spear/Spear/Collision/Collision.hs"] 16 ["/home/jeanne/programming/haskell/Spear/demos/simple-scene/GameState.hs","/home/jeanne/programming/haskell/Spear/Spear/App/Input.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Spatial.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Quaternion.hs","/home/jeanne/programming/haskell/Spear/Spear/Render/AnimatedModel.hs","/home/jeanne/programming/haskell/Spear/Spear/Render/StaticModel.hs","/home/jeanne/programming/haskell/Spear/Spear/Scene/Loader.hs","/home/jeanne/programming/haskell/Spear/Spear/Assets/Model.hsc","/home/jeanne/programming/haskell/Spear/Spear/Assets/Model/Model.h","/home/jeanne/programming/haskell/Spear/Spear/Scene/Graph.hs","/home/jeanne/programming/haskell/Spear/Spear/Scene/SceneResources.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Matrix4.hs"]
17Recently opened workspaces: 17Recently opened workspaces:
18 ["/home/jeanne/programming/haskell/Spear/Spear.lkshw","/home/jeanne/leksah.lkshw"] \ No newline at end of file 18 ["/home/jeanne/programming/haskell/Spear/Spear.lkshw","/home/jeanne/leksah.lkshw"] \ No newline at end of file
diff --git a/Spear.lkshw b/Spear.lkshw
index 865bceb..fdfc941 100644
--- a/Spear.lkshw
+++ b/Spear.lkshw
@@ -1,7 +1,7 @@
1Version of workspace file format: 1Version of workspace file format:
2 1 2 1
3Time of storage: 3Time of storage:
4 "Wed Aug 1 18:11:40 CEST 2012" 4 "Mon Aug 6 13:19:41 CEST 2012"
5Name of the workspace: 5Name of the workspace:
6 "Spear" 6 "Spear"
7File paths of contained packages: 7File paths of contained packages:
diff --git a/Spear/Physics.hs b/Spear/Physics.hs
new file mode 100644
index 0000000..248d4fe
--- /dev/null
+++ b/Spear/Physics.hs
@@ -0,0 +1,12 @@
1module Spear.Physics
2(
3 module Spear.Physics.Rigid
4, module Spear.Physics.Types
5, module Spear.Physics.World
6)
7where
8
9
10import Spear.Physics.Rigid
11import Spear.Physics.Types
12import Spear.Physics.World
diff --git a/Spear/Physics/Rigid.hs b/Spear/Physics/Rigid.hs
new file mode 100644
index 0000000..b9c84d2
--- /dev/null
+++ b/Spear/Physics/Rigid.hs
@@ -0,0 +1,122 @@
1module Spear.Physics.Rigid
2(
3 module Spear.Physics.Types
4, RigidBody(..)
5, rigidBody
6, update
7)
8where
9
10
11import qualified Spear.Math.Matrix4 as M4
12import Spear.Math.Spatial
13import Spear.Math.Vector3 as V3
14import Spear.Physics.Types
15
16import Data.List (foldl')
17import Control.Monad.State
18
19
20data RigidBody = RigidBody
21 { mass :: Float
22 , position :: Vector3
23 , velocity :: Vector3
24 , acceleration :: Vector3
25 }
26
27
28instance Spatial RigidBody where
29
30 move v body = body { position = v + position body }
31
32 moveFwd speed body = body { position = position body + scale (-speed) unitZ }
33
34 moveBack speed body = body { position = position body + scale speed unitZ }
35
36 strafeLeft speed body = body { position = position body + scale (-speed) unitX }
37
38 strafeRight speed body = body { position = position body + scale speed unitX }
39
40 pitch angle = id
41
42 yaw angle = id
43
44 roll angle = id
45
46 pos = position
47
48 fwd _ = unitZ
49
50 up _ = unitY
51
52 right _ = unitX
53
54 transform body = M4.transform unitX unitY unitZ $ position body
55
56 setTransform transf body = body { position = M4.position transf }
57
58 setPos p body = body { position = p }
59
60
61-- | Build a 'RigidBody'.
62rigidBody :: Mass -> Position -> RigidBody
63rigidBody m x = RigidBody m x V3.zero V3.zero
64
65
66-- | Update the given 'RigidBody'.
67update :: [Force] -> Dt -> RigidBody -> RigidBody
68update forces dt body =
69 let netforce = foldl' (+) V3.zero forces
70 m = mass body
71 r1 = position body
72 v1 = velocity body
73 a1 = acceleration body
74 r2 = r1 + scale dt v1 + scale (0.5*dt*dt) a1
75 v' = v1 + scale (0.5*dt) a1
76 a2 = a1 + scale (1/m) netforce
77 v2 = v1 + scale (dt/2) (a2+a1) + scale (0.5*dt) a2
78 in
79 RigidBody m r2 v2 a2
80
81
82-- test
83gravity = vec3 0 (-10) 0
84b0 = rigidBody 50 $ vec3 0 1000 0
85
86
87debug :: IO ()
88debug = evalStateT debug' b0
89
90
91
92debug' :: StateT RigidBody IO ()
93debug' = do
94 lift . putStrLn $ "Initial body:"
95 lift . putStrLn . show' $ b0
96 lift . putStrLn $ "Falling..."
97 step $ update [gravity*50] 1
98 step $ update [gravity*50] 1
99 step $ update [gravity*50] 1
100 lift . putStrLn $ "Jumping"
101 step $ update [gravity*50, vec3 0 9000 0] 1
102 lift . putStrLn $ "Falling..."
103 step $ update [gravity*50] 1
104 step $ update [gravity*50] 1
105 step $ update [gravity*50] 1
106
107
108step :: (RigidBody -> RigidBody) -> StateT RigidBody IO ()
109step update = do
110 modify update
111 body <- get
112 lift . putStrLn . show' $ body
113
114
115show' body =
116 "mass " ++ (show $ mass body) ++
117 ", position " ++ (showVec $ position body) ++
118 ", velocity " ++ (showVec $ velocity body) ++
119 ", acceleration " ++ (showVec $ acceleration body)
120
121
122showVec v = (show $ x v) ++ ", " ++ (show $ y v) ++ ", " ++ (show $ z v)
diff --git a/Spear/Physics/Types.hs b/Spear/Physics/Types.hs
new file mode 100644
index 0000000..5d87c47
--- /dev/null
+++ b/Spear/Physics/Types.hs
@@ -0,0 +1,11 @@
1module Spear.Physics.Types
2where
3
4
5import Spear.Math.Vector3
6
7
8type Dt = Float
9type Force = Vector3
10type Mass = Float
11type Position = Vector3
diff --git a/Spear/Physics/World.hs b/Spear/Physics/World.hs
new file mode 100644
index 0000000..4ad0191
--- /dev/null
+++ b/Spear/Physics/World.hs
@@ -0,0 +1,177 @@
1module Spear.Physics.World
2(
3 module Spear.Physics.Types
4 -- * Data types
5, World
6, ObjectID
7 -- * Construction
8, emptyWorld
9 -- * World operations
10, setGravity
11, updateWorld
12 -- * Object operations
13, newObject
14, deleteObject
15, modifyObject
16, objectTransform
17, objectForces
18, setForces
19)
20where
21
22
23import Spear.Collision.AABB
24import Spear.Collision.Collisioner as C
25import Spear.Collision.Sphere
26import Spear.Math.Matrix4 (Matrix4)
27import Spear.Math.Spatial
28import Spear.Math.Vector3
29import Spear.Physics.Rigid as Rigid
30import Spear.Physics.Types
31
32import Control.Monad.ST
33import Data.Array as A
34import Data.Array.ST
35import Data.Maybe (fromJust)
36
37
38-- | Uniquely identifies an object in a 'World'.
39newtype ObjectID = ObjectID Int
40
41
42data Object = Object
43 { body :: RigidBody
44 , collisioner :: Collisioner
45 , forces :: [Vector3]
46 }
47
48
49-- | The world where physical bodies are simulated.
50data World = World
51 { bodies :: Array Int (Maybe Object) -- ^ Collection of objects.
52 , gravity :: Vector3 -- ^ World gravity.
53 }
54
55
56-- | Create an empty 'World'.
57emptyWorld :: World
58emptyWorld = World emptyArray defaultGravity
59 where
60 defaultGravity = vec3 0 (-9.8) 0
61 emptyArray = listArray (0,0) []
62
63
64-- | Create a new object.
65newObject :: RigidBody -> Collisioner -> World -> (World, ObjectID)
66newObject body collisioner world =
67 let obj = (Object body collisioner [])
68 in case emptySlot world of
69 Just i -> (insert i obj world, ObjectID i)
70 Nothing -> append obj world
71
72
73-- | Search for an empty slot in the given 'World'.
74emptySlot :: World -> Maybe Int
75emptySlot world = Nothing
76
77
78-- | Insert the given 'Object' in the given 'World' at the given position.
79insert :: Int -> Object -> World -> World
80insert i obj world = world { bodies = bodies' }
81 where
82 bodies' = runSTArray $ do
83 bs <- thaw $ bodies world
84 writeArray bs i $ Just obj
85 return bs
86
87
88-- | Append the given object to the given 'World'.
89--
90-- The world's vectors are doubled in size to make future insertions faster.
91append :: Object -> World -> (World, ObjectID)
92append obj world = (world, ObjectID 0)
93
94
95-- | Remove the object specified by the given 'ObjectID' from the given 'World'.
96deleteObject :: ObjectID -> World -> World
97deleteObject (ObjectID i) world = world { bodies = bodies' }
98 where
99 bodies' = runSTArray $ do
100 bs <- thaw $ bodies world
101 writeArray bs i Nothing
102 return bs
103
104
105-- | Modify the object identified by the given 'ObjectID' in the given 'World'.
106modifyObject :: (RigidBody -> RigidBody) -> ObjectID -> World -> World
107modifyObject f (ObjectID i) world = world { bodies = bodies' }
108 where
109 bodies' = runSTArray $ do
110 bs <- thaw $ bodies world
111 obj <- readArray bs i
112 writeArray bs i $ fmap (\obj -> obj { body = f $ body obj }) obj
113 return bs
114
115
116-- | Get the transform of the object identified by the given 'ObjectID'.
117objectTransform :: World -> ObjectID -> Matrix4
118objectTransform world (ObjectID i) = transform . body . fromJust $ bodies world ! i
119
120
121-- | Get the forces acting on the object identified by the given 'ObjectID'.
122objectForces :: World -> ObjectID -> [Force]
123objectForces world (ObjectID i) = forces . fromJust $ bodies world ! i
124
125
126-- | Add the given force to the forces acting on the object identified by the given 'ObjectID'.
127setForces :: [Force] -> ObjectID -> World -> World
128setForces fs (ObjectID i) world = world { bodies = bodies' }
129 where
130 bodies' = runSTArray $ do
131 bs <- thaw $ bodies world
132 obj <- readArray bs i
133 writeArray bs i $ fmap (\obj -> obj { forces = fs }) obj
134 return bs
135
136
137-- | Set the world's gravity.
138setGravity :: Vector3 -> World -> World
139setGravity g world = world { gravity = g }
140
141
142-- | Update the 'World'.
143updateWorld :: Dt -> World -> World
144updateWorld dt world = world { bodies = bodies' }
145 where
146 bodies' = runSTArray $ do
147 bs <- thaw $ bodies world
148 mapArray updateObject bs
149 return bs
150
151 updateObject = fmap updateObject'
152 updateObject' (Object body collisioner forces) = Object body' collisioner' forces
153 where
154 -- Forces acting on the body.
155 forces' = scale (mass body) (gravity world) : forces
156
157 -- Updated body.
158 body' = Rigid.update forces dt body
159
160 -- Center collisioner around the new body's center.
161 collisioner' = center (Rigid.position body') collisioner
162
163 -- Center the collisioner around the given point.
164 center c (SphereCol (Sphere _ r)) = sphereCollisioner $ Sphere c r
165 center c (AABBCol (AABB min max)) =
166 let v = (max - min) / 2
167 min' = c - v
168 max' = c + v
169 in
170 aabbCollisioner $ AABB min' max'
171
172
173{--- | Test for potential collisions in the given 'World'.
174--
175-- Returns a new world and a list of colliding pairs of objects.
176--testCollisions :: World -> (World, [(ObjectID, ObjectID)])-}
177
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-29 06:36:31 +0000