diff --git a/13ball.png b/13ball.png deleted file mode 100644 Binary files a/13ball.png and /dev/null differ diff --git a/15ball.png b/15ball.png deleted file mode 100644 Binary files a/15ball.png and /dev/null differ diff --git a/17ball.png b/17ball.png deleted file mode 100644 Binary files a/17ball.png and /dev/null differ diff --git a/20ball.png b/20ball.png deleted file mode 100644 Binary files a/20ball.png and /dev/null differ diff --git a/20redball.png b/20redball.png new file mode 100644 Binary files /dev/null and b/20redball.png differ diff --git a/23redball.png b/23redball.png new file mode 100644 Binary files /dev/null and b/23redball.png differ diff --git a/25ball.png b/25ball.png deleted file mode 100644 Binary files a/25ball.png and /dev/null differ diff --git a/26redball.png b/26redball.png new file mode 100644 Binary files /dev/null and b/26redball.png differ diff --git a/30ball.png b/30ball.png deleted file mode 100644 Binary files a/30ball.png and /dev/null differ diff --git a/30redball.png b/30redball.png new file mode 100644 Binary files /dev/null and b/30redball.png differ diff --git a/35redball.png b/35redball.png new file mode 100644 Binary files /dev/null and b/35redball.png differ diff --git a/40redball.png b/40redball.png new file mode 100644 Binary files /dev/null and b/40redball.png differ diff --git a/AI.hs b/AI.hs --- a/AI.hs +++ b/AI.hs @@ -1,19 +1,8 @@ module AI - where -import Language.Haskell.TH - -import Debug.Trace - -import FRP.Yampa (SF, Event) import FRP.Yampa.Geometry -import FRP.Yampa.Forceable -import qualified Data.Map as M import Data.Maybe -import Data.List -import Control.Monad -import Control.Arrow import Global import BasicTypes @@ -78,7 +67,7 @@ else Nothing ball = fetchBallVS vss - (Point3 ballX ballY ballZ) = vsPos ball + (Point3 ballX ballY _) = vsPos ball game = fetchGameVS vss @@ -86,7 +75,7 @@ ballCarrier = fetchBallCarrier vss - (attackingTeam, defendingTeam) = + (_, defendingTeam) = (teamPlayers attacker vss, teamPlayers (otherTeam attacker) vss) setBestFreePlayer = @@ -96,17 +85,16 @@ return $ FPPlayerId (vsObjId fp) timeOfThrowIn = case vsGameState game of - (GSBaseOut, GPTeamPosition _ _ t _) -> Just t - (GSSideOut, GPTeamPosition _ _ t _) -> Just t + (GSOutOfPlay, GPTeamPosition _ _ _ _ t' _ _) -> Just t' _ -> Nothing timeOfPossession = case vsBallState ball of - (_, BPWho _ t) -> Just t + (_, BPWho _ t') -> Just t' _ -> Nothing setThrowingIn = listToMaybe $ map (FPPlayerId . vsObjId) - [p | p@(VSPlayer {vsPBState = (bs, bsp)}) + [p | p@(VSPlayer {vsPBState = (bs, _)}) <- vss, bs == PBSPrepareThrowIn, isJust timeOfThrowIn, t - fromJust timeOfThrowIn > 2] @@ -123,7 +111,7 @@ setKickOff = if GSKickOff == (fst . vsGameState . fetchGameVS) vss && t-t0 > 1 then Just FPEmpty else Nothing - where GPTeamPosition _ _ t0 _ = (snd . vsGameState . fetchGameVS) vss + where GPTeamPosition _ _ _ _ t0 _ _ = (snd . vsGameState . fetchGameVS) vss -- setBallCarrier = do -- bc <- ballCarrier @@ -155,22 +143,24 @@ +getPlayerValue :: Param -> Team -> VisibleState -> Double getPlayerValue param attacker pl = if attacker == Home then homeValue param spot else awayValue param spot where spot = (pointToSpot . projectP . vsPos) pl +runPathBlocked :: Param -> Team -> Maybe VisibleState -> [VisibleState] -> Maybe VisibleState runPathBlocked param attacker ballCarrier defenders = do carrierVss <- ballCarrier let pos = projectP $ vsPos carrierVss let goalPos = if attacker == Home then awayGoalCenter param else homeGoalCenter param listToMaybe $ filter (ahead pos goalPos) defenders where - ahead pos goalPos defender = + ahead pos _ defender = let defenderPos = projectP $ vsPos defender dist = distance pos defenderPos - Point2 dx dy = defenderPos - Point2 x y = pos + Point2 dx _ = defenderPos + Point2 x _ = pos in dist < 3 && if attacker == Home then dx < x diff --git a/AL.hs b/AL.hs --- a/AL.hs +++ b/AL.hs @@ -17,10 +17,11 @@ filterAL :: (a -> Bool) -> AL k a -> AL k a filterAL p (AL kas) = AL $ filter (p . snd) kas +elemsAL :: AL a b -> [b] elemsAL (AL xs) = map snd xs (!) :: (Eq k) => AL k a -> k -> a -(AL l) ! k = snd . fromJust $ find (\(k', a) -> k == k') l +(AL l) ! k = snd . fromJust $ find (\(k', _) -> k == k') l at :: AL k a -> Int -> (k, a) (AL l) `at` 0 = head l @@ -29,9 +30,12 @@ lookupAL :: (Eq a) => a -> AL a b -> Maybe b lookupAL x (AL xs) = lookup x xs +emptyAL :: AL k a emptyAL = AL [] +assocsAL :: AL t t1 -> [(t, t1)] assocsAL (AL l) = l +fromAssocs :: [(k, a)] -> AL k a fromAssocs l = AL l insertAL :: k -> a -> AL k a -> AL k a @@ -42,10 +46,11 @@ AL (deleteHlp kas) where deleteHlp [] = [] - deleteHlp (ka@(k', _) : kas) | k == k' = kas - | otherwise = ka : deleteHlp kas + deleteHlp (ka@(k', _) : kas') | k == k' = kas' + | otherwise = ka : deleteHlp kas' +appendAL :: AL k a -> AL k a -> AL k a appendAL (AL xs) (AL ys) = AL $ xs ++ ys -- collectAL :: (Eq a) => AL a b -> AL a [b] diff --git a/Animate.hs b/Animate.hs --- a/Animate.hs +++ b/Animate.hs @@ -1,47 +1,49 @@ module Animate where +import Graphics.UI.SDL +import Graphics.UI.SDL.TTF +import Graphics.UI.SDL.Mixer as Mix import Control.Monad.Loops import Control.Monad +import Data.Array import Data.IORef import Data.Convertible import Data.Time.Clock import FRP.Yampa -import FRP.Yampa.Geometry import qualified Graphics.UI.SDL as SDL -import qualified Graphics.UI.SDL.Image as SDLi -import qualified Graphics.UI.SDL.TTF as TTF import qualified Render as Render -import RenderUtil +import BasicTypes import Object -import ObjectBehaviour -import Parser -import GameLoop import AL import States - +import Global +import GameLoop +animate :: (Num i, Ix i) => Param -> + IORef (Maybe (Surface, Surface, Array i Font, Array Int (Surface, Int), Chunk, Chunk, Chunk)) -> Double -> IORef Double -> IORef Int -> [(ObjId, Object, ObjOutput)] -> IO () animate param sdlState tInit timeState frameCounter objs = do reactimate (initialize tInit) (input tInit timeState frameCounter) (output param sdlState) (gameLoop param - (AL $ map (\(id, o, oo) -> (id, oo)) objs) - (AL $ map (\(id, o, oo) -> (id, o)) objs) + (AL $ map (\(id', _, oo) -> (id', oo)) objs) + (AL $ map (\(id', o, _) -> (id', o)) objs) ) -- reactimation IO ---------- +initialize :: Double -> IO (Double, [SDL.Event]) initialize tInit = do events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent t <- getCurrentTime return ((convert t :: Double) - tInit, events) input :: Time -> IORef Double -> IORef Int -> Bool -> IO (DTime, Maybe GameInput) -input tInit stateTime counter b = do +input tInit stateTime counter _ = do count <- readIORef counter writeIORef counter (count + 1) events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent @@ -52,6 +54,10 @@ return (t1'-t0, Just (t1'-tInit, events)) +output :: (Eq k, Num k, Num i, Ix i) => + Param -> IORef (Maybe (Surface, Surface, Array i Font, Array Int (Surface, Int), Chunk, Chunk, Chunk)) -> + t -> AL k ObjOutput -> + IO Bool output param sdlState _ oal@(AL oos) = do Just sdl <- readIORef sdlState Render.render param (map (ooObsObjState . snd) oos) sdl diff --git a/BallFSM.hs b/BallFSM.hs --- a/BallFSM.hs +++ b/BallFSM.hs @@ -1,71 +1,129 @@ module BallFSM (freeBallSF, controlledBallSF, outOfPlayBallSF) - where -import Debug.Trace 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 = addTransition BTCollisionB 3 $ +s2 :: Param -> State BallState BallTransition (BallMsgParam, (BallMsgParam, [VisibleState])) [Message] +s2 param = addTransition BTCollisionB 3 $ addTransition BTOutOfPlay 4 $ addTransition BTLost 1 $ - state 2 BSControlled (const []) (const []) (const []) -s3 = addTransition BTGained 2 $ + 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 (const []) + 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 = addTransition BTLost 1 $ - state 6 BSControlledGoalie (const []) (const []) (const []) -Right fsm = fromList [s1, s2, s3, s4, s5, s6] +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 :: (BallStateParam, BallPerception) -> [Message] -takeMe (BPWho player t, (BPWho me _,vss)) = +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 - teamTouching = vsTeam $ fetchVS vss player + 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 - [(player, PlayerMessage (PhysicalPlayerMessage (PPTPrepareThrowIn, BSPWhoAndWhen me t)))] + [(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 goalie has the ball, then don't take it from him if ballState == BSControlledGoalie then - [(me, BallMessage (BTLost, ballParam))] + [(me, BallMessage (BTLost, ballParam))] else - [(player, PlayerMessage (PhysicalPlayerMessage (PPTTakeMe, BSPWhoAndWhen me t))), - (game, GameMessage (GTTakePossession, GPTeamPosition teamTouching (Point2 0 0) (-1) False))] ++ - (map (\vs -> (vsObjId vs, PlayerMessage (PhysicalPlayerMessage (PPTLoseMe, BSPRelease 0 RTNothing)))) $ filter hasBall vss) + [(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) -freeBallSF :: BallStateParam -> +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 me = reactMachineMult fsm s1 me -controlledBallSF goalie me = reactMachineMult fsm (if goalie then s6 else s2) me -outOfPlayBallSF me = reactMachineMult fsm s4 me +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 diff --git a/BasicTypes.hs b/BasicTypes.hs --- a/BasicTypes.hs +++ b/BasicTypes.hs @@ -9,7 +9,6 @@ import qualified Graphics.UI.SDL as SDL (Pixel, Event) import Physics -import States ------------------------------------------------------------------------------ @@ -46,7 +45,7 @@ type FactFunction = [FactParam] -> Maybe FactParam instance Show FactFunction where - show x = "FactFunction" + show _ = "FactFunction" data Facts = Facts { factCanIntercept :: FactFunction @@ -91,7 +90,9 @@ data OutOfPlay = OOPSideOut | OOPKickOff - | OOPCorner + | OOPBaseOut + | OOPOffsite + | InPlay deriving (Show, Eq) diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -26,22 +26,27 @@ | CmdFlipMeLow deriving (Show, Eq, Ord) ---cmd* :: [Command] -> (Bool, Time) +cmdQuit :: [Command] -> Bool cmdQuit [] = False; cmdQuit (c:cs) = case c of CmdQuit -> True ; _ -> cmdQuit cs ---cmdNewGame [] = False; cmdNewGame (c:cs) = case c of CmdNewGame -> True ; _ -> cmdNewGame cs +cmdFreeze :: [Command] -> Bool cmdFreeze [] = False; cmdFreeze (c:cs) = case c of CmdFreeze -> True ; _ -> cmdFreeze cs ---cmdResume [] = False; cmdResume (c:cs) = case c of CmdResume -> True ; _ -> cmdResume cs ---cmdPassHigh [] = (False, undefined); cmdPassHigh (c:cs) = case c of CmdPassHigh t -> (True, t) ; _ -> cmdPassHigh cs ---cmdPassLow [] = (False, undefined); cmdPassLow (c:cs) = case c of CmdPassLow t -> (True, t) ; _ -> cmdPassLow cs ---cmdKickHigh [] = (False, undefined); cmdKickHigh (c:cs) = case c of CmdKickHigh t -> (True, t) ; _ -> cmdKickHigh cs ---cmdKickLow [] = (False, undefined); cmdKickLow (c:cs) = case c of CmdKickLow t -> (True, t) ; _ -> cmdKickLow cs +cmdToggleFoot :: [Command] -> Bool cmdToggleFoot [] = False; cmdToggleFoot (c:cs) = case c of CmdToggleFoot -> True ; _ -> cmdToggleFoot cs +cmdTakeOver :: [Command] -> Bool cmdTakeOver [] = False; cmdTakeOver (c:cs) = case c of CmdTakeOver -> True ; _ -> cmdTakeOver cs +cmdMoveForward :: [Command] -> Bool cmdMoveForward [] = False; cmdMoveForward (c:cs) = case c of CmdMoveForward -> True ; _ -> cmdMoveForward cs +cmdMoveBackward :: [Command] -> Bool cmdMoveBackward [] = False; cmdMoveBackward (c:cs) = case c of CmdMoveBackward -> True ; _ -> cmdMoveBackward cs +cmdMoveLeft :: [Command] -> Bool cmdMoveLeft [] = False; cmdMoveLeft (c:cs) = case c of CmdMoveLeft -> True ; _ -> cmdMoveLeft cs +cmdMoveRight :: [Command] -> Bool cmdMoveRight [] = False; cmdMoveRight (c:cs) = case c of CmdMoveRight -> True ; _ -> cmdMoveRight cs +cmdMoveToGoal :: [Command] -> Bool cmdMoveToGoal [] = False; cmdMoveToGoal (c:cs) = case c of CmdMoveToGoal -> True ; _ -> cmdMoveToGoal cs +cmdMoveToMe :: [Command] -> Bool cmdMoveToMe [] = False; cmdMoveToMe (c:cs) = case c of CmdMoveToMe -> True ; _ -> cmdMoveToMe cs +cmdFlipMeLow :: [Command] -> Bool cmdFlipMeLow [] = False; cmdFlipMeLow (c:cs) = case c of CmdFlipMeLow -> True ; _ -> cmdFlipMeLow cs +cmdFlipMeHigh :: [Command] -> Bool cmdFlipMeHigh [] = False; cmdFlipMeHigh (c:cs) = case c of CmdFlipMeHigh -> True ; _ -> cmdFlipMeHigh cs diff --git a/Data/FSM.hs b/Data/FSM.hs --- a/Data/FSM.hs +++ b/Data/FSM.hs @@ -7,13 +7,10 @@ where -import Debug.Trace import FRP.Yampa -import FRP.Yampa.Event import qualified Data.Map as M import Data.List (nub, (\\), foldl') import Data.Monoid -import Data.Maybe import Data.Function (on) @@ -62,7 +59,7 @@ -- Construction of new State; new States instance start with an empty -- transition table state :: Int -> a -> (p -> m)-> (p -> m)-> (p -> m)-> State a t p m -state id a while onEnter onExit = State id a while onEnter onExit M.empty +state id' a' while' onEnter' onExit' = State id' a' while' onEnter' onExit' M.empty -- adds a new transition to a given State instance addTransition :: Ord t => t -> Int -> State a t p m -> State a t p m @@ -93,7 +90,7 @@ -- Same as runTrans, but takes a list of transistions instead of a single transistion, returns -- an additional Bool that indicates whether any transition occured runTransMult :: (Ord t, Monoid m) => FSM a t p m -> State a t p m -> [t] -> p -> (State a t p m, m, Bool) -runTransMult fsm currentState [] perception = +runTransMult _ currentState [] _ = (currentState, mempty, False) runTransMult fsm currentState (trans:transs) perception = case runTrans fsm currentState trans perception of @@ -157,7 +154,7 @@ allElems :: [a] -> [(a, [a])] allElems xs = let ixs = zip [0..length xs - 1] xs - in map (\(i,x) -> ((xs!!i), xs)) ixs + in map (\(i,_) -> ((xs!!i), xs)) ixs checkDoubles :: [State a e p m] -> [Int] checkDoubles states = @@ -192,9 +189,9 @@ -- to the new state reactTransition :: (Ord t, Monoid m) => FSM a t (s, p) m -> State a t (s, p) m -> s -> SF (Event ((t, s), p)) (State a t (s, p) m, Event (m, s)) -reactTransition fsm init initParam = - accumBy (runMachine fsm) (init, (mempty, initParam)) >>> - (fst ^<< hold (init, (mempty, initParam))) &&& arr (snd . splitE) +reactTransition fsm init' initParam = + accumBy (runMachine fsm) (init', (mempty, initParam)) >>> + (fst ^<< hold (init', (mempty, initParam))) &&& arr (snd . splitE) -- Yields the (time-varying) current state and the messages (that originate from -- either the onExit / onEnter-function on a transition or the while-function @@ -207,10 +204,9 @@ reactMachine :: (Ord t, Monoid m) => FSM a t (s, p) m -> State a t (s, p) m -> s -> SF (p, Event (t, s)) ((State a t (s, p) m, s), m) reactMachine fsm initState initParam = proc (perception, ets) -> do - let stateParam = snd $ splitE ets - (state, result) <- reactTransition fsm initState initParam -< attach ets perception + (state', result) <- reactTransition fsm initState initParam -< attach ets perception param <- hold initParam -< snd (splitE result) - returnA -< ((state, param), if isEvent result then fst (fromEvent result) else while state (param, perception)) + returnA -< ((state', param), if isEvent result then fst (fromEvent result) else while state' (param, perception)) -- ************************************************************************* @@ -222,14 +218,14 @@ rMM :: (Ord t, Monoid m) => FSM a t (s, p) m -> (State a t (s, p) m, s, Event [(t, s)], p) -> (State a t (s, p) m, (m, s)) -rMM fsm (s0, sp0, Event [], perc) = (s0, (mempty, sp0)) +rMM _ (s0, sp0, Event [], _) = (s0, (mempty, sp0)) rMM fsm (s0, sp0, Event ((t, s):tss), perc) = let (s1, (m1, sp1)) = case runTrans fsm s0 t (s, perc) of Nothing -> (s0, (mempty, sp0)) Just (s', m') -> (s', (m', s)) (s2, (m2, sp2)) = rMM fsm (s1, sp1, Event tss, perc) in (s2, (m1 `mappend` m2, sp2)) -rMM fsm (s0, sp0, _, _) = (s0, (mempty, sp0)) +rMM _ (s0, sp0, _, _) = (s0, (mempty, sp0)) reactMachineMult :: (Ord t, Monoid m, Eq m) => FSM a t (s, p) m -> State a t (s, p) m -> s -> SF (p, Event [(t, s)]) ((State a t (s, p) m, s), m) @@ -256,14 +252,14 @@ runMachineHist :: (Ord t, Monoid m) => FSM a t (s, (p,s)) m -> (State a t (s, (p,s)) m, (m, s)) -> (([t], s), (s,p)) -> (State a t (s, (p,s)) m, (m, s)) runMachineHist fsm (curr, (_,currParam)) ((transs, stateParam), (oldParam, perc)) = - let (state, messages, transOccured) = runTransMult fsm curr transs (stateParam, (perc, oldParam)) - in (state, (messages, if transOccured then stateParam else currParam)) + let (state', messages, transOccured) = runTransMult fsm curr transs (stateParam, (perc, oldParam)) + in (state', (messages, if transOccured then stateParam else currParam)) reactHistTransitions :: (Ord t, Monoid m) => FSM a t (s, (p,s)) m -> State a t (s, (p,s)) m -> s -> SF (Event (([t], s), (s, p))) (State a t (s, (p,s)) m, Event (m, s)) -reactHistTransitions fsm init initParam = - accumBy (runMachineHist fsm) (init, (mempty, initParam)) >>> - (fst ^<< hold (init, (mempty, initParam))) &&& arr (snd . splitE) +reactHistTransitions fsm init' initParam = + accumBy (runMachineHist fsm) (init', (mempty, initParam)) >>> + (fst ^<< hold (init', (mempty, initParam))) &&& arr (snd . splitE) -- This is a bit more complicated than it's single input counterpart: the onEnter etc. functions -- are not only provided with the stateParam s and the perception p, but also with the state diff --git a/GameFSM.hs b/GameFSM.hs --- a/GameFSM.hs +++ b/GameFSM.hs @@ -2,17 +2,14 @@ where -import Debug.Trace 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 @@ -21,45 +18,55 @@ type GamePerception = [VisibleState] +s1 :: Param -> State GameState GameTransition (GameStateParam, GamePerception) [Message] s1 param = addTransition GTTakePossession 1 $ - addTransition GTSideOut 2 $ - addTransition GTBaseOut 3 $ + addTransition GTOutOfPlay 2 $ addTransition GTGoal 4 $ addTransition GTQuit 5 $ addTransition GTFreeze 6 $ + addTransition GTCheckOffsite 8 $ state 1 GSRunning (checkIfTimeUp param) (const []) (const []) +s2 :: Param -> State GameState GameTransition (GameStateParam, GamePerception) [Message] s2 param = addTransition GTTakePossession 2 $ addTransition GTQuit 5 $ addTransition GTBallInPlay 1 $ - state 2 GSSideOut (const []) (sideOutMessages param) (const []) -s3 param = - addTransition GTBallInPlay 1 $ - addTransition GTTakePossession 3 $ - addTransition GTQuit 5 $ - state 3 GSBaseOut (const []) (baseOutMessages param) (const []) + state 2 GSOutOfPlay (const []) (sideOutMessages param) (const []) +s4 :: State GameState GameTransition p [a] s4 = addTransition GTTakePossession 4 $ state 4 GSGoal (const []) (const []) (const []) +s5 :: State GameState t p [a] s5 = --addTransition GTTakePossession 5 $ ??? state 5 GSQuit (const []) (const []) (const []) +s6 :: State GameState GameTransition (GameStateParam, GamePerception) [Message] s6 = addTransition GTTakePossession 6 $ addTransition GTFreeze 1 $ state 6 GSFrozen (const []) freezePlayers thawPlayers +s7 :: State GameState GameTransition (GameStateParam, GamePerception) [Message] s7 = addTransition GTRunGame 1 $ addTransition GTQuit 5 $ addTransition GTWaitKickOff 7 $ state 7 GSKickOff stopWhistling (const []) (const []) - -fsm param = fromList [s1 param, s2 param, s3 param, s4, s5, s6, s7] +s8 :: State GameState GameTransition p [a] +s8 = addTransition GTNoOffsite 1 $ + addTransition GTOutOfPlay 2 $ + addTransition GTGoal 4 $ + addTransition GTQuit 5 $ + addTransition GTOffsite 2 $ +-- addTransition GTFreeze 6 $ -- freeze/unfreeze should not break offsite + state 8 GSOffsitePending (const []) (const []) (const []) +fsm :: Param -> Either [Problem GameTransition] + (FSM GameState GameTransition (GameStateParam, GamePerception) [Message]) +fsm param = fromList [s1 param, s2 param, s4, s5, s6, s7, s8] stopWhistling :: (GameStateParam, GamePerception) -> [Message] stopWhistling (gsp,vss) = let g = fetchGameVS vss me = vsObjId g - GPTeamPosition a b c _ = gsp + GPTeamPosition a b c d e _ _ = gsp in [(me, GameMessage (GTWaitKickOff, - GPTeamPosition a b c False))] + GPTeamPosition a b c d e False OOPKickOff))] checkIfTimeUp :: Param -> (GameStateParam, GamePerception) -> [Message] checkIfTimeUp param (_,vss) = @@ -67,7 +74,7 @@ t = vsGameTime g me = vsObjId g in [(me, GameMessage (GTQuit, - GPTeamPosition Home (Point2 0 0) t True)) + GPTeamPosition Home (-1) [] (Point2 0 0) t True InPlay)) | t > pGameLength param] freezePlayers :: (GameStateParam, GamePerception) -> [Message] @@ -84,9 +91,8 @@ TacticalStateParam (Just $ projectP $ vsPos p) Nothing False Nothing Nothing Nothing Nothing)) | p <- teamPlayers Home vss ++ teamPlayers Away vss] - sideOutMessages :: Param -> (GameStateParam, GamePerception) -> [Message] -sideOutMessages param (GPTeamPosition team pos t _, vss) = +sideOutMessages param (GPTeamPosition team _ _ pos _ _ _, vss) = let ballVss = fetchBallVS vss ball = vsObjId ballVss lp = lastPlayer $ vsBallState ballVss @@ -108,13 +114,13 @@ ballMsg = [(ball, BallMessage (BTOutOfPlay, BPOutOfPlay team OOPSideOut pos lp))] in dropBall ++ holdPos ++ moveThrowIn ++ ballMsg -baseOutMessages :: Param -> (GameStateParam, GamePerception) -> [Message] -baseOutMessages = sideOutMessages - gameSF :: Param -> GameStateParam -> SF (GamePerception, Event [(GameTransition, GameStateParam)]) ((State GameState GameTransition (GameStateParam, GamePerception) [Message], GameStateParam), [Message]) gameSF param gsp = reactMachineMult (fromRight (fsm param)) s7 gsp -controlledGameSF param me = reactMachineMult (fromRight (fsm param)) (s2 param) me +-- controlledGameSF :: Param -> GameStateParam -> +-- SF (GamePerception, Event [(GameTransition, GameStateParam)]) +-- ((State GameState GameTransition (GameStateParam, GamePerception) [Message], GameStateParam), [Message]) +-- controlledGameSF param me = reactMachineMult (fromRight (fsm param)) (s2 param) me diff --git a/GameLoop.hs b/GameLoop.hs --- a/GameLoop.hs +++ b/GameLoop.hs @@ -3,13 +3,10 @@ module GameLoop where import Debug.Trace -import Data.List import FRP.Yampa import FRP.Yampa.Geometry -import FRP.Yampa.Utilities import Object -import ObjectBehaviour import Message import AL import Global @@ -17,28 +14,25 @@ import Helper import States import Lineup - -instance Show (SF a b) where - show sf = "SF" - + gameLoop :: Param -> ALOut -> ALObj -> SF GameInput ALOut -gameLoop param init objs0 = - switch (process init objs0) $ - \(time, possession, scoreHome, scoreAway) -> +gameLoop param init' objs0 = + switch (process init' objs0) $ + \(time', possession, scoreHome, scoreAway) -> #if DEBUG_MODE - trace ("Achtung Init: " ++ show init) $ + trace ("Achtung Init: " ++ show init') $ #endif uncurry (gameLoop param) - (lineupKickoff param init time possession scoreHome scoreAway) + (lineupKickoff param init' time' possession scoreHome scoreAway) process :: ALOut -> ALObj -> SF GameInput (ALOut, Event (Time, Team, Int, Int)) -process init objs0 = proc input -> do +process init' objs0 = proc input -> do ticker <- repeatedly 0.3 iterateTimerEvents -< () timerEvent <- accum TimerCalculateAwayAI -< ticker rec - oos <- core init objs0 -< ((timerEvent, input), oos) + oos <- core init' objs0 -< ((timerEvent, input), oos) let kickOffEvent = case ((gameOO . elemsAL) oos) of - OOSGame gTime (gScoreHome, gScoreAway) (GSGoal, GPTeamPosition gTeam _ _ _) _ _ -> + OOSGame gTime (gScoreHome, gScoreAway) (GSGoal, GPTeamPosition gTeam _ _ _ _ _ _) _ _ -> Event (gTime, (otherTeam gTeam), gScoreHome + homeAdder gTeam, gScoreAway + awayAdder gTeam) _ -> NoEvent returnA -< (oos, kickOffEvent) @@ -46,6 +40,7 @@ homeAdder gTeam = if gTeam == Home then 1 else 0 awayAdder gTeam = if gTeam == Away then 1 else 0 +gameOO :: [ObjOutput] -> ObsObjState gameOO [] = error "GameLoop.hs/gameOO: No Game in Object Output" gameOO (o:os) = case o of @@ -61,8 +56,8 @@ -- rather more complex core, only necessary if non-static objects are needed -- (e.g. trigger objects) core :: ALOut -> ALObj -> SF (Input, ALOut) (ALOut) -core init objs = proc (input, al) -> do - al' <- iPre init -< al +core init' objs = proc (input, al) -> do + al' <- iPre init' -< al res <- core' objs -< (input, al') returnA -< res @@ -73,7 +68,7 @@ killAndSpawn :: ((Input, ALOut), ALOut) -> Event (ALObj -> ALObj) -killAndSpawn ((input, _), oos) = +killAndSpawn (_, oos) = foldl (mergeBy (.)) noEvent events where events :: [Event (ALObj -> ALObj)] diff --git a/Global.hs b/Global.hs --- a/Global.hs +++ b/Global.hs @@ -2,8 +2,6 @@ where -import FRP.Yampa.Geometry - import Physics import BasicTypes import Object diff --git a/Grid.hs b/Grid.hs --- a/Grid.hs +++ b/Grid.hs @@ -2,15 +2,12 @@ where -import FRP.Yampa.Geometry import Data.List import Data.Ord import Control.Monad -import Control.Arrow import Global import BasicTypes -import Physics import Helper import Object @@ -24,7 +21,7 @@ i <- [1..m], j <- [1..n], let x = i * plm - plm2, let y = j * pln - pln2] viableSpot :: [VisibleState] -> Team -> Spot -> Spot -> Bool -viableSpot vss team currSpot destSpot = +viableSpot vss team _ destSpot = -- "viable" means: at least one of "my" players is nearer to the spot -- than every player of the "other" team -- AND the spot is close enough so that one can pass or @@ -48,16 +45,19 @@ -- in vector3 (vector2X result) (vector2Y result) 2 spotValue :: [VisibleState] -> Team -> GridElement -> Double -spotValue _ team (GridElement _ homeValue awayValue) = +spotValue _ team (GridElement _ homeValue_ awayValue_) = -- the value of a spot is defined by the corresponding value in the -- grid plus a value stating how "free" the spot is from enemy players - let gridValue = if team == Home then homeValue else awayValue + let gridValue = if team == Home then homeValue_ else awayValue_ freeValue = 0 -- missing yet in gridValue + freeValue +spotFromGE :: GridElement -> Spot spotFromGE (GridElement spot _ _) = spot -homeValueFromGE (GridElement _ homeValue _) = homeValue -awayValueFromGE (GridElement _ _ awayValue) = awayValue +homeValueFromGE :: GridElement -> Double +homeValueFromGE (GridElement _ homeValue_ _) = homeValue_ +awayValueFromGE :: GridElement -> Double +awayValueFromGE (GridElement _ _ awayValue_) = awayValue_ -- was wenn kein spot da? dann sollte das nicht hinkacheln, vielleicht besser @@ -70,10 +70,12 @@ -- berechnung mit der ganzen sortiererei vielleicht etwas aufwändiger ist als -- die bewertung der spots +compareSpots :: [VisibleState] -> Team -> GridElement -> GridElement -> Ordering compareSpots vss = comparing . spotValue vss -putGrid param m n = +putGrid :: Param -> t -> t1 -> IO () +putGrid param _ _ = forM_ (grid param 10 10) $ \(GridElement (Spot x y) vx vy) -> putStrLn $ show x ++ "; " ++ show y ++ "; " ++ show vx ++ "; " ++ show vy diff --git a/Helper.hs b/Helper.hs --- a/Helper.hs +++ b/Helper.hs @@ -4,8 +4,6 @@ where -import Debug.Trace - import Data.Maybe import Data.List import Data.Ord @@ -14,7 +12,6 @@ import FRP.Yampa import FRP.Yampa.Geometry -import FRP.Yampa.Point2 import Object import Message @@ -31,38 +28,53 @@ -- -- ************************************************************************* +spotToPoint :: Spot -> Point2 Double spotToPoint (Spot x y) = Point2 x y +pointToSpot :: Point2 Double -> Spot 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 - +spotDistance :: Spot -> Point2 Double -> Double +spotDistance (Spot x1 y1) = + distance (Point2 x1 y1) + +pointsForward :: RealFloat a => Vector3 a -> Team -> Bool +pointsForward v team = + (team == Home && vector3Y v < 0) || + (team == Away && vector3Y v > 0) +tm :: TacticalPlayerMessage -> MessageBody tm x = PlayerMessage $ TacticalPlayerMessage x +pm :: PhysicalPlayerMessage -> MessageBody pm x = PlayerMessage $ PhysicalPlayerMessage x +otherTeam :: Team -> Team otherTeam Home = Away otherTeam Away = Home +lastPlayer :: (t, BallMsgParam) -> ObjId lastPlayer ballState = case ballState of (_, BPWho oid _) -> oid (_, BPInit _ oid) -> oid (_, BPOutOfPlay _ _ _ oid) -> oid +teamMates :: ObjId -> [VisibleState] -> [VisibleState] teamMates me vss = let team = vsTeam $ fetchVS vss me in [p | p@(VSPlayer {}) <- vss, vsTeam p == team, vsObjId p /= me] +teamPlayers :: Team -> [VisibleState] -> [VisibleState] teamPlayers team vss = [p | p@(VSPlayer {vsTeam = team'}) <- vss, team' == team] +fetchGoalie :: Team -> [VisibleState] -> VisibleState fetchGoalie team vss = head $ filter isGoalie $ teamPlayers team vss +isGoalie :: VisibleState -> Bool isGoalie = (Goalie ==) . piPlayerRole . vsPlayerInfo playerWithBall :: [VisibleState] -> Maybe ObjId @@ -72,6 +84,7 @@ [] -> Nothing pls -> error $ "Helper.hs/playerWithBall: too many players " ++ show (map vsObjId pls) +playerIsFree :: [VisibleState] -> VisibleState -> Bool playerIsFree vss vs = let pos = vsPos vs team = vsTeam vs @@ -80,47 +93,56 @@ distance pos (vsPos vso) > 5) True otherPlayers +homeValue :: Param -> Spot -> Double homeValue param (Spot x y) = half x (pPositionFactorX param) (pPitchWidth param) + (pPitchLength param - y) * pPositionFactorY param +awayValue :: Param -> Spot -> Double 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 +half :: (Fractional a, Ord a) => a -> a -> a -> a +half u factor max_ + | u < (max_ / 2) = u * factor + | otherwise = (max_ - u) * factor +bestFreePlayer :: Param -> [VisibleState] -> VisibleState -> Maybe VisibleState 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 + else Just $ maximumBy (compare `on` valFun param . pointToSpot . projectP . vsPos) freePlayers +nearestNonAIPlayer :: Team -> [VisibleState] -> Position2 -> ObjId 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 -> [VisibleState] -> Position2 -> ObjId 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 -> [VisibleState] -> Position2 -> ObjId 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 -> [VisibleState] -> Position2 -> ObjId 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 :: (Ord a, AffineSpace p v a) => p -> p -> p -> Ordering closerToPoint p p1 p2 = if distance p p1 < distance p p2 then LT else GT @@ -128,7 +150,7 @@ fetchVS vss = fromJust . flip getObjVS vss getObjVS :: ObjId -> [VisibleState] -> Maybe VisibleState -getObjVS oid [] = Nothing +getObjVS _ [] = Nothing getObjVS oid (vs:vss) = if vsObjId vs == oid then Just vs else getObjVS oid vss @@ -146,6 +168,7 @@ VSBall {} -> v _ -> fetchBallVS vs +fetchBallCarrier :: [VisibleState] -> Maybe VisibleState fetchBallCarrier vss = let (s, sp) = vsBallState ball ball = fetchBallVS vss @@ -170,6 +193,7 @@ hasBall :: VisibleState -> Bool hasBall vs = isPlayer vs && (fst . vsPBState) vs == PBSInPossession +offsiteFrontier :: Param -> ObjId -> [VisibleState] -> Point2 Position 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 @@ -179,28 +203,28 @@ 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) + half_ = pPitchLength param / 2 + yAdjust = if myTeam == Home then min y half_ + 1 else max y half_ - 1 + in Point2 myXPos yAdjust -adjustForOffsite param p@(Point2 x y) me vss = - let pOff@(Point2 xOff yOff) = offsiteFrontier param me vss +adjustForOffsite :: Param -> Point2 Position -> ObjId -> [VisibleState] -> Point2 Position +adjustForOffsite param p@(Point2 _ y) me vss = + let pOff@(Point2 _ 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))) + ((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 + let pI = vsPlayerInfo $ fetchVS vss me + defensivePos = piBasePosDefense pI + offensivePos = piBasePosOffense pI myTeam = vsTeam $ fetchVS vss me ball = fetchBallVS vss posBall = projectP . vsPos $ ball @@ -223,11 +247,14 @@ -- -- ************************************************************************* +limitPosition :: RealFloat a => (a, a, a, a) -> Point2 a -> Point2 a 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 + where minmax min_ max_ z = if z < min_ then min_ else if z > max_ then max_ else z +noPoint :: Point2 Double noPoint = Point2 (-1) (-1) +zeroVel :: Vector3 Double zeroVel = vector3 0 0 0 sameDirection :: Param -> Velocity2 -> Velocity2 -> Bool @@ -235,13 +262,14 @@ abs(vector2Rho u) > pEps param && abs((vector2Rho u + vector2Rho v) - vector2Rho (u ^+^ v)) < pEps param +inOneSecond :: AffineSpace p v a => p -> v -> p inOneSecond pos vel = pos .+^ vel -(.+!) :: (Point2 Double) -> Double -> (Point3 Double) -(Point2 x y) .+! z = (Point3 x y z) +(.+!) :: Point2 Double -> Double -> Point3 Double +(Point2 x y) .+! z = Point3 x y z -(^+!) :: (Vector2 Double) -> Double -> (Vector3 Double) +(^+!) :: Vector2 Double -> Double -> Vector3 Double v ^+! z = let x = vector2X v y = vector2Y v @@ -264,15 +292,19 @@ y = vector3Y v b = a / vector2Rho (vector2 x y) +halfPi :: Double halfPi = pi / 2 +(^-.) :: RealFloat a => Point2 a -> Vector2 a -> Point2 a (Point2 x y) ^-. v = Point2 (vector2X v - x) (vector2Y v - y) +normTheta :: (Floating a, Ord a) => a -> a normTheta x | x < (- pi) = x + 2 * pi | x > pi = x - 2 * pi | otherwise = x +lookTo :: AffineSpace p v a => p -> p -> p lookTo p0 p1 = p0 .+^ (0.0001 *^ normalize (p1 .-. p0)) @@ -289,6 +321,7 @@ u `isLeftFrom` v = normTheta (vector2Theta (u `turnBy` v)) >= 0 +isRigthFrom :: Vector2 Double -> Vector2 Double -> Bool u `isRigthFrom` v = v `isLeftFrom` u sameDirAs :: Vector2 Double -> Vector2 Double -> Bool @@ -297,27 +330,35 @@ in (theta > 0 && theta < pi/2) || (theta < 0 && theta > -(pi/2)) +toPolar :: RealFloat t => t -> t -> (t, t) toPolar x y = (atan2 y x, sqrt ((x*x) + (y*y))) +getAngle :: RealFloat a => Vector2 a -> a getAngle v = atan2 (vector2Y v) (vector2X v) +fromPolar :: RealFloat a => a -> a -> Vector2 a fromPolar theta rho = vector2 (rho * cos theta) (rho * sin theta) -fromPolar3 theta rho z = - vector3 (rho * cos theta) (rho * sin theta) z +fromPolar3 :: RealFloat a => a -> a -> a -> Vector3 a +fromPolar3 theta rho = + vector3 (rho * cos theta) (rho * sin theta) -limit max v = +limit :: (Ord a, VectorSpace v a) => a -> v -> v +limit max_ v = let len = norm v in - if len > max then (max/len) *^ v else v + if len > max_ then (max_/len) *^ v else v +mirrorPoint :: RealFloat a => Point2 a -> Point2 a -> Point2 a mirrorPoint (Point2 x y) (Point2 ax ay) = Point2 (mirrorAt x ax) (mirrorAt y ay) +mirrorAt :: Num a => a -> a -> a mirrorAt x axis = 2 * axis - x +sqr :: Num a => a -> a sqr x = x * x -- ************************************************************************* -- @@ -325,8 +366,11 @@ -- -- ************************************************************************* +awayGoalCenter :: Param -> Point2 Double awayGoalCenter param = Point2 (pPitchWidth param / 2) 0 +homeGoalCenter :: Param -> Point2 Double homeGoalCenter param = Point2 (pPitchWidth param / 2) (pPitchLength param) +pitchCenter :: Param -> Point2 Double pitchCenter param = Point2 (pPitchWidth param / 2) (pPitchLength param / 2) -- ************************************************************************* @@ -335,10 +379,11 @@ -- -- ************************************************************************* -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 :: Command -> [MessageBody] +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)) @@ -358,18 +403,21 @@ (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') +fetch a = map snd . filter (\(a',_) -> a == a') -remove a = filter (\(a',b) -> a /= a') +remove :: Eq a => a -> [(a, t)] -> [(a, t)] +remove a = filter (\(a',_) -> 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 +fst3 :: (t, t1, t2) -> t +fst3 (a, _, _) = a +snd3 :: (t, t1, t2) -> t1 +snd3 (_, b, _) = b +thrd3 :: (t, t1, t2) -> t2 +thrd3 (_, _, c) = c +fromRight :: Either t t1 -> t1 fromRight (Right x) = x - - diff --git a/Lineup.hs b/Lineup.hs --- a/Lineup.hs +++ b/Lineup.hs @@ -21,16 +21,16 @@ lineupKickoff :: Param -> ALOut -> Time -> Team -> Int -> Int -> (ALOut, ALObj) -lineupKickoff param alout time possession scoreHome scoreAway = +lineupKickoff param alout time' possession scoreHome scoreAway = let (homeOos, homeObjs, maybeHomeKickers) = lineupKickoffTeam param alout Home (possession == Home) (awayOos, awayObjs, maybeAwayKickers) = lineupKickoffTeam param alout Away (possession == Away) - (kicksOff, kickedTo) = if maybeHomeKickers == Nothing then + (kicksOff, _) = if maybeHomeKickers == Nothing then fromJust maybeAwayKickers else fromJust maybeHomeKickers bid = ballId alout gid = gameId alout - (ballOos, ballObjs) = lineupKickoffBall param bid kicksOff time - (gameOos, gameObjs) = lineupKickoffGame param gid time possession scoreHome scoreAway + (ballOos, ballObjs) = lineupKickoffBall param bid kicksOff time' + (gameOos, gameObjs) = lineupKickoffGame param gid time' possession scoreHome scoreAway in #if DEBUG_MODE trace ("Lineup durchgeführt" ++ @@ -56,13 +56,13 @@ mapAL (ooObsObjState . snd) . filterAL isPlayerOO) oos sorted = fromAssocs $ - sortBy (\(_, oos) (_, oos') -> - comparing dist oos oos') $ + sortBy (\(_, oos') (_, oos'') -> + comparing dist oos' oos'') $ assocsAL players (kicksOffPlId, kicksOffPl) = sorted `at` 0 (kickedToPlId, kickedToPl) = sorted `at` 1 kickOffSpot = Point2 (pPitchWidth param / 2) (pPitchLength param / 2) - dist oos = distance (basePos oos) kickOffSpot + dist oos' = distance (basePos oos') kickOffSpot basePls = if kicksoff then deleteAL kicksOffPlId $ deleteAL kickedToPlId players else players @@ -77,13 +77,16 @@ else Nothing ) +isPlayerOO :: ObjOutput -> Bool isPlayerOO (ObjOutput {ooObsObjState = OOSPlayer {}}) = True isPlayerOO _ = False +mkBase :: Param -> Team -> AL ObjId ObsObjState -> (AL ObjId ObjOutput, AL ObjId Object) mkBase param team oos = (mapAL (mkStandardPlayerObjOutput . snd) oos, mapAL (uncurry (mkStandardPlayerObject param team)) oos) +mkObjs :: Param -> Team -> (ObjId, ObsObjState) -> (ObjId, ObsObjState) -> (AL ObjId ObjOutput, AL ObjId Object) mkObjs param team (fromId, fromPl) (toId, toPl) = let toOut = mkKickedToPlayerObjOutput param team toPl toObj = mkKickedToPlayerObject param toId team toPl @@ -94,8 +97,10 @@ in (fromAssocs [(toId, toOut), (fromId, fromOut)], fromAssocs [(toId, toObj), (fromId, fromObj)]) +basePos :: ObsObjState -> Point2 Double basePos = piBasePosDefense. oosPlayerInfo +kicksOffPosition :: Param -> Team -> Point2 Double kicksOffPosition param team -- | team == Home = Point2 42 52 -- basierend auf 80, 96 muss man noch verformeln -- | team == Away = Point2 38 44 @@ -103,6 +108,7 @@ | team == Away = Point2 (pPitchWidth param / 2 - 2) (pPitchLength param / 2 - 1) +kickedToPosition :: Param -> Team -> Point2 Double kickedToPosition param team -- | team == Home = Point2 35 50 -- | team == Away = Point2 45 46 @@ -124,7 +130,9 @@ mkStandardPlayerObjOutput :: ObsObjState -> ObjOutput mkStandardPlayerObjOutput oos = mkpoo (basePos oos) oos +mkKickedToPlayerObjOutput :: Param -> Team -> ObsObjState -> ObjOutput mkKickedToPlayerObjOutput param = mkpoo . kickedToPosition param +mkKicksOffPlayerObjOutput :: Param -> Team -> ObsObjState -> ObjOutput mkKicksOffPlayerObjOutput param = mkpoo . kicksOffPosition param @@ -151,15 +159,16 @@ (if (== Goalie) . piPlayerRole . oosPlayerInfo $ oos then TSGoalieWaitingForKickOff else if ai then TSWaitingForKickOff else TSNonAIKickingOff) where ai = not $ oosSelected oos - playerRole (_,pr,_,_) = pr maker = if ai then playerAI else player mkStandardPlayerObject :: Param -> Team -> ObjId -> ObsObjState -> Object mkStandardPlayerObject param team oid oos = mkpo param oid oos (basePos oos) PBSNoBall (if team == Home then 3*pi/2 else pi/2) +mkKickedToPlayerObject :: Param -> ObjId -> Team -> ObsObjState -> Object mkKickedToPlayerObject param oid team oos = mkpo param oid oos (kickedToPosition param team) PBSNoBall (if team == Home then 0 else pi) +mkKicksOffPlayerObject :: Param -> ObjId -> Team -> ObsObjState -> Object mkKicksOffPlayerObject param oid team oos = mkpo param oid oos (kicksOffPosition param team) PBSInPossession (if team == Home then pi else 0) @@ -171,9 +180,9 @@ -- ************************************************************************* lineupKickoffBall :: Param -> ObjId -> ObjId -> Time -> (ALOut, ALObj) -lineupKickoffBall param ballId playerId t0 = +lineupKickoffBall param ballId' playerId t0 = let (_, bobjs, boos) = mkBallInPossession param - ballId + ballId' playerId t0 False @@ -181,9 +190,9 @@ (pitchCenter param .+! 0) (vector3 0 0 0) [] - in (fromAssocs [(ballId, boos)], - fromAssocs [(ballId, bobjs)]) - + in (fromAssocs [(ballId', boos)], + fromAssocs [(ballId', bobjs)]) + -- ************************************************************************* -- @@ -192,16 +201,16 @@ -- ************************************************************************* lineupKickoffGame :: Param -> ObjId -> Time -> Team -> Int -> Int -> (ALOut, ALObj) -lineupKickoffGame param oid time possession scoreHome scoreAway = +lineupKickoffGame param oid time' possession scoreHome scoreAway = let goos = ObjOutput - (OOSGame time + (OOSGame time' (scoreHome, scoreAway) - (GSKickOff, GPTeamPosition possession (pitchCenter param) time True) + (GSKickOff, GPTeamPosition possession 100 [] (pitchCenter param) time' True InPlay) possession (Point3 (-10) (-10) 0)) NoEvent NoEvent [] - gobj = game param oid possession scoreHome scoreAway time + gobj = game param oid possession scoreHome scoreAway time' in (fromAssocs [(oid, goos)], fromAssocs [(oid, gobj)]) diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,4 +1,8 @@ module Main where + +import Graphics.UI.SDL (Surface) +import Graphics.UI.SDL.TTF +import Graphics.UI.SDL.Mixer as Mix import System.Directory import System.FilePath (()) @@ -7,17 +11,18 @@ import Data.Time.Clock import Data.List import Data.Ord - +import Data.Array +import Control.Monad + import FRP.Yampa import FRP.Yampa.Geometry import qualified Graphics.UI.SDL as SDL - -import qualified Render as Render + +import qualified Render import RenderUtil import Object -import ObjectBehaviour import Animate import AL import States @@ -28,19 +33,23 @@ import Parser import ParseTeam import Helper -import Object import Lineup -import AI +spainBorder :: SDL.Pixel spainBorder = rgbColor 252 0 2 +spainCircle :: SDL.Pixel spainCircle = rgbColor 255 255 1 +germanyBorder :: SDL.Pixel germanyBorder = rgbColor 0 0 0 +germanyCircle :: SDL.Pixel germanyCircle = rgbColor 255 255 255 +tiHome :: (Team, SDL.Pixel, SDL.Pixel) tiHome = (Home, spainBorder, spainCircle) +tiAway :: (Team, SDL.Pixel, SDL.Pixel) tiAway = (Away, germanyBorder, germanyCircle) - + main :: IO () main = do setupBasicFiles @@ -49,6 +58,7 @@ mainLoop sdl playersHome playersAway param SDL.quit +mainLoop :: (Num i, Ix i) => (Surface, Surface, Array i Font, Array Int (Surface, Int), Chunk, Chunk, Chunk) -> [PlayerInfo] -> [PlayerInfo] -> Param -> IO () mainLoop sdl playersHome playersAway param = do sdlState <- newIORef Nothing writeIORef sdlState (Just sdl) @@ -65,16 +75,17 @@ waitForSpaceKey animate param sdlState t' timeState frameCounter $ mergeAL lObj lOO count <- readIORef frameCounter - now <- getCurrentTime - let seconds = convert now - t' + rightNow <- getCurrentTime + let seconds = convert rightNow - t' putStrLn $ "Frames per second: " ++ show (fromIntegral count / seconds) Render.renderEndMsg sdl continue <- shouldContinue if continue then mainLoop sdl playersHome playersAway param else return () - -baseObjs param = + +baseObjs :: (Monad m, Num k) => t -> m (AL k ObjOutput) +baseObjs _ = let - g = (1, ObjOutput (OOSGame 0 (0, 0) (GSKickOff, GPTeamPosition Home (Point2 0 0) 0 False) Home (Point3 0 0 0)) + g = (1, ObjOutput (OOSGame 100 (0, 0) (GSKickOff, GPTeamPosition Home 100 [] (Point2 0 0) 0 False OOPKickOff) Home (Point3 0 0 0)) NoEvent NoEvent []) -- CAUTION: Always start with a valid player id!! @@ -84,25 +95,26 @@ in return $ AL [g, ball] +playersInit :: (Enum k, Num k) => Param -> [PlayerInfo] -> [PlayerInfo] -> AL k ObjOutput playersInit param playersHome playersAway = - let h = zip [100..] $ map (\pi -> op (kicksOff == piNumber pi) tiHome pi) playersHome - a = zip [200..] $ map (op False tiAway) $ map mirrorPlayer playersAway + let h = zip [100..] $ map (\pI -> op (kicksOff == piNumber pI) tiHome pI) playersHome + a = zip [200..] $ map (op False tiAway . mirrorPlayer) playersAway axis = Point2 (pPitchWidth param / 2) (pPitchLength param / 2) kicksOff = piNumber $ minimumBy (\p1 p2 -> comparing dist p1 p2) playersHome - dist pi = distance (piBasePosDefense pi) kickOffSpot + dist pI = distance (piBasePosDefense pI) kickOffSpot kickOffSpot = Point2 (pPitchWidth param / 2) (pPitchLength param / 2) - op selected ti pi = ObjOutput (OOSPlayer (Point3 0 0 0) + op selected ti pI = ObjOutput (OOSPlayer (Point3 0 0 0) (vector3 0 0 0) (vector3 0 0 0) selected selected selected 0 - ti pi 0 + ti pI 0 (PBSNoBall, BSPNothing) (TSWaitingForKickOff, tspNull) NoFoot ) NoEvent NoEvent [] - mirrorPlayer p@(PlayerInfo { piBasePosDefense = pd, piBasePosOffense = po }) = - p{ piBasePosDefense = mirrorPoint pd axis, piBasePosOffense = mirrorPoint po axis } + mirrorPlayer pl@(PlayerInfo { piBasePosDefense = pd, piBasePosOffense = po }) = + pl{ piBasePosDefense = mirrorPoint pd axis, piBasePosOffense = mirrorPoint po axis } in AL $ h ++ a @@ -116,12 +128,12 @@ let param = Param { pEps = 0.1, pGround = 0, - pLeftBorderX = 8.9, - pRightBorderX = 46.1, - pUpperBorderY = 9.3, - pLowerBorderY = 10, - pPitchLength = 102.0, - pPitchWidth = 83.5, + pLeftBorderX = 3.0, --8.9, + pRightBorderX = 43.0, --46.1, + pUpperBorderY = 2.0, --9.3, + pLowerBorderY = 4.0, --10, + pPitchLength = 116.8, + pPitchWidth = 89.5, pGoalWidth = 10.32, pMaxheight = 60.0, -- in Meter @@ -144,4 +156,5 @@ pGrid = undefined } - return $ (pHome, pAway, param {pGrid = grid param 10 10}) + return (pHome, pAway, param {pGrid = grid param 10 10}) + diff --git a/Message.hs b/Message.hs --- a/Message.hs +++ b/Message.hs @@ -86,11 +86,11 @@ | PPTUnStun | PPTCollisionP | PPTPrepareThrowIn - | PPTThrowIn + -- | PPTThrowIn deriving (Show, Eq, Ord) -instance Show Position3 - where show (Point3 x y z) = "(" ++ show x ++ ", " ++ show y ++ ", " ++ show z ++ ")" +--instance Show Position3 +-- where show (Point3 x y z) = "(" ++ show x ++ ", " ++ show y ++ ", " ++ show z ++ ")" data TacticalStateParam = TacticalStateParam { tspDesiredPos :: Maybe Position2 @@ -103,6 +103,7 @@ -- state was entered... } deriving (Show, Eq) +tspNull :: TacticalStateParam tspNull = TacticalStateParam Nothing Nothing False @@ -135,7 +136,7 @@ instance Ord TacticalPlayerTransition where x < y = translate x < translate y where - translate TPTWaitForKickOff = 5 + translate TPTWaitForKickOff = 5 :: Integer translate TPTWait = 10 translate TPTMoveTo = 20 translate TPTHoldPosition = 30 @@ -167,8 +168,7 @@ -- ************************************************************************* data GameTransition = - GTSideOut - | GTBaseOut + GTOutOfPlay | GTGoal | GTOffsite | GTQuit @@ -177,18 +177,23 @@ | GTTakePossession | GTRunGame | GTWaitKickOff + | GTCheckOffsite + | GTNoOffsite deriving (Show, Eq, Ord) - data GameMsgParam = - GPTeamPosition Team Position2 Time Bool -- Team who gets the ball on sideout, foul or offsite, - -- position and time of event and whistle flag + GPTeamPosition Team -- Team who gets the ball on sideout or who passed the ball on OffsitePending + ObjId -- Player who passed the ball on OffsitePending + [(Team, ObjId, Position)] -- Position of players on passing (for OffsitePending) + Position2 -- Position of event + Time -- Time of event + Bool -- Whistle flag + OutOfPlay deriving (Eq) instance Show GameMsgParam where --- show (GPTeam x) = "Team " ++ show x - show (GPTeamPosition team (Point2 x y) t _) = "TeamPosition " ++ show team ++ ", pos=(" ++ show x ++ ", " ++ show y ++ ") " ++ show t --- show (GPNothing) = "Nothing" + show (GPTeamPosition team oid _ (Point2 x y) t _ _) = + "T=" ++ show team ++ ",P="++show oid++",p=(" ++ show x ++ ", " ++ show y ++ ") " ++ show t type GameStateParam = GameMsgParam type GameMessage = (GameTransition, GameMsgParam) @@ -202,9 +207,14 @@ type Collisions = [ObjId] +isBallMessage :: MessageBody -> Bool isBallMessage mb = case mb of BallMessage _ -> True; _ -> False +isPhysicalPlayerMessage :: MessageBody -> Bool isPhysicalPlayerMessage mb = case mb of PlayerMessage (PhysicalPlayerMessage _) -> True; _ -> False +isTacticalPlayerMessage :: MessageBody -> Bool isTacticalPlayerMessage mb = case mb of PlayerMessage (TacticalPlayerMessage _) -> True; _ -> False +isGameMessage :: MessageBody -> Bool isGameMessage mb = case mb of GameMessage _ -> True; _ -> False +fromBPWho :: BallMsgParam -> ObjId fromBPWho (BPWho x _) = x diff --git a/Object.hs b/Object.hs --- a/Object.hs +++ b/Object.hs @@ -5,11 +5,8 @@ where import FRP.Yampa -- (SF, Event) -import FRP.Yampa.Geometry import FRP.Yampa.Forceable -import Graphics.UI.SDL as SDL (Pixel) - import AL import Physics import Message @@ -76,11 +73,11 @@ oosOnFoot :: !OnFoot } | OOSGame { - oosGameTime :: !Time, - oosGameScore:: !(Int, Int), - oosGameState:: !(GameState, GameStateParam), - oosAttacker :: !Team, - oosPos :: !Position3 -- Dummy, zum Sortieren... + oosGameTime :: !Time, + oosGameScore :: !(Int, Int), + oosGameState :: !(GameState, GameStateParam), + oosAttacker :: !Team, + oosPos :: !Position3 -- Dummy, zum Sortieren... } @@ -118,9 +115,10 @@ } +vsFromObjOutput :: ObjId -> ObjOutput -> VisibleState vsFromObjOutput oid os = case ooObsObjState os of OOSBall p v _ s -> VSBall oid msg p v s - OOSPlayer p v a _ _ des _ (t, _, _) pi d bs ts f -> VSPlayer oid msg p v a des t pi d bs ts f + OOSPlayer p v a _ _ des _ (t, _, _) pI d bs ts f -> VSPlayer oid msg p v a des t pI d bs ts f OOSGame t sc st att _ -> VSGame oid msg t sc att st where msg = ooMessages os @@ -155,7 +153,7 @@ type RuleFunction = [ObjId ] -> Facts -> [VisibleState] -> Maybe [Message] instance Show RuleFunction where - show x = "RuleFunction" + show _ = "RuleFunction" data Rule = Rule { opRuleId :: RuleId, diff --git a/ObjectBehaviour.hs b/ObjectBehaviour.hs --- a/ObjectBehaviour.hs +++ b/ObjectBehaviour.hs @@ -9,12 +9,10 @@ import Data.List import Data.Maybe import Control.Monad (guard) -import Graphics.UI.SDL (Pixel) +--import Graphics.UI.SDL (Pixel) import FRP.Yampa -import FRP.Yampa.Utilities import FRP.Yampa.Geometry -import FRP.Yampa.Point2 import Data.FSM @@ -41,7 +39,7 @@ 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 +fly param me lpInit t0 p0 v0 acc initColls = proc (ObjInput {oiGameInput = (_, (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 @@ -54,16 +52,24 @@ stopped <- edge -< sameDirection param (project v) (project acc) -- drop redundant collisions - (collisions, cNext) <- ballCollisionSF initColls -< colls + (collisions, _) <- ballCollisionSF initColls -< colls let ms = map (\(BallMessage msg) -> msg) $ filter isBallMessage mi + let mcs = #if DEBUG_MODE - trace ("Ball (Free): " ++ show (ms ++ collisions)) + trace ("__StMsg__Ball__Msg__" ++ show (ms ++ collisions)) #endif (ms ++ collisions) - (bs@(st,stParam), msOut') <- freeBallSF (BPWho lpInit t0) -< ((BPWho me t1, vss), (Event mcs)) + (bs@(st',stParam), msOut') <- freeBallSF param (BPWho lpInit t0) -< ((BPWho me t1, vss), (Event mcs)) + + let st = +#if DEBUG_MODE + trace ("__StMsg__Ball__St__" ++ show (content st')) +#endif + st' + let lp = lastPlayer bs let msOut = @@ -91,15 +97,14 @@ (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 +ballInPossession param me plr t0 goalieHasGained _ initColls = {-# SCC "ballIP" #-} + proc (ObjInput {oiGameInput = (_, (t1,_)), oiMessages = (mi, colls), oiGameState = vss}) -> do -- drop redundant collisions (collisions, cNext) <- ballCollisionSF initColls -< colls @@ -107,13 +112,26 @@ let ms = map (\(BallMessage msg) -> msg) $ filter isBallMessage mi let mcs = #if DEBUG_MODE - trace ("Ball (Poss): " ++ show (ms ++ collisions)) + trace ("__StMsg__Ball__Msg__" ++ 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 + ((st',stParam), ems) <- (controlledBallSF param goalieHasGained) (BPWho plr t0) -< ((BPWho me t1, vss), (Event mcs)) + + let st = +#if DEBUG_MODE + trace ("__StMsg__Ball__St__" ++ show (content st')) +#endif + st' + + let stParam' = +#if DEBUG_MODE + trace ("BallParam (Poss): " ++ show stParam) +#endif + stParam + + currPlayer <- iPre plr -< fetchPlayer stParam' let Just playerVS = getObjVS currPlayer vss -- ball is either on the left or right foot of the player, ball position will be @@ -141,41 +159,45 @@ (ems ++ lineCrossedMsgs param t1 (content st) p currPlayer vss) where fetchPlayer (BPWho who _) = who +makeBreakVector :: Velocity3 -> Vector3 Velocity makeBreakVector vel = let vel2 = project vel - (theta, rho) = toPolar (vector2X vel2) (vector2Y vel2) + (theta, _) = toPolar (vector2X vel2) (vector2Y vel2) (theta', rho') = (normTheta (theta + pi), 3) vel2' = fromPolar theta' rho' in vector3 (vector2X vel2') (vector2Y vel2') (-10) +fetchVel :: BallMsgParam -> Vector3 Double fetchVel (BPInit vel _) = vel fetchVel _ = zeroVel lineCrossedMsgs :: Param -> Time -> BallState -> (Point3 Double) -> ObjId -> [VisibleState] -> [Message] -lineCrossedMsgs param t st pos lastPlayer vss = +lineCrossedMsgs param t _ pos1 lastPlr 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))] - + let gameId_ = vsObjId $ fetchGameVS vss + pos0 = vsPos . fetchBallVS $ vss + (x0, y0) = (point3X pos0, point3Y pos0) + (x1, y1) = (point3X pos1, point3Y pos1) + xMax = pPitchWidth param + yMax = pPitchLength param + xBase = if x1 <= (pPitchWidth param) / 2 then 0 else pPitchWidth param + yBase = if y1 <= 0 then 0 else (pPitchLength param) + teamThrowingIn = otherTeam . vsTeam $ fetchVS vss lastPlr + goalTeam = if y1 < 0 then Home else Away + in if (x1 < 0 && x0 >= 0) || (x1 > xMax && x0 <= xMax) then + [(gameId_, GameMessage (GTOutOfPlay, GPTeamPosition teamThrowingIn (-1) [] (Point2 x1 y1) t True OOPSideOut))] + else if ((y1 < 0 && y0 >= 0) || (y1 > yMax && y0 <= yMax)) && + ((x1 < (xMax - pGoalWidth param) / 2) || (x1 > (xMax + pGoalWidth param) / 2)) then + [(gameId_, GameMessage (GTOutOfPlay, GPTeamPosition teamThrowingIn (-1) [] (Point2 xBase yBase) t True OOPBaseOut))] + else if ((y1 < 0 && y0 >= 0) || (y1 > yMax && y0 <= yMax)) && + ((x1 >= (xMax - pGoalWidth param) / 2) && (x1 <= (xMax + pGoalWidth param) / 2)) + then [(gameId_, GameMessage (GTGoal, GPTeamPosition goalTeam (-1) [] (Point2 0 0) t True OOPKickOff))] + else [] 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 + proc (ObjInput {oiGameInput = (_, (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 @@ -193,11 +215,18 @@ let ms = map (\(BallMessage msg) -> msg) $ filter isBallMessage mi let mcs = #if DEBUG_MODE - trace ("Ball (Poss): " ++ show (ms ++ collisions)) + trace ("__StMsg__Ball__Msg__" ++ show (ms ++ collisions)) #endif (ms ++ collisions) - (bs@(st,stParam), ems) <- outOfPlayBallSF (BPOutOfPlay team oopType pos lpInit) -< ((BPWho me t1, vss), (Event mcs)) + (bs@(st',stParam), ems) <- outOfPlayBallSF param (BPOutOfPlay team oopType pos lpInit) -< ((BPWho me t1, vss), (Event mcs)) + let st = +#if DEBUG_MODE + trace ("__StMsg__Ball__St__" ++ show (content st')) +#endif + st' + + let lp = lastPlayer bs let Just playerVS = getObjVS lp vss @@ -229,21 +258,21 @@ 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 = +playerAI param me t0 p0 v0 angle0 sel des ti pI pbsInit _ 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)) + trace ("__StMsg__AI " ++ show me ++ "__Msg__" ++ show (convertTms mi)) #endif - (convertTms mi) + convertTms mi rec pdDefault <- iPre p0 -< pd --projectP pos - ((st, stParam@(TacticalStateParam maybePd vd kicked plId ovrwtDir _ timeOfPossession)), msOut) + ((st, stParam@(TacticalStateParam maybePd _ _ _ ovrwtDir _ _)), msOut) <- tacticalPlayerSF param initState angle0 -< ((t1, me, vss, commands), Event tms) let isDesignated = elem (TPTDesignateReceiver, tspNull) tms @@ -254,13 +283,10 @@ 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 + 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 + results@(ObjOutput oop@OOSPlayer{oosPos = pos, oosVel = vel, oosDir = angle } _ _ _) + <- playerCore param me t0 p0 v0 sel des ti pI pbsInit -< (pd, False, ovrwtDir, t1, commands, (msLocal ++ mi, colls), vss) let rm = ooMessages results @@ -280,7 +306,7 @@ False False ti - pi + pI (fst $ oosBasicState oop) (oosOnFoot oop) (if content st == TSWaitingForKickOff @@ -295,8 +321,10 @@ -- -- ************************************************************************* -convertTms mi = (sortWith fst (map (\(PlayerMessage (TacticalPlayerMessage tm)) -> tm) $ filter isTacticalPlayerMessage mi)) +convertTms :: [MessageBody] -> [(TacticalPlayerTransition, TacticalStateParam)] +convertTms mi = (sortWith fst (map (\(PlayerMessage (TacticalPlayerMessage tm_)) -> tm_) $ filter isTacticalPlayerMessage mi)) +messageForNearestPlayer :: Param -> ObjId -> Team -> Position2 -> [Command] -> [VisibleState] -> (ObjId, MessageBody) messageForNearestPlayer param npId myTeam myPos mc vss = (npId, if cmdTakeOver mc then tm (TPTSwitchControl, tspNull) @@ -332,16 +360,14 @@ 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 +messageForTeamMate :: ObjId -> Team -> t -> [Command] -> [VisibleState] -> Maybe (ObjId, MessageBody) +messageForTeamMate me myTeam _ 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))) return (vsObjId bc, pm (PPTLoseMe, BSPPass 1 kickType (Just me))) +getKickType :: [Command] -> Maybe ReleaseType getKickType mc = if cmdFlipMeLow mc then Just RTLow else if cmdFlipMeHigh mc then Just RTHigh @@ -349,8 +375,8 @@ 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 +player param me t0 p0 v0 angle0 sel des ti pI pbsInit _ initState = + proc (ObjInput {oiGameInput = gi@(_,(t1,_)), oiGameState = vss, oiMessages = (mi, colls)}) -> do -- desired position is current mouse position (pd, commands) <- playerInput param -< gi @@ -361,9 +387,9 @@ let tms = #if DEBUG_MODE - trace ("Tactical " ++ show me ++ ": " ++ show (convertTms mi)) + trace ("__StMsg__AI " ++ show me ++ "__Msg__" ++ show (convertTms mi)) #endif - (convertTms mi) + convertTms mi let comMsgs = concatMap comToMsg commands @@ -375,8 +401,15 @@ 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) + ((st',stParam), _) <- tacticalNonAiSF initState -< ((t1, me, vss, commands), Event tms) + + let st = +#if DEBUG_MODE + trace ("__StMsg__AI " ++ show me ++ "__St__" ++ show (content st')) +#endif + st' + let running = content st /= TSNonAIKickingOff -- player commands will be ignored before kickoff @@ -388,12 +421,11 @@ 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 + oosBasicState = (oosBS, _)} + _ + _ msgs) - <- playerCore param me t0 p0 v0 sel des ti pi pbsInit + <- 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) = @@ -410,13 +442,13 @@ False False ti - pi + pI oosBS (oosOnFoot oop) (if content st == TSNonAIKickingOff then TSWaitingForKickOff else - if piPlayerRole pi == Goalie + if piPlayerRole pI == Goalie then TSTendingGoal else TSHoldingPosition)]) @@ -436,12 +468,13 @@ -- -- ************************************************************************* +bouncePower :: (VisibleState -> Velocity3) -> [VisibleState] -> [ObjId] -> Vector2 Velocity 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 = +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 @@ -468,26 +501,33 @@ 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 + 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) + 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 pms = map (\(PlayerMessage (PhysicalPlayerMessage pm')) -> pm') $ filter isPhysicalPlayerMessage mi let mcs = #if DEBUG_MODE - trace ("Player " ++ show me ++ ": " ++ show (pms ++ allCollisions)) + trace ("__StMsg__Tactical " ++ show me ++ "__Msg__ " ++ show (pms ++ allCollisions)) #endif (pms ++ allCollisions) - ((st,stParam), ems) <- basicPlayerSF pbsInit t0 -< ((t1, me, vss), (Event mcs)) + ((st',stParam), ems) <- basicPlayerSF pbsInit t0 -< ((t1, me, vss), (Event mcs)) + + let st = +#if DEBUG_MODE + trace ("__StMsg__Tactical " ++ show me ++ "__St__" ++ show (content st')) +#endif + st' + let ems' = #if DEBUG_MODE trace ("Messages Player " ++ show me ++ ": " ++ show ems) @@ -509,7 +549,7 @@ des 2 ti - pi + pI (fromMaybe dir ovrwtDir) ((content st), stParam) (TSNonAI, tspNull) @@ -519,23 +559,28 @@ ooMessages = ems' } +leftOrRightFoot :: Position2 -> Vector2 Double -> Position3 -> OnFoot leftOrRightFoot pPlayer dirPlayer pBall = if isLeftFrom dirPlayer (projectP pBall .-. pPlayer) then LeftFoot else RightFoot +myjoin :: Event OnFoot -> Event () -> Event (OnFoot, Bool) myjoin (Event NoFoot) _ = NoEvent myjoin (Event x) NoEvent = Event (x, False) myjoin NoEvent (Event ()) = Event (undefined, True) myjoin NoEvent NoEvent = NoEvent myjoin _ _ = NoEvent +switchFoot :: OnFoot -> OnFoot switchFoot NoFoot = NoFoot switchFoot RightFoot = LeftFoot switchFoot LeftFoot = RightFoot -switcher (oldF, _) (newF, False) = (newF, False) +switcher :: (OnFoot, t) -> (OnFoot, Bool) -> (OnFoot, Bool) +switcher (_, _) (newF, False) = (newF, False) switcher (oldF, _) (_, True) = (switchFoot oldF, False) -fetchBall ((VSBall oid _ _ _ _):xs) = oid +fetchBall :: [VisibleState] -> ObjId +fetchBall ((VSBall oid _ _ _ _):_) = oid fetchBall (_:xs) = fetchBall xs @@ -545,44 +590,51 @@ -- -- ************************************************************************* ---runRulesOnEvent :: Facts -> [VisibleState] -> RuleBase -> RuleBase -> TimerEvent -> [(ObjId, MessageBody)] +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 = +game param _ 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)) + trace ("__StMsg__Game__Msg__" ++ 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)] + let comMsgs = if cmdQuit commands then [(GTQuit, GPTeamPosition freezeAttacker (-1) [] (Point2 0 0) t1 True InPlay)] + else if cmdFreeze commands then [(GTFreeze, GPTeamPosition freezeAttacker (-1) [] (Point2 0 0) t1 False InPlay)] 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! + -- hack!! should not be 100 but real init player + ((st', stParam@(GPTeamPosition attacker _ _ _ _ _ _)), msOut) <- gameSF param (GPTeamPosition initialAttacker 100 [] (Point2 0 0) t0 True OOPKickOff) -< (vss, Event (comMsgs ++ gms)) --- 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 st = +#if DEBUG_MODE + trace ("__StMsg__Game__St__" ++ show (content st')) +#endif + st' 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 + + let totalMsgOut = +#if DEBUG_MODE + trace ("Game messages: " ++ show (msOut ++ msg)) +#endif + msOut ++ msg + + returnA -< ObjOutput { ooObsObjState = OOSGame t1 -- time (scoreHome, scoreAway) -- score @@ -591,9 +643,10 @@ (Point3 0 0 0), ooKillReq = noEvent, ooSpawnReq = noEvent, - ooMessages = msOut ++ msg -- ++ (map (\x -> (me, GameMessage x)) later) + ooMessages = totalMsgOut } +safePartition :: [a] -> ([a], [a]) safePartition [] = ([], []) safePartition [a] = ([a], []) safePartition (a:as) = ([a], as) @@ -612,9 +665,9 @@ 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 []) +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 []) -- ************************************************************************* -- @@ -636,15 +689,15 @@ else acc ballCollisionSF :: Collisions -> SF Collisions ([BallMessage], Collisions) -ballCollisionSF init = proc c1 -> do - c2 <- iPre init -< c1 +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 +playerCollisionSF init' = proc c1 -> do + c2 <- iPre init' -< c1 let newColls = map (\c -> (PPTCollisionP, BSPWhoAndWhen c 0)) $ c1 \\ c2 returnA -< newColls diff --git a/ParseTeam.hs b/ParseTeam.hs --- a/ParseTeam.hs +++ b/ParseTeam.hs @@ -10,9 +10,8 @@ import Control.Monad import BasicTypes import Rules -import Data.List - +setupBasicFiles :: IO () setupBasicFiles = do dir <- getAppUserDataDirectory "Rasenschach" createDirectoryIfMissing False dir @@ -23,6 +22,7 @@ when (not awayExists) $ writeFile (dir "away.team") basicSetup +getTeam :: FilePath -> IO (Either (ParseErrorId, ParseErrorMsg) ([PlayerInfo], [Rule])) getTeam fn = do input <- readFile fn case parseFile (map removeComment $ lines input) 1 of @@ -33,7 +33,7 @@ removeComment :: String -> String removeComment [] = [] removeComment [x] = [x] -removeComment ('-':'-':xs) = [] +removeComment ('-':'-':_) = [] removeComment (x:xs) = x:(removeComment xs) parseFile :: [String] -> Int -> Either (ParseErrorId, ParseErrorMsg) @@ -42,9 +42,9 @@ parseFile ls counter = if null tokens then parseFile (tail ls) counter else if head tokens == "player" then do - pi <- parsePlayer (head ls) + pi' <- parsePlayer (head ls) (pis, rs) <- parseFile (tail ls) counter - return (pi:pis, rs) + return (pi':pis, rs) else if head tokens == "rule" then do (ruleLines, rest) <- grabRule ls [] (name, prio, clauses, msg) <- parseRule ruleLines @@ -82,6 +82,7 @@ cover <- parseDouble (tokens !! 14) return $ PlayerInfo numberOnJersey role (Point2 defX defY) (Point2 offX offY) speed acc cover +checkPlayerStructure :: Num t => [String] -> Either (t, String) () checkPlayerStructure tokens = if length tokens /= 15 || tokens !! 0 /= "player" || @@ -94,6 +95,7 @@ concat (zipWith (++) tokens (repeat " "))) else Right () +checkRole :: Num t => String -> Either (t, String) PlayerRole checkRole pos | pos == "goalie" = Right Goalie | pos == "defender" = Right Defender @@ -107,6 +109,7 @@ y' <- parseDouble y return (x',y') +checkDefense :: String -> String -> Either (ParseErrorId, ParseErrorMsg) (Double, Double) checkDefense = checkOffense parseDouble :: String -> Either (ParseErrorId, ParseErrorMsg) Double @@ -131,18 +134,22 @@ -- send ... -- -- +t1 :: IO String t1 = readFile "team.txt" +p' :: IO () p' = do ps <- t1 print $ grabRule (lines ps) [] +p :: Int -> IO () p x = do ps <- t1 print $ parseFile (lines ps) x +basicSetup :: String basicSetup = "player 10 forward defense 42 55 offense 60 15 speed 10.0 acc 15.0 cover 0.1\n \ player 11 forward defense 20 70 offense 30 15 speed 10.0 acc 15.0 cover 0.1\n \ player 9 forward defense 30 60 offense 35 50 speed 10.0 acc 15.0 cover 0.1\n \ diff --git a/Parser.hs b/Parser.hs --- a/Parser.hs +++ b/Parser.hs @@ -3,26 +3,20 @@ module Parser (playerInput, shouldContinue, gameKeysSF, GameInput, Input, TimerEvent (..), waitForSpaceKey) where - -import Debug.Trace - + import qualified Graphics.UI.SDL as SDL -import Data.List -import Data.Monoid +import Graphics.UI.SDL.Keysym import Data.Maybe import Control.Monad (when) import Control.Monad.Loops (unfoldWhileM) - import FRP.Yampa -import FRP.Yampa.Utilities import FRP.Yampa.Geometry import RenderUtil import Physics import Command import Data.FSM -import AL import Global import BasicTypes @@ -90,8 +84,8 @@ -- ************************************************************************* singleKeyCommand :: KeyFSM -> KeyState -> SF (CurrentTime, Event ([(KeyAction, SDL.SDLKey, Shifted)], StateTime)) [Command] -singleKeyCommand fsm initState = proc event -> do - ((_,_),command) <- reactMachineHist fsm initState 0 -< event +singleKeyCommand fsm initState = proc event' -> do + ((_,_),command) <- reactMachineHist fsm initState 0 -< event' returnA -< command @@ -101,8 +95,8 @@ newKeyOnUpFSM :: SDL.SDLKey -> Command -> Command -> (KeyFSM, KeyState) newKeyOnUpFSM key commandShifted commandUnshifted = let - onEnterSmA (s, (p, sOld)) = [commandShifted {dt = p-sOld}] - onEnterGrA (s, (p, sOld)) = [commandUnshifted {dt = p-sOld}] + onEnterSmA (_, (p, sOld)) = [commandShifted {dt = p-sOld}] + onEnterGrA (_, (p, sOld)) = [commandUnshifted {dt = p-sOld}] s0 = addTransition (Down, key, Unshifted) 1 $ addTransition (Down, key, Shifted) 1 $ @@ -127,8 +121,8 @@ newKeyOnDownFSM :: SDL.SDLKey -> Command -> Command -> (KeyFSM, KeyState) newKeyOnDownFSM key commandShifted commandUnshifted = let - onEnterSmA (s, (p, sOld)) = [commandShifted] - onEnterGrA (s, (p, sOld)) = [commandUnshifted] + onEnterSmA _ = [commandShifted] + onEnterGrA _ = [commandUnshifted] s0 = addTransition (Down, key, Unshifted) 1 $ addTransition (Down, key, Shifted) 2 $ @@ -147,6 +141,7 @@ in (fsm, s0) +keySF :: (t -> t1 -> a -> (KeyFSM, KeyState)) -> t -> t1 -> a -> SF (CurrentTime, Event ([(KeyAction, SDLKey, Shifted)], StateTime)) [Command] keySF newKeyFSM key commandShifted = uncurry singleKeyCommand . newKeyFSM key commandShifted @@ -156,6 +151,7 @@ mapKeyEvent keys (SDL.KeyDown (SDL.Keysym key mods _)) = if elem key keys then Just (Down, key, checkModifiers mods) else Nothing mapKeyEvent _ _ = Nothing +checkModifiers :: [Modifier] -> Shifted checkModifiers mods = if elem SDL.KeyModLeftShift mods || elem SDL.KeyModRightShift mods || elem SDL.KeyModShift mods then Shifted else Unshifted @@ -195,6 +191,7 @@ -- ************************************************************************* -- Caution: When adding more commands, remember to put the additional key in keyCommandSF!! +playerKeysSF :: SF Input [Command] playerKeysSF = keyCommandSF [(SDL.SDLK_a, OnUp, (CmdPassLow 0, CmdPassHigh 0)), (SDL.SDLK_d, OnDown, (CmdFlipLow, CmdFlipHigh)), (SDL.SDLK_e, OnDown, (CmdMoveForward, CmdMoveBackward)), @@ -211,13 +208,14 @@ -- ************************************************************************* -- Caution: When adding more commands, remember to put the additional key in keyCommandSF!! +gameKeysSF :: SF Input [Command] gameKeysSF = keyCommandSF [(SDL.SDLK_ESCAPE, OnDown, (CmdQuit, CmdQuit)), (SDL.SDLK_f, OnDown, (CmdFreeze, CmdFreeze))] playerInput :: Param -> SF Input (Position2, [Command]) -playerInput param = proc gi@(_,(t1,incoming)) -> do +playerInput param = proc gi@(_,(_,incoming)) -> do pd <- mousePos param (Point2 0 0) -< gi commands <- playerKeysSF -< gi @@ -231,11 +229,13 @@ -- -- ************************************************************************* +waitForSpaceKey :: IO () waitForSpaceKey = do events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent let keys = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [SDL.SDLK_SPACE]) events when (null keys) waitForSpaceKey +shouldContinue :: IO Bool shouldContinue = do events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent let yess = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [SDL.SDLK_y]) events diff --git a/PlayerFSM.hs b/PlayerFSM.hs --- a/PlayerFSM.hs +++ b/PlayerFSM.hs @@ -29,6 +29,9 @@ --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 $ @@ -63,58 +66,75 @@ takePossessionOOP ((BSPWhoAndWhen ball t), (_, me, _)) = [(ball, (BallMessage (BTGainedOOP, BPWho me t)))] +_howfast :: Position _howfast = 10 loseBall :: (BasicStateParam, BasicPerception) -> [Message] -loseBall ((BSPRelease dt kickType), (_, me, vss)) = +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 + 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] + in [(ball, (BallMessage (BTLost, BPInit v me))) | kickType /= RTNothing] ++ + checkForOffsite me vss v t1 -loseBall ((BSPPass dt kickType Nothing), (_, me, vss)) = +loseBall ((BSPPass dt' kickType Nothing), (t1, me, vss)) = let designated = fromJust $ find vsDesignated $ teamMates me vss - in passTo dt kickType me designated vss + in passTo dt' kickType me designated vss t1 -loseBall ((BSPPass dt kickType (Just receiverId)), (_, me, vss)) = +loseBall ((BSPPass dt' kickType (Just receiverId)), (t1, me, vss)) = let receiverVs = fetchVS vss receiverId - in passTo dt kickType me receiverVs vss + in passTo dt' kickType me receiverVs vss t1 -loseBall ((BSPShoot vel), (_, me, vss)) = - [((vsObjId . fetchBallVS) vss, (BallMessage (BTLost, BPInit vel me)))] +loseBall ((BSPShoot vel), (t1, me, vss)) = + [((vsObjId . fetchBallVS) vss, (BallMessage (BTLost, BPInit vel me)))] ++ + checkForOffsite me vss vel t1 -passTo dt kickType passerId receiverVs vss = +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 + 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 + vb = (1+dt')*_howfast -- (t, b) = fromMaybe (0, 0) $ findBestTime (xd, yd, a, norm vd) (xb, yb, vb) - (t, b) = + (_, 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)) + (if kickType == RTHigh then (1+dt')*5 else 0)) - in [(ballId, (BallMessage (BTLost, BPInit v passerId))) | kickType /= RTNothing] + 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 d@(xd, yd, a, vd) b@(xb, yb, vb) = +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)) + else Just . fst $ localMinimumBy (\a b' -> compare (snd a) (snd b')) (head fits) fits @@ -128,6 +148,7 @@ 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) @@ -156,11 +177,13 @@ 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 @@ -171,7 +194,7 @@ basicPlayerSF :: BasicState -> Time -> SF (BasicPerception, Event [(PhysicalPlayerTransition, BasicStateParam)]) ((State BasicState PhysicalPlayerTransition (BasicStateParam, BasicPerception) [Message], BasicStateParam), [Message]) -basicPlayerSF init _= uncurry reactMachineMult (basicFSM init) BSPNothing +basicPlayerSF init' _= uncurry reactMachineMult (basicFSM init') BSPNothing --reactMachineMult fsm (if hasBall then s2 else s1) BSPNothing @@ -252,13 +275,13 @@ 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 - (bs, bsp) = vsBallState ball diff = posBall .-. posPlayer dir = if hasBall myself then -- look straight ahead if team == Away then pi / 2 else pi + pi / 2 @@ -267,6 +290,7 @@ 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) @@ -282,35 +306,28 @@ in Point2 (pPitchWidth param - xgMirror) (pPitchLength param - ygMirror) -turnTowards ((TacticalStateParam _ mvd@(Just vd) _ rec _ kt _), (_, me, vss, _)) = +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@(Just rec) _ kt _), (_, me, vss, _)) = - let recPos = vsPos $ fetchVS vss rec - myPos = vsPos $ fetchVS vss me - vd = myPos .-. recPos - dir = atan2 (vector3Y vd) (vector3X vd) - in [(me, tm (TPTWait, - TacticalStateParam Nothing Nothing False mr Nothing kt Nothing))] +turnTowards ((TacticalStateParam _ _ _ mr _ kt _), (_, me, _, _)) = + [(me, tm (TPTWait, + TacticalStateParam Nothing Nothing False mr Nothing kt Nothing))] -kickTowards ((TacticalStateParam _ mvd@(Just vd) _ Nothing _ _ _), (_, me, vss, _)) = +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, vss, _)) = +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 --- dist = distance posBall (projectP $ vsPos $ fetchVS vss me) --- adjust = if dist > 5 then velBall else (vector2 0 0) --- (bs, bsp) = vsBallState ball let ball = fetchBallVS vss posBall = projectP . vsPos $ ball velBall = project . vsVel $ ball - (bs, bsp) = vsBallState ball + (bs, _) = vsBallState ball myPos = (projectP . vsPos . fetchVS vss) me adjust = if abs (getAngle velBall - (getAngle (myPos .-. posBall))) > 0.2 then velBall @@ -322,18 +339,20 @@ (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 team = vsTeam $ fetchVS vss me - interceptors = map vsObjId $ filter ((TSInterceptBall ==) . fst . vsPTState) (teamMates 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 @@ -349,17 +368,19 @@ (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 + 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, bsp) = vsBallState ball + b'@(bs, _) = vsBallState ball diff = posBall .-. posPlayer dir = atan2 (vector2Y diff) (vector2X diff) iHaveTheBall = bs `elem` [BSControlled, BSControlledGoalie, BSControlledOOP] @@ -368,6 +389,7 @@ 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 @@ -380,8 +402,8 @@ 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) +tacticalPlayerSF param init' angle0 = + uncurry reactMachineMult (tacticalFSM param init') (TacticalStateParam Nothing Nothing False Nothing (Just angle0) Nothing Nothing) diff --git a/Rasenschach.cabal b/Rasenschach.cabal --- a/Rasenschach.cabal +++ b/Rasenschach.cabal @@ -1,17 +1,17 @@ name: Rasenschach -version: 0.1.1 +version: 0.1.2 cabal-version: >=1.2 build-type: Simple license: BSD3 license-file: LICENSE maintainer: mwoehrle@arcor.de -homepage: http://patch-tag.com/r/martingw/Rasenschach/wiki/ +homepage: http://hub.darcs.net/martingw/Rasenschach synopsis: Soccer simulation description: Soccer simulation with simple graphics and highly configurable AI category: Game author: Martin Wöhrle -data-files: 13ball.png 15ball.png 17ball.png 20THCENT.TTF - 20ball.png 25ball.png 30ball.png SqueakyChalkSound.ttf ballM.wav +data-files: 20redball.png 23redball.png 26redball.png 20THCENT.TTF + 30redball.png 35redball.png 40redball.png SqueakyChalkSound.ttf ballM.wav chalkboard.png tockH.wav whistle.wav data-dir: "" extra-source-files: AI.hs AL.hs Animate.hs BallFSM.hs BasicTypes.hs @@ -32,9 +32,11 @@ cpp-options: -D NO_DEBUG_MODE extensions: CPP hs-source-dirs: . - other-modules: Helper Message RenderBall Grid RenderUtil BallFSM - PlayerFSM ObjectBehaviour BasicTypes Lineup Global RenderPlayer - Rules ParseTeam Main RenderGame Render States GameLoop Physics - GameFSM Command AI Main Parser Object Animate AL Data.FSM - ghc-options: -O2 - + other-modules: GameLoop Physics ParseTeam PlayerFSM Render Main AL + ObjectBehaviour GameFSM Message Rules Object BasicTypes Animate + Helper RenderGame Global Command RenderUtil BallFSM RenderPlayer + Main States AI Grid RenderBall Parser Lineup Main Data.FSM + ghc-prof-options: --enable-executable-profiling +-- ghc-options: -O2 -prof -Wall + ghc-options: -O2 -Wall + diff --git a/Render.hs b/Render.hs --- a/Render.hs +++ b/Render.hs @@ -1,12 +1,10 @@ module Render where import Control.Monad (forM_) -import Data.List -import Data.Array ((!)) +import Data.Array as A (Array, Ix,(!)) import GHC.Exts import Graphics.UI.SDL as SDL -import Graphics.UI.SDL.Image as SDLi import Graphics.UI.SDL.TTF as TTF import Graphics.UI.SDL.Mixer as Mix import FRP.Yampa.Geometry @@ -19,7 +17,9 @@ import Object import States import BasicTypes +import Global +init :: IO (Surface, Surface, A.Array Integer Font, Array Int (Surface, Int), Chunk, Chunk, Chunk) init = do SDL.init [SDL.InitVideo] TTF.init @@ -33,57 +33,67 @@ return (screen, pitch, fonts, balls, tockWav, kickWav, whistleWav) +exit :: IO () exit = do closeAudio TTF.quit SDL.quit -renderObjects param oos (screen, pitch, fonts, balls, tockWav, kickWav, whistleWav) = do +renderObjects :: (Num i, A.Ix i) => Param -> [ObsObjState] + -> (Surface, t, A.Array i Font, A.Array Int (Surface, Int), Chunk, Chunk, Chunk) + -> IO () +renderObjects param oos (screen, _, fonts, balls, tockWav, kickWav, whistleWav) = do cf <- chalkFontsRessources cfb <- bigChalkFonts forM_ sorted $ \os -> case os of - OOSBall oosPos - oosVelocity - oosBounced + OOSBall oosPos' + _ + oosBounced' oosPState - -> do renderBall param screen balls tockWav oosPos oosBounced - renderBallDebug screen oosPState cf (point3Z oosPos) - OOSPlayer oosPos - oosVel - oosAcc - oosKicked - oosSelected - oosDesignated - oosRadius + -> do renderBall param screen balls tockWav oosPos' oosBounced' + renderBallDebug screen oosPState cf (point3Z oosPos') + OOSPlayer oosPos' + _ + _ + oosKicked' + oosSelected' + oosDesignated' + _ (oosTeam, oosBorder, oosBody) (PlayerInfo oosNumber _ bpOff bpDef _ _ _) - oosDir - (bs, bsp) - (ts, tsp) - oosOnFoot - -> do renderPlayer param screen oosPos oosDir oosSelected oosNumber - oosBody oosBorder oosBorder oosKicked - (ts==TSNonAI) oosDesignated fonts kickWav - renderPlayerDebug screen oosSelected oosNumber bs ts oosBody + oosDir' + (bs, _) + (ts, _) + _ + -> do renderPlayer param screen oosPos' oosDir' oosSelected' oosNumber + oosBody oosBorder oosBorder oosKicked' + (ts==TSNonAI) oosDesignated' fonts kickWav + renderPlayerDebug screen oosSelected' oosNumber bs ts oosBody cf bpDef bpOff oosTeam - OOSGame oosGameTime - oosGameScore - oosGameState - oosAttacker + OOSGame oosGameTime' + oosGameScore' + oosGameState' + oosAttacker' _ - -> renderGame param screen oosGameTime oosGameScore oosGameState - oosAttacker cfb (fonts ! 4) whistleWav + -> do renderGame param screen oosGameTime' oosGameScore' oosGameState' + oosAttacker' cfb (fonts ! 4) whistleWav + renderGameDebug screen oosGameState' cf where sorted = sortWith (point3Z . oosPos) oos +render :: (Num i, Ix i) => + Param -> [ObsObjState] + -> (Surface, Surface, Array i Font, Array Int (Surface, Int), Chunk, Chunk, Chunk) + -> IO () render param oos (screen, pitch, fonts, balls, tockWav, kickWav, whistleWav) = do --- putStrLn $ "Anzahl: " ++ show (length oos) SDL.blitSurface pitch Nothing screen Nothing renderObjects param oos (screen, pitch, fonts, balls, tockWav, kickWav, whistleWav) SDL.flip screen +renderStartMsg :: (Num i, Ix i) => + (Surface, t, Array i Font, t1, t2, t3, t4) -> IO () renderStartMsg (screen,_, fonts,_,_,_,_) = do let font = fonts ! 4 @@ -94,6 +104,7 @@ SDL.blitSurface fontSurface Nothing screen (Just $ Rect 250 400 100 100) SDL.flip screen +renderEndMsg :: (Num i, Ix i) => (Surface, t, Array i Font, t1, t2, t3, Chunk) -> IO () renderEndMsg (screen,_, fonts,_,_,_,whistle) = do let font = fonts ! 4 diff --git a/RenderBall.hs b/RenderBall.hs --- a/RenderBall.hs +++ b/RenderBall.hs @@ -5,7 +5,6 @@ import Data.Array import Control.Monad import Data.Bits -import Data.Int import FRP.Yampa.Geometry @@ -14,6 +13,7 @@ import Graphics.UI.SDL.Mixer as Mix import RenderUtil +import Global sizedBall :: Double -> Array Int (Surface, Int) -> (Surface, Int) sizedBall z balls = @@ -24,6 +24,7 @@ else if z < 3.0 then balls!4 else balls!5 +renderBall :: Param -> Surface -> Array Int (Surface, Int) -> Chunk -> Point3 Double -> Bool -> IO Bool renderBall param surface balls tock p bounced = do when bounced $ playChannel (-1) tock 0 >> return () let Point3 px py pz = p @@ -33,7 +34,8 @@ let adjust = fromIntegral $ points `shiftR` 2 SDL.blitSurface ball Nothing surface (Just $ Rect (x'-adjust) (y'-adjust) (x'+adjust) (y'+adjust)) -renderBallDebug surface state font z = +renderBallDebug :: Show a => Surface -> a -> Font -> t -> IO Bool +renderBallDebug surface state font _ = do let color = colorFromPixel $ rgbColor 255 255 1 fontSurface <- SDLt.renderTextSolid font ("Ball: " ++ show state) color diff --git a/RenderGame.hs b/RenderGame.hs --- a/RenderGame.hs +++ b/RenderGame.hs @@ -2,13 +2,8 @@ where -import Data.Array import Control.Monad -import Data.Bits -import Data.Int -import FRP.Yampa.Geometry - import Graphics.UI.SDL as SDL import Graphics.UI.SDL.TTF as SDLt import Graphics.UI.SDL.Mixer as Mix @@ -16,26 +11,57 @@ import RenderUtil import States import Message +import BasicTypes -renderGame param surface t (scoreHome, scoreAway) (gState, gStateParam) - attacker font bigfont whistle = +renderGame :: (Num a1, Ord a1, RealFrac a, Show a1) => + t -> Surface -> a -> (a1, a1) -> + (GameState, GameMsgParam) -> t1 -> Font -> Font -> Chunk -> + IO Bool +renderGame _ surface t (scoreHome, scoreAway) (gState, gStateParam) + _ font bigfont whistle = do let color = colorFromPixel $ rgbColor 255 255 1 let tt = truncate t - let (min, sec) = (tt `div` 60, tt `mod` 60) :: (Int, Int) - fontSurface <- SDLt.renderTextSolid font ("Score " ++ show scoreHome ++ "-" ++ show scoreAway ++ - " " ++ show min ++ "min " ++ show sec ++ "sec") - color + let (min', sec) = (tt `div` 60, tt `mod` 60) :: (Int, Int) + fontSurface <- SDLt.renderTextSolid font ("Score " ++ show scoreHome ++ "-" ++ show scoreAway) color + timeSurface <- SDLt.renderTextSolid font ("Time" ++ show min' ++ "min " ++ show sec ++ "sec") color when (gState == GSKickOff && shouldWhistle gStateParam) $ do +-- when (shouldWhistle gStateParam) $ do playChannel (1) whistle 0 >> return () - SDL.blitSurface fontSurface Nothing surface (Just $ Rect 850 60 950 60) - + SDL.blitSurface fontSurface Nothing surface (Just $ Rect 850 50 950 50) + SDL.blitSurface timeSurface Nothing surface (Just $ Rect 850 80 950 80) + when (gState == GSKickOff && scoreHome + scoreAway > 0) $ do goalSurface <- SDLt.renderTextSolid bigfont ("GOAL!!") color SDL.blitSurface goalSurface Nothing surface (Just $ Rect 380 400 100 100) return () + let (GPTeamPosition _ _ _ _ _ _ oop) = gStateParam + + when (oop == OOPSideOut) $ do + goalSurface <- SDLt.renderTextSolid bigfont ("Throw in") color + SDL.blitSurface goalSurface Nothing surface (Just $ Rect 380 300 100 100) + return () + + when (oop == OOPOffsite) $ do + goalSurface <- SDLt.renderTextSolid bigfont ("Offsite") color + SDL.blitSurface goalSurface Nothing surface (Just $ Rect 380 300 100 100) + return () + + when (oop == OOPBaseOut) $ do + goalSurface <- SDLt.renderTextSolid bigfont ("Corner") color + SDL.blitSurface goalSurface Nothing surface (Just $ Rect 380 300 100 100) + return () + return True -shouldWhistle (GPTeamPosition _ _ _ w) = w +shouldWhistle :: GameMsgParam -> Bool +shouldWhistle (GPTeamPosition _ _ _ _ _ w _) = w + +renderGameDebug :: Show a => Surface -> a -> Font -> IO Bool +renderGameDebug surface state font = + do + let color = colorFromPixel $ rgbColor 255 255 1 + fontSurface <- SDLt.renderTextSolid font ("Game: " ++ show state) color + SDL.blitSurface fontSurface Nothing surface (Just $ Rect 850 120 1000 140) diff --git a/RenderPlayer.hs b/RenderPlayer.hs --- a/RenderPlayer.hs +++ b/RenderPlayer.hs @@ -1,14 +1,12 @@ module RenderPlayer (renderPlayer, renderPlayerDebug) - + where import Data.Bits import GHC.Int import Data.Array import Control.Monad -import Physics import Data.Time.Clock -import Data.Convertible import FRP.Yampa.Geometry @@ -21,32 +19,44 @@ import RenderUtil import Global +orange :: Pixel orange = rgbColor 0xE7 0x5B 0x12 -- Alles rund um den Fußballer... +r1 :: Fractional a => a -> a r1 z = 3.0 + z -- Punkte zwischen Kreisrand und äußerem Ring +r2 :: Fractional a => a -> a r2 z = 6.0 + z -- Punkte zwischen Kreisrand innerem Ring +angle :: Double angle = 0.45 -- Winkel des Zeiger-Dreiecks +pr1 :: (Integral b, RealFrac a) => a -> b pr1 z = truncate $ r1 z -triangle x y height radD alpha r1 r2 angle = - let l1 = radD - (r1 height) - l2 = radD - (r2 height) +triangle :: (Floating a, Integral t2, Integral t1, RealFrac a) => + t1 -> t2 -> t -> a -> a -> (t -> a) -> (t -> a) -> a + -> ((t1, t2), (t1, t2), (t1, t2)) +triangle x y height radD alpha r1' r2' angle' = + let l1 = radD - (r1' height) + l2 = radD - (r2' height) a = (x + truncate (l1 * cos alpha), y + truncate (l1 * sin alpha)) - b = (x + truncate (l2 * cos (alpha-angle)), y + truncate (l2 * sin (alpha-angle))) - c = (x + truncate (l2 * cos (alpha+angle)), y + truncate (l2 * sin (alpha+angle))) + b = (x + truncate (l2 * cos (alpha-angle')), y + truncate (l2 * sin (alpha-angle'))) + c = (x + truncate (l2 * cos (alpha+angle')), y + truncate (l2 * sin (alpha+angle'))) in (a,b,c) +playersizeMin :: Int16 playersizeMin = 25 :: Int16 -- in Pixeln +playersizeMax :: Int16 playersizeMax = 50 +maxJump :: Double maxJump = 3.0 -- in Meter +blinker :: IO Bool blinker = do - t <- fmap ((100 *) . convert) getCurrentTime :: IO Double - let t' = truncate t `mod` 100 - return $ t' < 50 + t <- fmap utctDayTime getCurrentTime + let tFrac = t - fromIntegral (truncate t) + return $ tFrac < 0.5 playerSize :: Param -> Double -> Int16 playerSize param z = -- zwischen 0 und 2 Meter Höhe, dann wechselt der Spieler zwischen 30 und 50 Dicke... @@ -54,7 +64,11 @@ else if z < pGround param then playersizeMin else truncate $ fromIntegral playersizeMin + z * (fromIntegral playersizeMax - fromIntegral playersizeMin) / 10.0 -renderPlayer param surface p alpha sel number cCircle cTriangle cBorder kicked nonai designated fonts wav = +renderPlayer :: (Num i, Num a, Ord a, Show a, Ix i) => + Param -> Surface -> Point3 Double -> Double -> t -> a -> + Pixel -> Pixel -> Pixel -> Bool -> Bool -> Bool -> Array i Font -> Chunk -> + IO Bool +renderPlayer param surface p alpha _ number cCircle cTriangle cBorder kicked nonai designated fonts wav = do when kicked $ playChannel (-1) wav 0 >> return () @@ -63,12 +77,12 @@ let radius' = (radius `shiftR` 1)-4 -- hacky: try to align exactly with ball... let (x', y') = pitchToPoint param (px, py) let (x, y) = (x'+radius', y'+radius') - let xAdjust = truncate (-0.4*pz) + if number > 9 then 3 else 1 :: Int16 -- Zentrieren der Rückennummer - let yAdjust = if pz < 1 then 4 else if pz < 2 then 5 else 5 :: Int16 -- Zentrieren der Rückennummer + let xAdjust = truncate (-0.4*pz) + if number > 9 then 5 else 2 :: Int16 -- Zentrieren der Rückennummer + let yAdjust = if pz < 1 then 6 else if pz < 2 then 4 else 4 :: Int16 -- Zentrieren der Rückennummer let radD = fromIntegral radius let ((ax, ay), (bx, by), - (cx, cy)) = triangle x y pz radD alpha r1 r2 angle + (cx, cy)) = triangle x y pz (2*radD) alpha r1 r2 angle let font = if pz < 1 then fonts ! 1 else if pz < 2 then fonts ! 2 else fonts ! 3 @@ -105,7 +119,10 @@ (fromIntegral (y-yAdjust+10))) -renderPlayerDebug surface sel number bState tState color font baseDef baseOff oosTeam = +renderPlayerDebug :: (Show a1, Show a) => + Surface -> t -> Int -> a1 -> a -> Pixel -> Font -> t1 -> t2 -> Team -> + IO Bool +renderPlayerDebug surface _ number bState tState color font _ _ oosTeam = do fontSurface <- SDLt.renderTextSolid font (show number ++ ": " ++ show tState ++ ", " ++ diff --git a/RenderUtil.hs b/RenderUtil.hs --- a/RenderUtil.hs +++ b/RenderUtil.hs @@ -1,36 +1,38 @@ module RenderUtil where -import FRP.Yampa.Geometry - import Graphics.UI.SDL as SDL import Graphics.UI.SDL.Image as SDLi import Graphics.UI.SDL.Types as SDLt import Graphics.UI.SDL.TTF as TTF import Graphics.UI.SDL.Mixer as Mix - + import GHC.Int import GHC.Word import Data.Bits import Data.Array -import Physics import Global import Paths_Rasenschach -fi a = fromIntegral a +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral rgbColor :: Word8 -> Word8 -> Word8 -> Pixel -rgbColor r g b = Pixel (shiftL (fi r) 24 .|. shiftL (fi g) 16 .|. shiftL (fi b) 8 .|. fi 255) +rgbColor r g b = Pixel (shiftL (fi r) (24::Int) .|. shiftL (fi g) (16::Int) .|. shiftL (fi b) (8::Int) .|. fi (255::Int)) +colorFromPixel :: Pixel -> Color colorFromPixel (Pixel p) = Color (fi $ shiftR p 24) (fi $ shiftR p 16) (fi $ shiftR p 8) -- Geometrie - + +winHeight :: Double winHeight = 1050 :: Double -winWidth = 1195 :: Double +winWidth :: Double +winWidth = 1096 :: Double -ratio param = 8.625 -- winHeight / (pPitchLength param + pUpperBorderY param + pLowerBorderY param) +ratio :: Fractional a => t -> a +ratio _ = 8.625 -- winHeight / (pPitchLength param + pUpperBorderY param + pLowerBorderY param) pixelToMeter :: Param -> Int16 -> Double pixelToMeter param p = fromIntegral p / ratio param @@ -38,9 +40,11 @@ meterToPixel :: Param -> Double -> Int16 meterToPixel param = truncate . (* ratio param) +pitchToPoint :: Param -> (Double, Double) -> (Int16, Int16) pitchToPoint param (x,y) = (meterToPixel param $ (pLeftBorderX param) + x, meterToPixel param $ (pUpperBorderY param) + y) +pointToPitch :: Param -> (Int16, Int16) -> (Double, Double) pointToPitch param (x,y) = (pixelToMeter param x - pLeftBorderX param, pixelToMeter param y - pUpperBorderY param) ballRessources :: Surface -> IO (Array Int (Surface, Int)) @@ -48,69 +52,74 @@ t <- mapRGB (surfaceGetPixelFormat screen) 0 255 0 - fn13 <- getDataFileName "13ball.png" - png13 <- SDLi.load fn13 - b13 <- convertSurface png13 (surfaceGetPixelFormat screen) [] - setColorKey b13 [SrcColorKey, RLEAccel] t - - fn15 <- getDataFileName "15ball.png" - png15 <- SDLi.load fn15 - b15 <- convertSurface png15 (surfaceGetPixelFormat screen) [] - setColorKey b15 [SrcColorKey, RLEAccel] t - - fn17 <- getDataFileName "17ball.png" - png17 <- SDLi.load fn17 - b17 <- convertSurface png17 (surfaceGetPixelFormat screen) [] - setColorKey b17 [SrcColorKey, RLEAccel] t - - fn20 <- getDataFileName "20ball.png" + fn20 <- getDataFileName "20redball.png" png20 <- SDLi.load fn20 b20 <- convertSurface png20 (surfaceGetPixelFormat screen) [] setColorKey b20 [SrcColorKey, RLEAccel] t - fn25 <- getDataFileName "25ball.png" - png25 <- SDLi.load fn25 - b25 <- convertSurface png25 (surfaceGetPixelFormat screen) [] - setColorKey b25 [SrcColorKey, RLEAccel] t + fn23 <- getDataFileName "23redball.png" + png23 <- SDLi.load fn23 + b23 <- convertSurface png23 (surfaceGetPixelFormat screen) [] + setColorKey b23 [SrcColorKey, RLEAccel] t - fn30 <- getDataFileName "30ball.png" + fn26 <- getDataFileName "26redball.png" + png26 <- SDLi.load fn26 + b26 <- convertSurface png26 (surfaceGetPixelFormat screen) [] + setColorKey b26 [SrcColorKey, RLEAccel] t + + fn30 <- getDataFileName "30redball.png" png30 <- SDLi.load fn30 b30 <- convertSurface png30 (surfaceGetPixelFormat screen) [] setColorKey b30 [SrcColorKey, RLEAccel] t - return $ array (0,5) [(0,(b13, SDLt.surfaceGetWidth b13)), - (1,(b15, SDLt.surfaceGetWidth b15)), - (2,(b17, SDLt.surfaceGetWidth b17)), - (3,(b20, SDLt.surfaceGetWidth b20)), - (4,(b25, SDLt.surfaceGetWidth b25)), - (5,(b30, SDLt.surfaceGetWidth b30))] + fn35 <- getDataFileName "35redball.png" + png35 <- SDLi.load fn35 + b35 <- convertSurface png35 (surfaceGetPixelFormat screen) [] + setColorKey b35 [SrcColorKey, RLEAccel] t + fn40 <- getDataFileName "40redball.png" + png40 <- SDLi.load fn40 + b40 <- convertSurface png40 (surfaceGetPixelFormat screen) [] + setColorKey b40 [SrcColorKey, RLEAccel] t + + return $ array (0,5) [(0,(b20, SDLt.surfaceGetWidth b20)), + (1,(b23, SDLt.surfaceGetWidth b23)), + (2,(b26, SDLt.surfaceGetWidth b26)), + (3,(b30, SDLt.surfaceGetWidth b30)), + (4,(b35, SDLt.surfaceGetWidth b35)), + (5,(b40, SDLt.surfaceGetWidth b40))] + +fontsRessources :: IO (Array Integer Font) fontsRessources = do -- fn <- getDataFileName "C64_User_Mono_v1.0-STYLE.ttf" fn <- getDataFileName "20THCENT.TTF" - f1 <- TTF.openFont fn 8 - f2 <- TTF.openFont fn 9 - f3 <- TTF.openFont fn 10 + f1 <- TTF.openFont fn 14 --8 + f2 <- TTF.openFont fn 16 -- 9 + f3 <- TTF.openFont fn 18 --10 f4 <- TTF.openFont fn 30 -- for messages f5 <- TTF.openFont fn 20 -- for marking designated player return $ array (1,5) [(1,f1),(2,f2),(3,f3),(4,f4),(5,f5)] +chalkFontsRessources :: IO Font chalkFontsRessources = do fn <- getDataFileName "SqueakyChalkSound.ttf" TTF.openFont fn 14 -- setFontStyle f [StyleBold] +bigChalkFonts :: IO Font bigChalkFonts = do fn <- getDataFileName "SqueakyChalkSound.ttf" TTF.openFont fn 20 +pitchRessources :: Surface -> IO Surface pitchRessources screen = do fn <- getDataFileName "chalkboard.png" pitch <- SDLi.load fn convertSurface pitch (surfaceGetPixelFormat screen) [] +soundRessources :: IO (Chunk, Chunk, Chunk) soundRessources = do fnt <- getDataFileName "tockH.wav" t <- loadWAV fnt diff --git a/Rules.hs b/Rules.hs --- a/Rules.hs +++ b/Rules.hs @@ -14,19 +14,14 @@ import FRP.Yampa.Geometry -import qualified Data.Map as M import Data.List import Data.Function (on) -import Data.Ord import Data.Maybe -import Control.Monad import Debug.Trace - -import Physics + import Object import BasicTypes import Message -import AI import AL import Helper @@ -37,6 +32,7 @@ -- ************************************************************************ +concatMaybe :: Maybe [a] -> [a] concatMaybe Nothing = [] concatMaybe (Just xs) = xs @@ -44,36 +40,21 @@ uncollect = concatMap (\(a, bs) -> zip (repeat a) bs) runRules' :: [ObjId] -> Facts -> [VisibleState] -> RuleBase -> [(ObjId, [(Priority, MessageBody)])] -runRules' teamMates facts vss = +runRules' teamMates' facts vss = collect . map (\(p,(o,m)) -> (o, (p,m))) . uncollect - . map (\rule -> (opPriority rule, concatMaybe $ opRule rule teamMates facts vss)) + . map (\rule -> (opPriority rule, concatMaybe $ opRule rule teamMates' facts vss)) -- collect all the messages for each player that have the lowest prio runRules :: [ObjId] -> Facts -> [VisibleState] -> RuleBase -> [(ObjId, MessageBody)] -runRules teamMates facts vss = +runRules teamMates' facts vss = concatMap (\(o, pms) -> let pmsSort = sortBy (compare `on` fst) pms lowest = fst $ head pmsSort relevantMsgs = map snd $ takeWhile ((lowest ==) . fst) pmsSort in zip (repeat o) relevantMsgs) - . runRules' teamMates facts vss - --- old version: fetch only the lowest prio message for each player --- runRules semNet vss = --- map ((\ (o, (p, m)) -> (o, m)) . --- second (minimumBy comparePM)) --- . runRules' semNet vss --- another option: let all the messages for a player pass ---runRules :: SemNet -> [VisibleState] -> RuleBase -> [(ObjId, MessageBody)] ---runRules semNet vss ruleBase = --- map (\(o,(p,m)) -> (o, m)) $ --- concat $ map (\(o, pms) -> [(o, (p, m)) | (p, m) <- pms]) $ --- runRules' semNet vss ruleBase + . runRules' teamMates' facts vss -comparePM :: (Priority, MessageBody) -> (Priority, MessageBody) -> Ordering -comparePM = comparing fst - -- ************************************************************************* -- -- Basic rules for all teams, not changeable by user @@ -104,7 +85,7 @@ -- d. solange zielen (AimingForThrowIn), bis Güte des Spots über einen Schwellenwert -- liegt ODER die Zeit seit Start der Einwurfaktion überschritten ist rule_throw_in :: RuleFunction -rule_throw_in _ facts vss = do +rule_throw_in _ facts _ = do FPPlayerId p <- factThrowingIn facts [] FPFromTo curr dest <- factBestPosition facts [] return $ (p, pm (PPTLoseMe, @@ -112,16 +93,17 @@ trace ("RULE=" ++ show (BSPShoot (towards curr dest)) ++ show "; " ++ show dest) #endif BSPShoot (towards curr dest))) : + (1, GameMessage (GTBallInPlay, GPTeamPosition Home (-1) [] (Point2 0 0) 0 False InPlay)) : [(p, tm (TPTReposition, tspNull))] rule_stop_idling :: RuleFunction -rule_stop_idling _ facts vss = do +rule_stop_idling _ facts _ = do FPPlayers ps <- factIdling facts [] return $ map (\p -> (p, tm (TPTHoldPosition, tspNull))) ps rule_punt :: RuleFunction -rule_punt _ facts vss = do +rule_punt _ facts _ = do FPPlayerVector p v <- factPunt facts [] return $ [(p, pm (PPTLoseMe, BSPShoot v))] @@ -145,6 +127,7 @@ -- mindestens mal angestoßen werden... -- klingt so, als sollte man es erst mal mit innerhalb probieren... +basicRules :: [Rule] basicRules = [Rule (RuleId (-1000)) "throw in" (Priority 1) rule_throw_in ,Rule (RuleId (-1001)) "kickoff" (Priority 0) rule_kick_off ,Rule (RuleId (-1002)) "punt" (Priority 4) rule_punt @@ -156,12 +139,6 @@ type Clause = Facts -> [FactParam] -> Maybe FactParam type MsgMaker = [VisibleState] -> [FactParam] -> [Message] -instance Show Clause where - show x = "Clause" -instance Show MsgMaker where - show x = "MsgMaker" - - type ParamId = Int type Statement = [(Maybe ParamId, Clause, [RuleParam])] data RuleParam = PId ParamId | PConst FactParam deriving (Show) @@ -181,16 +158,19 @@ fp <- clause facts $ fetchParams paramFactsSoFar clauseParams run myTeamMates vss facts rs msg $ maybeInsertAL pId fp paramFactsSoFar +maybeInsertAL :: Maybe k -> a -> AL k a -> AL k a maybeInsertAL Nothing _ paramFactsSoFar = paramFactsSoFar maybeInsertAL (Just pId) fp paramFactsSoFar = insertAL pId fp paramFactsSoFar -filterTeam teamMates = - filter (\(oid,_) -> elem oid teamMates) +filterTeam :: Eq a => [a] -> [(a, t)] -> [(a, t)] +filterTeam teamMates' = + filter (\(oid,_) -> elem oid teamMates') +fetchParams :: AL ParamId FactParam -> [RuleParam] -> [FactParam] fetchParams _ [] = [] fetchParams pvs (p:ps) = case p of - PId p -> pvs ! p : fetchParams pvs ps + PId p' -> pvs ! p' : fetchParams pvs ps PConst c -> c : fetchParams pvs ps @@ -215,6 +195,7 @@ (msg, msgParams) <- parseMsg (last ls) params return (ruleName, rulePrio, clauses, (msg, msgParams)) +checkRuleStructure :: Num t => [a] -> Either (t, String) () checkRuleStructure ls = if length ls < 3 then Left $ (10, "rule must consist of rule head, at least one clause and message") @@ -233,6 +214,7 @@ (restClauses, newAcc) <- gatherClauses cs (pushIfJust maybeVar acc) return ((fst `fmap` maybeVar, clause, params) : restClauses, newAcc) +pushIfJust :: Maybe a -> [a] -> [a] pushIfJust Nothing xs = xs pushIfJust (Just x) xs = x : xs @@ -258,6 +240,7 @@ ps <- parseParams params (drop (if hasVar then 3 else 2) tokens) return (maybeVar, fact, ps) +checkClauseStructure :: Num t => [String] -> Either (t, String) Bool checkClauseStructure tokens = if length tokens >= 3 && tokens !! 1 == "is" then Right True @@ -272,13 +255,15 @@ if elem token (map snd params) then Left (2, "variable name already used: " ++ token) else Right $ Just (newParamId params, token) -checkVariable params token False = Right Nothing +checkVariable _ _ False = Right Nothing +newParamId :: (Num a, Ord a) => [(a, b)] -> a newParamId params = if null params then 1 else 1 + (maximum $ map fst params) -parseParams params [] = Right [] +parseParams :: Num t => [(ParamId, String)] -> [String] -> Either (t, String) [RuleParam] +parseParams _ [] = Right [] parseParams params ("scalar":tokens) = do (scalar, rest) <- checkParamScalar tokens result <- parseParams params rest @@ -292,11 +277,13 @@ result <- parseParams params tokens return $ (PId pid) : result +checkParamScalar :: Num t => [String] -> Either (t, String) (Double, [String]) checkParamScalar tokens = if null tokens then Left (4, "unexpected end of clause after scalar keyword") else if null (reads (head tokens) :: [(Double, String)]) then Left (5, "no number after scalar: " ++ head tokens) else Right (fst $ head (reads (head tokens) :: [(Double, String)]), tail tokens) +checkParamSpot :: Num t => [String] -> Either (t, String) (Double, Double, [String]) checkParamSpot tokens = if length tokens < 2 then Left (4, "unexpected end of clause after spot keyword") else if null (reads (tokens !! 0) :: [(Double, String)]) || @@ -305,6 +292,7 @@ else Right (fst $ head (reads (tokens !! 0) :: [(Double, String)]), fst $ head (reads (tokens !! 1) :: [(Double, String)]), drop 2 tokens) +checkParamName :: Num t => [(b, String)] -> String -> Either (t, String) b checkParamName params paramName = case find ((paramName ==) . snd) params of Just (pid, _) -> Right pid @@ -320,6 +308,7 @@ ps <- parseParams params (drop 2 tokens) return (msg, ps) +checkMsgStructure :: Num t => [String] -> Either (t, String) () checkMsgStructure tokens = if null tokens || length tokens < 2 || tokens !! 0 /= "send" @@ -327,11 +316,13 @@ concat (zipWith (++) tokens (repeat " "))) else Right () +checkMsg :: Num t => String -> Either (t, String) MsgMaker checkMsg "msgKick" = Right msgKick checkMsg "msgPassTo" = Right msgPassTo checkMsg "msgIntercept" = Right msgIntercept checkMsg x = Left (3, "no valid message: " ++ x) +checkFact :: String -> Either a (Facts -> FactFunction) checkFact "factCanIntercept" = Right factCanIntercept checkFact "factIsCloseTo" = Right factIsCloseTo checkFact "factInLineWith" = Right factInLineWith diff --git a/States.hs b/States.hs --- a/States.hs +++ b/States.hs @@ -41,11 +41,10 @@ data GameState = GSGoal | GSFrozen - | GSSideOut - | GSBaseOut + | GSOutOfPlay | GSThrowIn - | GSCorner | GSKickOff | GSRunning + | GSOffsitePending | GSQuit deriving (Show, Eq) diff --git a/chalkboard.png b/chalkboard.png Binary files a/chalkboard.png and b/chalkboard.png differ