Rasenschach-0.1.3: ObjectBehaviour.hs
{-# LANGUAGE Arrows, FlexibleInstances #-}
module ObjectBehaviour -- (ball, ballInPossession, player, playerAI, game)
where
import Debug.Trace
import GHC.Exts
import Data.List
import Data.Maybe
import Control.Monad (guard)
import FRP.Yampa
import FRP.Yampa.Geometry
import Data.FSM
import Physics
import Object
import Parser
import Command
import Message
import PlayerFSM
import BallFSM
import GameFSM
import States
import Helper
import Global
import BasicTypes
import AI
import Rules
-- *************************************************************************
--
-- Object: Ball
--
-- *************************************************************************
fly :: Param -> ObjId -> ObjId -> Time -> Position3 -> Velocity3 -> Acceleration3 -> Collisions
-> SF ObjInput (ObjOutput, Event (Param, ObjId, ObjId, Time, Position3, Velocity3, Acceleration3, Collisions))
fly param me lpInit t0 p0 v0 acc initColls = proc (ObjInput {oiGameInput = (_, (t1,_)), oiMessages = (mi, colls), oiGameState = vss}) -> do
-- models basic physics of a ball in free flight (speed, gravity, friction)
-- if ball is longer in free flight (either because it went out of bounds (tbd) or
-- because the ball is taken up and controlled by a player), the SF kills itself
-- and respawns as a corresponding SF
v <- (v0 ^+^) ^<< integral -< acc
p <- (p0 .+^) ^<< integral -< v
bounced <- edge -< point3Z p + pEps param < pGround param
stopped <- edge -< sameDirection param (project v) (project acc)
-- drop redundant collisions
(collisions, _) <- ballCollisionSF initColls -< colls
let ms = map (\(BallMessage msg) -> msg) $ filter isBallMessage mi
let mcs =
#if DEBUG_MODE
trace ("__StMsg__Ball__Msg__" ++ show (ms ++ collisions))
#endif
(ms ++ collisions)
(bs@(st',stParam), msOut') <- freeBallSF param (BPWho lpInit t0) -< ((BPWho me t1, vss), (Event mcs))
let st =
#if DEBUG_MODE
trace ("__StMsg__Ball__St__" ++ show (content st'))
#endif
st'
let lp = lastPlayer bs
let msOut =
#if DEBUG_MODE
trace ("Ball (Free) messages: " ++ show msOut' ++ show (lineCrossedMsgs param t1 (content st) p lpInit vss))
#endif
(msOut' ++ lineCrossedMsgs param t1 (content st) p lpInit vss)
gainedControl <- edge -< content st `elem` [BSControlled, BSControlledGoalie]
outOfPlay <- edge -< content st == BSOutOfPlay
let goalieHasGained = content st == BSControlledGoalie
returnA -< (ObjOutput (OOSBall p v (isEvent bounced && vector3Z v < (-5)) ((content st), stParam))
(gainedControl `merge` outOfPlay)
( -- what about cNext??
(gainedControl `tag` [snd3 $ mkBallInPossession param me (fetchPlayer stParam) t1
goalieHasGained lp (p .-^ vector3 (-2) (-2) 0) v colls])
`merge`
(outOfPlay `tag` [let BPOutOfPlay team oop pos _ = stParam in ballOutOfPlay param me lp team oop pos])
)
msOut,
tag (merge bounced stopped) $
let z = max (point3Z p) (pGround param)
vz = if z == pGround param then (-0.7) * vector3Z v else vector3Z v
(vx, vy) = event (vector3X v, vector3Y v) (const (0,0)) stopped
in (param, me, lp, t1, (Point3 (point3X p) (point3Y p) z), vector3 vx vy vz, acc, initColls))
where fetchPlayer (BPWho p _) = p
ball :: (Param, ObjId, ObjId, Time, Position3, Velocity3, Acceleration3, Collisions) -> SF ObjInput ObjOutput
ball (param, me, lpInit, t0, pos, v, acc, initColls) = dSwitch (fly param me lpInit t0 pos v acc initColls) ball
ballInPossession :: Param -> ObjId -> ObjId -> Time -> Bool -> ObjId -> Collisions-> SF ObjInput ObjOutput
ballInPossession param me plr t0 goalieHasGained _ initColls = {-# SCC "ballIP" #-}
proc (ObjInput {oiGameInput = (_, (t1,_)), oiMessages = (mi, colls), oiGameState = vss}) -> do
-- drop redundant collisions
(collisions, cNext) <- ballCollisionSF initColls -< colls
let ms = map (\(BallMessage msg) -> msg) $ filter isBallMessage mi
let mcs =
#if DEBUG_MODE
trace ("__StMsg__Ball__Msg__" ++ show (ms ++ collisions))
#endif
(ms ++ collisions)
((st',stParam), ems) <- (controlledBallSF param goalieHasGained) (BPWho plr t0) -< ((BPWho me t1, vss), (Event mcs))
let st =
#if DEBUG_MODE
trace ("__StMsg__Ball__St__" ++ show (content st'))
#endif
st'
let stParam' =
#if DEBUG_MODE
trace ("BallParam (Poss): " ++ show stParam)
#endif
stParam
currPlayer <- iPre plr -< fetchPlayer stParam'
let Just playerVS = getObjVS currPlayer vss
-- ball is either on the left or right foot of the player, ball position will be
-- adjusted accordingly
let foot = case vsOnFoot playerVS of
LeftFoot -> -(pi / 4)
RightFoot -> pi / 4
_ -> 0
-- position and velocity of the ball are taken from the player's
-- respective values
let p = vsPos playerVS .-^ fromPolar3 (foot + pi + vsDir playerVS) 1.7 0 -- 2.1 0
let v = vsVel playerVS
lostPossession <- edge -< content st == BSFree
outOfPlay <- edge -< content st == BSOutOfPlay
returnA -< ObjOutput (OOSBall p v False ((content st), stParam))
(lostPossession `merge` outOfPlay)
(
(lostPossession `tag` [snd3 $ mkBall (param, me, currPlayer, t1,
p, (fetchVel stParam), (makeBreakVector (fetchVel stParam)), cNext)])
`merge`
(outOfPlay `tag` [let BPOutOfPlay team oop pos _ = stParam in ballOutOfPlay param me currPlayer team oop pos])
)
(ems ++ lineCrossedMsgs param t1 (content st) p currPlayer vss)
where fetchPlayer (BPWho who _) = who
makeBreakVector :: Velocity3 -> Vector3 Velocity
makeBreakVector vel =
let vel2 = project vel
(theta, _) = toPolar (vector2X vel2) (vector2Y vel2)
(theta', rho') = (normTheta (theta + pi), 3)
vel2' = fromPolar theta' rho'
in vector3 (vector2X vel2') (vector2Y vel2') (-10)
fetchVel :: BallMsgParam -> Vector3 Double
fetchVel (BPInit vel _) = vel
fetchVel _ = zeroVel
lineCrossedMsgs :: Param -> Time -> BallState -> (Point3 Double) -> ObjId -> [VisibleState] -> [Message]
lineCrossedMsgs param t _ pos1 lastPlr vss =
-- checks if ball crossed base, side or goal line and sends a corresponding
-- message to the game object
let gameId_ = vsObjId $ fetchGameVS vss
pos0 = vsPos . fetchBallVS $ vss
(x0, y0) = (point3X pos0, point3Y pos0)
(x1, y1) = (point3X pos1, point3Y pos1)
xMax = pPitchWidth param
yMax = pPitchLength param
xBase = if x1 <= (pPitchWidth param) / 2 then 0 else pPitchWidth param
yBase = if y1 <= 0 then 0 else (pPitchLength param)
teamThrowingIn = otherTeam . vsTeam $ fetchVS vss lastPlr
goalTeam = if y1 < 0 then Home else Away
in if (x1 < 0 && x0 >= 0) || (x1 > xMax && x0 <= xMax) then
[(gameId_, GameMessage (GTOutOfPlay, GPTeamPosition teamThrowingIn (-1) [] (Point2 x1 y1) t True OOPSideOut))]
else if ((y1 < 0 && y0 >= 0) || (y1 > yMax && y0 <= yMax)) &&
((x1 < (xMax - pGoalWidth param) / 2) || (x1 > (xMax + pGoalWidth param) / 2)) then
[(gameId_, GameMessage (GTOutOfPlay, GPTeamPosition teamThrowingIn (-1) [] (Point2 xBase yBase) t True OOPBaseOut))]
else if ((y1 < 0 && y0 >= 0) || (y1 > yMax && y0 <= yMax)) &&
((x1 >= (xMax - pGoalWidth param) / 2) && (x1 <= (xMax + pGoalWidth param) / 2))
then [(gameId_, GameMessage (GTGoal, GPTeamPosition goalTeam (-1) [] (Point2 0 0) t True OOPKickOff))]
else []
ballOutOfPlay :: Param -> ObjId -> ObjId -> Team -> OutOfPlay -> Position2 -> SF ObjInput ObjOutput
ballOutOfPlay param me lpInit team oopType pos = {-# SCC "ballOOP" #-}
proc (ObjInput {oiGameInput = (_, (t1,_)), oiMessages = (mi, colls), oiGameState = vss}) -> do
-- -- what this does:
-- -- a.) as long as the ball is out of play, it's position is either the corresponding out-of-play spot
-- -- (kick off-, corner-positon or side-line position as long as not taken up by player), or
-- -- behind and above the player's head if it's a throw-in and the ball has been taken up by
-- -- a player (then the position changes when the player turns around)
-- -- b.) when the ball goes in play again, the SF kills itself and respawns as a
-- -- ball-SF
-- let ms = map (\(BallMessage msg) -> msg) $ filter isBallMessage mi
-- let mcs = trace ("Ball (Poss): " ++ show (ms ++ collisions)) (ms ++ collisions)
-- ((st,stParam), ems) <- controlledBallSF (BPWho player) -< ((BPWho me, vss), (Event mcs))
-- drop redundant collisions
(collisions, cNext) <- ballCollisionSF [] -< colls
let ms = map (\(BallMessage msg) -> msg) $ filter isBallMessage mi
let mcs =
#if DEBUG_MODE
trace ("__StMsg__Ball__Msg__" ++ show (ms ++ collisions))
#endif
(ms ++ collisions)
(bs@(st',stParam), ems) <- outOfPlayBallSF param (BPOutOfPlay team oopType pos lpInit) -< ((BPWho me t1, vss), (Event mcs))
let st =
#if DEBUG_MODE
trace ("__StMsg__Ball__St__" ++ show (content st'))
#endif
st'
let lp = lastPlayer bs
let Just playerVS = getObjVS lp vss
controlled <- taggedEdge -< (content st == BSControlledOOP, 2.5)
posZ <- hold 0 -< controlled
-- position is above and behind player
let posAdjust = if (content st) == BSControlledOOP then
vsPos playerVS .-^ fromPolar3 (vsDir playerVS) 2 (-posZ)
else pos .+! posZ
backInPlay <- edge -< not $ content st `elem` [BSOutOfPlay, BSControlledOOP, BSChallenged]
returnA -< ObjOutput (OOSBall posAdjust zeroVel False ((content st), stParam))
backInPlay
(backInPlay `tag` [snd3 $ mkBall (param, me, lp, t1, posAdjust,
fetchVel stParam,
makeBreakVector (fetchVel stParam),
cNext)])
ems
-- *************************************************************************
--
-- Object: PlayerAI (controlled by AI)
--
-- *************************************************************************
playerAI :: Param -> ObjId -> Time -> Position2 -> Velocity3 -> Angle -> Bool
-> Bool -> TeamInfo -> PlayerInfo -> BasicState -> OnFoot -> TacticalState -> Object
playerAI param me t0 p0 v0 angle0 sel des ti pI pbsInit _ initState =
proc (ObjInput {oiMessages = (mi, colls), oiGameState = vss, oiGameInput = (_,(t1,_))}) -> do
let commands = []
let tms =
#if DEBUG_MODE
trace ("__StMsg__AI " ++ show me ++ "__Msg__" ++ show (convertTms mi))
#endif
convertTms mi
rec
pdDefault <- iPre p0 -< pd --projectP pos
((st, stParam@(TacticalStateParam maybePd _ _ _ ovrwtDir _ _)), msOut)
<- tacticalPlayerSF param initState angle0 -< ((t1, me, vss, commands), Event tms)
let isDesignated = elem (TPTDesignateReceiver, tspNull) tms
let isSwitchControl = elem (TPTSwitchControl, tspNull) tms
-- desired position comes either from tactical fsm (if tactical transition yielded
-- new pd) or default pd that is usually the last player position
let pd = fromMaybe pdDefault maybePd
let msLocal = map snd $ filter ((me ==) . fst) $ filter (isPhysicalPlayerMessage . snd) msOut
let msOther = filter (\(id_, m) -> not ((id_ == me) && isPhysicalPlayerMessage m)) msOut
results@(ObjOutput oop@OOSPlayer{oosPos = pos, oosVel = vel, oosDir = angle } _ _ _)
<- playerCore param me t0 p0 v0 sel des ti pI pbsInit
-< (pd, False, ovrwtDir, t1, commands, (msLocal ++ mi, colls), vss)
let rm = ooMessages results
let oos = (ooObsObjState results) { oosTacticalState = (content st, stParam), oosDesignated = isDesignated }
returnA -< results { ooMessages = msOther ++ rm,
ooObsObjState = oos,
ooKillReq = if isSwitchControl then Event () else NoEvent,
ooSpawnReq = if isSwitchControl
then Event [ player param
me
t0
(projectP pos)
vel
angle
False
False
ti
pI
(fst $ oosBasicState oop)
(oosOnFoot oop)
(if content st == TSWaitingForKickOff
then TSNonAIKickingOff
else TSNonAI) ]
else NoEvent }
-- *************************************************************************
--
-- Object: Player (controlled by human)
--
-- *************************************************************************
convertTms :: [MessageBody] -> [(TacticalPlayerTransition, TacticalStateParam)]
convertTms mi = (sortWith fst (map (\(PlayerMessage (TacticalPlayerMessage tm_)) -> tm_) $ filter isTacticalPlayerMessage mi))
messageForNearestPlayer :: Param -> ObjId -> Team -> Position2 -> [Command] -> [VisibleState] -> (ObjId, MessageBody)
messageForNearestPlayer param npId myTeam myPos mc vss =
(npId, if cmdTakeOver mc then
tm (TPTSwitchControl, tspNull)
else if cmdMoveForward mc then
tm (TPTMoveTo,
TacticalStateParam (Just $ posNp .+^ vector2 0 adjust)
Nothing False Nothing Nothing Nothing Nothing)
else if cmdMoveBackward mc then
tm (TPTMoveTo,
TacticalStateParam (Just $ posNp .+^ vector2 0 ((-1)*adjust))
Nothing False Nothing Nothing Nothing Nothing)
else if cmdMoveLeft mc then
tm (TPTMoveTo,
TacticalStateParam (Just $ posNp .+^ vector2 adjust 0)
Nothing False Nothing Nothing Nothing Nothing)
else if cmdMoveRight mc then
tm (TPTMoveTo,
TacticalStateParam (Just $ posNp .+^ vector2 ((-1)*adjust) 0)
Nothing False Nothing Nothing Nothing Nothing)
else if cmdMoveToGoal mc then
tm (TPTMoveTo,
TacticalStateParam (Just goalPos)
Nothing False Nothing Nothing Nothing Nothing)
else if cmdMoveToMe mc then
tm (TPTMoveTo,
TacticalStateParam (Just myPos)
Nothing False Nothing Nothing Nothing Nothing)
else
tm (TPTDesignateReceiver, tspNull))
where
posNp = projectP . vsPos $ fetchVS vss npId
adjust = if myTeam == Home then -20 else 20
goalPos = if myTeam == Home then awayGoalCenter param else homeGoalCenter param
messageForTeamMate :: ObjId -> Team -> t -> [Command] -> [VisibleState] -> Maybe (ObjId, MessageBody)
messageForTeamMate me myTeam _ mc vss = do
kickType <- getKickType mc
bc <- fetchBallCarrier vss
guard $ vsTeam bc == myTeam
return (vsObjId bc, pm (PPTLoseMe, BSPPass 1 kickType (Just me)))
getKickType :: [Command] -> Maybe ReleaseType
getKickType mc =
if cmdFlipMeLow mc then Just RTLow
else if cmdFlipMeHigh mc then Just RTHigh
else Nothing
player :: Param -> ObjId -> Time -> Position2 -> Velocity3 -> Angle -> Bool -> Bool
-> TeamInfo -> PlayerInfo -> BasicState -> OnFoot -> TacticalState -> Object
player param me t0 p0 v0 angle0 sel des ti pI pbsInit _ initState =
proc (ObjInput {oiGameInput = gi@(_,(t1,_)), oiGameState = vss, oiMessages = (mi, colls)}) -> do
-- desired position is current mouse position
-- jetzt passt es fast, weil die Position des Spielers eingeht, ganz richtig wäre die Position der Maus...
(pd, commands) <- playerInput param p0 -< gi
-- mark designated receiver
let myTeam = fst3 ti
let npId = nearestAIPlayer myTeam vss pd
let tms =
#if DEBUG_MODE
trace ("__StMsg__AI " ++ show me ++ "__Msg__" ++ show (convertTms mi))
#endif
convertTms mi
let comMsgs = concatMap comToMsg commands
rec
pos' <- iPre p0 -< projectP pos
oosBS' <- iPre pbsInit -< oosBS
let markMsg = messageForNearestPlayer param npId myTeam pos' commands vss
let teamMateMsg = messageForTeamMate me myTeam pos' commands vss
((st',stParam), _) <- tacticalNonAiSF initState -< ((t1, me, vss, commands), Event tms)
let st =
#if DEBUG_MODE
trace ("__StMsg__AI " ++ show me ++ "__St__" ++ show (content st'))
#endif
st'
let running = content st /= TSNonAIKickingOff
-- player commands will be ignored before kickoff
let pdAdjusted = if not running then p0 -- .+^ (vector2 (-0.0000001) 0)
-- only look, don't walk when preparing for throw in
else if oosBS' == PBSPrepareThrowIn then lookTo pos' pd
else pd
let angleAdjusted = if not running then Just angle0 else Nothing
results@(ObjOutput oop@OOSPlayer{oosPos = pos, oosVel = vel, oosDir = angle,
oosBasicState = (oosBS, _)}
_
_
msgs)
<- playerCore param me t0 p0 v0 sel des ti pI pbsInit
-< (pdAdjusted, not (null comMsgs), angleAdjusted, t1, commands, (mi ++ comMsgs, colls), vss)
let (switchAI, newAI) =
if cmdTakeOver commands
then (Event (),
--playerAI :: Param -> ObjId -> Time -> Position2 -> Velocity3 -> Angle -> Bool
-- -> Bool -> TeamInfo -> PlayerInfo -> BasicState -> TacticalState -> Object
Event [playerAI param
me
t0
(projectP pos)
vel
angle
False
False
ti
pI
oosBS
(oosOnFoot oop)
(if content st == TSNonAIKickingOff
then TSWaitingForKickOff
else
if piPlayerRole pI == Goalie
then TSTendingGoal
else TSHoldingPosition)])
else (NoEvent, NoEvent)
let oos = (ooObsObjState results) { oosTacticalState = (content st, stParam) }
returnA -< results {ooMessages = maybeToList teamMateMsg ++ markMsg:msgs,
ooObsObjState = oos,
ooKillReq = switchAI,
ooSpawnReq = newAI}
-- *************************************************************************
--
-- Core player logic, used by both AI- and user controlled player
--
-- *************************************************************************
bouncePower :: (VisibleState -> Velocity3) -> [VisibleState] -> [ObjId] -> Vector2 Velocity
bouncePower f vss =
foldl' (^+^) (vector2 0 0) . map (project . f . fetchVS vss)
playerCore :: Param -> ObjId -> Time -> Position2 -> Velocity3 -> Bool -> Bool -> TeamInfo -> PlayerInfo -> BasicState
-> SF (Point2 Double, Bool, Maybe Angle, Time, [Command], ([MessageBody], Collisions), [VisibleState]) ObjOutput
playerCore param me t0 p0 v0 sel des ti pI pbsInit =
proc (pd, kicked, ovrwtDir, t1, commands, (mi, collsIn), vss) -> do
-- desired position is current mouse position
let pCollsIn = filter (isPlayer . fetchVS vss) collsIn
-- check for new collisions; every new collision will be fed to the basicPlayerFSM,
-- the subset of new player collisions is needed for the bouncing logic
allCollisions <- playerCollisionSF [] -< collsIn
pCollisions <- playerCollisionSF [] -< pCollsIn
-- save the time of the last player collision
pCollided <- taggedEdge -< (not (null pCollisions), t1)
pCollTime <- hold t0 -< pCollided
-- a collision only slows a player down for a given time
-- after that, the usual motion logic starts again
let inPlayerCollision = not (null pCollsIn) && t1 - pCollTime < pBouncingTime param
-- during a collision, the total acc and vel of all the players involved
-- are evenly divided between the "colliders"; this replaced the
-- usual acc and vel for the time of the collision
let adjust = 1 / (1 + fromIntegral (length pCollsIn))
let accBounce = adjust *^ bouncePower vsAcc vss (me:pCollsIn)
let velBounce = adjust *^ bouncePower vsVel vss (me:pCollsIn)
toggled <- edge -< cmdToggleFoot commands
rec
let ad = ((20 *^ (pd .-. p)) ^-^ (10 *^ v)) -- Desired acceleration
let acc = if inPlayerCollision then accBounce else limit (piPlayerAccMax pI) ad
v <- integral >>> arr ((limit (piPlayerSpeedMax pI)) . ((project v0) ^+^))
-< residualAcc param acc v (piPlayerSpeedMax pI)
p <- integral >>> arr (p0 .+^) -< if inPlayerCollision then velBounce else v
let dirV = pd .-. p
let dir = atan2 (vector2Y dirV) (vector2X dirV)
let pms = map (\(PlayerMessage (PhysicalPlayerMessage pm')) -> pm') $ filter isPhysicalPlayerMessage mi
let mcs =
#if DEBUG_MODE
trace ("__StMsg__Tactical " ++ show me ++ "__Msg__ " ++ show (pms ++ allCollisions))
#endif
(pms ++ allCollisions)
((st',stParam), ems) <- basicPlayerSF pbsInit t0 -< ((t1, me, vss), (Event mcs))
let st =
#if DEBUG_MODE
trace ("__StMsg__Tactical " ++ show me ++ "__St__" ++ show (content st'))
#endif
st'
let ems' =
#if DEBUG_MODE
trace ("Messages Player " ++ show me ++ ": " ++ show ems)
#endif
ems
-- toggle between left and right foot
possGained <- edge -< content st == PBSInPossession
let initialFoot = possGained `tag` leftOrRightFoot p dirV (vsPos $ fetchBallVS vss)
(foot, _) <- accumHoldBy switcher (NoFoot, False) -< myjoin initialFoot toggled
returnA -< ObjOutput {
ooObsObjState = OOSPlayer (Point3 (point2X p) (point2Y p) 0)
(vector3 (vector2X v) (vector2Y v) 0)
(vector3 (vector2X acc) (vector2Y acc) 0)
kicked
sel
des
2
ti
pI
(fromMaybe dir ovrwtDir)
((content st), stParam)
(TSNonAI, tspNull)
foot,
ooKillReq = noEvent,
ooSpawnReq = noEvent,
ooMessages = ems'
}
leftOrRightFoot :: Position2 -> Vector2 Double -> Position3 -> OnFoot
leftOrRightFoot pPlayer dirPlayer pBall =
if isLeftFrom dirPlayer (projectP pBall .-. pPlayer) then LeftFoot else RightFoot
myjoin :: Event OnFoot -> Event () -> Event (OnFoot, Bool)
myjoin (Event NoFoot) _ = NoEvent
myjoin (Event x) NoEvent = Event (x, False)
myjoin NoEvent (Event ()) = Event (undefined, True)
myjoin NoEvent NoEvent = NoEvent
myjoin _ _ = NoEvent
switchFoot :: OnFoot -> OnFoot
switchFoot NoFoot = NoFoot
switchFoot RightFoot = LeftFoot
switchFoot LeftFoot = RightFoot
switcher :: (OnFoot, t) -> (OnFoot, Bool) -> (OnFoot, Bool)
switcher (_, _) (newF, False) = (newF, False)
switcher (oldF, _) (_, True) = (switchFoot oldF, False)
fetchBall :: [VisibleState] -> ObjId
fetchBall ((VSBall oid _ _ _ _):_) = oid
fetchBall (_:xs) = fetchBall xs
-- *************************************************************************
--
-- Object: Game
--
-- *************************************************************************
runRulesOnEvent :: Facts -> [VisibleState] -> RuleBase -> RuleBase -> TimerEvent -> [(ObjId, MessageBody)]
runRulesOnEvent facts vss trb_home trb_away te =
runRules tps facts vss (if team == Home then trb_home else trb_away)
where team = if te == TimerCalculateHomeAI then Home else Away
tps = map vsObjId $ teamPlayers team vss
game :: Param -> ObjId -> Team -> Int -> Int -> Time -> Object
game param _ initialAttacker scoreHome scoreAway t0 =
proc (ObjInput {oiGameInput = gi@(te, (t1,_)), oiGameState = vss, oiMessages = (mi, _)}) -> do
commands <- gameKeysSF -< gi
let gms =
#if DEBUG_MODE
trace ("__StMsg__Game__Msg__" ++ show (map (\(GameMessage gm) -> gm) $ filter isGameMessage mi))
#endif
(map (\(GameMessage gm) -> gm) $ filter isGameMessage mi)
rec
freezeAttacker <- iPre initialAttacker -< attacker
let comMsgs = if cmdQuit commands then [(GTQuit, GPTeamPosition freezeAttacker (-1) [] (Point2 0 0) t1 True InPlay)]
else if cmdFreeze commands then [(GTFreeze, GPTeamPosition freezeAttacker (-1) [] (Point2 0 0) t1 False InPlay)]
else []
-- hack!! should not be 100 but real init player
((st', stParam@(GPTeamPosition attacker _ _ _ _ _ _)), msOut) <- gameSF param (GPTeamPosition initialAttacker 100 [] (Point2 0 0) t0 True OOPKickOff) -< (vss, Event (comMsgs ++ gms))
let st =
#if DEBUG_MODE
trace ("__StMsg__Game__St__" ++ show (content st'))
#endif
st'
let teamAtMove = if fromEvent te == TimerCalculateHomeAI then Home else Away
let semNet = deriveFacts param t1 attacker teamAtMove vss
let msg = event [] (runRulesOnEvent semNet vss (pRuleBaseHome param) (pRuleBaseAway param)) te
let totalMsgOut =
#if DEBUG_MODE
trace ("Game messages: " ++ show (msOut ++ msg))
#endif
msOut ++ msg
returnA -< ObjOutput {
ooObsObjState = OOSGame t1 -- time
(scoreHome, scoreAway) -- score
(content st, stParam)
attacker
(Point3 0 0 0),
ooKillReq = noEvent,
ooSpawnReq = noEvent,
ooMessages = totalMsgOut
}
safePartition :: [a] -> ([a], [a])
safePartition [] = ([], [])
safePartition [a] = ([a], [])
safePartition (a:as) = ([a], as)
-- *************************************************************************
--
-- Convenient maker functions
--
-- *************************************************************************
mkBall :: (Param, ObjId, ObjId, Time, Position3, Velocity3, Acceleration3, Collisions) ->
(ObjId, SF ObjInput ObjOutput, ObjOutput)
mkBall (param, me, lp, t0, pos, v, acc, initColls) =
(me, ball (param, me, lp, t0, pos, v, acc, initColls),
ObjOutput (OOSBall pos v False (BSFree, undefined)) NoEvent NoEvent [])
mkBallInPossession :: Param -> ObjId -> ObjId -> Time -> Bool -> ObjId -> Position3 -> Velocity3 ->
Collisions -> (ObjId, SF ObjInput ObjOutput, ObjOutput)
mkBallInPossession param me player' t0 goalieHasGained lp pos v initColls =
(me, ballInPossession param me player' t0 goalieHasGained lp initColls,
ObjOutput (OOSBall pos v False (BSControlled, BPWho player' t0)) NoEvent NoEvent [])
-- *************************************************************************
--
-- Various helper functions
--
-- *************************************************************************
residualAcc :: Param -> Acceleration2 -> Velocity2 -> Double -> Acceleration2
residualAcc param acc vel maxV =
let accTheta = vector2Theta acc
accRho = vector2Rho acc
velTheta = vector2Theta vel
velRho = vector2Rho vel
in
if (velRho + pEps param >= maxV) && (acc `sameDirAs` vel) then
fromPolar (normTheta $ if acc `isLeftFrom` vel then velTheta + pi else velTheta - pi)
-- (accRho * abs (sin (accTheta - accRho))) -- häh???
(accRho * abs (sin (accTheta - velTheta)))
else acc
ballCollisionSF :: Collisions -> SF Collisions ([BallMessage], Collisions)
ballCollisionSF init' = proc c1 -> do
c2 <- iPre init' -< c1
let cNext = c1 \\ c2
let newColls = map (\c -> (BTCollisionB, BPWho c (-1))) cNext
returnA -< (newColls, cNext)
playerCollisionSF :: Collisions -> SF Collisions [PhysicalPlayerMessage]
playerCollisionSF init' = proc c1 -> do
c2 <- iPre init' -< c1
let newColls = map (\c -> (PPTCollisionP, BSPWhoAndWhen c 0)) $ c1 \\ c2
returnA -< newColls
tupelize :: [(a, b)] -> c -> [(a, (b, c))]
tupelize [] _ = []
tupelize ((x,y):xs) z = (x,(y,z)):tupelize xs z
taggedEdge :: SF (Bool, a) (Event a)
taggedEdge = proc (bool, a) -> do
e <- edge -< bool
returnA -< tag e a