diff options
author | Jeanne-Kamikaze <jeannekamikaze@gmail.com> | 2013-08-18 12:08:06 +0200 |
---|---|---|
committer | Jeanne-Kamikaze <jeannekamikaze@gmail.com> | 2013-08-18 12:08:06 +0200 |
commit | 527272ec4fca5aa375e593b8a005c3206a1bcc27 (patch) | |
tree | e82100738beb350baf724e1e87fb329dd2de27fa | |
parent | 12b9253d857be440b0fc72a3344de20e4c60732a (diff) |
Enhanced Step function
-rw-r--r-- | Spear/Step.hs | 134 | ||||
-rw-r--r-- | demos/pong/Pong.hs | 54 |
2 files changed, 127 insertions, 61 deletions
diff --git a/Spear/Step.hs b/Spear/Step.hs index 5df873d..f1aef59 100644 --- a/Spear/Step.hs +++ b/Spear/Step.hs | |||
@@ -2,14 +2,20 @@ | |||
2 | module Spear.Step | 2 | module Spear.Step |
3 | ( | 3 | ( |
4 | -- * Definitions | 4 | -- * Definitions |
5 | Step(..) | 5 | Step |
6 | , Elapsed | 6 | , Elapsed |
7 | , Dt | 7 | , Dt |
8 | -- * Running | ||
9 | , runStep | ||
8 | -- * Constructors | 10 | -- * Constructors |
11 | , step | ||
9 | , sid | 12 | , sid |
10 | , spure | 13 | , spure |
11 | , sfst | 14 | , sfst |
12 | , ssnd | 15 | , ssnd |
16 | , switch | ||
17 | , multiSwitch | ||
18 | , sfold | ||
13 | -- * Combinators | 19 | -- * Combinators |
14 | , (.>) | 20 | , (.>) |
15 | , (<.) | 21 | , (<.) |
@@ -17,59 +23,133 @@ module Spear.Step | |||
17 | ) | 23 | ) |
18 | where | 24 | where |
19 | 25 | ||
26 | import Data.List (foldl') | ||
27 | import qualified Data.Map as Map | ||
28 | import Data.Map (Map) | ||
20 | import Data.Monoid | 29 | import Data.Monoid |
21 | 30 | ||
22 | type Elapsed = Double | 31 | type Elapsed = Double |
23 | type Dt = Float | 32 | type Dt = Float |
24 | 33 | ||
25 | -- | A step function. | 34 | -- | A step function. |
26 | data Step a b = Step { step :: Elapsed -> Dt -> a -> (b, Step a b) } | 35 | data Step s e a b = |
36 | Step { runStep :: Elapsed -> Dt -> s -> e -> a -> (b, Step s e a b) } | ||
37 | |||
38 | -- | Construct a step from a function. | ||
39 | step :: (Elapsed -> Dt -> s -> e -> a -> (b, Step s e a b)) -> Step s e a b | ||
40 | step = Step | ||
27 | 41 | ||
28 | -- | Step identity. | 42 | -- | Step identity. |
29 | sid :: Step a a | 43 | sid :: Step s e a a |
30 | sid = Step $ \_ _ a -> (a, sid) | 44 | sid = Step $ \_ _ _ _ a -> (a, sid) |
45 | |||
46 | -- | Construct a step from a pure function. | ||
47 | spure :: (a -> b) -> Step s e a b | ||
48 | spure f = Step $ \_ _ _ _ x -> (f x, spure f) | ||
31 | 49 | ||
32 | -- | The step that returns the first component in the tuple. | 50 | -- | The step that returns the first component in the tuple. |
33 | sfst :: Step (a,b) a | 51 | sfst :: Step s e (a,b) a |
34 | sfst = spure $ \(a,_) -> a | 52 | sfst = spure $ \(a,_) -> a |
35 | 53 | ||
36 | -- | The step that returns the second component in the tuple. | 54 | -- | The step that returns the second component in the tuple. |
37 | ssnd :: Step (a,b) b | 55 | ssnd :: Step s e (a,b) b |
38 | ssnd = spure $ \(_,b) -> b | 56 | ssnd = spure $ \(_,b) -> b |
39 | 57 | ||
40 | -- | Construct a step from a pure function. | 58 | -- | Construct a step that switches between two steps based on input. |
41 | spure :: (a -> b) -> Step a b | 59 | -- |
42 | spure f = Step $ \_ _ x -> (f x, spure f) | 60 | -- The initial step is the first one. |
61 | switch :: Eq e | ||
62 | => e -> (Step s (Maybe e) a a) | ||
63 | -> e -> (Step s (Maybe e) a a) | ||
64 | -> Step s (Maybe e) a a | ||
65 | switch flag1 s1 flag2 s2 = switch' s1 flag1 s1 flag2 s2 | ||
66 | |||
67 | switch' :: Eq e | ||
68 | => (Step s (Maybe e) a a) | ||
69 | -> e -> (Step s (Maybe e) a a) | ||
70 | -> e -> (Step s (Maybe e) a a) | ||
71 | -> Step s (Maybe e) a a | ||
72 | switch' cur flag1 s1 flag2 s2 = Step $ \elapsed dt g e a -> | ||
73 | case e of | ||
74 | Nothing -> | ||
75 | let (a',s') = runStep cur elapsed dt g Nothing a | ||
76 | in (a', switch' s' flag1 s1 flag2 s2) | ||
77 | Just e' -> | ||
78 | let next = if e' == flag1 then s1 | ||
79 | else if e' == flag2 then s2 | ||
80 | else cur | ||
81 | (a',s') = runStep next elapsed dt g e a | ||
82 | in (a', switch' s' flag1 s1 flag2 s2) | ||
83 | |||
84 | -- | Construct a step that switches among multiple steps based on input. | ||
85 | multiSwitch :: (Eq e, Ord e) => [(e, Step s (Maybe e) a a)] -> Step s (Maybe e) a a | ||
86 | multiSwitch xs = multiSwitch' Nothing sid (Map.fromList xs) | ||
87 | |||
88 | multiSwitch' :: (Eq e, Ord e) | ||
89 | => Maybe e -> Step s (Maybe e) a a -> Map e (Step s (Maybe e) a a) | ||
90 | -> Step s (Maybe e) a a | ||
91 | multiSwitch' curKey cur m = Step $ \elapsed dt g e a -> | ||
92 | let singleStep = let (a',s') = runStep cur elapsed dt g e a | ||
93 | in (a', multiSwitch' curKey s' m) | ||
94 | in case e of | ||
95 | Nothing -> singleStep | ||
96 | Just e' -> case Map.lookup e' m of | ||
97 | Nothing -> singleStep | ||
98 | Just s -> | ||
99 | let (a',s') = runStep s elapsed dt g e a | ||
100 | m' = case curKey of | ||
101 | Nothing -> m | ||
102 | Just key -> Map.insert key cur m | ||
103 | in (a', multiSwitch' e s' m') | ||
104 | |||
105 | -- | Construct a step that folds a given list of inputs. | ||
106 | -- | ||
107 | -- The step is run N+1 times, where N is the size of the input list. | ||
108 | sfold :: Step s (Maybe e) a a -> Step s [e] a a | ||
109 | sfold s = Step $ \elapsed dt g es a -> | ||
110 | case es of | ||
111 | [] -> | ||
112 | let (b',s') = runStep s elapsed dt g Nothing a | ||
113 | in (b', sfold s') | ||
114 | es -> | ||
115 | let (b',s') = sfold' elapsed dt g s a es | ||
116 | in (b', sfold s') | ||
117 | |||
118 | sfold' :: Elapsed -> Dt -> s -> Step s (Maybe e) a a -> a -> [e] | ||
119 | -> (a, Step s (Maybe e) a a) | ||
120 | sfold' elapsed dt g s a es = foldl' f (a',s') es | ||
121 | where f (a,s) e = runStep s elapsed dt g (Just e) a | ||
122 | (a',s') = runStep s elapsed dt g Nothing a | ||
43 | 123 | ||
44 | instance Functor (Step a) where | 124 | instance Functor (Step s e a) where |
45 | fmap f (Step s1) = Step $ \elapsed dt x -> | 125 | fmap f (Step s1) = Step $ \elapsed dt g e x -> |
46 | let (a, s') = s1 elapsed dt x | 126 | let (a, s') = s1 elapsed dt g e x |
47 | in (f a, fmap f s') | 127 | in (f a, fmap f s') |
48 | 128 | ||
49 | instance Monoid (Step a a) where | 129 | instance Monoid (Step s e a a) where |
50 | mempty = sid | 130 | mempty = sid |
51 | 131 | ||
52 | mappend (Step s1) (Step s2) = Step $ \elapsed dt a -> | 132 | mappend (Step s1) (Step s2) = Step $ \elapsed dt g e a -> |
53 | let (b, s1') = s1 elapsed dt a | 133 | let (b, s1') = s1 elapsed dt g e a |
54 | (c, s2') = s2 elapsed dt b | 134 | (c, s2') = s2 elapsed dt g e b |
55 | in (c, mappend s1' s2') | 135 | in (c, mappend s1' s2') |
56 | 136 | ||
57 | -- Combinators | 137 | -- Combinators |
58 | 138 | ||
59 | -- | Chain two steps. | 139 | -- | Compose two steps. |
60 | (.>) :: Step a b -> Step b c -> Step a c | 140 | (.>) :: Step s e a b -> Step s e b c -> Step s e a c |
61 | (Step s1) .> (Step s2) = Step $ \elapsed dt a -> | 141 | (Step s1) .> (Step s2) = Step $ \elapsed dt g e a -> |
62 | let (b, s1') = s1 elapsed dt a | 142 | let (b, s1') = s1 elapsed dt g e a |
63 | (c, s2') = s2 elapsed dt b | 143 | (c, s2') = s2 elapsed dt g e b |
64 | in (c, s1' .> s2') | 144 | in (c, s1' .> s2') |
65 | 145 | ||
66 | -- | Chain two steps. | 146 | -- | Compose two steps. |
67 | (<.) :: Step a b -> Step c a -> Step c b | 147 | (<.) :: Step s e a b -> Step s e c a -> Step s e c b |
68 | (<.) = flip (.>) | 148 | (<.) = flip (.>) |
69 | 149 | ||
70 | -- | Evaluate two steps and zip their results. | 150 | -- | Evaluate two steps and zip their results. |
71 | szip :: (a -> b -> c) -> Step d a -> Step d b -> Step d c | 151 | szip :: (a -> b -> c) -> Step s e d a -> Step s e d b -> Step s e d c |
72 | szip f (Step s1) (Step s2) = Step $ \elapsed dt d -> | 152 | szip f (Step s1) (Step s2) = Step $ \elapsed dt g e d -> |
73 | let (a, s1') = s1 elapsed dt d | 153 | let (a, s1') = s1 elapsed dt g e d |
74 | (b, s2') = s2 elapsed dt d | 154 | (b, s2') = s2 elapsed dt g e d |
75 | in (f a b, szip f s1' s2') \ No newline at end of file | 155 | in (f a b, szip f s1' s2') \ No newline at end of file |
diff --git a/demos/pong/Pong.hs b/demos/pong/Pong.hs index b323aa2..6b2f888 100644 --- a/demos/pong/Pong.hs +++ b/demos/pong/Pong.hs | |||
@@ -24,14 +24,14 @@ data GameEvent | |||
24 | | MoveRight | 24 | | MoveRight |
25 | | StopLeft | 25 | | StopLeft |
26 | | StopRight | 26 | | StopRight |
27 | deriving Eq | 27 | deriving (Eq, Ord) |
28 | 28 | ||
29 | -- Game objects | 29 | -- Game objects |
30 | 30 | ||
31 | data GameObject = GameObject | 31 | data GameObject = GameObject |
32 | { aabb :: AABB2 | 32 | { aabb :: AABB2 |
33 | , obj :: Obj2 | 33 | , obj :: Obj2 |
34 | , gostep :: Step ([GameEvent], [GameObject], GameObject) GameObject | 34 | , gostep :: Step [GameObject] [GameEvent] GameObject GameObject |
35 | } | 35 | } |
36 | 36 | ||
37 | instance Spatial2 GameObject where | 37 | instance Spatial2 GameObject where |
@@ -43,7 +43,7 @@ stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos | |||
43 | 43 | ||
44 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject | 44 | update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject |
45 | update elapsed dt evts gos go = | 45 | update elapsed dt evts gos go = |
46 | let (go', s') = step (gostep go) elapsed dt (evts, gos, go) | 46 | let (go', s') = runStep (gostep go) elapsed dt gos evts go |
47 | in go' { gostep = s' } | 47 | in go' { gostep = s' } |
48 | 48 | ||
49 | ballBox :: AABB2 | 49 | ballBox :: AABB2 |
@@ -63,23 +63,12 @@ newWorld = | |||
63 | , GameObject padBox (obj2 0.5 0.1) stepPlayer | 63 | , GameObject padBox (obj2 0.5 0.1) stepPlayer |
64 | ] | 64 | ] |
65 | 65 | ||
66 | -- Generic steppers | ||
67 | |||
68 | ignore :: Step ([GameEvent], [GameObject], GameObject) GameObject | ||
69 | ignore = spure $ \(_,_,go) -> go | ||
70 | |||
71 | ignoreEvts :: Step ([GameEvent], [GameObject], GameObject) ([GameObject], GameObject) | ||
72 | ignoreEvts = spure $ \(_, world, go) -> (world, go) | ||
73 | |||
74 | ignoreGOs :: Step ([GameEvent], [GameObject], GameObject) ([GameEvent], GameObject) | ||
75 | ignoreGOs = spure $ \(evts, _, go) -> (evts, go) | ||
76 | |||
77 | -- Ball steppers | 66 | -- Ball steppers |
78 | 67 | ||
79 | stepBall vel = ignoreEvts .> collideBall vel .> moveBall | 68 | stepBall vel = collideBall vel .> moveBall |
80 | 69 | ||
81 | collideBall :: Vector2 -> Step ([GameObject], GameObject) (Vector2, GameObject) | 70 | collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject) |
82 | collideBall vel = Step $ \_ _ (gos, ball) -> | 71 | collideBall vel = step $ \_ _ gos _ ball -> |
83 | let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball | 72 | let (AABB2 pmin pmax) = aabb ball `aabbAdd` pos ball |
84 | collideCol = x pmin < 0 || x pmax > 1 | 73 | collideCol = x pmin < 0 || x pmax > 1 |
85 | collideRow = y pmin < 0 || y pmax > 1 | 74 | collideRow = y pmin < 0 || y pmax > 1 |
@@ -99,15 +88,15 @@ collide go1 go2 = | |||
99 | 88 | ||
100 | aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax) | 89 | aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax) |
101 | 90 | ||
102 | moveBall :: Step (Vector2, GameObject) GameObject | 91 | moveBall :: Step s e (Vector2, GameObject) GameObject |
103 | moveBall = Step $ \_ dt (vel,ball) -> (move (scale dt vel) ball, moveBall) | 92 | moveBall = step $ \_ dt _ _ (vel,ball) -> (move (scale dt vel) ball, moveBall) |
104 | 93 | ||
105 | -- Enemy stepper | 94 | -- Enemy stepper |
106 | 95 | ||
107 | stepEnemy = ignore .> movePad | 96 | stepEnemy = movePad |
108 | 97 | ||
109 | movePad :: Step GameObject GameObject | 98 | movePad :: Step s e GameObject GameObject |
110 | movePad = Step $ \elapsed _ pad -> | 99 | movePad = step $ \elapsed _ _ _ pad -> |
111 | let p = vec2 px 0.9 | 100 | let p = vec2 px 0.9 |
112 | px = double2Float (sin elapsed * 0.5 + 0.5) | 101 | px = double2Float (sin elapsed * 0.5 + 0.5) |
113 | * (1 - 2 * x padSize) | 102 | * (1 - 2 * x padSize) |
@@ -116,20 +105,17 @@ movePad = Step $ \elapsed _ pad -> | |||
116 | 105 | ||
117 | -- Player stepper | 106 | -- Player stepper |
118 | 107 | ||
119 | stepPlayer = ignoreGOs | 108 | stepPlayer = sfold moveGO .> clamp |
120 | .> moveGO False MoveLeft StopLeft | 109 | |
121 | .> moveGO False MoveRight StopRight | 110 | moveGO = mconcat |
122 | .> ssnd | 111 | [ switch StopLeft sid MoveLeft (moveGO' $ vec2 (-1) 0) |
123 | .> clamp | 112 | , switch StopRight sid MoveRight (moveGO' $ vec2 1 0) |
113 | ] | ||
124 | 114 | ||
125 | moveGO :: Bool -> GameEvent -> GameEvent | 115 | moveGO' :: Vector2 -> Step s e GameObject GameObject |
126 | -> Step ([GameEvent], GameObject) ([GameEvent], GameObject) | 116 | moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir) |
127 | moveGO moving start stop = Step $ \_ dt (evts, go) -> | ||
128 | let moving' = (moving || any (==start) evts) && not (any (==stop) evts) | ||
129 | dir = scale dt $ toDir moving' start | ||
130 | in ((evts, move dir go), moveGO moving' start stop) | ||
131 | 117 | ||
132 | clamp :: Step GameObject GameObject | 118 | clamp :: Step s e GameObject GameObject |
133 | clamp = spure $ \go -> | 119 | clamp = spure $ \go -> |
134 | let p' = vec2 (clamp' x s (1 - s)) y | 120 | let p' = vec2 (clamp' x s (1 - s)) y |
135 | (Vector2 x y) = pos go | 121 | (Vector2 x y) = pos go |