diff options
-rw-r--r-- | Spear.lkshs | 8 | ||||
-rw-r--r-- | Spear/Physics/World.hs | 99 |
2 files changed, 28 insertions, 79 deletions
diff --git a/Spear.lkshs b/Spear.lkshs index 3f28583..afbce39 100644 --- a/Spear.lkshs +++ b/Spear.lkshs | |||
@@ -1,14 +1,14 @@ | |||
1 | Version of session file format: | 1 | Version of session file format: |
2 | 1 | 2 | 1 |
3 | Time of storage: | 3 | Time of storage: |
4 | "Thu Aug 9 11:37:44 CEST 2012" | 4 | "Thu Aug 9 13:31:29 CEST 2012" |
5 | Layout: VerticalP (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = 5, 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}) 279) 208)], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 732) 954 | 5 | Layout: VerticalP (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = 6, 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}) 266) 197)], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 702) 954 |
6 | Population: [(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" 259)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/GameState.hs" 670)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Sys/Store/ID.hs" 96)),[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 328 (PackageScope False,False) (Nothing,Nothing) (ExpanderState {packageExp = ([],[]), packageExpNoBlack = ([],[]), packageDExp = ([],[]), packageDExpNoBlack = ([],[]), workspaceExp = ([],[]), workspaceExpNoBlack = ([[5]],[]), 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" 207)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Physics/Rigid.hs" 2175)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Sys/Store.hs" 2183)),[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" 1269)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/main.hs" 204)),[SplitP LeftP])] | 6 | Population: [(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" 259)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/GameState.hs" 670)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Sys/Store/ID.hs" 96)),[SplitP LeftP]),(Just (InfoSt (InfoState (Just (Real (RealDescr {dscName' = "storeFree", dscMbTypeStr' = Just "storeFree :: Index -> Store a -> Store a", dscMbModu' = Just (PM {pack = PackageIdentifier {pkgName = PackageName "Spear", pkgVersion = Version {versionBranch = [0,1], versionTags = []}}, modu = ModuleName ["Spear","Sys","Store"]}), dscMbLocation' = Just (Location {locationSLine = 101, locationSCol = 1, locationELine = 108, locationECol = 32}), dscMbComment' = Just " Free the given slot.", dscTypeHint' = VariableDescr, dscExported' = True}))))),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP BottomP]),(Just (LogSt LogState),[SplitP RightP,SplitP BottomP]),(Just (ModulesSt (ModulesState 328 (PackageScope False,False) (Just (ModuleName ["Spear","Sys","Store"]),Just "storeFree") (ExpanderState {packageExp = ([],[]), packageExpNoBlack = ([[0,9],[0]],[]), packageDExp = ([],[]), packageDExpNoBlack = ([],[]), workspaceExp = ([],[]), workspaceExpNoBlack = ([[5]],[]), 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" 207)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Physics/Rigid.hs" 2175)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Sys/Store.hs" 4136)),[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" 287)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/main.hs" 204)),[SplitP LeftP])] |
7 | Window size: (1841,964) | 7 | Window size: (1841,964) |
8 | Completion size: | 8 | Completion size: |
9 | (750,400) | 9 | (750,400) |
10 | Workspace: Just "/home/jeanne/programming/haskell/Spear/Spear.lkshw" | 10 | Workspace: Just "/home/jeanne/programming/haskell/Spear/Spear.lkshw" |
11 | Active pane: Just "Store.hs" | 11 | Active pane: Just "World.hs" |
12 | Toolbar visible: | 12 | Toolbar visible: |
13 | True | 13 | True |
14 | FindbarState: (False,FindState {entryStr = "asda", entryHist = ["assigned","Triangle","transforma","gravity","asdad","rotSpeed","azimuth","mandatory","mandao","col","forward","MouseButton"], replaceStr = "objects", replaceHist = [], caseSensitive = True, entireWord = False, wrapAround = False, regex = False, lineNr = 1}) | 14 | FindbarState: (False,FindState {entryStr = "asda", entryHist = ["assigned","Triangle","transforma","gravity","asdad","rotSpeed","azimuth","mandatory","mandao","col","forward","MouseButton"], replaceStr = "objects", replaceHist = [], caseSensitive = True, entireWord = False, wrapAround = False, regex = False, lineNr = 1}) |
diff --git a/Spear/Physics/World.hs b/Spear/Physics/World.hs index e0996e6..b4e6176 100644 --- a/Spear/Physics/World.hs +++ b/Spear/Physics/World.hs | |||
@@ -12,9 +12,8 @@ module Spear.Physics.World | |||
12 | -- * Object operations | 12 | -- * Object operations |
13 | , newObject | 13 | , newObject |
14 | , deleteObject | 14 | , deleteObject |
15 | , modifyObject | 15 | , withBody |
16 | , objectTransform | 16 | , objectTransform |
17 | , objectForces | ||
18 | , setForces | 17 | , setForces |
19 | ) | 18 | ) |
20 | where | 19 | where |
@@ -28,10 +27,9 @@ import Spear.Math.Spatial | |||
28 | import Spear.Math.Vector3 | 27 | import Spear.Math.Vector3 |
29 | import Spear.Physics.Rigid as Rigid | 28 | import Spear.Physics.Rigid as Rigid |
30 | import Spear.Physics.Types | 29 | import Spear.Physics.Types |
30 | import Spear.Sys.Store | ||
31 | |||
31 | 32 | ||
32 | import Control.Monad.ST | ||
33 | import Data.Array as A | ||
34 | import Data.Array.ST | ||
35 | import Data.Maybe (fromJust) | 33 | import Data.Maybe (fromJust) |
36 | 34 | ||
37 | 35 | ||
@@ -48,90 +46,47 @@ data Object = Object | |||
48 | 46 | ||
49 | -- | The world where physical bodies are simulated. | 47 | -- | The world where physical bodies are simulated. |
50 | data World = World | 48 | data World = World |
51 | { bodies :: Array Int (Maybe Object) -- ^ Collection of objects. | 49 | { bodies :: Store Object -- ^ Collection of objects. |
52 | , gravity :: Vector3 -- ^ World gravity. | 50 | , gravity :: Vector3 -- ^ World gravity. |
53 | } | 51 | } |
54 | 52 | ||
55 | 53 | ||
56 | -- | Create an empty 'World'. | 54 | -- | Create an empty world. |
57 | emptyWorld :: World | 55 | emptyWorld :: World |
58 | emptyWorld = World emptyArray defaultGravity | 56 | emptyWorld = World emptyStore $ vec3 0 (-9.8) 0 |
59 | where | ||
60 | defaultGravity = vec3 0 (-9.8) 0 | ||
61 | emptyArray = listArray (0,0) [] | ||
62 | 57 | ||
63 | 58 | ||
64 | -- | Create a new object. | 59 | -- | Create a new object. |
65 | newObject :: RigidBody -> Collisioner -> World -> (World, ObjectID) | 60 | newObject :: RigidBody -> Collisioner -> World -> (ObjectID, World) |
66 | newObject body collisioner world = | 61 | newObject body collisioner world = |
67 | let obj = (Object body collisioner []) | 62 | let (index, bodies') = store (Object body collisioner []) $ bodies world |
68 | in case emptySlot world of | 63 | in (ObjectID index, world { bodies = bodies' }) |
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'. | ||
74 | emptySlot :: World -> Maybe Int | ||
75 | emptySlot world = Nothing | ||
76 | |||
77 | |||
78 | -- | Insert the given 'Object' in the given 'World' at the given position. | ||
79 | insert :: Int -> Object -> World -> World | ||
80 | insert 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 | 64 | ||
87 | 65 | ||
88 | -- | Append the given object to the given 'World'. | 66 | -- | Remove the object specified by the given object ID. |
89 | -- | ||
90 | -- The world's vectors are doubled in size to make future insertions faster. | ||
91 | append :: Object -> World -> (World, ObjectID) | ||
92 | append obj world = (world, ObjectID 0) | ||
93 | |||
94 | |||
95 | -- | Remove the object specified by the given 'ObjectID' from the given 'World'. | ||
96 | deleteObject :: ObjectID -> World -> World | 67 | deleteObject :: ObjectID -> World -> World |
97 | deleteObject (ObjectID i) world = world { bodies = bodies' } | 68 | deleteObject (ObjectID i) world = world { bodies = bodies' } |
98 | where | 69 | where |
99 | bodies' = runSTArray $ do | 70 | bodies' = storeFree i $ bodies world |
100 | bs <- thaw $ bodies world | ||
101 | writeArray bs i Nothing | ||
102 | return bs | ||
103 | 71 | ||
104 | 72 | ||
105 | -- | Modify the object identified by the given 'ObjectID' in the given 'World'. | 73 | -- | Modify the object identified by the given object ID. |
106 | modifyObject :: (RigidBody -> RigidBody) -> ObjectID -> World -> World | 74 | withBody :: ObjectID -> World -> (RigidBody -> RigidBody) -> World |
107 | modifyObject f (ObjectID i) world = world { bodies = bodies' } | 75 | withBody (ObjectID index) world f = world { bodies = bodies' } |
108 | where | 76 | where |
109 | bodies' = runSTArray $ do | 77 | bodies' = withElement index (bodies world) $ \obj -> obj { body = f $ body obj } |
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 | 78 | ||
115 | 79 | ||
116 | -- | Get the transform of the object identified by the given 'ObjectID'. | 80 | -- | Get the transform of the object identified by the given object ID. |
117 | objectTransform :: World -> ObjectID -> Matrix4 | 81 | objectTransform :: World -> ObjectID -> Matrix4 |
118 | objectTransform world (ObjectID i) = transform . body . fromJust $ bodies world ! i | 82 | objectTransform world (ObjectID i) = transform . body . fromJust $ (element i $ bodies world) |
119 | 83 | ||
120 | 84 | ||
121 | -- | Get the forces acting on the object identified by the given 'ObjectID'. | 85 | -- | Add the given force to the forces acting on the object identified by the given object ID. |
122 | objectForces :: World -> ObjectID -> [Force] | ||
123 | objectForces 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'. | ||
127 | setForces :: [Force] -> ObjectID -> World -> World | 86 | setForces :: [Force] -> ObjectID -> World -> World |
128 | setForces fs (ObjectID i) world = world { bodies = bodies' } | 87 | setForces fs (ObjectID i) world = world { bodies = bodies' } |
129 | where | 88 | where |
130 | bodies' = runSTArray $ do | 89 | bodies' = withElement i (bodies world) $ \obj -> obj { forces = fs } |
131 | bs <- thaw $ bodies world | ||
132 | obj <- readArray bs i | ||
133 | writeArray bs i $ fmap (\obj -> obj { forces = fs }) obj | ||
134 | return bs | ||
135 | 90 | ||
136 | 91 | ||
137 | -- | Set the world's gravity. | 92 | -- | Set the world's gravity. |
@@ -139,17 +94,11 @@ setGravity :: Vector3 -> World -> World | |||
139 | setGravity g world = world { gravity = g } | 94 | setGravity g world = world { gravity = g } |
140 | 95 | ||
141 | 96 | ||
142 | -- | Update the 'World'. | 97 | -- | Update the world. |
143 | updateWorld :: Dt -> World -> World | 98 | updateWorld :: Dt -> World -> World |
144 | updateWorld dt world = world { bodies = bodies' } | 99 | updateWorld dt world = world { bodies = fmap updateObject $ bodies world } |
145 | where | 100 | where |
146 | bodies' = runSTArray $ do | 101 | updateObject (Object body collisioner forces) = Object body' collisioner' forces |
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 | 102 | where |
154 | -- Forces acting on the body. | 103 | -- Forces acting on the body. |
155 | forces' = scale (mass body) (gravity world) : forces | 104 | forces' = scale (mass body) (gravity world) : forces |
@@ -170,7 +119,7 @@ updateWorld dt world = world { bodies = bodies' } | |||
170 | aabbCollisioner $ AABB min' max' | 119 | aabbCollisioner $ AABB min' max' |
171 | 120 | ||
172 | 121 | ||
173 | {--- | Test for potential collisions in the given 'World'. | 122 | {--- | Test for potential collisions. |
174 | -- | 123 | -- |
175 | -- Returns a new world and a list of colliding pairs of objects. | 124 | -- Returns a new world and a list of colliding pairs of objects. |
176 | --testCollisions :: World -> (World, [(ObjectID, ObjectID)])-} | 125 | --testCollisions :: World -> (World, [(ObjectID, ObjectID)])-} |