aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Spear/Step.hs134
-rw-r--r--demos/pong/Pong.hs54
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 @@
2module Spear.Step 2module 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)
18where 24where
19 25
26import Data.List (foldl')
27import qualified Data.Map as Map
28import Data.Map (Map)
20import Data.Monoid 29import Data.Monoid
21 30
22type Elapsed = Double 31type Elapsed = Double
23type Dt = Float 32type Dt = Float
24 33
25-- | A step function. 34-- | A step function.
26data Step a b = Step { step :: Elapsed -> Dt -> a -> (b, Step a b) } 35data 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.
39step :: (Elapsed -> Dt -> s -> e -> a -> (b, Step s e a b)) -> Step s e a b
40step = Step
27 41
28-- | Step identity. 42-- | Step identity.
29sid :: Step a a 43sid :: Step s e a a
30sid = Step $ \_ _ a -> (a, sid) 44sid = Step $ \_ _ _ _ a -> (a, sid)
45
46-- | Construct a step from a pure function.
47spure :: (a -> b) -> Step s e a b
48spure 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.
33sfst :: Step (a,b) a 51sfst :: Step s e (a,b) a
34sfst = spure $ \(a,_) -> a 52sfst = 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.
37ssnd :: Step (a,b) b 55ssnd :: Step s e (a,b) b
38ssnd = spure $ \(_,b) -> b 56ssnd = 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.
41spure :: (a -> b) -> Step a b 59--
42spure f = Step $ \_ _ x -> (f x, spure f) 60-- The initial step is the first one.
61switch :: 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
65switch flag1 s1 flag2 s2 = switch' s1 flag1 s1 flag2 s2
66
67switch' :: 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
72switch' 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.
85multiSwitch :: (Eq e, Ord e) => [(e, Step s (Maybe e) a a)] -> Step s (Maybe e) a a
86multiSwitch xs = multiSwitch' Nothing sid (Map.fromList xs)
87
88multiSwitch' :: (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
91multiSwitch' 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.
108sfold :: Step s (Maybe e) a a -> Step s [e] a a
109sfold 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
118sfold' :: Elapsed -> Dt -> s -> Step s (Maybe e) a a -> a -> [e]
119 -> (a, Step s (Maybe e) a a)
120sfold' 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
44instance Functor (Step a) where 124instance 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
49instance Monoid (Step a a) where 129instance 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.
71szip :: (a -> b -> c) -> Step d a -> Step d b -> Step d c 151szip :: (a -> b -> c) -> Step s e d a -> Step s e d b -> Step s e d c
72szip f (Step s1) (Step s2) = Step $ \elapsed dt d -> 152szip 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
31data GameObject = GameObject 31data 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
37instance Spatial2 GameObject where 37instance Spatial2 GameObject where
@@ -43,7 +43,7 @@ stepWorld elapsed dt evts gos = map (update elapsed dt evts gos) gos
43 43
44update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject 44update :: Elapsed -> Dt -> [GameEvent] -> [GameObject] -> GameObject -> GameObject
45update elapsed dt evts gos go = 45update 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
49ballBox :: AABB2 49ballBox :: 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
68ignore :: Step ([GameEvent], [GameObject], GameObject) GameObject
69ignore = spure $ \(_,_,go) -> go
70
71ignoreEvts :: Step ([GameEvent], [GameObject], GameObject) ([GameObject], GameObject)
72ignoreEvts = spure $ \(_, world, go) -> (world, go)
73
74ignoreGOs :: Step ([GameEvent], [GameObject], GameObject) ([GameEvent], GameObject)
75ignoreGOs = spure $ \(evts, _, go) -> (evts, go)
76
77-- Ball steppers 66-- Ball steppers
78 67
79stepBall vel = ignoreEvts .> collideBall vel .> moveBall 68stepBall vel = collideBall vel .> moveBall
80 69
81collideBall :: Vector2 -> Step ([GameObject], GameObject) (Vector2, GameObject) 70collideBall :: Vector2 -> Step [GameObject] e GameObject (Vector2, GameObject)
82collideBall vel = Step $ \_ _ (gos, ball) -> 71collideBall 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
100aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax) 89aabbAdd (AABB2 pmin pmax) p = AABB2 (p+pmin) (p+pmax)
101 90
102moveBall :: Step (Vector2, GameObject) GameObject 91moveBall :: Step s e (Vector2, GameObject) GameObject
103moveBall = Step $ \_ dt (vel,ball) -> (move (scale dt vel) ball, moveBall) 92moveBall = step $ \_ dt _ _ (vel,ball) -> (move (scale dt vel) ball, moveBall)
104 93
105-- Enemy stepper 94-- Enemy stepper
106 95
107stepEnemy = ignore .> movePad 96stepEnemy = movePad
108 97
109movePad :: Step GameObject GameObject 98movePad :: Step s e GameObject GameObject
110movePad = Step $ \elapsed _ pad -> 99movePad = 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
119stepPlayer = ignoreGOs 108stepPlayer = sfold moveGO .> clamp
120 .> moveGO False MoveLeft StopLeft 109
121 .> moveGO False MoveRight StopRight 110moveGO = 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
125moveGO :: Bool -> GameEvent -> GameEvent 115moveGO' :: Vector2 -> Step s e GameObject GameObject
126 -> Step ([GameEvent], GameObject) ([GameEvent], GameObject) 116moveGO' dir = step $ \_ dt _ _ go -> (move (scale dt dir) go, moveGO' dir)
127moveGO 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
132clamp :: Step GameObject GameObject 118clamp :: Step s e GameObject GameObject
133clamp = spure $ \go -> 119clamp = 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