module BallFSM (freeBallSF, controlledBallSF, outOfPlayBallSF)
where
import FRP.Yampa
import FRP.Yampa.Geometry
import Data.List
import Data.Maybe
import Data.FSM
import Message
import Physics
import Object
import States
import Helper
import BasicTypes
import Global
type BallPerception = (BallMsgParam, [VisibleState])
s1 :: State BallState BallTransition p [a]
s1 = addTransition BTCollisionB 3 $
addTransition BTOutOfPlay 4 $
state 1 BSFree (const []) (const []) (const [])
s2 :: Param -> State BallState BallTransition (BallMsgParam, (BallMsgParam, [VisibleState])) [Message]
s2 param = addTransition BTCollisionB 3 $
addTransition BTOutOfPlay 4 $
addTransition BTLost 1 $
state 2 BSControlled (const []) (checkForOffsite param) (const [])
s3 :: Param -> State BallState BallTransition (BallStateParam, BallPerception) [Message]
s3 param = addTransition BTGained 2 $
addTransition BTGainedOOP 5 $
addTransition BTGainedGoalie 6 $
addTransition BTLostOOP 4 $
addTransition BTLost 1 $
state 3 BSChallenged (const []) (takeMe param) (const [])
s4 :: State BallState BallTransition p [a]
s4 = addTransition BTCollisionB 3 $
state 4 BSOutOfPlay (const []) (const []) (const [])
s5 :: State BallState BallTransition p [a]
s5 = addTransition BTLost 1 $
state 5 BSControlledOOP (const []) (const []) (const [])
s6 :: Param -> State BallState BallTransition (BallMsgParam, (BallMsgParam, [VisibleState])) [Message]
s6 param = addTransition BTLost 1 $
state 6 BSControlledGoalie (const []) (checkForOffsite param) (const [])
fsm :: Param -> Either [Problem BallTransition] (FSM BallState BallTransition (BallMsgParam, (BallMsgParam, [VisibleState])) [Message])
fsm param = fromList [s1, s2 param, s3 param, s4, s5, s6 param]
takeMe :: Param -> (BallStateParam, BallPerception) -> [Message]
takeMe _ (BPWho playerIdTouching t, (BPWho me _,vss)) =
let (ballState, ballParam) = vsBallState . fetchBallVS $ vss
gameVS = fetchGameVS vss
game = vsObjId gameVS
attacker = vsAttacker gameVS
playerVS = fetchVS vss playerIdTouching
teamTouching = vsTeam playerVS
in
if ballState == BSOutOfPlay then
if teamTouching == attacker then
-- if colliding player is on the right team, send him a kickoff/throw-in/kick-corner message,
-- otherwise ignore him
[(playerIdTouching, PlayerMessage (PhysicalPlayerMessage (PPTPrepareThrowIn, BSPWhoAndWhen me t)))]
else
[(me, BallMessage (BTLostOOP, ballParam))]
else -- ball was in play
-- -- if goalie has the ball, then don't take it from him
if ballState == BSControlledGoalie then
[(me, BallMessage (BTLost, ballParam))]
else
[(playerIdTouching, PlayerMessage (PhysicalPlayerMessage (PPTTakeMe, BSPWhoAndWhen me t))),
(game, GameMessage (GTTakePossession, GPTeamPosition teamTouching (-1) [] (Point2 0 0) (-1) False InPlay))] ++
(map (\vs -> (vsObjId vs, PlayerMessage (PhysicalPlayerMessage (PPTLoseMe, BSPRelease 0 RTNothing)))) $ filter hasBall vss)
checkForOffsite :: Param -> (BallMsgParam, (BallMsgParam, [VisibleState])) -> [Message]
checkForOffsite param (BPWho playerIdTouching t, (BPWho _ _,vss)) =
let gameVS = fetchGameVS vss
playerVS = fetchVS vss playerIdTouching
teamTouching = vsTeam playerVS
posTouching = vsPos $ playerVS
in snd $ checkOffsite' param t (fst (vsGameState gameVS))
playerIdTouching teamTouching posTouching
((snd $ vsGameState gameVS), vss)
checkOffsite' :: Param -> Time -> GameState -> ObjId -> Team -> Position3 -> (GameStateParam, [VisibleState]) -> (Bool, [Message])
checkOffsite' param t gs playerIdTouching teamTouching _
(GPTeamPosition teamPassing playerIdPassing oposs posPassing _ _ _, vss) =
if gs /= GSOffsitePending then (False, [])
else if teamTouching /= teamPassing then (False, noOffsiteMsg)
else if playerIdTouching == playerIdPassing then (False, noOffsiteMsg)
else if noOffsite teamTouching (point2Y posPassing) (posYTouchingT0 playerIdTouching) then (False, noOffsiteMsg)
else (True, offsiteMsg)
where
me = vsObjId (fetchGameVS vss)
noOffsite team posPassing' posTouchingT0 =
False ||
(team == Home && posTouchingT0 > halfLine) ||
(team == Away && posTouchingT0 < halfLine) ||
(team == Home && posTouchingT0 >= posPassing') ||
(team == Away && posTouchingT0 <= posPassing') ||
(twoBehind team posTouchingT0 oposs)
noOffsiteMsg = [(me, GameMessage (GTNoOffsite,
GPTeamPosition teamTouching (-1) [] (Point2 0 50) t False InPlay))]
offsiteMsg = [(me, GameMessage (GTOffsite,
GPTeamPosition (otherTeam teamTouching) (-1) [] (Point2 0 50) t False OOPOffsite))]
halfLine = pPitchLength param / 2
posYTouchingT0 oid = thrd3 $ fromJust $ find (\(_, oid', _) -> oid == oid') oposs
twoBehind :: Ord a => Team -> a -> [(Team, t, a)] -> Bool
twoBehind team p0 oposs =
length (filter (\(t, _, p) ->
t == otherTeam team &&
if team == Home then p < p0 else p > p0) oposs) > 1
freeBallSF :: Param -> BallStateParam ->
SF (BallPerception, Event [(BallTransition, BallStateParam)])
((State BallState BallTransition (BallStateParam, BallPerception) [Message], BallStateParam), [Message])
freeBallSF param me = reactMachineMult (fromRight $ fsm param) s1 me
controlledBallSF :: Param -> Bool -> BallMsgParam ->
SF ((BallMsgParam, [VisibleState]), Event [(BallTransition, BallMsgParam)])
((State BallState BallTransition (BallMsgParam, (BallMsgParam, [VisibleState])) [Message], BallMsgParam), [Message])
controlledBallSF param goalie me = reactMachineMult (fromRight $ fsm param) (if goalie then (s6 param) else s2 param) me
outOfPlayBallSF :: Param -> BallMsgParam -> SF ((BallMsgParam, [VisibleState]), Event [(BallTransition, BallMsgParam)]) ((State BallState BallTransition (BallMsgParam, (BallMsgParam, [VisibleState])) [Message], BallMsgParam), [Message])
outOfPlayBallSF param me = reactMachineMult (fromRight $ fsm param) s4 me