{-# LANGUAGE Arrows #-}
module GameLoop where
import Debug.Trace
import FRP.Yampa
import FRP.Yampa.Geometry
import Object
import Message
import AL
import Global
import BasicTypes
import Helper
import States
import Lineup
gameLoop :: Param -> ALOut -> ALObj -> SF GameInput ALOut
gameLoop param init' objs0 =
switch (process init' objs0) $
\(time', possession, scoreHome, scoreAway) ->
#if DEBUG_MODE
trace ("Achtung Init: " ++ show init') $
#endif
uncurry (gameLoop param)
(lineupKickoff param init' time' possession scoreHome scoreAway)
process :: ALOut -> ALObj -> SF GameInput (ALOut, Event (Time, Team, Int, Int))
process init' objs0 = proc input -> do
ticker <- repeatedly 0.3 iterateTimerEvents -< ()
timerEvent <- accum TimerCalculateAwayAI -< ticker
rec
oos <- core init' objs0 -< ((timerEvent, input), oos)
let kickOffEvent = case ((gameOO . elemsAL) oos) of
OOSGame gTime (gScoreHome, gScoreAway) (GSGoal, GPTeamPosition gTeam _ _ _ _ _ _) _ _ ->
Event (gTime, (otherTeam gTeam), gScoreHome + homeAdder gTeam, gScoreAway + awayAdder gTeam)
_ -> NoEvent
returnA -< (oos, kickOffEvent)
where
homeAdder gTeam = if gTeam == Home then 1 else 0
awayAdder gTeam = if gTeam == Away then 1 else 0
gameOO :: [ObjOutput] -> ObsObjState
gameOO [] = error "GameLoop.hs/gameOO: No Game in Object Output"
gameOO (o:os) =
case o of
ObjOutput oog@(OOSGame {}) _ _ _ -> oog
_ -> gameOO os
iterateTimerEvents :: TimerEvent -> TimerEvent
iterateTimerEvents TimerCalculateHomeAI = TimerCalculateAwayAI
iterateTimerEvents TimerCalculateAwayAI = TimerCalculateHomeAI
-- rather more complex core, only necessary if non-static objects are needed
-- (e.g. trigger objects)
core :: ALOut -> ALObj -> SF (Input, ALOut) (ALOut)
core init' objs = proc (input, al) -> do
al' <- iPre init' -< al
res <- core' objs -< (input, al')
returnA -< res
core' :: ALObj -> SF (Input, ALOut) (ALOut)
core' objs = proc (input, al) -> do
res <- dpSwitch route objs (arr killAndSpawn >>> notYet) (\sfs' f -> core' (f sfs')) -< (input, al)
returnA -< res
killAndSpawn :: ((Input, ALOut), ALOut)
-> Event (ALObj -> ALObj)
killAndSpawn (_, oos) =
foldl (mergeBy (.)) noEvent events
where
events :: [Event (ALObj -> ALObj)]
events = [ mergeBy (.)
(fmap (foldl (.) id . map (insertAL k))
(ooSpawnReq oo))
(ooKillReq oo `tag` (deleteAL k))
| (k, oo) <- assocsAL oos ]
route :: (Input, ALOut) -> AL ObjId sf -> AL ObjId (ObjInput, sf)
route (input, oos) = {-# SCC "route" #-}
mapAL (\(oid, obj) -> (ObjInput (getObjMessages oid messages, getObjMessages oid collisions) gameState input, obj))
where
messages = collectMessages oos
AL kooss = mapAL (\(_,o) -> ooObsObjState o) oos
collisions = collect (hits kooss)
gameState = elemsAL . mapAL (\(oid', obj') -> vsFromObjOutput oid' obj') $ oos
collectMessages :: ALOut -> [(ObjId, [MessageBody])]
collectMessages = collect . concat . elemsAL . mapAL (ooMessages . snd)
getObjMessages :: ObjId -> [(ObjId, [a])] -> [a]
getObjMessages oid events =
case lookup oid events of
Just ms -> ms
Nothing -> []
hits :: [(ObjId, ObsObjState)] -> [(ObjId, ObjId)]
hits = {-# SCC "hits" #-}
map createMessage . mirror . hitsAux
where
createMessage (k,k',_,_) = (k, k')
hitsAux [] = []
-- Check each object 'State' against each other
hitsAux ((k,oos):kooss) =
[ (k, k',oos,oos') | (k', oos') <- kooss, oos `hit` oos' ]
++ hitsAux kooss
hit :: ObsObjState -> ObsObjState -> Bool
OOSPlayer {oosPos = p1} `hit` OOSPlayer {oosPos = p2} = distance p1 p2 < 3.0
OOSPlayer {oosPos = p1} `hit` OOSBall {oosPos = p2} = distance p1 p2 < 1.4
OOSBall {oosPos = p1} `hit` OOSPlayer {oosPos = p2} = distance p1 p2 < 1.4
_ `hit` _ = False
mirror [] = []
mirror ((a,b,c,d):xs) = (a,b,c,d):(b,a,d,c):mirror xs