-
Notifications
You must be signed in to change notification settings - Fork 0
/
Reactimation.hs
89 lines (76 loc) · 2.85 KB
/
Reactimation.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
{-# LANGUAGE Arrows #-}
module Reactimation where
import Types
import IdentityList
import FRP.Yampa as Yampa
import SFML.Window
import SFML.Graphics
import SFML.System
import Control.Monad.Loops
import GHC.Float
import Data.Maybe
allPendingEvents :: RenderWindow -> IO Input
allPendingEvents wnd = do
eventMaybe <- unfoldWhileM (/= Nothing) (pollEvent wnd)
return $ (fromMaybe []) $ sequence eventMaybe
initialize :: RenderWindow -> IO Input
initialize wnd = do
putStrLn "Initialize..."
allPendingEvents wnd
input :: RenderWindow -> Clock -> Bool -> IO (DTime, Maybe Input)
input wnd clk _ = do
events <- allPendingEvents wnd
delta <- fmap (float2Double.asSeconds) (restartClock clk)
return (delta, Just events)
-- Reactimation process
process :: IL Object -> SF Input (IL ObjOutput)
process objs0 = proc input -> do
rec
-- 'process' stores the 'State's (note: rec) and
-- passes them over to core
oos <- core objs0 -< (input, oos)
returnA -< oos
core :: IL Object -> SF (Input, IL ObjOutput) (IL ObjOutput)
core objs = dpSwitch route
objs
(arr killAndSpawn >>> notYet)
(\sfs' f -> core (f sfs'))
-- 1. process previous object 'State's (if any) and
-- generate logical events
-- 2. distribute input and logical events to the corresponding objects
route :: (Input, IL ObjOutput) -> IL sf -> IL (ObjEvents, sf)
route (input, oos) objs = mapIL routeAux objs
where
hs = hits (assocsIL (fmap ooState oos)) -- process all object 'State's
routeAux (k, obj) = (ObjEvents
{ oeInput = input
-- hit events are only routed to the objects they belong to (routing)
, oeLogic = if k `elem` hs then Event () else Yampa.NoEvent
}, obj)
hits :: [(ILKey, State)] -> [ILKey]
hits kooss = concat (hitsAux kooss)
where
hitsAux [] = []
-- Check each object 'State' against each other
hitsAux ((k,oos):kooss) =
[ [k, k'] | (k', oos') <- kooss, oos `hit` oos' ]
++ hitsAux kooss
hit :: State -> State -> Bool
(Entity p1 _ _ _ _) `hit` (Entity p2 _ _ _ _) = p1 == p2
killAndSpawn :: ((Input, IL ObjOutput), IL ObjOutput)
-> Yampa.Event (IL Object -> IL Object)
killAndSpawn ((input, _), oos) =
if any checkEscKey input || any checkExit input
then Event (\_ -> emptyIL) -- kill all 'State' on [Esc] => quit
else foldl (mergeBy (.)) noEvent events
where
events :: [Yampa.Event (IL Object -> IL Object)]
events = [ mergeBy (.)
(ooKillRequest oo `tag` (deleteIL k))
(fmap (foldl (.) id . map insertIL_)
(ooSpawnRequests oo))
| (k, oo) <- assocsIL oos ]
checkEscKey (SFEvtKeyPressed KeyEscape _ _ _ _) = True
checkEscKey _ = False
checkExit SFEvtClosed = True
checkExit _ = False