{-# LANGUAGE FlexibleInstances #-}
module Helper
where
import Debug.Trace
import Data.Maybe
import Data.List
import Data.Ord
import Data.Function
import GHC.Exts
import FRP.Yampa
import FRP.Yampa.Geometry
import FRP.Yampa.Point2
import Object
import Message
import Command
import States
import Physics
import Global
import BasicTypes
import AL
-- *************************************************************************
--
-- Various geometric functions
--
-- *************************************************************************
spotToPoint (Spot x y) = Point2 x y
pointToSpot (Point2 x y) = Spot x y
distanceToSpot :: Spot -> Point2 Double -> Point2 Double -> Ordering
distanceToSpot (Spot x y) =
comparing (distance (Point2 x y))
spotDistance (Spot x1 y1) p =
distance (Point2 x1 y1) p
tm x = PlayerMessage $ TacticalPlayerMessage x
pm x = PlayerMessage $ PhysicalPlayerMessage x
otherTeam Home = Away
otherTeam Away = Home
lastPlayer ballState =
case ballState of
(_, BPWho oid _) -> oid
(_, BPInit _ oid) -> oid
(_, BPOutOfPlay _ _ _ oid) -> oid
teamMates me vss =
let team = vsTeam $ fetchVS vss me
in [p | p@(VSPlayer {}) <- vss, vsTeam p == team, vsObjId p /= me]
teamPlayers team vss = [p | p@(VSPlayer {vsTeam = team'}) <- vss, team' == team]
fetchGoalie team vss =
head $ filter isGoalie $ teamPlayers team vss
isGoalie = (Goalie ==) . piPlayerRole . vsPlayerInfo
playerWithBall :: [VisibleState] -> Maybe ObjId
playerWithBall vss =
case filter hasBall vss of
[player] -> Just $ vsObjId player
[] -> Nothing
pls -> error $ "Helper.hs/playerWithBall: too many players " ++ show (map vsObjId pls)
playerIsFree vss vs =
let pos = vsPos vs
team = vsTeam vs
otherPlayers = teamPlayers (otherTeam team) vss
in foldl' (\acc vso -> acc &&
distance pos (vsPos vso) > 5) True otherPlayers
homeValue param (Spot x y) =
half x (pPositionFactorX param) (pPitchWidth param) +
(pPitchLength param - y) * pPositionFactorY param
awayValue param (Spot x y) =
homeValue param (Spot x (pPitchLength param - y))
half u factor max
| u < (max / 2) = u * factor
| otherwise = (max - u) * factor
bestFreePlayer param vss ballCarrier =
let team = vsTeam ballCarrier
me = vsObjId ballCarrier
valFun = if team == Home then homeValue else awayValue
freePlayers = filter (playerIsFree vss) $ teamMates me vss
in if null freePlayers then Nothing
else Just $ maximumBy (compare `on` (valFun param) . pointToSpot . projectP . vsPos) freePlayers
nearestNonAIPlayer team vss pos =
let players = [p | p@(VSPlayer {}) <- vss, vsTeam p == team, fst (vsPTState p) == TSNonAI ]
nearest = minimumBy (\pl1 pl2 -> closerToPoint pos (projectP $ vsPos pl1) (projectP $ vsPos pl2)) players
in vsObjId nearest
nearestAIPlayer team vss pos =
let players = [p | p@(VSPlayer {}) <- vss, vsTeam p == team, fst (vsPTState p) /= TSNonAI ]
nearest = minimumBy (\pl1 pl2 -> closerToPoint pos (projectP $ vsPos pl1) (projectP $ vsPos pl2)) players
in vsObjId nearest
nearestAIFieldPlayer team vss pos =
let players = [p | p@(VSPlayer {}) <- vss, vsTeam p == team, fst (vsPTState p) /= TSNonAI,
(piPlayerRole . vsPlayerInfo) p /= Goalie ]
nearest = minimumBy (\pl1 pl2 -> closerToPoint pos (projectP $ vsPos pl1) (projectP $ vsPos pl2)) players
in vsObjId nearest
nearestPlayer team vss pos =
let players = [p | p@(VSPlayer {}) <- vss, vsTeam p == team]
nearest = minimumBy (\pl1 pl2 -> closerToPoint pos (projectP $ vsPos pl1) (projectP $ vsPos pl2)) players
in vsObjId nearest
closerToPoint p p1 p2 =
if distance p p1 < distance p p2 then LT else GT
fetchVS :: [VisibleState] -> ObjId -> VisibleState
fetchVS vss = fromJust . flip getObjVS vss
getObjVS :: ObjId -> [VisibleState] -> Maybe VisibleState
getObjVS oid [] = Nothing
getObjVS oid (vs:vss) =
if vsObjId vs == oid then Just vs else getObjVS oid vss
fetchGameVS :: [VisibleState] -> VisibleState
fetchGameVS [] = error "Helper/fetchGameVS: No game in Visible States"
fetchGameVS (v:vs) =
case v of
VSGame {} -> v
_ -> fetchGameVS vs
fetchBallVS :: [VisibleState] -> VisibleState
fetchBallVS [] = error "Helper/fetchBallVS: No ball in Visible States"
fetchBallVS (v:vs) =
case v of
VSBall {} -> v
_ -> fetchBallVS vs
fetchBallCarrier vss =
let (s, sp) = vsBallState ball
ball = fetchBallVS vss
in if s `elem` [BSControlled, BSControlledOOP, BSControlledGoalie]
then Just (fetchVS vss (fromBPWho sp))
else Nothing
ballId :: ALOut -> ObjId
ballId (AL []) = error "Helper.hs/ballId: No Ball in Object Output"
ballId (AL ((xId, xOO):xs)) =
case xOO of
ObjOutput (OOSBall {}) _ _ _ -> xId
_ -> ballId (AL xs)
gameId :: ALOut -> ObjId
gameId (AL []) = error "Helper.hs/gameId: No Game in Object Output"
gameId (AL ((xId, xOO):xs)) =
case xOO of
ObjOutput (OOSGame {}) _ _ _ -> xId
_ -> gameId (AL xs)
-- time possession score1 score2
hasBall :: VisibleState -> Bool
hasBall vs = isPlayer vs && (fst . vsPBState) vs == PBSInPossession
offsiteFrontier param me vss =
-- yield the a position for the player on the offsite frontiert. needs at least 2 players in every team
let myself = fetchVS vss me
myTeam = vsTeam myself
Point3 myXPos _ _ = vsPos myself
others = teamPlayers (otherTeam myTeam) vss
reverser = if myTeam == Home then id else reverse
-- Achtung: Auf-/absteigend sortieren je nach Home / Away!
Point3 _ y _ = vsPos . head . tail . reverser $ sortWith (point3Y . vsPos) others
half = pPitchLength param / 2
yAdjust = if myTeam == Home then min y half else max y half
in (Point2 myXPos yAdjust)
-- in (Point2 0 0)
adjustForOffsite param p@(Point2 x y) me vss =
let pOff@(Point2 xOff yOff) = offsiteFrontier param me vss
myself = fetchVS vss me
myTeam = vsTeam myself
ballCarrier = hasBall myself
in
if not ballCarrier &&
(((myTeam == Home && y < yOff) ||
(myTeam == Away && y > yOff)))
then pOff else p
basePosition :: Param -> ObjId -> [VisibleState] -> Team -> TacticalStateParam
basePosition param me vss attacker =
-- yield me's optimal position in relation to the ball and his state (attacking or defending)
let pi = vsPlayerInfo $ fetchVS vss me
defensivePos = piBasePosDefense pi
offensivePos = piBasePosOffense pi
myTeam = vsTeam $ fetchVS vss me
ball = fetchBallVS vss
posBall = projectP . vsPos $ ball
adjust = posBall .-. pitchCenter param
adjust' = vector2 (pHorizontalShiftRatio param * vector2X adjust) (pVerticalShiftRatio param * vector2Y adjust)
-- defPos = limitPosition (border, pitchWidth + border, border + lineEnds, pitchLength + border - lineEnds) (defensivePos .+^ adjust')
defPos = limitPosition (0, pPitchWidth param, pLineEnds param, pPitchLength param - pLineEnds param) (defensivePos .+^ adjust')
offPos = adjustForOffsite param offensivePos me vss
in TacticalStateParam (Just $ if myTeam == attacker then offPos else defPos)
Nothing
False
Nothing
Nothing
Nothing
Nothing
-- *************************************************************************
--
-- Various geometric functions
--
-- *************************************************************************
limitPosition (xmin, xmax, ymin, ymax) (Point2 px py) =
Point2 (minmax xmin xmax px) (minmax ymin ymax py)
where minmax min max z = if z < min then min else if z > max then max else z
noPoint = Point2 (-1) (-1)
zeroVel = vector3 0 0 0
sameDirection :: Param -> Velocity2 -> Velocity2 -> Bool
sameDirection param u v =
abs(vector2Rho u) > pEps param &&
abs((vector2Rho u + vector2Rho v) - vector2Rho (u ^+^ v)) < pEps param
inOneSecond pos vel = pos .+^ vel
(.+!) :: (Point2 Double) -> Double -> (Point3 Double)
(Point2 x y) .+! z = (Point3 x y z)
(^+!) :: (Vector2 Double) -> Double -> (Vector3 Double)
v ^+! z =
let x = vector2X v
y = vector2Y v
in vector3 x y z
project :: Velocity3 -> Velocity2
project v = vector2 x y
where x = vector3X v
y = vector3Y v
projectP :: Position3 -> Position2
projectP v = Point2 x y
where x = point3X v
y = point3Y v
brake :: Param -> Velocity3 -> Double -> Velocity3
brake param v a =
vector3 (-b*x) (-b*y) (pGravity param)
where x = vector3X v
y = vector3Y v
b = a / vector2Rho (vector2 x y)
halfPi = pi / 2
(Point2 x y) ^-. v = Point2 (vector2X v - x) (vector2Y v - y)
normTheta x
| x < (- pi) = x + 2 * pi
| x > pi = x - 2 * pi
| otherwise = x
lookTo p0 p1 =
p0 .+^ (0.0001 *^ normalize (p1 .-. p0))
towards :: Spot -> Spot -> Vector3 Double
towards curr dest =
let delta = 20 *^ normalize (spotToPoint dest .-. spotToPoint curr)
in delta ^+! 0
turnBy :: Vector2 Double -> Vector2 Double -> Vector2 Double
u `turnBy` v =
fromPolar (vector2Theta u - vector2Theta v) (vector2Rho u)
isLeftFrom :: Vector2 Double -> Vector2 Double -> Bool
u `isLeftFrom` v =
normTheta (vector2Theta (u `turnBy` v)) >= 0
u `isRigthFrom` v = v `isLeftFrom` u
sameDirAs :: Vector2 Double -> Vector2 Double -> Bool
u `sameDirAs` v =
let theta = normTheta $ vector2Theta (u `turnBy` v)
in
(theta > 0 && theta < pi/2) || (theta < 0 && theta > -(pi/2))
toPolar x y =
(atan2 y x, sqrt ((x*x) + (y*y)))
getAngle v = atan2 (vector2Y v) (vector2X v)
fromPolar theta rho =
vector2 (rho * cos theta) (rho * sin theta)
fromPolar3 theta rho z =
vector3 (rho * cos theta) (rho * sin theta) z
limit max v =
let len = norm v
in
if len > max then (max/len) *^ v else v
mirrorPoint (Point2 x y) (Point2 ax ay) =
Point2 (mirrorAt x ax) (mirrorAt y ay)
mirrorAt x axis = 2 * axis - x
sqr x = x * x
-- *************************************************************************
--
-- Parameters
--
-- *************************************************************************
awayGoalCenter param = Point2 (pPitchWidth param / 2) 0
homeGoalCenter param = Point2 (pPitchWidth param / 2) (pPitchLength param)
pitchCenter param = Point2 (pPitchWidth param / 2) (pPitchLength param / 2)
-- *************************************************************************
--
-- Messages and commands
--
-- *************************************************************************
comToMsg (CmdKickHigh dt) = [pm (PPTLoseMe, BSPRelease dt RTHigh)]
comToMsg (CmdKickLow dt) = [pm (PPTLoseMe, BSPRelease dt RTLow)]
comToMsg (CmdPassHigh dt) = [pm (PPTLoseMe, BSPPass dt RTHigh Nothing)]
comToMsg (CmdPassLow dt) = [pm (PPTLoseMe, BSPPass dt RTLow Nothing)]
comToMsg CmdFlipHigh = [pm (PPTLoseMe, BSPPass 1 RTHigh Nothing)]
comToMsg CmdFlipLow = [pm (PPTLoseMe, BSPPass 1 RTLow Nothing)]
--comToMsg pos CmdMoveForward = [tm (TPTMoveTo, TacticalStateParam (Just $ pos .+^ vector2 0 (-20))
-- Nothing False Nothing
-- Nothing Nothing)]
comToMsg _ = []
-- *************************************************************************
--
-- Various generic list and tupel functions
--
-- *************************************************************************
collect :: (Eq a) => [(a,b)] -> [(a, [b])]
collect [] = []
collect ((a, b) : rest) =
(a, b:fetch a rest) : collect (remove a rest)
fetch :: (Eq a) => a -> [(a,b)] -> [b]
fetch a = map snd . filter (\(a',b) -> a == a')
remove a = filter (\(a',b) -> a /= a')
mergeList :: (Eq a) => [(a, [b])] -> [(a, [b])]
mergeList =
map (\(a,bs) -> (a, concat bs)) . collect
fst3 (a, b, c) = a
snd3 (a, b, c) = b
thrd3 (a, b, c) = c
fromRight (Right x) = x