Rasenschach 0.1.1 → 0.1.2
raw patch · 41 files changed
+835/−556 lines, 41 filesbinary-added
Files
- 13ball.png binary
- 15ball.png binary
- 17ball.png binary
- 20ball.png binary
- 20redball.png binary
- 23redball.png binary
- 25ball.png binary
- 26redball.png binary
- 30ball.png binary
- 30redball.png binary
- 35redball.png binary
- 40redball.png binary
- AI.hs +11/−21
- AL.hs +8/−3
- Animate.hs +17/−11
- BallFSM.hs +80/−22
- BasicTypes.hs +4/−3
- Command.hs +12/−7
- Data/FSM.hs +15/−19
- GameFSM.hs +28/−22
- GameLoop.hs +13/−18
- Global.hs +0/−2
- Grid.hs +11/−9
- Helper.hs +89/−41
- Lineup.hs +26/−17
- Main.hs +39/−26
- Message.hs +22/−12
- Object.hs +8/−10
- ObjectBehaviour.hs +149/−96
- ParseTeam.hs +12/−5
- Parser.hs +15/−15
- PlayerFSM.hs +65/−43
- Rasenschach.cabal +12/−10
- Render.hs +42/−31
- RenderBall.hs +4/−2
- RenderGame.hs +40/−14
- RenderPlayer.hs +33/−16
- RenderUtil.hs +48/−39
- Rules.hs +30/−39
- States.hs +2/−3
- chalkboard.png binary
− 13ball.png
binary file changed (599 → absent bytes)
− 15ball.png
binary file changed (775 → absent bytes)
− 17ball.png
binary file changed (932 → absent bytes)
− 20ball.png
binary file changed (1041 → absent bytes)
+ 20redball.png view
binary file changed (absent → 902 bytes)
+ 23redball.png view
binary file changed (absent → 1097 bytes)
− 25ball.png
binary file changed (1494 → absent bytes)
+ 26redball.png view
binary file changed (absent → 1236 bytes)
− 30ball.png
binary file changed (2053 → absent bytes)
+ 30redball.png view
binary file changed (absent → 1699 bytes)
+ 35redball.png view
binary file changed (absent → 2122 bytes)
+ 40redball.png view
binary file changed (absent → 2254 bytes)
AI.hs view
@@ -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
AL.hs view
@@ -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]
Animate.hs view
@@ -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
BallFSM.hs view
@@ -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
BasicTypes.hs view
@@ -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)
Command.hs view
@@ -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
Data/FSM.hs view
@@ -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
GameFSM.hs view
@@ -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
GameLoop.hs view
@@ -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)]
Global.hs view
@@ -2,8 +2,6 @@ where -import FRP.Yampa.Geometry- import Physics import BasicTypes import Object
Grid.hs view
@@ -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
Helper.hs view
@@ -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--
Lineup.hs view
@@ -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)])
Main.hs view
@@ -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})+
Message.hs view
@@ -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
Object.hs view
@@ -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,
ObjectBehaviour.hs view
@@ -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
ParseTeam.hs view
@@ -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 \
Parser.hs view
@@ -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
PlayerFSM.hs view
@@ -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)
Rasenschach.cabal view
@@ -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+
Render.hs view
@@ -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
RenderBall.hs view
@@ -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
RenderGame.hs view
@@ -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)
RenderPlayer.hs view
@@ -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 ++ ", " ++
RenderUtil.hs view
@@ -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
Rules.hs view
@@ -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
States.hs view
@@ -41,11 +41,10 @@ data GameState = GSGoal | GSFrozen- | GSSideOut- | GSBaseOut+ | GSOutOfPlay | GSThrowIn- | GSCorner | GSKickOff | GSRunning+ | GSOffsitePending | GSQuit deriving (Show, Eq)
chalkboard.png view
binary file changed (821634 → 19340 bytes)