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'=yb then Q2 else if xd' (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