Rasenschach-0.1: GameLoop.hs

{-# LANGUAGE Arrows #-}

module GameLoop where

import Debug.Trace
import Data.List

import FRP.Yampa
import FRP.Yampa.Geometry
import FRP.Yampa.Utilities
import Object
import ObjectBehaviour
import Message
import AL
import Global
import BasicTypes
import Helper
import States
import Lineup

instance Show (SF a b) where
    show sf = "SF"

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 [] = 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 ((input, _), 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