Rasenschach-0.1: 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 Graphics.UI.SDL (Pixel)
import FRP.Yampa
import FRP.Yampa.Utilities
import FRP.Yampa.Geometry
import FRP.Yampa.Point2
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 = gi@(te, (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, cNext) <- ballCollisionSF initColls -< colls
let ms = map (\(BallMessage msg) -> msg) $ filter isBallMessage mi
let mcs =
#if DEBUG_MODE
trace ("Ball (Free): " ++ show (ms ++ collisions))
#endif
(ms ++ collisions)
(bs@(st,stParam), msOut') <- freeBallSF (BPWho lpInit t0) -< ((BPWho me t1, vss), (Event mcs))
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
oopPos (BPOutOfPlay _ _ pos _) = pos
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 player t0 goalieHasGained lpInit initColls = {-# SCC "ballIP" #-}
proc (ObjInput {oiGameInput = gi@(te, (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 ("Ball (Poss): " ++ show (ms ++ collisions))
#endif
(ms ++ collisions)
(bs@(st,stParam), ems) <- (controlledBallSF goalieHasGained) (BPWho player t0) -< ((BPWho me t1, vss), (Event mcs))
currPlayer <- iPre player -< 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) 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 vel =
let vel2 = project vel
(theta, rho) = toPolar (vector2X vel2) (vector2Y vel2)
(theta', rho') = (normTheta (theta + pi), 3)
vel2' = fromPolar theta' rho'
in vector3 (vector2X vel2') (vector2Y vel2') (-10)
fetchVel (BPInit vel _) = vel
fetchVel _ = zeroVel
lineCrossedMsgs :: Param -> Time -> BallState -> (Point3 Double) -> ObjId -> [VisibleState] -> [Message]
lineCrossedMsgs param t st pos lastPlayer vss =
-- checks if ball crossed base, side or goal line and sends a corresponding
-- message to the game object
let gameId = vsObjId $ fetchGameVS vss
x = point3X pos
y = point3Y pos
xBase = if x <= (pPitchWidth param) / 2 then 0 else pPitchWidth param
yBase = if y <= 0 then 0 else (pPitchLength param)
teamThrowingIn = otherTeam . vsTeam $ fetchVS vss lastPlayer
goalTeam = if y < 0 then Home else Away
in if st `elem` [BSOutOfPlay, BSControlledOOP, BSChallenged] then []
else if x < 0 || x > pPitchWidth param then [(gameId, GameMessage (GTSideOut, GPTeamPosition teamThrowingIn (Point2 x y) t True))]
else if (y < 0 || y > pPitchLength param) &&
((x < (pPitchWidth param - pGoalWidth param) / 2) || (x > (pPitchWidth param + pGoalWidth param) / 2))
then [(gameId, GameMessage (GTBaseOut, GPTeamPosition teamThrowingIn (Point2 xBase yBase) t True))]
else if (y < 0 || y > pPitchLength param) &&
((x >= (pPitchWidth param - pGoalWidth param) / 2) && (x <= (pPitchWidth param + pGoalWidth param) / 2))
then [(gameId, GameMessage (GTGoal, GPTeamPosition goalTeam (Point2 0 0) t True))]
else [(gameId, GameMessage (GTBallInPlay, GPTeamPosition teamThrowingIn (Point2 0 0) t True))]
ballOutOfPlay :: Param -> ObjId -> ObjId -> Team -> OutOfPlay -> Position2 -> SF ObjInput ObjOutput
ballOutOfPlay param me lpInit team oopType pos = {-# SCC "ballOOP" #-}
proc (ObjInput {oiGameInput = gi@(_, (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 ("Ball (Poss): " ++ show (ms ++ collisions))
#endif
(ms ++ collisions)
(bs@(st,stParam), ems) <- outOfPlayBallSF (BPOutOfPlay team oopType pos lpInit) -< ((BPWho me t1, vss), (Event mcs))
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) 3 (-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 foot initState =
proc (ObjInput {oiMessages = (mi, colls), oiGameState = vss, oiGameInput = (_,(t1,_))}) -> do
let commands = []
let tms =
#if DEBUG_MODE
trace ("Tactical " ++ show me ++ ": " ++ show (convertTms mi))
#endif
(convertTms mi)
rec
pdDefault <- iPre p0 -< pd --projectP pos
((st, stParam@(TacticalStateParam maybePd vd kicked plId ovrwtDir _ timeOfPossession)), 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,
oosBasicState = (oosBS, oosBSP)}
kill
spawn
msgs) <- 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 mi = (sortWith fst (map (\(PlayerMessage (TacticalPlayerMessage tm)) -> tm) $ filter isTacticalPlayerMessage mi))
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 me myTeam myPos mc vss = do
kickType <- getKickType mc
bc <- fetchBallCarrier vss
guard $ vsTeam bc == myTeam
let hisPos = projectP $ vsPos bc
return (vsObjId bc, tm (TPTKickTowards,
(TacticalStateParam Nothing (Just $ (myPos .-. hisPos) ^+! 0) False (Just me)
Nothing (Just kickType) Nothing)))
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 foot initState =
proc (ObjInput {oiGameInput = gi@(_,(t1,incoming)), oiGameState = vss, oiMessages = (mi, colls)}) -> do
-- desired position is current mouse position
(pd, commands) <- playerInput param -< gi
-- mark designated receiver
let myTeam = fst3 ti
let npId = nearestAIPlayer myTeam vss pd
let tms =
#if DEBUG_MODE
trace ("Tactical " ++ show me ++ ": " ++ 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 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, oosBSP),
oosTacticalState = (oosTS, oosTSP)}
kill
spawn
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 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 ("Player " ++ show me ++ ": " ++ show (pms ++ allCollisions))
#endif
(pms ++ allCollisions)
((st,stParam), ems) <- basicPlayerSF pbsInit t0 -< ((t1, me, vss), (Event mcs))
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 pPlayer dirPlayer pBall =
if isLeftFrom dirPlayer (projectP pBall .-. pPlayer) then LeftFoot else RightFoot
myjoin (Event NoFoot) _ = NoEvent
myjoin (Event x) NoEvent = Event (x, False)
myjoin NoEvent (Event ()) = Event (undefined, True)
myjoin NoEvent NoEvent = NoEvent
myjoin _ _ = NoEvent
switchFoot NoFoot = NoFoot
switchFoot RightFoot = LeftFoot
switchFoot LeftFoot = RightFoot
switcher (oldF, _) (newF, False) = (newF, False)
switcher (oldF, _) (_, True) = (switchFoot oldF, False)
fetchBall ((VSBall oid _ _ _ _):xs) = 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 me initialAttacker scoreHome scoreAway t0 =
proc (ObjInput {oiGameInput = gi@(te, (t1,_)), oiGameState = vss, oiMessages = (mi, _)}) -> do
commands <- gameKeysSF -< gi
let gms =
#if DEBUG_MODE
trace ("Game: " ++ 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 (Point2 0 0) t1 True)]
else if cmdFreeze commands then [(GTFreeze, GPTeamPosition freezeAttacker (Point2 0 0) t1 False)]
else []
-- process only first message, and keep rest for later
-- important since the result of every game message should be
-- processed outside the reactimate loop
-- ACHTUNG!!! Das passt nicht, weil die Ball In Play-Meldungen ja jedes Mal kommen!
-- let (now, later) = safePartition $ comMsgs ++ gms
-- ((st, stParam@(GPTeamPosition attacker _ _)), msOut) <- gameSF param (GPTeamPosition initialAttacker (Point2 0 0) 0) -< (vss, Event now)
((st, stParam@(GPTeamPosition attacker _ _ _)), msOut) <- gameSF param (GPTeamPosition initialAttacker (Point2 0 0) t0 True) -< (vss, Event (comMsgs ++ gms))
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
returnA -< ObjOutput {
ooObsObjState = OOSGame t1 -- time
(scoreHome, scoreAway) -- score
(content st, stParam)
attacker
(Point3 0 0 0),
ooKillReq = noEvent,
ooSpawnReq = noEvent,
ooMessages = msOut ++ msg -- ++ (map (\x -> (me, GameMessage x)) later)
}
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