module PlayerFSM (basicPlayerSF, tacticalPlayerSF, tacticalNonAiSF)
where
import Debug.Trace
import FRP.Yampa
import FRP.Yampa.Geometry
import Data.Maybe
import Data.List
import Data.FSM
import Message
import Physics
import Object
import States
import Command
import Helper
import Global
import BasicTypes
-- *************************************************************************
--
-- Basic FSM
--
-- *************************************************************************
-- time of last state entrance (for stunning etc.), ball and state
type BasicPerception = (Time, ObjId, [VisibleState])
--s1 :: State BasicState PhysicalPlayerTransition (BasicStateParam, BasicPerception) [Message]
basicFSM :: BasicState ->
(FSM BasicState PhysicalPlayerTransition (BasicStateParam, BasicPerception) [Message],
State BasicState PhysicalPlayerTransition (BasicStateParam, BasicPerception) [Message])
basicFSM initial =
let
s1 = addTransition PPTTakeMe 2 $
addTransition PPTPrepareThrowIn 4 $
state 1 PBSNoBall (const []) loseBall (const [])
s2 = addTransition PPTStun 3 $
addTransition PPTPrepareThrowIn 4 $
addTransition PPTLoseMe 1 $
state 2 PBSInPossession (const []) takePossession (const [])
s3 = addTransition PPTUnStun 1 $
addTransition PPTPrepareThrowIn 4 $
state 3 PBSStunned unStun (const []) (const [])
s4 = addTransition PPTLoseMe 1 $
state 4 PBSPrepareThrowIn (const []) takePossessionOOP (const [])
ss = [s1, s2, s3, s4]
Right fsm = fromList ss
in (fsm, fromJust $ find ((== initial) . content) ss)
unStun :: (BasicStateParam, BasicPerception) -> [Message]
unStun ((BSPUnstun t0), (t1, me, _)) =
[(me, PlayerMessage (PhysicalPlayerMessage (PPTUnStun, BSPWhoAndWhen me t1))) | t1 - t0 > 1]
takePossession :: (BasicStateParam, BasicPerception) -> [Message]
takePossession ((BSPWhoAndWhen ball t), (_, me, vss)) =
let role = piPlayerRole . vsPlayerInfo $ fetchVS vss me
transition = if role == Goalie then BTGainedGoalie else BTGained
in
[(ball, (BallMessage (transition, BPWho me t)))]
takePossessionOOP :: (BasicStateParam, BasicPerception) -> [Message]
takePossessionOOP ((BSPWhoAndWhen ball t), (_, me, _)) =
[(ball, (BallMessage (BTGainedOOP, BPWho me t)))]
_howfast :: Position
_howfast = 10
loseBall :: (BasicStateParam, BasicPerception) -> [Message]
loseBall ((BSPRelease dt' kickType), (t1, me, vss)) =
let dir = vsDir $ fetchVS vss me
ball = (vsObjId . fetchBallVS) vss
shootV = fromPolar3 dir _howfast 0
v = if kickType == RTLow then (1 + dt') *^ shootV
else if kickType == RTHigh then ((1 + dt') *^ shootV) ^+^ vector3 0 0 10
else vector3 0 0 0
in [(ball, (BallMessage (BTLost, BPInit v me))) | kickType /= RTNothing] ++
checkForOffsite me vss v t1
loseBall ((BSPPass dt' kickType Nothing), (t1, me, vss)) =
let designated = fromJust $ find vsDesignated $ teamMates me vss
in passTo dt' kickType me designated vss t1
loseBall ((BSPPass dt' kickType (Just receiverId)), (t1, me, vss)) =
let receiverVs = fetchVS vss receiverId
in passTo dt' kickType me receiverVs vss t1
loseBall ((BSPShoot vel), (t1, me, vss)) =
[((vsObjId . fetchBallVS) vss, (BallMessage (BTLost, BPInit vel me)))] ++
checkForOffsite me vss vel t1
passTo :: Position -> ReleaseType -> ObjId -> VisibleState -> [VisibleState] -> Time -> [(ObjId, MessageBody)]
passTo dt' kickType passerId receiverVs vss t1 =
let (xd, yd) = trace ("CCCC-Dest " ++ show ((point3X $ vsPos receiverVs, point3Y $ vsPos receiverVs)))
(point3X $ vsPos receiverVs, point3Y $ vsPos receiverVs)
(a , vd) = trace ("CCCC-VelD " ++ show (norm $ vsVel receiverVs))
(vsDir receiverVs, norm $ vsVel receiverVs)
ball = fetchBallVS vss
ballId' = vsObjId ball
(xb, yb) = trace ("CCCC-Ball " ++ show (point3X $ vsPos ball, point3Y $ vsPos ball))
(point3X $ vsPos ball, point3Y $ vsPos ball)
vb = (1+dt')*_howfast
-- (t, b) = fromMaybe (0, 0) $ findBestTime (xd, yd, a, norm vd) (xb, yb, vb)
(_, b) =
trace ("CCCC-Resl " ++ (show $ fromMaybe (0,0) $ findBestTime (xd, yd, a, norm vd) (xb, yb, vb)))
(fromMaybe (0,0) $ findBestTime (xd, yd, a, vd) (xb, yb, vb))
v = (vector3 (vb*cos b) (vb*sin b)
(if kickType == RTHigh then (1+dt')*5 else 0))
in [(ballId', (BallMessage (BTLost, BPInit v passerId))) | kickType /= RTNothing] ++
checkForOffsite passerId vss v t1
checkForOffsite :: RealFloat a => ObjId -> [VisibleState] -> Vector3 a -> Time -> [(ObjId, MessageBody)]
checkForOffsite me vss dir t1 =
let gameId' = vsObjId $ fetchGameVS vss
myVs = fetchVS vss me
myTeam = vsTeam myVs
myPos = projectP $ vsPos myVs
oposs = map (\vs -> (myTeam, vsObjId vs, point3Y (vsPos vs))) $ teamMates me vss
otherOposs = map (\vs -> ((otherTeam myTeam, vsObjId vs, point3Y (vsPos vs)))) $
teamPlayers (otherTeam myTeam) vss
in [(gameId', (GameMessage (GTCheckOffsite, GPTeamPosition myTeam me (oposs++otherOposs) myPos t1 False InPlay)))
| pointsForward dir myTeam]
findBestTime :: (Enum a, Floating a, Ord a) => (a, a, a, a) -> (a, a, a) -> Maybe (a, a)
findBestTime d b =
let fits = concatMap (fit d b) [0.05,0.051..3.5]
in if fits == [] then Nothing
-- else Just . fst $ minimumBy (\a b -> compare (snd a) (snd b)) fits
else Just . fst $ localMinimumBy (\a b' -> compare (snd a) (snd b'))
(head fits) fits
-- findBestTime (10, 10, (pi/2), 0) (5, 10, 20)
-- concatMap (fit (10, 10, (pi/2), 0) (5, 10, 20)) [0.1, 0.2, 0.25, 0.3, 0.4, 0.5, 0.6, 0.7, 3.5]
-- fit (10, 10, (pi/2), 0) (5, 10, 20) 0.1
localMinimumBy :: (t -> t -> Ordering) -> t -> [t] -> t
localMinimumBy _ x [] = x
localMinimumBy f x (y:ys) =
if f y x == GT then x
else localMinimumBy f y ys
fit :: (Floating t, Ord t) => (t, t, t, t) -> (t, t, t) -> t -> [((t, t), t)]
fit (xd, yd, a, vd) (xb, yb, vb) t =
let sinB = (yd' - yb) / (vb*t)
cosB = (xd' - xb) / (vb*t)
xd' = xd + vd*t*(cos a)
yd' = yd + vd*t*(sin a)
quadrant = if xd'>=xb && yd'>=yb then Q1
else if xd'<xb && yd'>=yb then Q2
else if xd'<xb && yd'<yb then Q3
else Q4
bSin = asinNorm quadrant (asin sinB)
bCos = acosNorm quadrant (acos cosB)
in [((t, (bSin + bCos)/2), abs $ bSin - bCos)
-- | abs asin_ <= 0.5 && abs acos_ <= 0.5]
| abs sinB <= 1 && abs cosB <= 1]
--Prelude> (acos $ 10/t, asin $ 5/t)
--(0.46364760900080615,0.4636476090008061)
--Prelude> (acos $ -10/t, asin $ 5/t)
--(2.677945044588987,0.4636476090008061)
--Prelude> (acos $ -10/t, asin $ -5/t)
--(2.677945044588987,-0.4636476090008061)
--Prelude> (acos $ 10/t, asin $ -5/t)
--(0.46364760900080615,-0.4636476090008061)
data Quadrant = Q1 | Q2 | Q3 | Q4
acosNorm :: Floating a => Quadrant -> a -> a
acosNorm Q1 x = x
acosNorm Q2 x = x
acosNorm Q3 x = 2*pi-x
acosNorm Q4 x = 2*pi-x
asinNorm :: Floating a => Quadrant -> a -> a
asinNorm Q1 x = x
asinNorm Q2 x = pi-x
asinNorm Q3 x = pi-x
asinNorm Q4 x = 2*pi+x
--basicPlayerSF :: Bool -> Time ->
basicPlayerSF :: BasicState -> Time ->
SF (BasicPerception, Event [(PhysicalPlayerTransition, BasicStateParam)])
((State BasicState PhysicalPlayerTransition (BasicStateParam, BasicPerception) [Message], BasicStateParam), [Message])
basicPlayerSF init' _= uncurry reactMachineMult (basicFSM init') BSPNothing
--reactMachineMult fsm (if hasBall then s2 else s1) BSPNothing
-- *************************************************************************
--
-- Tactical FSM for AI Player
--
-- *************************************************************************
type TacticalPerception = (Time, ObjId, [VisibleState], [Command])
-- current time, me, vss commands
tacticalFSM :: Param -> TacticalState ->
(FSM TacticalState TacticalPlayerTransition (TacticalStateParam, TacticalPerception) [Message],
State TacticalState TacticalPlayerTransition (TacticalStateParam, TacticalPerception) [Message])
tacticalFSM param initial =
let
s1 = addTransition TPTWait 1 $
addTransition TPTCover 2 $
addTransition TPTMoveTo 3 $
addTransition TPTHoldPosition 4 $
addTransition TPTIntercept 5 $
addTransition TPTMoveToThrowIn 7 $
addTransition TPTFreeze 8 $
addTransition TPTKickTowards 9 $
state 1 TSWaiting (lookOutForBall TPTWait) (const []) (const [])
s2 = addTransition TPTWait 1 $
addTransition TPTCover 2 $
addTransition TPTIntercept 5 $
addTransition TPTMoveToThrowIn 7 $
addTransition TPTFreeze 8 $
addTransition TPTKickTowards 9 $
state 2 TSCovering (const []) (coverPlayer param) (const [])
s3 = addTransition TPTWait 1 $
addTransition TPTMoveTo 3 $
addTransition TPTIntercept 5 $
addTransition TPTHoldPosition 4 $
addTransition TPTMoveToThrowIn 7 $
addTransition TPTFreeze 8 $
addTransition TPTKickTowards 9 $
state 3 TSPositioning checkIfPositionReached (const []) (const [])
s4 = addTransition TPTWait 1 $
addTransition TPTIntercept 5 $
addTransition TPTHoldPosition 4 $
addTransition TPTMoveTo 3 $
addTransition TPTMoveToThrowIn 7 $
addTransition TPTFreeze 8 $
addTransition TPTKickTowards 9 $
state 4 TSHoldingPosition (holdPosition param) (const []) (const [])
s5 = addTransition TPTDropInterception 4 $
addTransition TPTIntercept 5 $
addTransition TPTMoveToThrowIn 7 $
addTransition TPTFreeze 8 $
addTransition TPTKickTowards 9 $
state 5 TSInterceptBall intercept dropInterception (const [])
s6 = addTransition TPTKickedOff 4 $
addTransition TPTIntercept 5 $ -- ???
addTransition TPTWaitForKickOff 6 $
addTransition TPTFreeze 8 $
state 6 TSWaitingForKickOff (lookOutForBall TPTWaitForKickOff) (const []) (const [])
s7 = addTransition TPTReposition 4 $
addTransition TPTFreeze 8 $
state 7 TSMovingToThrowIn (const []) (holdThrowInPosition param) (const [])
s8 = addTransition TPTHoldPosition 4 $
state 8 TSFrozen (const []) (const []) (const [])
s9 = addTransition TPTWait 1 $
addTransition TPTFreeze 8 $
state 9 TSKickingTowards (const []) turnTowards kickTowards
s10 = addTransition TPTFreeze 8 $
addTransition TPTTendGoal 10 $
state 10 TSTendingGoal (tendGoal param) (const []) (const [])
s11 = addTransition TPTFreeze 8 $
addTransition TPTKickedOff 10 $
state 11 TSGoalieWaitingForKickOff (tendGoal param) (const []) (const [])
ss = [s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11]
Right fsm = fromList ss
in (fsm, fromJust $ find ((== initial) . content) ss)
-- All of the following functions are of type :: (TacticalStateParam, TacticalPerception) -> [Message]
tendGoal :: Param -> (TacticalStateParam, (Time, ObjId, [VisibleState], t)) -> [(ObjId, MessageBody)]
tendGoal param ((TacticalStateParam _ _ _ _ _ _ _), (t, me, vss, _)) =
let myself = fetchVS vss me
team = vsTeam myself
ball = fetchBallVS vss
posBall = projectP . vsPos $ ball
posPlayer = goaliePosition param team 0.2 posBall
diff = posBall .-. posPlayer
dir = if hasBall myself then -- look straight ahead
if team == Away then pi / 2 else pi + pi / 2
else atan2 (vector2Y diff) (vector2X diff)
in [(me, tm (TPTTendGoal,
TacticalStateParam (Just posPlayer) (Just $ vector3 0 0 0) False
Nothing (Just dir) Nothing (Just t)))]
goaliePosition :: Param -> Team -> Double -> Point2 Double -> Point2 Double
goaliePosition param Away factor (Point2 bx by) =
let Point2 x0 y0 = awayGoalCenter param
vn = normalize $ vector2 (bx-x0) (by-y0)
distB = sqrt $ sqr (bx-x0) + sqr (by-y0)
r = factor * distB
xg = r * (vector2X vn) + x0
yg = r * (vector2Y vn) + y0
in Point2 xg yg
goaliePosition param Home factor (Point2 bx by) =
let bxMirror = pPitchWidth param - bx
byMirror = pPitchLength param - by
Point2 xgMirror ygMirror = goaliePosition param Away factor (Point2 bxMirror byMirror)
in Point2 (pPitchWidth param - xgMirror) (pPitchLength param - ygMirror)
turnTowards :: (TacticalStateParam, (t, ObjId, [VisibleState], t1)) -> [(ObjId, MessageBody)]
turnTowards ((TacticalStateParam _ mvd@(Just vd) _ rec _ kt _), (_, me, _, _)) =
let dir = atan2 (vector3Y vd) (vector3X vd)
in [(me, tm (TPTWait,
TacticalStateParam Nothing mvd False rec (Just dir) kt Nothing))]
turnTowards ((TacticalStateParam _ _ _ mr _ kt _), (_, me, _, _)) =
[(me, tm (TPTWait,
TacticalStateParam Nothing Nothing False mr Nothing kt Nothing))]
kickTowards :: (TacticalStateParam, (t, t3, t1, t2)) -> [(t3, MessageBody)]
kickTowards ((TacticalStateParam _ (Just vd) _ Nothing _ _ _), (_, me, _, _)) =
[(me, pm (PPTLoseMe, BSPShoot vd))]
kickTowards ((TacticalStateParam _ _ _ (Just receiver) _ (Just kt) _), (_, me, _, _)) =
[(me, pm (PPTLoseMe, BSPPass 1 kt (Just receiver)))]
intercept :: (TacticalStateParam, (t, ObjId, [VisibleState], t1)) -> [(ObjId, MessageBody)]
intercept ((TacticalStateParam posTarget _ _ _ _ _ _), (_, me, vss, _)) =
let ball = fetchBallVS vss
posBall = projectP . vsPos $ ball
velBall = project . vsVel $ ball
(bs, _) = vsBallState ball
myPos = (projectP . vsPos . fetchVS vss) me
adjust = if abs (getAngle velBall - (getAngle (myPos .-. posBall))) > 0.2
then velBall
else vector2 0 0
in [if bs == BSFree then
(me, tm (TPTIntercept,
TacticalStateParam (Just $ posBall .+^ adjust) Nothing False Nothing Nothing Nothing Nothing))
else
(me, tm (TPTDropInterception,
TacticalStateParam posTarget Nothing False Nothing Nothing Nothing Nothing))]
dropInterception :: (TacticalStateParam, (t, ObjId, [VisibleState], t1)) -> [(ObjId, MessageBody)]
dropInterception ((TacticalStateParam posTarget _ _ _ _ _ _), (_, me, vss, _)) =
let interceptors = map vsObjId $ filter ((TSInterceptBall ==) . fst . vsPTState) (teamMates me vss)
in [(interceptor, tm (TPTDropInterception,
TacticalStateParam posTarget Nothing False Nothing Nothing Nothing Nothing))
| interceptor <- interceptors]
checkIfPositionReached :: (TacticalStateParam, (t, ObjId, [VisibleState], t1)) -> [(ObjId, MessageBody)]
checkIfPositionReached ((TacticalStateParam posTarget _ _ _ _ _ _), (_, me, vss, _)) =
let posPlayer = projectP . vsPos $ fetchVS vss me
in [(me, tm (TPTWait, TacticalStateParam posTarget Nothing False Nothing Nothing Nothing Nothing))
| (distance (fromJust posTarget) posPlayer < 2)]
holdPosition :: Param -> (TacticalStateParam, (t, ObjId, [VisibleState], t1)) -> [(ObjId, MessageBody)]
holdPosition param ((TacticalStateParam mobp _ _ _ _ _ _), (_, me, vss, _)) =
let attacker = vsAttacker $ fetchGameVS vss
sp@(TacticalStateParam (Just newTargetPos) _ _ _ _ _ _) = basePosition param me vss attacker
currPos = vsPos $ fetchVS vss me
oldTargetPos = fromMaybe (Point2 0 0) mobp
-- 5m off in 1m is too far (ratio = 10)
-- 5m off in 5m is too far (ratio=1)
-- 2 1/2m off in 5m is too far (ratio=0.5)
-- 5m off in 50m is close enough (ratio=0.1)
tooFarOff = (distance newTargetPos oldTargetPos) /
(distance newTargetPos (projectP currPos)) > 0.5
in [(me, tm (TPTHoldPosition, sp)) | tooFarOff]
holdThrowInPosition :: Param -> (t, (t1, ObjId, [VisibleState], t2)) -> [(ObjId, MessageBody)]
holdThrowInPosition param (_, (_, me, vss, _)) =
let (_, GPTeamPosition teamThrowingIn _ _ _ _ _ _) = vsGameState . fetchGameVS $ vss
myTeam = vsTeam $ fetchVS vss me
in [(me, tm (TPTWaitForThrowIn,
basePosition param me vss (if teamThrowingIn == myTeam then teamThrowingIn else otherTeam teamThrowingIn)))]
lookOutForBall :: TacticalPlayerTransition -> (t, (t1, ObjId, [VisibleState], t2)) -> [(ObjId, MessageBody)]
lookOutForBall msg (_, (_, me, vss, _)) =
let posPlayer = projectP . vsPos $ fetchVS vss me
ball = fetchBallVS vss
posBall = projectP . vsPos $ ball
b'@(bs, _) = vsBallState ball
diff = posBall .-. posPlayer
dir = atan2 (vector2Y diff) (vector2X diff)
iHaveTheBall = bs `elem` [BSControlled, BSControlledGoalie, BSControlledOOP]
&& lastPlayer b' == me
in [(me, tm (msg,
TacticalStateParam (Just posPlayer) Nothing False Nothing (Just dir) Nothing Nothing))
| not iHaveTheBall] -- (bs == BSControlled && bsp == BPWho me)]
coverPlayer :: Param -> (TacticalStateParam, (t, t2, [VisibleState], t1)) -> [(t2, MessageBody)]
coverPlayer param ((TacticalStateParam _ _ _ tc@(Just toCover) _ _ _), (_, me, vss, _)) =
let myState = fetchVS vss toCover
posCover = projectP . vsPos $ myState
myCoverRatio = piPlayerCoverRatio . vsPlayerInfo $ myState
posTarget = posCover .+^ myCoverRatio *^ (awayGoalCenter param .-. posCover)
in [(me, tm (TPTCover,
TacticalStateParam (Just posTarget) Nothing False tc Nothing Nothing Nothing))]
tacticalPlayerSF ::
Param -> TacticalState -> Angle ->
SF (TacticalPerception, Event [(TacticalPlayerTransition, TacticalStateParam)])
((State TacticalState TacticalPlayerTransition (TacticalStateParam, TacticalPerception) [Message], TacticalStateParam), [Message])
tacticalPlayerSF param init' angle0 =
uncurry reactMachineMult (tacticalFSM param init')
(TacticalStateParam Nothing Nothing False Nothing (Just angle0) Nothing Nothing)
-- *************************************************************************
--
-- Tactical FSM for Non AI Player
--
-- *************************************************************************
tacticalNonAiFSM :: TacticalState ->
(FSM TacticalState TacticalPlayerTransition (TacticalStateParam, TacticalPerception) [Message],
State TacticalState TacticalPlayerTransition (TacticalStateParam, TacticalPerception) [Message])
tacticalNonAiFSM initial =
let
s8 = state 8 TSNonAI (const []) (const []) (const [])
s9 = addTransition TPTKickedOff 8 $
state 9 TSNonAIKickingOff (const []) (const []) (const [])
ss = [s8, s9]
Right fsm = fromList ss
in (fsm, fromJust $ find ((== initial) . content) ss)
tacticalNonAiSF ::
TacticalState ->
SF (TacticalPerception, Event [(TacticalPlayerTransition, TacticalStateParam)])
((State TacticalState TacticalPlayerTransition (TacticalStateParam, TacticalPerception) [Message], TacticalStateParam),
[Message])
tacticalNonAiSF initial =
uncurry reactMachineMult (tacticalNonAiFSM initial) tspNull