Rasenschach (empty) → 0.1
raw patch · 44 files changed
+4980/−0 lines, 44 filesdep +SDLdep +SDL-gfxdep +SDL-imagesetup-changedbinary-added
Dependencies added: SDL, SDL-gfx, SDL-image, SDL-mixer, SDL-ttf, Yampa, array, base, containers, convertible, directory, filepath, ghc, monad-loops, template-haskell, time
Files
- 13ball.png binary
- 15ball.png binary
- 17ball.png binary
- 20THCENT.TTF binary
- 20ball.png binary
- 25ball.png binary
- 30ball.png binary
- AI.hs +179/−0
- AL.hs +58/−0
- Animate.hs +61/−0
- BallFSM.hs +71/−0
- BasicTypes.hs +105/−0
- Command.hs +47/−0
- Data/FSM.hs +280/−0
- GameFSM.hs +120/−0
- GameLoop.hs +130/−0
- Global.hs +42/−0
- Grid.hs +79/−0
- Helper.hs +375/−0
- LICENSE +30/−0
- Lineup.hs +207/−0
- Main.hs +147/−0
- Message.hs +210/−0
- Object.hs +168/−0
- ObjectBehaviour.hs +657/−0
- ParseTeam.hs +192/−0
- Parser.hs +246/−0
- Physics.hs +135/−0
- PlayerFSM.hs +405/−0
- README +142/−0
- Rasenschach.cabal +40/−0
- Render.hs +107/−0
- RenderBall.hs +44/−0
- RenderGame.hs +41/−0
- RenderPlayer.hs +119/−0
- RenderUtil.hs +123/−0
- Rules.hs +365/−0
- Setup.lhs +4/−0
- SqueakyChalkSound.ttf binary
- States.hs +51/−0
- ballM.wav binary
- chalkboard.png binary
- tockH.wav binary
- whistle.wav binary
+ 13ball.png view
binary file changed (absent → 599 bytes)
+ 15ball.png view
binary file changed (absent → 775 bytes)
+ 17ball.png view
binary file changed (absent → 932 bytes)
+ 20THCENT.TTF view
binary file changed (absent → 22824 bytes)
+ 20ball.png view
binary file changed (absent → 1041 bytes)
+ 25ball.png view
binary file changed (absent → 1494 bytes)
+ 30ball.png view
binary file changed (absent → 2053 bytes)
+ AI.hs view
@@ -0,0 +1,179 @@+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+import Physics+import States+import Message+import Helper+import Object+import Grid+++-- *************************************************************************+--+-- Semantic Net for Game and Player Facts+--+-- ************************************************************************+++deriveFacts :: Param -> Time -> Team -> Team -> [VisibleState] -> Facts+deriveFacts param t attacker teamAtMove vss =+ Facts+ (\_ -> Just FPEmpty)+ (\_ -> Just FPEmpty)+ (\_ -> Just FPEmpty)+ (\_ -> setBestFreePlayer)+ setNearestAIPlayer+ (\_ -> setBallIsFree)+ (\_ -> Just $ FPTeam attacker)+ (\_ -> setThrowingIn)+ (\_ -> Just $ FPFromTo currSpot setBestPosition)+ (\_ -> setKickOff)+ (\_ -> (FPPlayerId . vsObjId) `fmap`ballCarrier)+ setPlayerSpot+ setSpotValue+ (\_ -> setBestShootingVector)+ (\_ -> setBestPassingVector)+ (\_ -> setPunt)+ (\_ -> setIdling)+ (\_ -> Just $ FPTeam teamAtMove)+ (\[x, y] -> if x == y then Just FPEmpty else Nothing)+ setGT+ setGetVector++ where+ setPlayerSpot [FPPlayerId oid] =+ return $ FPSpot (pointToSpot $ projectP $ vsPos $ fetchVS vss oid)++ setSpotValue [FPSpot spot] =+ return $ FPScalar $ if attacker == Home then homeValue param spot+ else awayValue param spot++ setGT [FPScalar x, FPScalar y] = if x > y then Just FPEmpty else Nothing++ setGetVector [FPSpot x, FPSpot y] = Just $ FPVector $ towards x y++ setNearestAIPlayer [FPTeam team, FPSpot spot] =+ Just $ FPPlayerId $ nearestAIPlayer team vss (spotToPoint spot)++ setBallIsFree =+ if fst (vsBallState ball) == BSFree then+ Just $ FPSpot $ pointToSpot (inOneSecond (projectP $ vsPos ball) (project $ vsVel ball))+ else Nothing++ ball = fetchBallVS vss+ (Point3 ballX ballY ballZ) = vsPos ball++ game = fetchGameVS vss++ currSpot = (pointToSpot . projectP . vsPos) ball++ ballCarrier = fetchBallCarrier vss++ (attackingTeam, defendingTeam) =+ (teamPlayers attacker vss, teamPlayers (otherTeam attacker) vss)++ setBestFreePlayer =+ do+ bc <- ballCarrier+ fp <- bestFreePlayer param vss bc+ return $ FPPlayerId (vsObjId fp)++ timeOfThrowIn = case vsGameState game of+ (GSBaseOut, GPTeamPosition _ _ t _) -> Just t+ (GSSideOut, GPTeamPosition _ _ t _) -> Just t+ _ -> Nothing++ timeOfPossession = case vsBallState ball of+ (_, BPWho _ t) -> Just t+ _ -> Nothing++ setThrowingIn = listToMaybe $+ map (FPPlayerId . vsObjId)+ [p | p@(VSPlayer {vsPBState = (bs, bsp)})+ <- vss, bs == PBSPrepareThrowIn,+ isJust timeOfThrowIn,+ t - fromJust timeOfThrowIn > 2]++ goalie = fetchGoalie attacker vss++ setPunt =+ let to = if attacker == Away then 20 else -20+ in listToMaybe $+ [FPPlayerVector (vsObjId goalie) (vector3 0 to 10)+ | hasBall goalie && t - fromJust timeOfPossession > 2]++ setBestPosition = bestSpot vss attacker currSpot (pGrid param)++ setKickOff = if GSKickOff == (fst . vsGameState . fetchGameVS) vss && t-t0 > 1+ then Just FPEmpty else Nothing+ where GPTeamPosition _ _ t0 _ = (snd . vsGameState . fetchGameVS) vss++-- setBallCarrier = do+-- bc <- ballCarrier+-- return $ FPPlayer (vsObjId bc)+-- (getPlayerValue param attacker bc)+-- (pointToSpot $ projectP $ vsPos bc)++ setBestShootingVector =+ if ballX > 20 && ballX < 60 &&+ (attacker == Home &&+ ballY < 30+ ||+ attacker == Away &&+ ballY > 65) then Just (FPVector v)+ else Nothing++ where v = towards (Spot ballX ballY) goal+ goal = pointToSpot (if attacker == Home then+ awayGoalCenter param+ else+ homeGoalCenter param)++ setBestPassingVector = do+ runPathBlocked param attacker ballCarrier defendingTeam+ return $ FPVector $ towards currSpot setBestPosition++ setIdling = Just $ FPPlayers $ map vsObjId $ filter ((==) TSWaiting . fst . vsPTState) $+ teamPlayers attacker vss++++getPlayerValue param attacker pl =+ if attacker == Home then homeValue param spot+ else awayValue param spot+ where spot = (pointToSpot . projectP . vsPos) pl++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 =+ let defenderPos = projectP $ vsPos defender+ dist = distance pos defenderPos+ Point2 dx dy = defenderPos+ Point2 x y = pos+ in+ dist < 3 &&+ if attacker == Home then dx < x+ else dx > x++
+ AL.hs view
@@ -0,0 +1,58 @@+module AL++where++import Data.List hiding ((!!))+import Data.Maybe++data AL k a = AL [(k, a)]+instance Functor (AL k) where fmap f (AL xs) = AL $ map (\(k, a) -> (k, f a)) xs+instance (Show k, Show a) => Show (AL k a) where+ show (AL xs) = "AL " ++ show xs++mapAL :: ((k, a) -> b) -> AL k a -> AL k b+mapAL f (AL kas) =+ AL [(k, f ka) | ka@(k,_) <- kas]++filterAL :: (a -> Bool) -> AL k a -> AL k a+filterAL p (AL kas) = AL $ filter (p . snd) kas++elemsAL (AL xs) = map snd xs++(!) :: (Eq k) => AL k a -> k -> a+(AL l) ! k = snd . fromJust $ find (\(k', a) -> k == k') l++at :: AL k a -> Int -> (k, a)+(AL l) `at` 0 = head l+(AL l) `at` n = (AL (tail l)) `at` (n-1)++lookupAL :: (Eq a) => a -> AL a b -> Maybe b+lookupAL x (AL xs) = lookup x xs++emptyAL = AL []++assocsAL (AL l) = l+fromAssocs l = AL l++insertAL :: k -> a -> AL k a -> AL k a+insertAL k a (AL al) = AL ((k,a):al)++deleteAL :: (Eq k) => k -> AL k a -> AL k a+deleteAL k (AL kas) =+ AL (deleteHlp kas)+ where+ deleteHlp [] = []+ deleteHlp (ka@(k', _) : kas) | k == k' = kas+ | otherwise = ka : deleteHlp kas+++appendAL (AL xs) (AL ys) = AL $ xs ++ ys++-- collectAL :: (Eq a) => AL a b -> AL a [b]+-- collectAL (AL xs) = AL (collect xs)++mergeAL :: (Eq k) => (AL k a) -> (AL k b) -> [(k,a,b)]+mergeAL (AL []) _ = []+mergeAL (AL ((k,x):xs)) ys = (k,x,ys ! k) : mergeAL (AL xs) ys++--mergeAL (AL [(1,100),(2,100)]) (AL [(2,20),(1,10)])
+ Animate.hs view
@@ -0,0 +1,61 @@+module Animate where++import Control.Monad.Loops+import Control.Monad++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 Object+import ObjectBehaviour+import Parser+import GameLoop+import AL+import States+++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)+ )++-- reactimation IO ----------++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+ count <- readIORef counter+ writeIORef counter (count + 1)+ events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent+ t1 <- getCurrentTime+ let t1' = convert t1 :: Double+ t0 <- readIORef stateTime+ writeIORef stateTime t1'+ return (t1'-t0, Just (t1'-tInit, events))+++output param sdlState _ oal@(AL oos) = do+ Just sdl <- readIORef sdlState+ Render.render param (map (ooObsObjState . snd) oos) sdl+ let ol = (AL.!) oal 1++ when (((fst . oosGameState . ooObsObjState) ol) == GSQuit) $ putStrLn "Hallo"+ return (((fst . oosGameState . ooObsObjState) ol) == GSQuit)
+ BallFSM.hs view
@@ -0,0 +1,71 @@+module BallFSM (freeBallSF, controlledBallSF, outOfPlayBallSF)+++where++import Debug.Trace+import FRP.Yampa+import FRP.Yampa.Geometry++import Data.FSM+import Message+import Object+import States+import Helper+import BasicTypes++type BallPerception = (BallMsgParam, [VisibleState])++s1 = addTransition BTCollisionB 3 $+ addTransition BTOutOfPlay 4 $+ state 1 BSFree (const []) (const []) (const [])+s2 = addTransition BTCollisionB 3 $+ addTransition BTOutOfPlay 4 $+ addTransition BTLost 1 $+ state 2 BSControlled (const []) (const []) (const [])+s3 = addTransition BTGained 2 $+ addTransition BTGainedOOP 5 $+ addTransition BTGainedGoalie 6 $+ addTransition BTLostOOP 4 $+ addTransition BTLost 1 $+ state 3 BSChallenged (const []) takeMe (const [])+s4 = addTransition BTCollisionB 3 $+ state 4 BSOutOfPlay (const []) (const []) (const [])+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]++takeMe :: (BallStateParam, BallPerception) -> [Message]+takeMe (BPWho player t, (BPWho me _,vss)) =+ let (ballState, ballParam) = vsBallState . fetchBallVS $ vss+ gameVS = fetchGameVS vss+ game = vsObjId gameVS+ attacker = vsAttacker gameVS+ teamTouching = vsTeam $ fetchVS vss player+ 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)))]+ else+ [(me, BallMessage (BTLostOOP, ballParam))]+ else -- ball was in play+ -- if goalie has the ball, then don't take it from him+ if ballState == BSControlledGoalie then+ [(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)+++freeBallSF :: 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+
+ BasicTypes.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-}++module BasicTypes++where++import FRP.Yampa+import FRP.Yampa.Geometry+import qualified Graphics.UI.SDL as SDL (Pixel, Event)++import Physics+import States++------------------------------------------------------------------------------++type ObjId = Int++data OnFoot = LeftFoot | RightFoot | NoFoot deriving (Eq, Show)++data PlayerRole = Goalie | Defender | Midfielder | Forward deriving (Eq, Show, Read)++data Team = Home | Away deriving (Eq, Show)++type TeamInfo = (Team, -- True = Home, False = Away+ SDL.Pixel, -- Team color 1+ SDL.Pixel) -- Team color 2++data PlayerInfo = PlayerInfo {+ piNumber :: Int -- Number on jersey+ ,piPlayerRole :: PlayerRole -- "Left Defensive", "Center Forward", ...+ ,piBasePosDefense :: Point2 Double -- Base Defensive Position+ ,piBasePosOffense :: Point2 Double -- Base Offensive Position+ ,piPlayerSpeedMax :: Double+ ,piPlayerAccMax :: Double+ ,piPlayerCoverRatio :: Double -- defines how close a player covers his oppenent (~0: very close; ~1 very loose)+} deriving (Show)++data TimerEvent = TimerCalculateHomeAI | TimerCalculateAwayAI | TimerCalculateFacts | NoTimerEvent+ deriving (Show, Eq)++type CurrentTime = Time+type StateTime = Time++type GameInput = (CurrentTime, [SDL.Event])+type Input = (Event TimerEvent, GameInput)++type FactFunction = [FactParam] -> Maybe FactParam+instance Show FactFunction where+ show x = "FactFunction"++data Facts = Facts {+ factCanIntercept :: FactFunction+ , factIsCloseTo :: FactFunction+ , factInLineWith :: FactFunction+ , factBestFreePlayer :: FactFunction -- Player, Value of Spot, Spot+ , factNearestAIPlayer :: FactFunction+ , factBallIsFree :: FactFunction -- current pos and projection in one secone+ , factAttacking :: FactFunction+ , factThrowingIn :: FactFunction+ , factBestPosition :: FactFunction -- current and best spot+ , factKickOff :: FactFunction+ , factBallCarrier :: FactFunction -- Player, Value of Spot, Spot+ , factPlayerSpot :: FactFunction -- Player, Value of Spot, Spot+ , factSpotValue :: FactFunction -- Player, Value of Spot, Spot+ , factBestShootingVector :: FactFunction+ , factBestPassingVector :: FactFunction+ , factPunt :: FactFunction+ , factIdling :: FactFunction+ , factWhoAmI :: FactFunction+ , factEq :: FactFunction+ , factGT :: FactFunction+ , factGetVector :: FactFunction+}+-- deriving (Show)+--ACHTUNG: Funktion NFA, rnf definieren!!!++data FactParam =+ FPTeam Team+ | FPEmpty+ | FPPlayers [ObjId]+ | FPSpot Spot+ | FPFromTo Spot Spot+ | FPScalar Double+ | FPVector Velocity3+ | FPPlayer ObjId Double Spot+ | FPPlayerId ObjId+ | FPPlayerVector ObjId Velocity3+ deriving (Show, Eq)+++data OutOfPlay =+ OOPSideOut+ | OOPKickOff+ | OOPCorner+ deriving (Show, Eq)+++data Spot = Spot !Double !Double deriving (Show, Eq)+data GridElement = GridElement !Spot !Double !Double deriving (Show, Eq)+type Grid = [GridElement]+++++
+ Command.hs view
@@ -0,0 +1,47 @@+module Command+where++import FRP.Yampa++data Command =+ CmdQuit+ | CmdNewGame+ | CmdFreeze+ | CmdResume+ | CmdPassHigh {dt :: Time}+ | CmdPassLow {dt :: Time}+ | CmdKickHigh {dt :: Time}+ | CmdKickLow {dt :: Time}+ | CmdToggleFoot+ | CmdTakeOver+ | CmdFlipHigh+ | CmdFlipLow+ | CmdMoveForward+ | CmdMoveBackward+ | CmdMoveLeft+ | CmdMoveRight+ | CmdMoveToGoal+ | CmdMoveToMe+ | CmdFlipMeHigh+ | CmdFlipMeLow+ deriving (Show, Eq, Ord)++--cmd* :: [Command] -> (Bool, Time)+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 [] = 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 [] = False; cmdToggleFoot (c:cs) = case c of CmdToggleFoot -> True ; _ -> cmdToggleFoot cs+cmdTakeOver [] = False; cmdTakeOver (c:cs) = case c of CmdTakeOver -> True ; _ -> cmdTakeOver cs+cmdMoveForward [] = False; cmdMoveForward (c:cs) = case c of CmdMoveForward -> True ; _ -> cmdMoveForward cs+cmdMoveBackward [] = False; cmdMoveBackward (c:cs) = case c of CmdMoveBackward -> True ; _ -> cmdMoveBackward cs+cmdMoveLeft [] = False; cmdMoveLeft (c:cs) = case c of CmdMoveLeft -> True ; _ -> cmdMoveLeft cs+cmdMoveRight [] = False; cmdMoveRight (c:cs) = case c of CmdMoveRight -> True ; _ -> cmdMoveRight cs+cmdMoveToGoal [] = False; cmdMoveToGoal (c:cs) = case c of CmdMoveToGoal -> True ; _ -> cmdMoveToGoal cs+cmdMoveToMe [] = False; cmdMoveToMe (c:cs) = case c of CmdMoveToMe -> True ; _ -> cmdMoveToMe cs+cmdFlipMeLow [] = False; cmdFlipMeLow (c:cs) = case c of CmdFlipMeLow -> True ; _ -> cmdFlipMeLow cs+cmdFlipMeHigh [] = False; cmdFlipMeHigh (c:cs) = case c of CmdFlipMeHigh -> True ; _ -> cmdFlipMeHigh cs
+ Data/FSM.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE Arrows #-}++module Data.FSM+ (FSM, State, state, content, addTransition,+ fromList, checkStates, Problem, reactMachine,+ reactMachineMult, reactMachineHist, fsmToDot)++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)+++-- *************************************************************************+--+-- Datatypes for States and FSMs+--+-- *************************************************************************++type SId = Int++data Problem t = NonUniqueState SId+ | MissingTarget SId t+ deriving (Show)++-- State consists of an unique Id, a content describing the state+-- (possibly an enum), functions for generating messages on+-- leaving the current state or entering a new state, resp., and+-- a transitiion table from a given state to its neighboring states+data State a t perception messages = State {+ stateId :: SId,+ content :: a,+ while, onEnter, onExit :: perception -> messages,+ transition :: M.Map t Int+}+instance (Show t, Show a) => Show (State a t p m)+-- where show s = "State " ++ show (content s) ++ ", ("+-- ++ concatMap (\(t,y) -> ' ' : (show t ++ "->" ++ show y)) (M.toList (transition s))+-- ++ " )"+ where show s = "{" ++ show (stateId s) ++ "}"++instance Eq (State a t p m)+ where (==) = (==) `on` stateId++-- a FSM is defined as a Map of State Ids to its corresponding State data+type FSM a t p m = M.Map SId (State a t p m)+++-- *************************************************************************+--+-- Basic functions for creating States and FSMs and for running transitions+-- on a given FSM+--+-- *************************************************************************++-- 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++-- adds a new transition to a given State instance+addTransition :: Ord t => t -> Int -> State a t p m -> State a t p m+addTransition t transStateId s =+ let newTrans = M.insert t transStateId (transition s)+ in s {transition = newTrans }++-- Creates a new FSM from a list of previously generated states, returns+-- either a Right FSM or - in case of duplicate states or transitions to+-- non-existent states - a list of detected problems in the Leftt+fromList :: [State a t p m] -> Either [Problem t] (FSM a t p m)+fromList ss =+ case checkStates ss of+ [] -> Right $ foldl (\m s -> M.insert (stateId s) s m) M.empty ss+ ps -> Left ps++-- Given a FSM, a current state and a transition, the function computes the+-- next state (if transition is applicable) or Nothing (if transition is not+-- applicable); if transition was applicable, the messages from leaving the+-- old state and entering the new state will be collected+runTrans :: (Ord t, Monoid m) => FSM a t p m -> State a t p m -> t -> p -> Maybe (State a t p m, m)+runTrans fsm currentState trans perception = do+ newId <- M.lookup trans (transition currentState)+ let Just newState = M.lookup newId fsm+ return (newState, onExit currentState perception `mappend` onEnter newState perception)+++-- 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 =+ (currentState, mempty, False)+runTransMult fsm currentState (trans:transs) perception =+ case runTrans fsm currentState trans perception of+ Just (s1, m1) -> let (s2, m2, _) = runTransMult fsm s1 transs perception in (s2, m1 `mappend` m2, True)+ Nothing -> let (s2, m2, occ) = runTransMult fsm currentState transs perception in (s2, mempty `mappend` m2, occ)+++-- *************************************************************************+--+-- Create dot-output for rendering with graphviz. To do so: Capture the+-- output of fsmToDot in a file, then use dot to convert+--+-- Example of dot-format:+--+-- digraph simple_hierarchy {+-- B [label="The boss"] // node B+-- E [label="The employee"] // node E+-- B->E [label="commands", fontcolor=darkgreen] // edge B->E+-- }+-- *************************************************************************++fsmToDot :: (Show a, Show t) => FSM a t p m -> String+fsmToDot fsm =+ "digraph fsm\n{\n" +++ (foldl (++) "" $ map statesToDot (M.elems fsm)) +++ "}\n"+ where+ formatTrans source k a result =+ result ++ show source ++ "->" ++ show a ++ " [label=\"" ++ show k ++ "\"]\n"+ statesToDot s =+ let ts = M.map (\dest -> content ((M.!) fsm dest)) $ transition s+ curr = content s+ in+ M.foldrWithKey (formatTrans curr) "" ts -- (M.fromList [(5,"a"), (3,"b")])+++-- *************************************************************************+--+-- Sanity checks on a set of FSM states, checks for duplicate states and+-- transitions with missing target states+--+-- *************************************************************************++checkStates :: [State a e p m] -> [Problem e]+checkStates states =+ map NonUniqueState (checkDoubles states) +++ map (\(i,e,_) -> MissingTarget i e) (checkTransitions states)++checkTransitions :: [State a e p m] -> [(Int, e, Int)]+checkTransitions = foldl' checkProblem [] . allElems++checkProblem :: [(Int, e, Int)] -> (State a e p m, [State a e p m]) -> [(Int, e, Int)]+checkProblem ps (s, ts) = ps ++ missingStates (stateId s) (transition s) ts++missingStates :: Int -> M.Map e Int -> [State a e p m] -> [(Int, e, Int)]+missingStates s trans ss =+ let sIds = map stateId ss+ ts = M.toList trans+ in concatMap (\(e, sId) -> if elem sId sIds then [] else [(s, e, sId)]) ts++allElems :: [a] -> [(a, [a])]+allElems xs =+ let ixs = zip [0..length xs - 1] xs+ in map (\(i,x) -> ((xs!!i), xs)) ixs++checkDoubles :: [State a e p m] -> [Int]+checkDoubles states =+ let ids = map stateId states+ in ids \\ nub ids+++-- *************************************************************************+--+-- Reactivity+--+-- *************************************************************************++-- Wrapper function for easy access to runTrans by accumHold; if no transition+-- applies, the wrapper returns the old state and no messages+-- additionaly, the function pushes through a state parameter that will be attached+-- to the new state+runMachine :: (Ord t, Monoid m) =>+ FSM a t (s, p) m -> (State a t (s, p) m, (m, s)) -> ((t, s), p) -> (State a t (s, p) m, (m, s))+runMachine fsm curr ((trans, stateParam), perc) =+ let (curr', (_, currParam)) = curr+ in+ case runTrans fsm curr' trans (stateParam, perc) of+ Nothing -> (curr', (mempty, currParam))+ Just (newState, messages) -> (newState, (messages, stateParam))++-- Reactive FSM transition: yields the (time-varying) current state and+-- for every transition (defined by an Event containing the transition+-- and the perception for the onExit / onEnter functions) a Monoid of+-- the collected messages from the onExit / onEnter functions+-- additionaly, the function pushes through a state parameter that will be attached+-- 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)++-- Yields the (time-varying) current state and the messages (that originate from+-- either the onExit / onEnter-function on a transition or the while-function+-- if no transition occured)+-- The event that yields a state transition (Event (t, s)) consist of the actual+-- transition t that advances the FSM, and a state parameter s that will be attached+-- to the new state. E.g. a event could be "Event (RunTo, Position 10 20)", telling+-- a player in state "Waiting" to change to state "RunTo", and attaching the additional+-- information "Position 10 20" to the new state+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+ param <- hold initParam -< snd (splitE result)+ returnA -< ((state, param), if isEvent result then fst (fromEvent result) else while state (param, perception))+++-- *************************************************************************+--+-- Similar to reactMachine, but puts a whole list of transition through+-- the FSM at a given point in time+--+-- *************************************************************************++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 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))++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)+reactMachineMult fsm initState initParam = proc (perception, tss) -> do+ rec+ (s2, sp2) <- iPre (initState, initParam) -< (s1, sp1)+ (s1, (ms, sp1)) <- arr (rMM fsm) -< (s2, sp2, tss, perception)+-- Achtung, hier auch die while-Events aufsammeln!!!+ returnA -< ((s1, sp1), ms `mappend` (while s1 (sp1, perception)))++-- instance (Show e) => Show (Event e) where+-- show NoEvent = "NoEvent"+-- show (Event e) = "Event " ++ show e+++-- *************************************************************************+--+-- Similar to reactMachineMult, but also provides the state parameter from+-- the previous state to the message generators. (Special case, used by+-- the key parser to determine the duration between keydown and keyup states+--+-- *************************************************************************++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))++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)++-- 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+-- param of the previous state, so the input to the onEnter etc. functions is (s, (p,s)) and+-- not (s, p) as in reactMachine.+reactMachineHist :: (Ord t, Monoid m)+ => FSM a t (s, (p,s)) m -> State a t (s, (p,s)) m -> s -> SF (p, Event ([t], s)) ((State a t (s, (p,s)) m, s), m)+reactMachineHist fsm initState initParam = proc (perception, ets) -> do+ rec+ (state, result) <- reactHistTransitions fsm initState initParam -< attach ets (oldParam, perception)+ param <- hold initParam -< snd (splitE result)+ oldParam <- iPre initParam -< param+ returnA -< ((state, param), if isEvent result then fst (fromEvent result) else while state (param, (perception, oldParam)))+
+ GameFSM.hs view
@@ -0,0 +1,120 @@+module GameFSM (gameSF)++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 GamePerception = [VisibleState]++s1 param = addTransition GTTakePossession 1 $+ addTransition GTSideOut 2 $+ addTransition GTBaseOut 3 $+ addTransition GTGoal 4 $+ addTransition GTQuit 5 $+ addTransition GTFreeze 6 $+ state 1 GSRunning (checkIfTimeUp param) (const []) (const [])+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 [])+s4 = addTransition GTTakePossession 4 $+ state 4 GSGoal (const []) (const []) (const [])+s5 = --addTransition GTTakePossession 5 $ ???+ state 5 GSQuit (const []) (const []) (const [])+s6 = addTransition GTTakePossession 6 $+ addTransition GTFreeze 1 $+ state 6 GSFrozen (const []) freezePlayers thawPlayers+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]+++stopWhistling :: (GameStateParam, GamePerception) -> [Message]+stopWhistling (gsp,vss) =+ let g = fetchGameVS vss+ me = vsObjId g+ GPTeamPosition a b c _ = gsp+ in [(me, GameMessage (GTWaitKickOff,+ GPTeamPosition a b c False))]++checkIfTimeUp :: Param -> (GameStateParam, GamePerception) -> [Message]+checkIfTimeUp param (_,vss) =+ let g = fetchGameVS vss+ t = vsGameTime g+ me = vsObjId g+ in [(me, GameMessage (GTQuit,+ GPTeamPosition Home (Point2 0 0) t True))+ | t > pGameLength param]++freezePlayers :: (GameStateParam, GamePerception) -> [Message]+freezePlayers (_, vss) =+-- nicht einfach point 0 0, sondern die position aus vss!+ [(vsObjId p, tm (TPTFreeze,+ TacticalStateParam (Just $ projectP $ vsPos p) Nothing False Nothing Nothing Nothing Nothing)) |+ p <- teamPlayers Home vss ++ teamPlayers Away vss]++thawPlayers :: (GameStateParam, GamePerception) -> [Message]+thawPlayers (_, vss) =+-- nicht einfach point 0 0, sondern die position aus vss!+ [(vsObjId p, tm (TPTHoldPosition,+ 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) =+ let ballVss = fetchBallVS vss+ ball = vsObjId ballVss+ lp = lastPlayer $ vsBallState ballVss+ np = nearestAIFieldPlayer team vss pos+ mpb = playerWithBall vss+ teamThrowingIn = teamPlayers team vss+ teamNotThrowingIn = teamPlayers (otherTeam team) vss++ -- messages+ dropBall = map (\x -> (x, pm (PPTLoseMe, BSPRelease 0 RTNothing))) $ maybeToList mpb+ holdPos = map (\(oid, oteam) ->+ (oid, tm (TPTHoldPosition,+ basePosition param oid vss (if oteam == team then oteam else otherTeam oteam)))) $+ map (\x -> (vsObjId x, vsTeam x)) $+ filter ((/= np) . vsObjId) $+ teamThrowingIn ++ teamNotThrowingIn+ moveThrowIn = [(np, tm (TPTMoveToThrowIn,+ TacticalStateParam (Just pos) Nothing False Nothing Nothing Nothing Nothing))]+ 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+
+ GameLoop.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE Arrows #-}++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+import BasicTypes+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) ->+#if DEBUG_MODE+ trace ("Achtung Init: " ++ show init) $+#endif+ uncurry (gameLoop param)+ (lineupKickoff param init time possession scoreHome scoreAway)++process :: ALOut -> ALObj -> SF GameInput (ALOut, Event (Time, Team, Int, Int))+process init objs0 = proc input -> do+ ticker <- repeatedly 0.3 iterateTimerEvents -< ()+ timerEvent <- accum TimerCalculateAwayAI -< ticker+ rec+ oos <- core init objs0 -< ((timerEvent, input), oos)+ let kickOffEvent = case ((gameOO . elemsAL) oos) of+ OOSGame gTime (gScoreHome, gScoreAway) (GSGoal, GPTeamPosition gTeam _ _ _) _ _ ->+ Event (gTime, (otherTeam gTeam), gScoreHome + homeAdder gTeam, gScoreAway + awayAdder gTeam)+ _ -> NoEvent+ returnA -< (oos, kickOffEvent)+ where+ homeAdder gTeam = if gTeam == Home then 1 else 0+ awayAdder gTeam = if gTeam == Away then 1 else 0++gameOO [] = error "GameLoop.hs/gameOO: No Game in Object Output"+gameOO (o:os) =+ case o of+ ObjOutput oog@(OOSGame {}) _ _ _ -> oog+ _ -> gameOO os+++iterateTimerEvents :: TimerEvent -> TimerEvent+iterateTimerEvents TimerCalculateHomeAI = TimerCalculateAwayAI+iterateTimerEvents TimerCalculateAwayAI = TimerCalculateHomeAI+++-- 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+ res <- core' objs -< (input, al')+ returnA -< res++core' :: ALObj -> SF (Input, ALOut) (ALOut)+core' objs = proc (input, al) -> do+ res <- dpSwitch route objs (arr killAndSpawn >>> notYet) (\sfs' f -> core' (f sfs')) -< (input, al)+ returnA -< res++killAndSpawn :: ((Input, ALOut), ALOut)+ -> Event (ALObj -> ALObj)+killAndSpawn ((input, _), oos) =+ foldl (mergeBy (.)) noEvent events+ where+ events :: [Event (ALObj -> ALObj)]+ events = [ mergeBy (.)+ (fmap (foldl (.) id . map (insertAL k))+ (ooSpawnReq oo))+ (ooKillReq oo `tag` (deleteAL k))+ | (k, oo) <- assocsAL oos ]++route :: (Input, ALOut) -> AL ObjId sf -> AL ObjId (ObjInput, sf)+route (input, oos) = {-# SCC "route" #-}+ mapAL (\(oid, obj) -> (ObjInput (getObjMessages oid messages, getObjMessages oid collisions) gameState input, obj))+ where+ messages = collectMessages oos++ AL kooss = mapAL (\(_,o) -> ooObsObjState o) oos+ collisions = collect (hits kooss)++ gameState = elemsAL . mapAL (\(oid', obj') -> vsFromObjOutput oid' obj') $ oos++ collectMessages :: ALOut -> [(ObjId, [MessageBody])]+ collectMessages = collect . concat . elemsAL . mapAL (ooMessages . snd)++ getObjMessages :: ObjId -> [(ObjId, [a])] -> [a]+ getObjMessages oid events =+ case lookup oid events of+ Just ms -> ms+ Nothing -> []++hits :: [(ObjId, ObsObjState)] -> [(ObjId, ObjId)]+hits = {-# SCC "hits" #-}+ map createMessage . mirror . hitsAux+ where++ createMessage (k,k',_,_) = (k, k')++ hitsAux [] = []+ -- Check each object 'State' against each other+ hitsAux ((k,oos):kooss) =+ [ (k, k',oos,oos') | (k', oos') <- kooss, oos `hit` oos' ]+ ++ hitsAux kooss++ hit :: ObsObjState -> ObsObjState -> Bool+ OOSPlayer {oosPos = p1} `hit` OOSPlayer {oosPos = p2} = distance p1 p2 < 3.0+ OOSPlayer {oosPos = p1} `hit` OOSBall {oosPos = p2} = distance p1 p2 < 1.4+ OOSBall {oosPos = p1} `hit` OOSPlayer {oosPos = p2} = distance p1 p2 < 1.4+ _ `hit` _ = False++ mirror [] = []+ mirror ((a,b,c,d):xs) = (a,b,c,d):(b,a,d,c):mirror xs++++
+ Global.hs view
@@ -0,0 +1,42 @@+module Global++where++import FRP.Yampa.Geometry++import Physics+import BasicTypes+import Object++data Param = Param {+ pEps :: Double,+ pGround :: Position,+ pLeftBorderX :: Double,+ pRightBorderX :: Double,+ pUpperBorderY :: Double,+ pLowerBorderY :: Double,+ pPitchLength :: Double,+ pPitchWidth :: Double,+ pGoalWidth :: Double,++ pMaxheight :: Double,++ pGravity :: Double,+ pBouncingTime :: Double,++ pPositionFactorX :: Double,+ pPositionFactorY :: Double,++ -- Various constants that define player behaviour+ pVerticalShiftRatio :: Double, -- defines how far a players vertically follows the ball while holding his position+ pHorizontalShiftRatio :: Double, -- dito horizontally++ pLineEnds :: Double, -- defines at what vertical position the line will not follow the ball further++ pGameLength :: Double, -- game length in seconds++ pRuleBaseHome :: RuleBase,+ pRuleBaseAway :: RuleBase,++ pGrid :: Grid+}
+ Grid.hs view
@@ -0,0 +1,79 @@+module Grid++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++grid :: Param -> Double -> Double -> Grid+grid param m n =+ let plm = pPitchWidth param / m+ plm2 = plm / 2+ pln = pPitchLength param / n+ pln2 = pln / 2+ in [GridElement(Spot x y) (homeValue param (Spot x y)) (awayValue param (Spot x y)) |+ 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 =+-- "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+-- throw to it...+ let myTeam = map (projectP . vsPos) $ teamPlayers team vss+ others = map (projectP . vsPos) $ teamPlayers (otherTeam team) vss+ myNearest = minimumBy (distanceToSpot destSpot) myTeam+ theirNearest = minimumBy (distanceToSpot destSpot) others+ in spotDistance destSpot myNearest < spotDistance destSpot theirNearest+-- AND-part yet missing+++-- simple function for ball shooting parameter+--calculateVector :: Spot -> Spot -> Velocity3+--calculateVector (Spot sourceX sourceY) (Spot destX destY) =+-- let diff = (Point2 sourceX sourceY) .-. (Point2 destX destY)+-- dir = atan2 (vector2Y diff) (vector2X diff)+-- base = fromPolar dir 10+-- addon = 0.1 *^ diff+-- result = base ^+^ addon+-- in vector3 (vector2X result) (vector2Y result) 2++spotValue :: [VisibleState] -> Team -> GridElement -> Double+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+ freeValue = 0 -- missing yet+ in gridValue + freeValue++spotFromGE (GridElement spot _ _) = spot+homeValueFromGE (GridElement _ homeValue _) = homeValue+awayValueFromGE (GridElement _ _ awayValue) = awayValue+++-- was wenn kein spot da? dann sollte das nicht hinkacheln, vielleicht besser+-- maybe spot zurückgeben+bestSpot :: [VisibleState] -> Team -> Spot -> Grid -> Spot+bestSpot vss team currSpot =+ spotFromGE . maximumBy (compareSpots vss team) .+ filter (viableSpot vss team currSpot . spotFromGE)+-- die bearbeitungsreihenfolge ist vielleicht etwas doof, weil die viableSpot+-- berechnung mit der ganzen sortiererei vielleicht etwas aufwändiger ist als+-- die bewertung der spots++compareSpots vss =+ comparing . spotValue vss++putGrid param m n =+ forM_ (grid param 10 10) $+ \(GridElement (Spot x y) vx vy) -> putStrLn $ show x ++ "; " ++ show y ++ "; " ++ show vx ++ "; " ++ show vy+
+ Helper.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE FlexibleInstances #-}++module Helper++where++import Debug.Trace++import Data.Maybe+import Data.List+import Data.Ord+import Data.Function+import GHC.Exts++import FRP.Yampa+import FRP.Yampa.Geometry+import FRP.Yampa.Point2++import Object+import Message+import Command+import States+import Physics+import Global+import BasicTypes+import AL++-- *************************************************************************+--+-- Various geometric functions+--+-- *************************************************************************++spotToPoint (Spot x y) = Point2 x y+pointToSpot (Point2 x y) = Spot x y++distanceToSpot :: Spot -> Point2 Double -> Point2 Double -> Ordering+distanceToSpot (Spot x y) =+ comparing (distance (Point2 x y))++spotDistance (Spot x1 y1) p =+ distance (Point2 x1 y1) p+++tm x = PlayerMessage $ TacticalPlayerMessage x+pm x = PlayerMessage $ PhysicalPlayerMessage x++otherTeam Home = Away+otherTeam Away = Home++lastPlayer ballState =+ case ballState of+ (_, BPWho oid _) -> oid+ (_, BPInit _ oid) -> oid+ (_, BPOutOfPlay _ _ _ oid) -> oid++teamMates me vss =+ let team = vsTeam $ fetchVS vss me+ in [p | p@(VSPlayer {}) <- vss, vsTeam p == team, vsObjId p /= me]++teamPlayers team vss = [p | p@(VSPlayer {vsTeam = team'}) <- vss, team' == team]++fetchGoalie team vss =+ head $ filter isGoalie $ teamPlayers team vss++isGoalie = (Goalie ==) . piPlayerRole . vsPlayerInfo++playerWithBall :: [VisibleState] -> Maybe ObjId+playerWithBall vss =+ case filter hasBall vss of+ [player] -> Just $ vsObjId player+ [] -> Nothing+ pls -> error $ "Helper.hs/playerWithBall: too many players " ++ show (map vsObjId pls)++playerIsFree vss vs =+ let pos = vsPos vs+ team = vsTeam vs+ otherPlayers = teamPlayers (otherTeam team) vss+ in foldl' (\acc vso -> acc &&+ distance pos (vsPos vso) > 5) True otherPlayers+++homeValue param (Spot x y) =+ half x (pPositionFactorX param) (pPitchWidth param) ++ (pPitchLength param - y) * pPositionFactorY param++awayValue param (Spot x y) =+ homeValue param (Spot x (pPitchLength param - y))++half u factor max+ | u < (max / 2) = u * factor+ | otherwise = (max - u) * factor+++bestFreePlayer param vss ballCarrier =+ let team = vsTeam ballCarrier+ me = vsObjId ballCarrier+ valFun = if team == Home then homeValue else awayValue+ freePlayers = filter (playerIsFree vss) $ teamMates me vss+ in if null freePlayers then Nothing+ else Just $ maximumBy (compare `on` (valFun param) . pointToSpot . projectP . vsPos) freePlayers++nearestNonAIPlayer team vss pos =+ let players = [p | p@(VSPlayer {}) <- vss, vsTeam p == team, fst (vsPTState p) == TSNonAI ]+ nearest = minimumBy (\pl1 pl2 -> closerToPoint pos (projectP $ vsPos pl1) (projectP $ vsPos pl2)) players+ in vsObjId nearest++nearestAIPlayer team vss pos =+ let players = [p | p@(VSPlayer {}) <- vss, vsTeam p == team, fst (vsPTState p) /= TSNonAI ]+ nearest = minimumBy (\pl1 pl2 -> closerToPoint pos (projectP $ vsPos pl1) (projectP $ vsPos pl2)) players+ in vsObjId nearest++nearestAIFieldPlayer team vss pos =+ let players = [p | p@(VSPlayer {}) <- vss, vsTeam p == team, fst (vsPTState p) /= TSNonAI,+ (piPlayerRole . vsPlayerInfo) p /= Goalie ]+ nearest = minimumBy (\pl1 pl2 -> closerToPoint pos (projectP $ vsPos pl1) (projectP $ vsPos pl2)) players+ in vsObjId nearest++nearestPlayer team vss pos =+ let players = [p | p@(VSPlayer {}) <- vss, vsTeam p == team]+ nearest = minimumBy (\pl1 pl2 -> closerToPoint pos (projectP $ vsPos pl1) (projectP $ vsPos pl2)) players+ in vsObjId nearest++closerToPoint p p1 p2 =+ if distance p p1 < distance p p2 then LT else GT++fetchVS :: [VisibleState] -> ObjId -> VisibleState+fetchVS vss = fromJust . flip getObjVS vss++getObjVS :: ObjId -> [VisibleState] -> Maybe VisibleState+getObjVS oid [] = Nothing+getObjVS oid (vs:vss) =+ if vsObjId vs == oid then Just vs else getObjVS oid vss++fetchGameVS :: [VisibleState] -> VisibleState+fetchGameVS [] = error "Helper/fetchGameVS: No game in Visible States"+fetchGameVS (v:vs) =+ case v of+ VSGame {} -> v+ _ -> fetchGameVS vs++fetchBallVS :: [VisibleState] -> VisibleState+fetchBallVS [] = error "Helper/fetchBallVS: No ball in Visible States"+fetchBallVS (v:vs) =+ case v of+ VSBall {} -> v+ _ -> fetchBallVS vs++fetchBallCarrier vss =+ let (s, sp) = vsBallState ball+ ball = fetchBallVS vss+ in if s `elem` [BSControlled, BSControlledOOP, BSControlledGoalie]+ then Just (fetchVS vss (fromBPWho sp))+ else Nothing++ballId :: ALOut -> ObjId+ballId (AL []) = error "Helper.hs/ballId: No Ball in Object Output"+ballId (AL ((xId, xOO):xs)) =+ case xOO of+ ObjOutput (OOSBall {}) _ _ _ -> xId+ _ -> ballId (AL xs)++gameId :: ALOut -> ObjId+gameId (AL []) = error "Helper.hs/gameId: No Game in Object Output"+gameId (AL ((xId, xOO):xs)) =+ case xOO of+ ObjOutput (OOSGame {}) _ _ _ -> xId+ _ -> gameId (AL xs)+ -- time possession score1 score2+hasBall :: VisibleState -> Bool+hasBall vs = isPlayer vs && (fst . vsPBState) vs == PBSInPossession++offsiteFrontier param me vss =+-- yield the a position for the player on the offsite frontiert. needs at least 2 players in every team+ let myself = fetchVS vss me+ myTeam = vsTeam myself+ Point3 myXPos _ _ = vsPos myself+ others = teamPlayers (otherTeam myTeam) vss+ reverser = if myTeam == Home then id else reverse+ -- Achtung: Auf-/absteigend sortieren je nach Home / Away!+ Point3 _ y _ = vsPos . head . tail . reverser $ sortWith (point3Y . vsPos) others+ half = pPitchLength param / 2+ yAdjust = if myTeam == Home then min y half else max y half+ in (Point2 myXPos yAdjust)+-- in (Point2 0 0)++adjustForOffsite param p@(Point2 x y) me vss =+ let pOff@(Point2 xOff yOff) = offsiteFrontier param me vss+ myself = fetchVS vss me+ myTeam = vsTeam myself+ ballCarrier = hasBall myself+ in+ if not ballCarrier &&+ (((myTeam == Home && y < yOff) ||+ (myTeam == Away && y > yOff)))+ then pOff else p++basePosition :: Param -> ObjId -> [VisibleState] -> Team -> TacticalStateParam+basePosition param me vss attacker =+-- yield me's optimal position in relation to the ball and his state (attacking or defending)+ let pi = vsPlayerInfo $ fetchVS vss me+ defensivePos = piBasePosDefense pi+ offensivePos = piBasePosOffense pi+ myTeam = vsTeam $ fetchVS vss me+ ball = fetchBallVS vss+ posBall = projectP . vsPos $ ball+ adjust = posBall .-. pitchCenter param+ adjust' = vector2 (pHorizontalShiftRatio param * vector2X adjust) (pVerticalShiftRatio param * vector2Y adjust)+-- defPos = limitPosition (border, pitchWidth + border, border + lineEnds, pitchLength + border - lineEnds) (defensivePos .+^ adjust')+ defPos = limitPosition (0, pPitchWidth param, pLineEnds param, pPitchLength param - pLineEnds param) (defensivePos .+^ adjust')+ offPos = adjustForOffsite param offensivePos me vss+ in TacticalStateParam (Just $ if myTeam == attacker then offPos else defPos)+ Nothing+ False+ Nothing+ Nothing+ Nothing+ Nothing++-- *************************************************************************+--+-- Various geometric functions+--+-- *************************************************************************++limitPosition (xmin, xmax, ymin, ymax) (Point2 px py) =+ Point2 (minmax xmin xmax px) (minmax ymin ymax py)+ where minmax min max z = if z < min then min else if z > max then max else z++noPoint = Point2 (-1) (-1)+zeroVel = vector3 0 0 0++sameDirection :: Param -> Velocity2 -> Velocity2 -> Bool+sameDirection param u v =+ abs(vector2Rho u) > pEps param &&+ abs((vector2Rho u + vector2Rho v) - vector2Rho (u ^+^ v)) < pEps param++inOneSecond pos vel = pos .+^ vel++(.+!) :: (Point2 Double) -> Double -> (Point3 Double)+(Point2 x y) .+! z = (Point3 x y z)+++(^+!) :: (Vector2 Double) -> Double -> (Vector3 Double)+v ^+! z =+ let x = vector2X v+ y = vector2Y v+ in vector3 x y z++project :: Velocity3 -> Velocity2+project v = vector2 x y+ where x = vector3X v+ y = vector3Y v++projectP :: Position3 -> Position2+projectP v = Point2 x y+ where x = point3X v+ y = point3Y v++brake :: Param -> Velocity3 -> Double -> Velocity3+brake param v a =+ vector3 (-b*x) (-b*y) (pGravity param)+ where x = vector3X v+ y = vector3Y v+ b = a / vector2Rho (vector2 x y)++halfPi = pi / 2++(Point2 x y) ^-. v = Point2 (vector2X v - x) (vector2Y v - y)++normTheta x+ | x < (- pi) = x + 2 * pi+ | x > pi = x - 2 * pi+ | otherwise = x++lookTo p0 p1 =+ p0 .+^ (0.0001 *^ normalize (p1 .-. p0))++towards :: Spot -> Spot -> Vector3 Double+towards curr dest =+ let delta = 20 *^ normalize (spotToPoint dest .-. spotToPoint curr)+ in delta ^+! 0++turnBy :: Vector2 Double -> Vector2 Double -> Vector2 Double+u `turnBy` v =+ fromPolar (vector2Theta u - vector2Theta v) (vector2Rho u)++isLeftFrom :: Vector2 Double -> Vector2 Double -> Bool+u `isLeftFrom` v =+ normTheta (vector2Theta (u `turnBy` v)) >= 0++u `isRigthFrom` v = v `isLeftFrom` u++sameDirAs :: Vector2 Double -> Vector2 Double -> Bool+u `sameDirAs` v =+ let theta = normTheta $ vector2Theta (u `turnBy` v)+ in+ (theta > 0 && theta < pi/2) || (theta < 0 && theta > -(pi/2))++toPolar x y =+ (atan2 y x, sqrt ((x*x) + (y*y)))++getAngle v = atan2 (vector2Y v) (vector2X v)++fromPolar theta rho =+ vector2 (rho * cos theta) (rho * sin theta)++fromPolar3 theta rho z =+ vector3 (rho * cos theta) (rho * sin theta) z++limit max v =+ let len = norm v+ in+ if len > max then (max/len) *^ v else v++mirrorPoint (Point2 x y) (Point2 ax ay) =+ Point2 (mirrorAt x ax) (mirrorAt y ay)++mirrorAt x axis = 2 * axis - x++sqr x = x * x+-- *************************************************************************+--+-- Parameters+--+-- *************************************************************************++awayGoalCenter param = Point2 (pPitchWidth param / 2) 0+homeGoalCenter param = Point2 (pPitchWidth param / 2) (pPitchLength param)+pitchCenter param = Point2 (pPitchWidth param / 2) (pPitchLength param / 2)++-- *************************************************************************+--+-- Messages and commands+--+-- *************************************************************************++comToMsg (CmdKickHigh dt) = [pm (PPTLoseMe, BSPRelease dt RTHigh)]+comToMsg (CmdKickLow dt) = [pm (PPTLoseMe, BSPRelease dt RTLow)]+comToMsg (CmdPassHigh dt) = [pm (PPTLoseMe, BSPPass dt RTHigh Nothing)]+comToMsg (CmdPassLow dt) = [pm (PPTLoseMe, BSPPass dt RTLow Nothing)]+comToMsg CmdFlipHigh = [pm (PPTLoseMe, BSPPass 1 RTHigh Nothing)]+comToMsg CmdFlipLow = [pm (PPTLoseMe, BSPPass 1 RTLow Nothing)]+--comToMsg pos CmdMoveForward = [tm (TPTMoveTo, TacticalStateParam (Just $ pos .+^ vector2 0 (-20))+-- Nothing False Nothing+-- Nothing Nothing)]+comToMsg _ = []++-- *************************************************************************+--+-- Various generic list and tupel functions+--+-- *************************************************************************++collect :: (Eq a) => [(a,b)] -> [(a, [b])]+collect [] = []+collect ((a, b) : rest) =+ (a, b:fetch a rest) : collect (remove a rest)++fetch :: (Eq a) => a -> [(a,b)] -> [b]+fetch a = map snd . filter (\(a',b) -> a == a')++remove a = filter (\(a',b) -> a /= a')++mergeList :: (Eq a) => [(a, [b])] -> [(a, [b])]+mergeList =+ map (\(a,bs) -> (a, concat bs)) . collect++fst3 (a, b, c) = a+snd3 (a, b, c) = b+thrd3 (a, b, c) = c++fromRight (Right x) = x++
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Martin Wöhrle++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Martin Wöhrle nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Lineup.hs view
@@ -0,0 +1,207 @@+module Lineup where++import Debug.Trace++import Data.List+import Data.Maybe+import Data.Ord++import FRP.Yampa+import FRP.Yampa.Geometry++import Object+import ObjectBehaviour+import Message+import AL+import Global+import BasicTypes+import Helper+import States+import Physics+++lineupKickoff :: Param -> ALOut -> Time -> Team -> Int -> Int -> (ALOut, ALObj)+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+ 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+ in+#if DEBUG_MODE+ trace ("Lineup durchgeführt" +++ show ((ballOos `appendAL` gameOos `appendAL` homeOos `appendAL` awayOos)) +++ show "Home=" ++ show (map fst $ assocsAL homeObjs) +++ show "Away=" ++ show (map fst $ assocsAL awayObjs)) $+#endif+ (ballOos `appendAL` gameOos `appendAL` homeOos `appendAL` awayOos,+ ballObjs `appendAL` gameObjs `appendAL` homeObjs `appendAL` awayObjs)+++-- *************************************************************************+--+-- Player lineups+--+-- *************************************************************************++-- returns the lineup for given team on kickoff, depending on whether team+-- kicks off or nor, and also the player who has the ball on kickoff (if any)+lineupKickoffTeam :: Param -> ALOut -> Team -> Bool -> (ALOut, ALObj, Maybe (ObjId, ObjId))+lineupKickoffTeam param oos team kicksoff =+ let players = (filterAL ((== team) . fst3 . oosTeamInfo) .+ mapAL (ooObsObjState . snd) .+ filterAL isPlayerOO) oos+ sorted = fromAssocs $+ 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+ basePls = if kicksoff then deleteAL kicksOffPlId $+ deleteAL kickedToPlId players+ else players+ (baseOuts, baseObjs) = mkBase param team basePls+ (kicksOut, kicksObjs) = if kicksoff then mkObjs param team+ (kicksOffPlId, kicksOffPl)+ (kickedToPlId, kickedToPl)+ else (emptyAL, emptyAL)+ in (baseOuts `appendAL` kicksOut,+ baseObjs `appendAL` kicksObjs,+ if kicksoff then Just (kicksOffPlId, kickedToPlId)+ else Nothing+ )++isPlayerOO (ObjOutput {ooObsObjState = OOSPlayer {}}) = True+isPlayerOO _ = False++mkBase param team oos =+ (mapAL (mkStandardPlayerObjOutput . snd) oos,+ mapAL (uncurry (mkStandardPlayerObject param team)) oos)++mkObjs param team (fromId, fromPl) (toId, toPl) =+ let toOut = mkKickedToPlayerObjOutput param team toPl+ toObj = mkKickedToPlayerObject param toId team toPl++ fromOut = mkKicksOffPlayerObjOutput param team fromPl+ fromObj = mkKicksOffPlayerObject param fromId team fromPl++ in (fromAssocs [(toId, toOut), (fromId, fromOut)],+ fromAssocs [(toId, toObj), (fromId, fromObj)])++basePos = piBasePosDefense. oosPlayerInfo++kicksOffPosition param team+-- | team == Home = Point2 42 52 -- basierend auf 80, 96 muss man noch verformeln+-- | team == Away = Point2 38 44+ | team == Home = Point2 (pPitchWidth param / 2 + 2) (pPitchLength param / 2 + 1)+ | team == Away = Point2 (pPitchWidth param / 2 - 2) (pPitchLength param / 2 - 1)+++kickedToPosition param team+-- | team == Home = Point2 35 50+-- | team == Away = Point2 45 46+ | team == Home = Point2 (pPitchWidth param / 2 - 5) (pPitchLength param / 2)+ | team == Away = Point2 (pPitchWidth param / 2 + 5) (pPitchLength param / 2)+++----------------------------------------------------------------------------------+--+-- create ObjOutput for player+--+----------------------------------------------------------------------------------++mkpoo :: Position2 -> ObsObjState -> ObjOutput+mkpoo pos oos = ObjOutput+ oos {oosPos = pos .+! 0}+ NoEvent NoEvent []++mkStandardPlayerObjOutput :: ObsObjState -> ObjOutput+mkStandardPlayerObjOutput oos = mkpoo (basePos oos) oos++mkKickedToPlayerObjOutput param = mkpoo . kickedToPosition param+mkKicksOffPlayerObjOutput param = mkpoo . kicksOffPosition param+++----------------------------------------------------------------------------------+--+-- create Object for player+--+----------------------------------------------------------------------------------++mkpo :: Param -> ObjId -> ObsObjState -> Position2 -> BasicState -> Angle -> Object+mkpo param oid oos pos pbsInit angle0 =+ maker param+ oid+ 0+ pos+ (vector3 0 0 0)+ angle0+ (oosSelected oos)+ False --(oosDesignated oos)+ (oosTeamInfo oos)+ (oosPlayerInfo oos)+ pbsInit+ NoFoot+ (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 oid team oos =+ mkpo param oid oos (kickedToPosition param team) PBSNoBall (if team == Home then 0 else pi)+mkKicksOffPlayerObject param oid team oos =+ mkpo param oid oos (kicksOffPosition param team) PBSInPossession (if team == Home then pi else 0)+++-- *************************************************************************+--+-- Ball lineup+--+-- *************************************************************************++lineupKickoffBall :: Param -> ObjId -> ObjId -> Time -> (ALOut, ALObj)+lineupKickoffBall param ballId playerId t0 =+ let (_, bobjs, boos) = mkBallInPossession param+ ballId+ playerId+ t0+ False+ playerId+ (pitchCenter param .+! 0)+ (vector3 0 0 0)+ []+ in (fromAssocs [(ballId, boos)],+ fromAssocs [(ballId, bobjs)])+++-- *************************************************************************+--+-- Game lineup+--+-- *************************************************************************++lineupKickoffGame :: Param -> ObjId -> Time -> Team -> Int -> Int -> (ALOut, ALObj)+lineupKickoffGame param oid time possession scoreHome scoreAway =+ let goos = ObjOutput+ (OOSGame time+ (scoreHome, scoreAway)+ (GSKickOff, GPTeamPosition possession (pitchCenter param) time True)+ possession+ (Point3 (-10) (-10) 0))+ NoEvent+ NoEvent+ []+ gobj = game param oid possession scoreHome scoreAway time+ in (fromAssocs [(oid, goos)],+ fromAssocs [(oid, gobj)])
+ Main.hs view
@@ -0,0 +1,147 @@+module Main where++import System.Directory+import System.FilePath ((</>))+import Data.IORef+import Data.Convertible+import Data.Time.Clock+import Data.List+import Data.Ord++import FRP.Yampa+import FRP.Yampa.Geometry++import qualified Graphics.UI.SDL as SDL++import qualified Render as Render+import RenderUtil++import Object+import ObjectBehaviour+import Animate+import AL+import States+import BasicTypes+import Message+import Global+import Grid+import Parser+import ParseTeam+import Helper+import Object+import Lineup+import AI++spainBorder = rgbColor 252 0 2+spainCircle = rgbColor 255 255 1++germanyBorder = rgbColor 0 0 0+germanyCircle = rgbColor 255 255 255++tiHome = (Home, spainBorder, spainCircle)+tiAway = (Away, germanyBorder, germanyCircle)++main :: IO ()+main = do+ setupBasicFiles+ sdl <- Render.init+ (playersHome, playersAway, param) <- paramFromOutside+ mainLoop sdl playersHome playersAway param+ SDL.quit++mainLoop sdl playersHome playersAway param = do+ sdlState <- newIORef Nothing+ writeIORef sdlState (Just sdl)+ bos <- baseObjs param+ let pls = playersInit param playersHome playersAway+ let alout = appendAL bos pls+ frameCounter <- newIORef 0 :: IO (IORef Int)+ t <- getCurrentTime+ let t' = convert t :: Double+ timeState <- newIORef t' --(convert t :: Double)+ let (lOO,lObj) = lineupKickoff param alout 0 Home 0 0+ Render.render param (map ooObsObjState $ elemsAL lOO) sdl+ Render.renderStartMsg sdl+ waitForSpaceKey+ animate param sdlState t' timeState frameCounter $ mergeAL lObj lOO+ count <- readIORef frameCounter+ now <- getCurrentTime+ let seconds = convert now - 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 =+ let+ g = (1, ObjOutput (OOSGame 0 (0, 0) (GSKickOff, GPTeamPosition Home (Point2 0 0) 0 False) Home (Point3 0 0 0))+ NoEvent NoEvent [])++ -- CAUTION: Always start with a valid player id!!+ ball = (4, ObjOutput (OOSBall (Point3 0 0 0) (vector3 0 0 0) False (BSFree, BPWho 0 0))+ NoEvent NoEvent [])++ in return $ AL [g, ball]+++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+ axis = Point2 (pPitchWidth param / 2) (pPitchLength param / 2)+ kicksOff = piNumber $ minimumBy (\p1 p2 -> comparing dist p1 p2) playersHome+ dist pi = distance (piBasePosDefense pi) kickOffSpot+ kickOffSpot = Point2 (pPitchWidth param / 2) (pPitchLength param / 2)+ 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+ (PBSNoBall, BSPNothing)+ (TSWaitingForKickOff, tspNull)+ NoFoot+ )+ NoEvent NoEvent []+ mirrorPlayer p@(PlayerInfo { piBasePosDefense = pd, piBasePosOffense = po }) =+ p{ piBasePosDefense = mirrorPoint pd axis, piBasePosOffense = mirrorPoint po axis }++ in AL $ h ++ a+++paramFromOutside :: IO ([PlayerInfo], [PlayerInfo], Param)+paramFromOutside = do+ dir <- getAppUserDataDirectory "Rasenschach"+ putStrLn dir+ Right (pHome, rulesHome) <- getTeam $ dir </> "home.team"+ Right (pAway, rulesAway) <- getTeam $ dir </> "away.team"+ 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,+ pGoalWidth = 10.32,++ pMaxheight = 60.0, -- in Meter++ pGravity = -10.0,+ pBouncingTime = 0.5,++ pPositionFactorX = 1.0,+ pPositionFactorY = 1.0,++ pVerticalShiftRatio = 1.0,+ pHorizontalShiftRatio = 0.3,++ pLineEnds = 10.0,++ pGameLength = 120.0,++ pRuleBaseHome = rulesHome,+ pRuleBaseAway = rulesAway,++ pGrid = undefined+ }+ return $ (pHome, pAway, param {pGrid = grid param 10 10})
+ Message.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}++module Message++where++import FRP.Yampa+import FRP.Yampa.Geometry+import Physics+import BasicTypes++type Message = (ObjId, MessageBody)++data MessageBody =+ BallMessage BallMessage+ | PlayerMessage PlayerMessage+ | GameMessage GameMessage+ deriving (Eq, Show)+++-- *************************************************************************+--+-- Ball Messages+--+-- *************************************************************************++data BallMsgParam =+ BPWho ObjId Time -- player currently touching the ball and when he touched it+ | BPInit (Vector3 Double) ObjId -- starting speed and last player to touch the ball+ | BPOutOfPlay Team OutOfPlay Position2 ObjId -- team to throw in, type of outofplay (throw in,+ -- kick off, corner, free kick) and last player to touch+ -- the ball+ deriving Eq++instance Show BallMsgParam where+ show (BPWho x t) = "BWho " ++ show x ++ " " ++ show t+ show (BPInit _ x) = "BPInit " ++ show x+ show (BPOutOfPlay team oop pos oid) = "BPOOP " ++ show team ++ " "+ ++ show oop ++ " " ++ show pos+ ++ " " ++ show oid+type BallStateParam = BallMsgParam+type BallMessage = (BallTransition, BallMsgParam)+data BallTransition =+ BTGained+ | BTLost+ | BTCollisionB+ | BTOutOfPlay+ | BTGainedOOP+ | BTLostOOP+ | BTGainedGoalie+ deriving (Show, Eq, Ord)+++-- *************************************************************************+--+-- Player Messages+--+-- *************************************************************************++data PlayerMessage =+ PhysicalPlayerMessage PhysicalPlayerMessage+ | TacticalPlayerMessage TacticalPlayerMessage+ deriving (Show, Eq)++data ReleaseType = RTHigh | RTLow | RTNothing+ deriving (Show, Eq)++data BasicMsgParam =+ BSPNothing+ | BSPWhoAndWhen ObjId Time+ | BSPUnstun Time++ -- duration of key pressed, type of kick+ | BSPRelease Time ReleaseType+ | BSPPass Time ReleaseType (Maybe ObjId) -- optional: pass receiver, if Nothing pass to designated+ | BSPShoot Velocity3+ deriving (Show, Eq)++type BasicStateParam = BasicMsgParam++type PhysicalPlayerMessage = (PhysicalPlayerTransition, BasicMsgParam)+data PhysicalPlayerTransition =+ PPTTakeMe+ | PPTLoseMe+ | PPTStun+ | PPTUnStun+ | PPTCollisionP+ | PPTPrepareThrowIn+ | PPTThrowIn+ deriving (Show, Eq, Ord)++instance Show Position3+ where show (Point3 x y z) = "(" ++ show x ++ ", " ++ show y ++ ", " ++ show z ++ ")"++data TacticalStateParam = TacticalStateParam {+ tspDesiredPos :: Maybe Position2+ ,tspDesiredVector :: Maybe Velocity3+ ,tspKicked :: Bool -- true when player has kicked the ball (necessary for rendering)+ ,tspPlayerId :: Maybe ObjId -- e.g. for covering another player+ ,tspDirection :: Maybe Angle -- direction where player is looking+ ,tsKickType :: Maybe ReleaseType+ ,tsTime :: Maybe Time -- not yet in use, can for instance track the time when+ -- state was entered...+} deriving (Show, Eq)++tspNull = TacticalStateParam Nothing+ Nothing+ False+ Nothing+ Nothing+ Nothing+ Nothing :: TacticalStateParam++type TacticalPlayerMessage = (TacticalPlayerTransition, TacticalStateParam)+data TacticalPlayerTransition =+ TPTWait+ | TPTCover+ | TPTHoldPosition+ | TPTMoveTo+ | TPTMoveToThrowIn+ | TPTIntercept+ | TPTDropInterception+ | TPTWaitForThrowIn+ | TPTAimThrowIn+ | TPTReposition+ | TPTKickedOff+ | TPTWaitForKickOff+ | TPTDesignateReceiver+ | TPTFreeze+ | TPTSwitchControl+ | TPTKickTowards+ | TPTTendGoal+ deriving (Show, Eq)++instance Ord TacticalPlayerTransition where+ x < y = translate x < translate y+ where+ translate TPTWaitForKickOff = 5+ translate TPTWait = 10+ translate TPTMoveTo = 20+ translate TPTHoldPosition = 30+ translate TPTCover = 40+ translate TPTIntercept = 50+ translate TPTDropInterception = 60+ translate TPTWaitForThrowIn = 70+ translate TPTMoveToThrowIn = 80+ translate TPTAimThrowIn = 90+ translate TPTReposition = 100+ translate TPTKickedOff = 200+ translate TPTDesignateReceiver = 2+ translate TPTFreeze = 210+ translate TPTSwitchControl = 215+ translate TPTKickTowards = 216+ translate TPTTendGoal = 10++ x <= y = x == y || x < y+ x > y = not $ x < y+ x >= y = x == y || x > y+ min x y = if x < y then x else y+ max x y = if x > y then x else y+++-- *************************************************************************+--+-- Game Messages+--+-- *************************************************************************++data GameTransition =+ GTSideOut+ | GTBaseOut+ | GTGoal+ | GTOffsite+ | GTQuit+ | GTFreeze+ | GTBallInPlay+ | GTTakePossession+ | GTRunGame+ | GTWaitKickOff+ 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+ 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"++type GameStateParam = GameMsgParam+type GameMessage = (GameTransition, GameMsgParam)+++-- *************************************************************************+--+-- General Types and Helper Functions+--+-- *************************************************************************++type Collisions = [ObjId]++isBallMessage mb = case mb of BallMessage _ -> True; _ -> False+isPhysicalPlayerMessage mb = case mb of PlayerMessage (PhysicalPlayerMessage _) -> True; _ -> False+isTacticalPlayerMessage mb = case mb of PlayerMessage (TacticalPlayerMessage _) -> True; _ -> False+isGameMessage mb = case mb of GameMessage _ -> True; _ -> False++fromBPWho (BPWho x _) = x
+ Object.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}++module Object++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+import States+import BasicTypes+++------------------------------------------------------------------------------+-- Object and related types+------------------------------------------------------------------------------++-- Objects are represented by signal functions, i.e. they are reactive and+-- can carry internal state.++type Object = SF ObjInput ObjOutput++type ALOut = AL ObjId ObjOutput+type ALObj = AL ObjId Object++--data MessageBody = GotoPosition Position2 | Wait+++data ObjInput = ObjInput {+ oiMessages :: !([MessageBody], Collisions),+ oiGameState :: ![VisibleState],+ oiGameInput :: !Input -- Mouse und Keyboard+}++data ObjOutput = ObjOutput {+ ooObsObjState :: !ObsObjState,+ ooKillReq :: !(Event ()),+ ooSpawnReq :: !(Event [Object]),+ ooMessages :: ![Message]+}+instance Show ObjOutput where+ show (ObjOutput o _ _ _) = case o of+ OOSBall {} -> "OOSBall"+ OOSPlayer {} -> "OOSPlayer"+ OOSGame {} -> "OOSGame"+++-- To avoid space leaks, all fields (except possibly dependent ones) are+-- strict.+data ObsObjState =+ OOSBall {+ oosPos :: !Position3,+ oosVel :: !Velocity3,+ oosBounced :: !Bool,+ oosBState :: !(BallState, BallStateParam)+ }+ | OOSPlayer {+ oosPos :: !Position3,+ oosVel :: !Velocity3,+ oosAcc :: !Acceleration3,+ oosKicked :: !Bool,+ oosSelected :: !Bool,+ oosDesignated :: !Bool,+ oosRadius :: !Length,+ oosTeamInfo :: !TeamInfo,+ oosPlayerInfo :: !PlayerInfo,+ oosDir :: !Heading, -- Winkel in Bogenmaß (0 Grad: rechts, pi/2 Grad: oben etc.)+ oosBasicState :: !(BasicState, BasicStateParam),+ oosTacticalState :: !(TacticalState, TacticalStateParam),+ oosOnFoot :: !OnFoot+ }+ | OOSGame {+ oosGameTime :: !Time,+ oosGameScore:: !(Int, Int),+ oosGameState:: !(GameState, GameStateParam),+ oosAttacker :: !Team,+ oosPos :: !Position3 -- Dummy, zum Sortieren...+ }+++-- Subset of ObjOutput that is visible to the other objects in the game+-- ObjId is needed for directing a message to the corresponding object+data VisibleState =+ VSBall {+ vsObjId :: !ObjId,+ vsMessages :: ![Message],+ vsPos :: !Position3,+ vsVel :: !Velocity3,+ vsBallState :: !(BallState, BallStateParam)+ }+ | VSPlayer {+ vsObjId :: !ObjId,+ vsMessages :: ![Message],+ vsPos :: !Position3,+ vsVel :: !Velocity3,+ vsAcc :: !Acceleration3,+ vsDesignated:: !Bool,+ vsTeam :: !Team,+ vsPlayerInfo:: !PlayerInfo,+ vsDir :: !Heading, -- Winkel in Bogenmaß (0 Grad: rechts, pi/2 Grad: oben etc.)+ vsPBState :: !(BasicState, BasicStateParam),+ vsPTState :: !(TacticalState, TacticalStateParam),+ vsOnFoot :: !OnFoot+ }+ | VSGame {+ vsObjId :: !ObjId,+ vsMessages :: ![Message],+ vsGameTime :: !Time,+ vsGameScore :: !(Int, Int),+ vsAttacker :: !Team,+ vsGameState :: !(GameState, GameStateParam)+ }+++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+ OOSGame t sc st att _ -> VSGame oid msg t sc att st+ where msg = ooMessages os++------------------------------------------------------------------------------+-- Instances+------------------------------------------------------------------------------++instance Forceable ObsObjState where+ -- If non-strict fields: oosNonStrict1 obj `seq` ... `seq` obj+ force obj = obj++------------------------------------------------------------------------------+-- Recognizers+------------------------------------------------------------------------------++isBall :: VisibleState -> Bool+isBall (VSBall {}) = True+isBall _ = False++isPlayer :: VisibleState -> Bool+isPlayer (VSPlayer {}) = True+isPlayer _ = False++++newtype RuleId = RuleId Int deriving (Show, Eq)++type RuleName = String++newtype Priority = Priority Int deriving (Show, Eq, Ord)++type RuleFunction = [ObjId ] -> Facts -> [VisibleState] -> Maybe [Message]++instance Show RuleFunction where+ show x = "RuleFunction"++data Rule = Rule {+ opRuleId :: RuleId,+ opRuleName :: RuleName,+ opPriority :: Priority,+ opRule :: RuleFunction+ } deriving (Show)++type RuleBase = [Rule]+
+ ObjectBehaviour.hs view
@@ -0,0 +1,657 @@+{-# LANGUAGE Arrows, FlexibleInstances #-}++module ObjectBehaviour -- (ball, ballInPossession, player, playerAI, game)+where++import Debug.Trace++import GHC.Exts+import Data.List+import Data.Maybe+import Control.Monad (guard)+import Graphics.UI.SDL (Pixel)++import FRP.Yampa+import FRP.Yampa.Utilities+import FRP.Yampa.Geometry+import FRP.Yampa.Point2++import Data.FSM++import Physics+import Object+import Parser+import Command+import Message+import PlayerFSM+import BallFSM+import GameFSM+import States+import Helper+import Global+import BasicTypes+import AI+import Rules++-- *************************************************************************+--+-- Object: Ball+--+-- *************************************************************************++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+-- 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+-- and respawns as a corresponding SF++ v <- (v0 ^+^) ^<< integral -< acc+ p <- (p0 .+^) ^<< integral -< v++ bounced <- edge -< point3Z p + pEps param < pGround param+ stopped <- edge -< sameDirection param (project v) (project acc)++ -- drop redundant collisions+ (collisions, cNext) <- ballCollisionSF initColls -< colls++ let ms = map (\(BallMessage msg) -> msg) $ filter isBallMessage mi+ let mcs =+#if DEBUG_MODE+ trace ("Ball (Free): " ++ show (ms ++ collisions))+#endif+ (ms ++ collisions)+ (bs@(st,stParam), msOut') <- freeBallSF (BPWho lpInit t0) -< ((BPWho me t1, vss), (Event mcs))++ let lp = lastPlayer bs++ let msOut =+#if DEBUG_MODE+ trace ("Ball (Free) messages: " ++ show msOut' ++ show (lineCrossedMsgs param t1 (content st) p lpInit vss))+#endif+ (msOut' ++ lineCrossedMsgs param t1 (content st) p lpInit vss)++ gainedControl <- edge -< content st `elem` [BSControlled, BSControlledGoalie]+ outOfPlay <- edge -< content st == BSOutOfPlay+ let goalieHasGained = content st == BSControlledGoalie++ returnA -< (ObjOutput (OOSBall p v (isEvent bounced && vector3Z v < (-5)) ((content st), stParam))+ (gainedControl `merge` outOfPlay)+ ( -- what about cNext??+ (gainedControl `tag` [snd3 $ mkBallInPossession param me (fetchPlayer stParam) t1+ goalieHasGained lp (p .-^ vector3 (-2) (-2) 0) v colls])+ `merge`+ (outOfPlay `tag` [let BPOutOfPlay team oop pos _ = stParam in ballOutOfPlay param me lp team oop pos])+ )+ msOut,+ tag (merge bounced stopped) $+ let z = max (point3Z p) (pGround param)+ vz = if z == pGround param then (-0.7) * vector3Z v else vector3Z v+ (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++ -- drop redundant collisions+ (collisions, cNext) <- ballCollisionSF initColls -< colls++ let ms = map (\(BallMessage msg) -> msg) $ filter isBallMessage mi+ let mcs =+#if DEBUG_MODE+ trace ("Ball (Poss): " ++ 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+ let Just playerVS = getObjVS currPlayer vss++ -- ball is either on the left or right foot of the player, ball position will be+ -- adjusted accordingly+ let foot = case vsOnFoot playerVS of+ LeftFoot -> -(pi / 4)+ RightFoot -> pi / 4+ _ -> 0++ -- position and velocity of the ball are taken from the player's+ -- respective values+ let p = vsPos playerVS .-^ fromPolar3 (foot + pi + vsDir playerVS) 2.1 0+ let v = vsVel playerVS++ lostPossession <- edge -< content st == BSFree+ outOfPlay <- edge -< content st == BSOutOfPlay++ returnA -< ObjOutput (OOSBall p v False ((content st), stParam))+ (lostPossession `merge` outOfPlay)+ (+ (lostPossession `tag` [snd3 $ mkBall (param, me, currPlayer, t1, p, (fetchVel stParam), (makeBreakVector (fetchVel stParam)), cNext)])+ `merge`+ (outOfPlay `tag` [let BPOutOfPlay team oop pos _ = stParam in ballOutOfPlay param me currPlayer team oop pos])+ )+ (ems ++ lineCrossedMsgs param t1 (content st) p currPlayer vss)+ where fetchPlayer (BPWho who _) = who++makeBreakVector vel =+ let vel2 = project vel+ (theta, rho) = toPolar (vector2X vel2) (vector2Y vel2)+ (theta', rho') = (normTheta (theta + pi), 3)+ vel2' = fromPolar theta' rho'+ in vector3 (vector2X vel2') (vector2Y vel2') (-10)++fetchVel (BPInit vel _) = vel+fetchVel _ = zeroVel++lineCrossedMsgs :: Param -> Time -> BallState -> (Point3 Double) -> ObjId -> [VisibleState] -> [Message]+lineCrossedMsgs param t st pos lastPlayer 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))]+++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+-- -- 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+-- -- behind and above the player's head if it's a throw-in and the ball has been taken up by+-- -- a player (then the position changes when the player turns around)+-- -- b.) when the ball goes in play again, the SF kills itself and respawns as a+-- -- ball-SF+-- let ms = map (\(BallMessage msg) -> msg) $ filter isBallMessage mi+-- let mcs = trace ("Ball (Poss): " ++ show (ms ++ collisions)) (ms ++ collisions)+-- ((st,stParam), ems) <- controlledBallSF (BPWho player) -< ((BPWho me, vss), (Event mcs))++ -- drop redundant collisions+ (collisions, cNext) <- ballCollisionSF [] -< colls++ let ms = map (\(BallMessage msg) -> msg) $ filter isBallMessage mi+ let mcs =+#if DEBUG_MODE+ trace ("Ball (Poss): " ++ show (ms ++ collisions))+#endif+ (ms ++ collisions)+ (bs@(st,stParam), ems) <- outOfPlayBallSF (BPOutOfPlay team oopType pos lpInit) -< ((BPWho me t1, vss), (Event mcs))++ let lp = lastPlayer bs++ let Just playerVS = getObjVS lp vss++ controlled <- taggedEdge -< (content st == BSControlledOOP, 2.5)+ posZ <- hold 0 -< controlled++ -- position is above and behind player+ let posAdjust = if (content st) == BSControlledOOP then+ vsPos playerVS .-^ fromPolar3 (vsDir playerVS) 3 (-posZ)+ else pos .+! posZ++ backInPlay <- edge -< not $ content st `elem` [BSOutOfPlay, BSControlledOOP, BSChallenged]++ returnA -< ObjOutput (OOSBall posAdjust zeroVel False ((content st), stParam))+ backInPlay+ (backInPlay `tag` [snd3 $ mkBall (param, me, lp, t1, posAdjust,+ fetchVel stParam,+ makeBreakVector (fetchVel stParam),+ cNext)])+ ems+++-- *************************************************************************+--+-- Object: PlayerAI (controlled by AI)+--+-- *************************************************************************++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 =+ proc (ObjInput {oiMessages = (mi, colls), oiGameState = vss, oiGameInput = (_,(t1,_))}) -> do+ let commands = []++ let tms =+#if DEBUG_MODE+ trace ("Tactical " ++ show me ++ ": " ++ show (convertTms mi))+#endif+ (convertTms mi)++ rec++ pdDefault <- iPre p0 -< pd --projectP pos++ ((st, stParam@(TacticalStateParam maybePd vd kicked plId ovrwtDir _ timeOfPossession)), msOut)+ <- tacticalPlayerSF param initState angle0 -< ((t1, me, vss, commands), Event tms)++ let isDesignated = elem (TPTDesignateReceiver, tspNull) tms+ let isSwitchControl = elem (TPTSwitchControl, tspNull) tms++ -- desired position comes either from tactical fsm (if tactical transition yielded+ -- new pd) or default pd that is usually the last player position+ 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++ 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+ -< (pd, False, ovrwtDir, t1, commands, (msLocal ++ mi, colls), vss)++ let rm = ooMessages results++ let oos = (ooObsObjState results) { oosTacticalState = (content st, stParam), oosDesignated = isDesignated }++ returnA -< results { ooMessages = msOther ++ rm,+ ooObsObjState = oos,+ ooKillReq = if isSwitchControl then Event () else NoEvent,+ ooSpawnReq = if isSwitchControl+ then Event [ player param+ me+ t0+ (projectP pos)+ vel+ angle+ False+ False+ ti+ pi+ (fst $ oosBasicState oop)+ (oosOnFoot oop)+ (if content st == TSWaitingForKickOff+ then TSNonAIKickingOff+ else TSNonAI) ]+ else NoEvent }+++-- *************************************************************************+--+-- Object: Player (controlled by human)+--+-- *************************************************************************++convertTms mi = (sortWith fst (map (\(PlayerMessage (TacticalPlayerMessage tm)) -> tm) $ filter isTacticalPlayerMessage mi))++messageForNearestPlayer param npId myTeam myPos mc vss =+ (npId, if cmdTakeOver mc then+ tm (TPTSwitchControl, tspNull)+ else if cmdMoveForward mc then+ tm (TPTMoveTo,+ TacticalStateParam (Just $ posNp .+^ vector2 0 adjust)+ Nothing False Nothing Nothing Nothing Nothing)+ else if cmdMoveBackward mc then+ tm (TPTMoveTo,+ TacticalStateParam (Just $ posNp .+^ vector2 0 ((-1)*adjust))+ Nothing False Nothing Nothing Nothing Nothing)+ else if cmdMoveLeft mc then+ tm (TPTMoveTo,+ TacticalStateParam (Just $ posNp .+^ vector2 adjust 0)+ Nothing False Nothing Nothing Nothing Nothing)+ else if cmdMoveRight mc then+ tm (TPTMoveTo,+ TacticalStateParam (Just $ posNp .+^ vector2 ((-1)*adjust) 0)+ Nothing False Nothing Nothing Nothing Nothing)+ else if cmdMoveToGoal mc then+ tm (TPTMoveTo,+ TacticalStateParam (Just goalPos)+ Nothing False Nothing Nothing Nothing Nothing)+ else if cmdMoveToMe mc then+ tm (TPTMoveTo,+ TacticalStateParam (Just myPos)+ Nothing False Nothing Nothing Nothing Nothing)+ else+ tm (TPTDesignateReceiver, tspNull))++ where+ posNp = projectP . vsPos $ fetchVS vss npId+ 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+ 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)))++getKickType mc =+ if cmdFlipMeLow mc then Just RTLow+ else if cmdFlipMeHigh mc then Just RTHigh+ else Nothing++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++ -- desired position is current mouse position+ (pd, commands) <- playerInput param -< gi++ -- mark designated receiver+ let myTeam = fst3 ti+ let npId = nearestAIPlayer myTeam vss pd++ let tms =+#if DEBUG_MODE+ trace ("Tactical " ++ show me ++ ": " ++ show (convertTms mi))+#endif+ (convertTms mi)++ let comMsgs = concatMap comToMsg commands++ rec++ pos' <- iPre p0 -< projectP pos+ oosBS' <- iPre pbsInit -< oosBS++ 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)++ let running = content st /= TSNonAIKickingOff++ -- player commands will be ignored before kickoff+ let pdAdjusted = if not running then p0 -- .+^ (vector2 (-0.0000001) 0)+ -- only look, don't walk when preparing for throw in+ else if oosBS' == PBSPrepareThrowIn then lookTo pos' pd+ else pd++ 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+ msgs)+ <- 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) =+ if cmdTakeOver commands+ then (Event (),+--playerAI :: Param -> ObjId -> Time -> Position2 -> Velocity3 -> Angle -> Bool+-- -> Bool -> TeamInfo -> PlayerInfo -> BasicState -> TacticalState -> Object+ Event [playerAI param+ me+ t0+ (projectP pos)+ vel+ angle+ False+ False+ ti+ pi+ oosBS+ (oosOnFoot oop)+ (if content st == TSNonAIKickingOff+ then TSWaitingForKickOff+ else+ if piPlayerRole pi == Goalie+ then TSTendingGoal+ else TSHoldingPosition)])++ else (NoEvent, NoEvent)++ let oos = (ooObsObjState results) { oosTacticalState = (content st, stParam) }++ returnA -< results {ooMessages = maybeToList teamMateMsg ++ markMsg:msgs,+ ooObsObjState = oos,+ ooKillReq = switchAI,+ ooSpawnReq = newAI}+++-- *************************************************************************+--+-- Core player logic, used by both AI- and user controlled player+--+-- *************************************************************************++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 =+ proc (pd, kicked, ovrwtDir, t1, commands, (mi, collsIn), vss) -> do+ -- desired position is current mouse position++ let pCollsIn = filter (isPlayer . fetchVS vss) collsIn++ -- check for new collisions; every new collision will be fed to the basicPlayerFSM,+ -- the subset of new player collisions is needed for the bouncing logic+ allCollisions <- playerCollisionSF [] -< collsIn+ pCollisions <- playerCollisionSF [] -< pCollsIn++ -- save the time of the last player collision+ pCollided <- taggedEdge -< (not (null pCollisions), t1)+ pCollTime <- hold t0 -< pCollided++ -- a collision only slows a player down for a given time+ -- after that, the usual motion logic starts again+ let inPlayerCollision = not (null pCollsIn) && t1 - pCollTime < pBouncingTime param++ -- during a collision, the total acc and vel of all the players involved+ -- are evenly divided between the "colliders"; this replaced the+ -- usual acc and vel for the time of the collision+ let adjust = 1 / (1 + fromIntegral (length pCollsIn))+ let accBounce = adjust *^ bouncePower vsAcc vss (me:pCollsIn)+ 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++ 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 mcs =+#if DEBUG_MODE+ trace ("Player " ++ show me ++ ": " ++ show (pms ++ allCollisions))+#endif+ (pms ++ allCollisions)++ ((st,stParam), ems) <- basicPlayerSF pbsInit t0 -< ((t1, me, vss), (Event mcs))+ let ems' =+#if DEBUG_MODE+ trace ("Messages Player " ++ show me ++ ": " ++ show ems)+#endif+ ems++ -- toggle between left and right foot+ possGained <- edge -< content st == PBSInPossession+ let initialFoot = possGained `tag` leftOrRightFoot p dirV (vsPos $ fetchBallVS vss)+ (foot, _) <- accumHoldBy switcher (NoFoot, False) -< myjoin initialFoot toggled+++ returnA -< ObjOutput {+ ooObsObjState = OOSPlayer (Point3 (point2X p) (point2Y p) 0)+ (vector3 (vector2X v) (vector2Y v) 0)+ (vector3 (vector2X acc) (vector2Y acc) 0)+ kicked+ sel+ des+ 2+ ti+ pi+ (fromMaybe dir ovrwtDir)+ ((content st), stParam)+ (TSNonAI, tspNull)+ foot,+ ooKillReq = noEvent,+ ooSpawnReq = noEvent,+ ooMessages = ems'+ }++leftOrRightFoot pPlayer dirPlayer pBall =+ if isLeftFrom dirPlayer (projectP pBall .-. pPlayer) then LeftFoot else RightFoot++myjoin (Event NoFoot) _ = NoEvent+myjoin (Event x) NoEvent = Event (x, False)+myjoin NoEvent (Event ()) = Event (undefined, True)+myjoin NoEvent NoEvent = NoEvent+myjoin _ _ = NoEvent++switchFoot NoFoot = NoFoot+switchFoot RightFoot = LeftFoot+switchFoot LeftFoot = RightFoot++switcher (oldF, _) (newF, False) = (newF, False)+switcher (oldF, _) (_, True) = (switchFoot oldF, False)++fetchBall ((VSBall oid _ _ _ _):xs) = oid+fetchBall (_:xs) = fetchBall xs+++-- *************************************************************************+--+-- Object: Game+--+-- *************************************************************************++--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 =+ 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))+#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)]+ 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!++-- 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 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+ returnA -< ObjOutput {+ ooObsObjState = OOSGame t1 -- time+ (scoreHome, scoreAway) -- score+ (content st, stParam)+ attacker+ (Point3 0 0 0),+ ooKillReq = noEvent,+ ooSpawnReq = noEvent,+ ooMessages = msOut ++ msg -- ++ (map (\x -> (me, GameMessage x)) later)+ }++safePartition [] = ([], [])+safePartition [a] = ([a], [])+safePartition (a:as) = ([a], as)++-- *************************************************************************+--+-- Convenient maker functions+--+-- *************************************************************************++mkBall :: (Param, ObjId, ObjId, Time, Position3, Velocity3, Acceleration3, Collisions) ->+ (ObjId, SF ObjInput ObjOutput, ObjOutput)+mkBall (param, me, lp, t0, pos, v, acc, initColls) =+ (me, ball (param, me, lp, t0, pos, v, acc, initColls),+ ObjOutput (OOSBall pos v False (BSFree, undefined)) NoEvent NoEvent [])++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 [])++-- *************************************************************************+--+-- Various helper functions+--+-- *************************************************************************++residualAcc :: Param -> Acceleration2 -> Velocity2 -> Double -> Acceleration2+residualAcc param acc vel maxV =+ let accTheta = vector2Theta acc+ accRho = vector2Rho acc+ velTheta = vector2Theta vel+ velRho = vector2Rho vel+ in+ if (velRho + pEps param >= maxV) && (acc `sameDirAs` vel) then+ fromPolar (normTheta $ if acc `isLeftFrom` vel then velTheta + pi else velTheta - pi)+-- (accRho * abs (sin (accTheta - accRho))) -- häh???+ (accRho * abs (sin (accTheta - velTheta)))+ else acc++ballCollisionSF :: Collisions -> SF Collisions ([BallMessage], Collisions)+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+ let newColls = map (\c -> (PPTCollisionP, BSPWhoAndWhen c 0)) $ c1 \\ c2+ returnA -< newColls++tupelize :: [(a, b)] -> c -> [(a, (b, c))]+tupelize [] _ = []+tupelize ((x,y):xs) z = (x,(y,z)):tupelize xs z++taggedEdge :: SF (Bool, a) (Event a)+taggedEdge = proc (bool, a) -> do+ e <- edge -< bool+ returnA -< tag e a
+ ParseTeam.hs view
@@ -0,0 +1,192 @@+module ParseTeam++where++import System.Directory+import System.FilePath++import FRP.Yampa.Geometry++import Control.Monad+import BasicTypes+import Rules+import Data.List+++setupBasicFiles = do+ dir <- getAppUserDataDirectory "Rasenschach"+ createDirectoryIfMissing False dir+ homeExists <- doesFileExist $ dir </> "home.team"+ when (not homeExists) $+ writeFile (dir </> "home.team") basicSetup+ awayExists <- doesFileExist $ dir </> "away.team"+ when (not awayExists) $+ writeFile (dir </> "away.team") basicSetup++getTeam fn = do+ input <- readFile fn+ case parseFile (map removeComment $ lines input) 1 of+ err@(Left _) -> return err+ Right (players, rules) -> return $ Right (players, basicRules ++ rules)++-- comments start Haskell-like with --+removeComment :: String -> String+removeComment [] = []+removeComment [x] = [x]+removeComment ('-':'-':xs) = []+removeComment (x:xs) = x:(removeComment xs)++parseFile :: [String] -> Int -> Either (ParseErrorId, ParseErrorMsg)+ ([PlayerInfo], [Rule])+parseFile [] _ = Right ([], [])+parseFile ls counter =+ if null tokens then parseFile (tail ls) counter+ else if head tokens == "player" then do+ pi <- parsePlayer (head ls)+ (pis, rs) <- parseFile (tail ls) counter+ return (pi:pis, rs)+ else if head tokens == "rule" then do+ (ruleLines, rest) <- grabRule ls []+ (name, prio, clauses, msg) <- parseRule ruleLines+ let ruleFunction = runner clauses msg+ let rule = Rule (RuleId counter) name (Priority prio) ruleFunction+ (pis, rs) <- parseFile rest (counter + 1)+ return (pis, rule:rs)+ else Left (93,"parser error")+ where tokens = words . head $ ls++grabRule :: [String] -> [String] -> Either (ParseErrorId, ParseErrorMsg)+ ([String], [String])+grabRule [] _ = Left (91, "unexpected end of rule")+grabRule ls acc =+ if (head $ words $ head ls) == "send" then+ return (reverse (head ls : acc), tail ls)+ else+ grabRule (tail ls) (head ls : acc)+++-- let x = grabRule ["hallo", "hier fehlt", "das", "Ende"]++parsePlayer :: String ->+ Either (ParseErrorId, ParseErrorMsg)+ PlayerInfo+parsePlayer pString = do+ let tokens = words pString+ checkPlayerStructure tokens+ numberOnJersey <- parseInt (tokens !! 1)+ role <- checkRole (tokens !! 2)+ (defX, defY) <- checkDefense (tokens !! 4) (tokens !! 5)+ (offX, offY) <- checkOffense (tokens !! 7) (tokens !! 8)+ speed <- parseDouble (tokens !! 10)+ acc <- parseDouble (tokens !! 12)+ cover <- parseDouble (tokens !! 14)+ return $ PlayerInfo numberOnJersey role (Point2 defX defY) (Point2 offX offY) speed acc cover++checkPlayerStructure tokens =+ if length tokens /= 15 ||+ tokens !! 0 /= "player" ||+ tokens !! 3 /= "defense" ||+ tokens !! 6 /= "offense" ||+ tokens !! 9 /= "speed" ||+ tokens !! 11 /= "acc" ||+ tokens !! 13 /= "cover"+ then Left (100, "player clause must be of form 'player <x> <position> offense <x> <x> defense <x> <x> speed <x> acc <x> cover <x>', was: " +++ concat (zipWith (++) tokens (repeat " ")))+ else Right ()++checkRole pos+ | pos == "goalie" = Right Goalie+ | pos == "defender" = Right Defender+ | pos == "midfielder" = Right Midfielder+ | pos == "forward" = Right Forward+ | otherwise = Left (101, "position must be goalie, defender, midfielder or forward, was: " ++ pos)++checkOffense :: String -> String -> Either (ParseErrorId, ParseErrorMsg) (Double, Double)+checkOffense x y = do+ x' <- parseDouble x+ y' <- parseDouble y+ return (x',y')++checkDefense = checkOffense++parseDouble :: String -> Either (ParseErrorId, ParseErrorMsg) Double+parseDouble x =+ if null (reads x :: [(Double, String)]) then+ Left (99, "not a float: " ++ x)+ else Right $ fst $ head (reads x)++parseInt :: String -> Either (ParseErrorId, ParseErrorMsg) Int+parseInt x =+ if null (reads x :: [(Int, String)]) then+ Left (99, "not an integer: " ++ x)+ else Right $ fst $ head (reads x)++-- player 17 goalie offense 17 18 defense 18 29 speed 17.1 acc 17.3 cover 0.2+-- ...+--+-- rule ...+-- send ...+--+-- rule ...+-- send ...+--+--+t1 = readFile "team.txt"++p' = do+ ps <- t1+ print $ grabRule (lines ps) []++p x = do+ ps <- t1+ print $ parseFile (lines ps) x++++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 \+player 8 forward defense 42 70 offense 10 30 speed 10.0 acc 15.0 cover 0.1\n \+player 7 forward defense 52 60 offense 35 30 speed 10.0 acc 15.0 cover 0.1\n \+player 6 forward defense 62 70 offense 45 30 speed 10.0 acc 15.0 cover 0.1\n \+player 5 forward defense 10 90 offense 70 30 speed 10.0 acc 15.0 cover 0.1\n \+player 4 forward defense 30 90 offense 10 55 speed 10.0 acc 15.0 cover 0.1\n \+player 3 forward defense 51 90 offense 35 55 speed 10.0 acc 15.0 cover 0.1\n \+player 2 forward defense 73 90 offense 45 55 speed 10.0 acc 15.0 cover 0.1\n \+player 1 goalie defense 40 90 offense 40 90 speed 10.0 acc 15.0 cover 0.1\n \+\n \+rule shoot priority 5\n \+ att is factAttacking\n \+ me is factWhoAmI\n \+ check factEq att me\n \+ ballCarrier is factBallCarrier\n \+ goalVector is factBestShootingVector\n \+send msgKick ballCarrier goalVector\n \+\n \+rule pass priority 5\n \+ att is factAttacking\n \+ me is factWhoAmI\n \+ check factEq att me\n \+ ballCarrier is factBallCarrier\n \+ passVector is factBestPassingVector\n \+send msgKick ballCarrier passVector\n \+\n \+rule get_ball priority 5\n \+ me is factWhoAmI\n \+ ballSpot is factBallIsFree\n \+ np is factNearestAIPlayer me ballSpot\n \+send msgIntercept np ballSpot\n \+\n \+rule pass_to_free priority 5\n \+ att is factAttacking\n \+ me is factWhoAmI\n \+ check factEq att me\n \+ bcId is factBallCarrier\n \+ bcSpot is factPlayerSpot bcId\n \+ bcValue is factSpotValue bcSpot\n \+ recId is factBestFreePlayer\n \+ recSpot is factPlayerSpot recId\n \+ recValue is factSpotValue recSpot\n \+ check factGT recValue bcValue\n \+ passVector is factGetVector bcSpot recSpot\n \+send msgKick bcId passVector"
+ Parser.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE Arrows #-}++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 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++-- *************************************************************************+--+-- Various type abbreviations+--+-- *************************************************************************++data Trigger = OnUp | OnDown++type KeyFSM =+ FSM+ String -- Just the state's name, only for debugging+ (KeyAction, SDL.SDLKey, Shifted) -- Transition is directe by the action (Up or Down),+ -- The key (a, s, ...) and the information whether+ -- The shift key was held down during release+ (StateTime, (CurrentTime, StateTime)) -- Whoa, that's kind of messy: first StateTime indicates+ -- the time when the current state was entered, the CurrentTime+ -- is - well - the current time, and the second StateTime indicates+ -- the time the previous state was entered. since we wish to+ -- calculate the duration a key was pressed, we need the time difference+ -- between the current time and the time the previous state+ -- (that would have been the "Key Down"-state) was entered. The+ -- first StateTime is ignored.+ [Command] -- Resulting command list. Will be only one, but needs to be a Monoid,+ -- so probably Maybe Command should also work?+type KeyState = State String (KeyAction, SDL.SDLKey, Shifted) (StateTime, (CurrentTime, StateTime)) [Command]+++-- *************************************************************************+--+-- FSM for parsing mouse motion+--+-- *************************************************************************++mousePos :: Param -> Position2 -> SF Input Position2+mousePos param pInit = proc (_,(_,input)) -> do+ let me = mouseEvent param input+ p <- hold pInit -< me+ returnA -< p++mouseEvent :: Param -> [SDL.Event] -> Event Position2+mouseEvent _ [] = NoEvent+mouseEvent param (e:es) =+ case e of+ SDL.MouseMotion x y _ _ -> let (x', y') = pointToPitch param (fromIntegral x, fromIntegral y)+ in Event (Point2 x' y')+ _ -> mouseEvent param es+++mouseCommand :: [SDL.Event] -> [Command]+mouseCommand [] = []+mouseCommand (e:es) =+ case e of+ SDL.MouseButtonDown _ _ SDL.ButtonLeft -> [CmdTakeOver]+ SDL.MouseButtonDown _ _ SDL.ButtonRight -> []+ _ -> mouseCommand es+++-- *************************************************************************+--+-- FSM for parsing single keys (action on key-up)+--+-- *************************************************************************++singleKeyCommand :: KeyFSM -> KeyState -> SF (CurrentTime, Event ([(KeyAction, SDL.SDLKey, Shifted)], StateTime)) [Command]+singleKeyCommand fsm initState = proc event -> do+ ((_,_),command) <- reactMachineHist fsm initState 0 -< event+ returnA -< command+++data KeyAction = Up | Down deriving (Ord, Eq, Show)+data Shifted = Shifted | Unshifted deriving (Ord, Eq, Show)++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}]++ s0 = addTransition (Down, key, Unshifted) 1 $+ addTransition (Down, key, Shifted) 1 $+ state 0 "start" (const []) (const []) (const [])++ s1 = addTransition (Up, key, Unshifted) 2 $+ addTransition (Up, key, Shifted) 3 $+ state 1 "down" (const []) (const []) (const [])++ s2 = addTransition (Down, key, Shifted) 1 $+ addTransition (Down, key, Unshifted) 1 $+ state 2 "up" (const []) onEnterSmA (const [])++ s3 = addTransition (Down, key, Shifted) 1 $+ addTransition (Down, key, Unshifted) 1 $+ state 3 "UP" (const []) onEnterGrA (const [])++ Right fsm = fromList [s0, s1, s2, s3]++ in (fsm, s0)++newKeyOnDownFSM :: SDL.SDLKey -> Command -> Command -> (KeyFSM, KeyState)+newKeyOnDownFSM key commandShifted commandUnshifted =+ let+ onEnterSmA (s, (p, sOld)) = [commandShifted]+ onEnterGrA (s, (p, sOld)) = [commandUnshifted]++ s0 = addTransition (Down, key, Unshifted) 1 $+ addTransition (Down, key, Shifted) 2 $+ state 0 "start" (const []) (const []) (const [])++ s1 = addTransition (Down, key, Shifted) 2 $+ addTransition (Down, key, Unshifted) 1 $+ state 1 "up" (const []) onEnterSmA (const [])++ s2 = addTransition (Down, key, Shifted) 2 $+ addTransition (Down, key, Unshifted) 1 $+ state 2 "UP" (const []) onEnterGrA (const [])++ Right fsm = fromList [s0, s1, s2]++ in (fsm, s0)+++keySF newKeyFSM key commandShifted =+ uncurry singleKeyCommand . newKeyFSM key commandShifted+++mapKeyEvent :: [SDL.SDLKey] -> SDL.Event -> Maybe (KeyAction, SDL.SDLKey, Shifted)+mapKeyEvent keys (SDL.KeyUp (SDL.Keysym key mods _)) = if elem key keys then Just (Up, key, checkModifiers mods) else Nothing+mapKeyEvent keys (SDL.KeyDown (SDL.Keysym key mods _)) = if elem key keys then Just (Down, key, checkModifiers mods) else Nothing+mapKeyEvent _ _ = Nothing++checkModifiers mods =+ if elem SDL.KeyModLeftShift mods || elem SDL.KeyModRightShift mods || elem SDL.KeyModShift mods+ then Shifted else Unshifted+++-- *************************************************************************+--+-- FSM for parsing multiple keys+--+-- *************************************************************************++keyCommandSF' :: [(SDL.SDLKey, Trigger, (Command, Command))] -> SF (CurrentTime, Event ([(KeyAction, SDL.SDLKey, Shifted)], StateTime)) [Command]+keyCommandSF' keys =+ let fsms = map (\(sdlKey, trigger, (cShifted, cUnshifted)) ->+ case trigger of+ OnDown -> keySF newKeyOnDownFSM sdlKey cShifted cUnshifted+ _ -> keySF newKeyOnUpFSM sdlKey cShifted cUnshifted) keys+ in concat ^<< parB fsms -- not really efficient, could also broadcast only those messages that+ -- are of interest to a given FSM++keyCommandSF :: [(SDL.SDLKey, Trigger, (Command, Command))] -> SF Input [Command]+keyCommandSF keysCommands = proc (_, (gametime, input)) -> do+ let keys = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [SDL.SDLK_a, SDL.SDLK_s,+ SDL.SDLK_d, SDL.SDLK_e,+ SDL.SDLK_w, SDL.SDLK_q, SDL.SDLK_c,+ SDL.SDLK_SPACE, SDL.SDLK_ESCAPE,+ SDL.SDLK_f]) input+ let keyEvents = if keys == [] then NoEvent else Event (keys, gametime)+ result <- keyCommandSF' keysCommands -< (gametime, keyEvents)+ returnA -< result+++-- *************************************************************************+--+-- FSM for player commands+--+-- *************************************************************************++-- Caution: When adding more commands, remember to put the additional key in keyCommandSF!!+playerKeysSF = keyCommandSF [(SDL.SDLK_a, OnUp, (CmdPassLow 0, CmdPassHigh 0)),+ (SDL.SDLK_d, OnDown, (CmdFlipLow, CmdFlipHigh)),+ (SDL.SDLK_e, OnDown, (CmdMoveForward, CmdMoveBackward)),+ (SDL.SDLK_w, OnDown, (CmdMoveLeft, CmdMoveRight)),+ (SDL.SDLK_q, OnDown, (CmdMoveToGoal, CmdMoveToMe)),+ (SDL.SDLK_s, OnUp, (CmdKickLow 0, CmdKickHigh 0)),+ (SDL.SDLK_c, OnDown, (CmdFlipMeLow, CmdFlipMeHigh)),+ (SDL.SDLK_SPACE, OnDown, (CmdToggleFoot, CmdToggleFoot))]++-- *************************************************************************+--+-- FSM for game commands+--+-- *************************************************************************++-- Caution: When adding more commands, remember to put the additional key in keyCommandSF!!+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+ pd <- mousePos param (Point2 0 0) -< gi++ commands <- playerKeysSF -< gi+ let allCommands = mouseCommand incoming ++ commands++ returnA -< (pd, allCommands)++-- *************************************************************************+--+-- some functions for basic game control+--+-- *************************************************************************++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 = do+ events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent+ let yess = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [SDL.SDLK_y]) events+ let nos = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [SDL.SDLK_n]) events+ if null $ yess ++ nos then shouldContinue else return $ null nos+++
+ Physics.hs view
@@ -0,0 +1,135 @@+module Physics (+ RasenschachReal,++-- One dimensional+ Time,+ DTime,+ Frequency,+ Mass,+ Length,+ Distance,+ Position,+ Speed,+ Velocity,+ Acceleration,+ Angle,+ Heading,+ Bearing,+ RotVel,+ RotAcc,++-- Two dimensional+ Distance2,+ Position2,+ Velocity2,+ Acceleration2,++-- Three dimensional+ Distance3,+ Position3,+ Velocity3,+ Acceleration3,++-- Operations+ normalizeAngle, -- :: Angle -> Angle+ normalizeHeading, -- :: Heading -> Heading+ bearingToHeading, -- :: Bearing -> Heading+ headingToBearing, -- :: Heading -> Bearing++-- Constants+-- ground,+-- border,+-- pitchLength,+-- pitchWidth,+-- homeGoalCenter,+-- awayGoalCenter,+-- pitchCenter,+-- maxheight,++-- gravity,+-- playerSpeedMax,+-- playerAccMax,+-- eps++) where++import FRP.Yampa (Time, DTime)+import FRP.Yampa.Miscellany (fMod)+import FRP.Yampa.Geometry++-- Many of the physical dimensions below are related to time, and variables+-- of these types can thus be expected to occur in numerical expressions along+-- with variables of type time. To facilitate things, they should thus share+-- the same representation. Maybe it is a mistake that AFRP has fixed the+-- type of Time (currently to Double)?++-- Dimensionless type. Same representation as AFRP's Time.+type RasenschachReal = Time++------------------------------------------------------------------------------+-- One-dimensional types+------------------------------------------------------------------------------++type Frequency = RasenschachReal -- [Hz]+type Mass = RasenschachReal -- [kg]+type Length = RasenschachReal -- [m]+type Position = RasenschachReal -- [m] (absolute)+type Distance = RasenschachReal -- [m] (relative)+type Speed = RasenschachReal -- [m/s] (unsigned, speed = abs(velocity))+type Velocity = RasenschachReal -- [m/s] (signed)+type Acceleration = RasenschachReal -- [m/s^2]+type Angle = RasenschachReal -- [rad] (relative)+type Heading = RasenschachReal -- [rad] (angle relative to x-axis = east)+type Bearing = RasenschachReal -- [deg] (compass direction, 0 = N, 90 = E)+type RotVel = RasenschachReal -- [rad/s]+type RotAcc = RasenschachReal -- [rad/s^2]+++------------------------------------------------------------------------------+-- Two-dimensional types+------------------------------------------------------------------------------++type Position2 = Point2 Position -- [m] (absolute)+type Distance2 = Vector2 Distance -- [m] (relative)+type Velocity2 = Vector2 Velocity -- [m/s]+type Acceleration2 = Vector2 Acceleration -- [m/s^2]+++------------------------------------------------------------------------------+-- Three-dimensional types+------------------------------------------------------------------------------++type Position3 = Point3 Position -- [m] (absolute)+type Distance3 = Vector3 Distance -- [m] (relative)+type Velocity3 = Vector3 Velocity -- [m/s]+type Acceleration3 = Vector3 Acceleration -- [m/s^2]+++------------------------------------------------------------------------------+-- Operations+------------------------------------------------------------------------------++-- The resulting angle is in the interval [-pi, pi).+normalizeAngle :: Angle -> Angle+normalizeAngle d = fMod (d + pi) (2 * pi) - pi+++-- The resulting heading is in the interval [-pi, pi).+normalizeHeading :: Heading -> Heading+normalizeHeading = normalizeAngle+++-- Bearings in degrees are understood as on a compass; i.e., north is 0,+-- east is 90, south is 180, west is 270.+-- Heading is understood as the angle (in radians) relative to the "x-axis"+-- which is supposed to point East.++-- The resulting heading is in the interval [-pi, pi).+bearingToHeading :: Bearing -> Heading+bearingToHeading b = (fMod (270 - b) 360 - 180) * pi / 180+++-- The resulting bearing is in the interval [0, 360).+headingToBearing :: Heading -> Bearing+headingToBearing d = fMod (90 - d * 180 / pi) 360+
+ PlayerFSM.hs view
@@ -0,0 +1,405 @@+module PlayerFSM (basicPlayerSF, tacticalPlayerSF, tacticalNonAiSF)++where++import Debug.Trace+import FRP.Yampa+import FRP.Yampa.Geometry+import Data.Maybe+import Data.List++import Data.FSM+import Message+import Physics+import Object+import States+import Command+import Helper+import Global+import BasicTypes++-- *************************************************************************+--+-- Basic FSM+--+-- *************************************************************************++ -- time of last state entrance (for stunning etc.), ball and state+type BasicPerception = (Time, ObjId, [VisibleState])++--s1 :: State BasicState PhysicalPlayerTransition (BasicStateParam, BasicPerception) [Message]++basicFSM initial =+ let+ s1 = addTransition PPTTakeMe 2 $+ addTransition PPTPrepareThrowIn 4 $+ state 1 PBSNoBall (const []) loseBall (const [])+ s2 = addTransition PPTStun 3 $+ addTransition PPTPrepareThrowIn 4 $+ addTransition PPTLoseMe 1 $+ state 2 PBSInPossession (const []) takePossession (const [])+ s3 = addTransition PPTUnStun 1 $+ addTransition PPTPrepareThrowIn 4 $+ state 3 PBSStunned unStun (const []) (const [])+ s4 = addTransition PPTLoseMe 1 $+ state 4 PBSPrepareThrowIn (const []) takePossessionOOP (const [])++ ss = [s1, s2, s3, s4]+ Right fsm = fromList ss+ in (fsm, fromJust $ find ((== initial) . content) ss)++unStun :: (BasicStateParam, BasicPerception) -> [Message]+unStun ((BSPUnstun t0), (t1, me, _)) =+ [(me, PlayerMessage (PhysicalPlayerMessage (PPTUnStun, BSPWhoAndWhen me t1))) | t1 - t0 > 1]++takePossession :: (BasicStateParam, BasicPerception) -> [Message]+takePossession ((BSPWhoAndWhen ball t), (_, me, vss)) =+ let role = piPlayerRole . vsPlayerInfo $ fetchVS vss me+ transition = if role == Goalie then BTGainedGoalie else BTGained+ in+ [(ball, (BallMessage (transition, BPWho me t)))]++takePossessionOOP :: (BasicStateParam, BasicPerception) -> [Message]+takePossessionOOP ((BSPWhoAndWhen ball t), (_, me, _)) =+ [(ball, (BallMessage (BTGainedOOP, BPWho me t)))]++_howfast = 10++loseBall :: (BasicStateParam, BasicPerception) -> [Message]+loseBall ((BSPRelease dt kickType), (_, me, vss)) =+ let dir = vsDir $ fetchVS vss me+ ball = (vsObjId . fetchBallVS) vss+ shootV = fromPolar3 dir _howfast 0+ v = if kickType == RTLow then (1 + dt) *^ shootV+ else if kickType == RTHigh then ((1 + dt) *^ shootV) ^+^ vector3 0 0 10+ else vector3 0 0 0+ in [(ball, (BallMessage (BTLost, BPInit v me))) | kickType /= RTNothing]++loseBall ((BSPPass dt kickType Nothing), (_, me, vss)) =+ let designated = fromJust $ find vsDesignated $ teamMates me vss+ in passTo dt kickType me designated vss++loseBall ((BSPPass dt kickType (Just receiverId)), (_, me, vss)) =+ let receiverVs = fetchVS vss receiverId+ in passTo dt kickType me receiverVs vss++loseBall ((BSPShoot vel), (_, me, vss)) =+ [((vsObjId . fetchBallVS) vss, (BallMessage (BTLost, BPInit vel me)))]++passTo dt kickType passerId receiverVs vss =+ let (xd, yd) = trace ("CCCC-Dest " ++ show ((point3X $ vsPos receiverVs, point3Y $ vsPos receiverVs)))+ (point3X $ vsPos receiverVs, point3Y $ vsPos receiverVs)+ (a , vd) = trace ("CCCC-VelD " ++ show (norm $ vsVel receiverVs))+ (vsDir receiverVs, norm $ vsVel receiverVs)++ ball = fetchBallVS vss+ ballId = vsObjId ball++ (xb, yb) = trace ("CCCC-Ball " ++ show (point3X $ vsPos ball, point3Y $ vsPos ball))+ (point3X $ vsPos ball, point3Y $ vsPos ball)++ vb = (1+dt)*_howfast+-- (t, b) = fromMaybe (0, 0) $ findBestTime (xd, yd, a, norm vd) (xb, yb, vb)+ (t, b) =+ trace ("CCCC-Resl " ++ (show $ fromMaybe (0,0) $ findBestTime (xd, yd, a, norm vd) (xb, yb, vb)))+ (fromMaybe (0,0) $ findBestTime (xd, yd, a, vd) (xb, yb, vb))++ v = (vector3 (vb*cos b) (vb*sin b)+ (if kickType == RTHigh then (1+dt)*5 else 0))++ in [(ballId, (BallMessage (BTLost, BPInit v passerId))) | kickType /= RTNothing]+++findBestTime d@(xd, yd, a, vd) b@(xb, yb, vb) =+ let fits = concatMap (fit d b) [0.05,0.051..3.5]+ in if fits == [] then Nothing+-- else Just . fst $ minimumBy (\a b -> compare (snd a) (snd b)) fits+ else Just . fst $ localMinimumBy (\a b -> compare (snd a) (snd b))+ (head fits) fits+++-- findBestTime (10, 10, (pi/2), 0) (5, 10, 20)+-- concatMap (fit (10, 10, (pi/2), 0) (5, 10, 20)) [0.1, 0.2, 0.25, 0.3, 0.4, 0.5, 0.6, 0.7, 3.5]+-- fit (10, 10, (pi/2), 0) (5, 10, 20) 0.1++localMinimumBy :: (t -> t -> Ordering) -> t -> [t] -> t+localMinimumBy _ x [] = x+localMinimumBy f x (y:ys) =+ if f y x == GT then x+ else localMinimumBy f y ys++fit (xd, yd, a, vd) (xb, yb, vb) t =+ let sinB = (yd' - yb) / (vb*t)+ cosB = (xd' - xb) / (vb*t)+ xd' = xd + vd*t*(cos a)+ yd' = yd + vd*t*(sin a)+ quadrant = if xd'>=xb && yd'>=yb then Q1+ else if xd'<xb && yd'>=yb then Q2+ else if xd'<xb && yd'<yb then Q3+ else Q4++ bSin = asinNorm quadrant (asin sinB)+ bCos = acosNorm quadrant (acos cosB)++ in [((t, (bSin + bCos)/2), abs $ bSin - bCos)+-- | abs asin_ <= 0.5 && abs acos_ <= 0.5]+ | abs sinB <= 1 && abs cosB <= 1]++--Prelude> (acos $ 10/t, asin $ 5/t)+--(0.46364760900080615,0.4636476090008061)+--Prelude> (acos $ -10/t, asin $ 5/t)+--(2.677945044588987,0.4636476090008061)+--Prelude> (acos $ -10/t, asin $ -5/t)+--(2.677945044588987,-0.4636476090008061)+--Prelude> (acos $ 10/t, asin $ -5/t)+--(0.46364760900080615,-0.4636476090008061)++data Quadrant = Q1 | Q2 | Q3 | Q4++acosNorm Q1 x = x+acosNorm Q2 x = x+acosNorm Q3 x = 2*pi-x+acosNorm Q4 x = 2*pi-x++asinNorm Q1 x = x+asinNorm Q2 x = pi-x+asinNorm Q3 x = pi-x+asinNorm Q4 x = 2*pi+x+++--basicPlayerSF :: Bool -> Time ->+basicPlayerSF :: BasicState -> Time ->+ SF (BasicPerception, Event [(PhysicalPlayerTransition, BasicStateParam)])+ ((State BasicState PhysicalPlayerTransition (BasicStateParam, BasicPerception) [Message], BasicStateParam), [Message])+basicPlayerSF init _= uncurry reactMachineMult (basicFSM init) BSPNothing+--reactMachineMult fsm (if hasBall then s2 else s1) BSPNothing+++-- *************************************************************************+--+-- Tactical FSM for AI Player+--+-- *************************************************************************++type TacticalPerception = (Time, ObjId, [VisibleState], [Command])+ -- current time, me, vss commands++tacticalFSM :: Param -> TacticalState ->+ (FSM TacticalState TacticalPlayerTransition (TacticalStateParam, TacticalPerception) [Message],+ State TacticalState TacticalPlayerTransition (TacticalStateParam, TacticalPerception) [Message])+tacticalFSM param initial =+ let+ s1 = addTransition TPTWait 1 $+ addTransition TPTCover 2 $+ addTransition TPTMoveTo 3 $+ addTransition TPTHoldPosition 4 $+ addTransition TPTIntercept 5 $+ addTransition TPTMoveToThrowIn 7 $+ addTransition TPTFreeze 8 $+ addTransition TPTKickTowards 9 $+ state 1 TSWaiting (lookOutForBall TPTWait) (const []) (const [])+ s2 = addTransition TPTWait 1 $+ addTransition TPTCover 2 $+ addTransition TPTIntercept 5 $+ addTransition TPTMoveToThrowIn 7 $+ addTransition TPTFreeze 8 $+ addTransition TPTKickTowards 9 $+ state 2 TSCovering (const []) (coverPlayer param) (const [])+ s3 = addTransition TPTWait 1 $+ addTransition TPTMoveTo 3 $+ addTransition TPTIntercept 5 $+ addTransition TPTHoldPosition 4 $+ addTransition TPTMoveToThrowIn 7 $+ addTransition TPTFreeze 8 $+ addTransition TPTKickTowards 9 $+ state 3 TSPositioning checkIfPositionReached (const []) (const [])+ s4 = addTransition TPTWait 1 $+ addTransition TPTIntercept 5 $+ addTransition TPTHoldPosition 4 $+ addTransition TPTMoveTo 3 $+ addTransition TPTMoveToThrowIn 7 $+ addTransition TPTFreeze 8 $+ addTransition TPTKickTowards 9 $+ state 4 TSHoldingPosition (holdPosition param) (const []) (const [])+ s5 = addTransition TPTDropInterception 4 $+ addTransition TPTIntercept 5 $+ addTransition TPTMoveToThrowIn 7 $+ addTransition TPTFreeze 8 $+ addTransition TPTKickTowards 9 $+ state 5 TSInterceptBall intercept dropInterception (const [])+ s6 = addTransition TPTKickedOff 4 $+ addTransition TPTIntercept 5 $ -- ???+ addTransition TPTWaitForKickOff 6 $+ addTransition TPTFreeze 8 $+ state 6 TSWaitingForKickOff (lookOutForBall TPTWaitForKickOff) (const []) (const [])+ s7 = addTransition TPTReposition 4 $+ addTransition TPTFreeze 8 $+ state 7 TSMovingToThrowIn (const []) (holdThrowInPosition param) (const [])+ s8 = addTransition TPTHoldPosition 4 $+ state 8 TSFrozen (const []) (const []) (const [])+ s9 = addTransition TPTWait 1 $+ addTransition TPTFreeze 8 $+ state 9 TSKickingTowards (const []) turnTowards kickTowards+ s10 = addTransition TPTFreeze 8 $+ addTransition TPTTendGoal 10 $+ state 10 TSTendingGoal (tendGoal param) (const []) (const [])+ s11 = addTransition TPTFreeze 8 $+ addTransition TPTKickedOff 10 $+ state 11 TSGoalieWaitingForKickOff (tendGoal param) (const []) (const [])++ ss = [s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11]+ Right fsm = fromList ss+ in (fsm, fromJust $ find ((== initial) . content) ss)++-- All of the following functions are of type :: (TacticalStateParam, TacticalPerception) -> [Message]+tendGoal param ((TacticalStateParam _ _ _ _ _ _ _), (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+ else atan2 (vector2Y diff) (vector2X diff)+ in [(me, tm (TPTTendGoal,+ TacticalStateParam (Just posPlayer) (Just $ vector3 0 0 0) False+ Nothing (Just dir) Nothing (Just t)))]++goaliePosition param Away factor (Point2 bx by) =+ let Point2 x0 y0 = awayGoalCenter param+ vn = normalize $ vector2 (bx-x0) (by-y0)+ distB = sqrt $ sqr (bx-x0) + sqr (by-y0)+ r = factor * distB+ xg = r * (vector2X vn) + x0+ yg = r * (vector2Y vn) + y0+ in Point2 xg yg+goaliePosition param Home factor (Point2 bx by) =+ let bxMirror = pPitchWidth param - bx+ byMirror = pPitchLength param - by+ Point2 xgMirror ygMirror = goaliePosition param Away factor (Point2 bxMirror byMirror)+ in Point2 (pPitchWidth param - xgMirror) (pPitchLength param - ygMirror)+++turnTowards ((TacticalStateParam _ mvd@(Just vd) _ rec _ kt _), (_, me, vss, _)) =+ let dir = atan2 (vector3Y vd) (vector3X vd)+ in [(me, tm (TPTWait,+ TacticalStateParam Nothing mvd False rec (Just dir) kt Nothing))]++kickTowards ((TacticalStateParam _ mvd@(Just vd) _ Nothing _ _ _), (_, me, vss, _)) =+ [(me, pm (PPTLoseMe, BSPShoot vd))]+kickTowards ((TacticalStateParam _ _ _ (Just receiver) _ (Just kt) _), (_, me, vss, _)) =+ [(me, pm (PPTLoseMe, BSPPass 1 kt (Just receiver)))]+++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+ myPos = (projectP . vsPos . fetchVS vss) me+ adjust = if abs (getAngle velBall - (getAngle (myPos .-. posBall))) > 0.2+ then velBall+ else vector2 0 0+ in [if bs == BSFree then+ (me, tm (TPTIntercept,+ TacticalStateParam (Just $ posBall .+^ adjust) Nothing False Nothing Nothing Nothing Nothing))+ else+ (me, tm (TPTDropInterception,+ TacticalStateParam posTarget Nothing False Nothing Nothing Nothing Nothing))]++dropInterception ((TacticalStateParam posTarget _ _ _ _ _ _), (_, me, vss, _)) =+ let team = vsTeam $ fetchVS vss me+ 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 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 mobp _ _ _ _ _ _), (_, me, vss, _)) =+ let attacker = vsAttacker $ fetchGameVS vss+ sp@(TacticalStateParam (Just newTargetPos) _ _ _ _ _ _) = basePosition param me vss attacker+ currPos = vsPos $ fetchVS vss me++ oldTargetPos = fromMaybe (Point2 0 0) mobp++ -- 5m off in 1m is too far (ratio = 10)+ -- 5m off in 5m is too far (ratio=1)+ -- 2 1/2m off in 5m is too far (ratio=0.5)+ -- 5m off in 50m is close enough (ratio=0.1)+ tooFarOff = (distance newTargetPos oldTargetPos) /+ (distance newTargetPos (projectP currPos)) > 0.5+ in [(me, tm (TPTHoldPosition, sp)) | tooFarOff]++holdThrowInPosition param (_, (_, me, vss, _)) =+ let (_, GPTeamPosition teamThrowingIn _ _ _) = vsGameState . fetchGameVS $ vss+ myTeam = vsTeam $ fetchVS vss me+ in [(me, tm (TPTWaitForThrowIn,+ basePosition param me vss (if teamThrowingIn == myTeam then teamThrowingIn else otherTeam teamThrowingIn)))]++lookOutForBall msg (_, (_, me, vss, _)) =+ let posPlayer = projectP . vsPos $ fetchVS vss me+ ball = fetchBallVS vss+ posBall = projectP . vsPos $ ball+ b'@(bs, bsp) = vsBallState ball+ diff = posBall .-. posPlayer+ dir = atan2 (vector2Y diff) (vector2X diff)+ iHaveTheBall = bs `elem` [BSControlled, BSControlledGoalie, BSControlledOOP]+ && lastPlayer b' == me+ in [(me, tm (msg,+ TacticalStateParam (Just posPlayer) Nothing False Nothing (Just dir) Nothing Nothing))+ | not iHaveTheBall] -- (bs == BSControlled && bsp == BPWho me)]++coverPlayer param ((TacticalStateParam _ _ _ tc@(Just toCover) _ _ _), (_, me, vss, _)) =+ let myState = fetchVS vss toCover+ posCover = projectP . vsPos $ myState+ myCoverRatio = piPlayerCoverRatio . vsPlayerInfo $ myState+ posTarget = posCover .+^ myCoverRatio *^ (awayGoalCenter param .-. posCover)+ in [(me, tm (TPTCover,+ TacticalStateParam (Just posTarget) Nothing False tc Nothing Nothing Nothing))]++tacticalPlayerSF ::+ Param -> TacticalState -> Angle ->+ SF (TacticalPerception, Event [(TacticalPlayerTransition, TacticalStateParam)])+ ((State TacticalState TacticalPlayerTransition (TacticalStateParam, TacticalPerception) [Message], TacticalStateParam), [Message])+tacticalPlayerSF param init angle0 =+ uncurry reactMachineMult (tacticalFSM param init)+ (TacticalStateParam Nothing Nothing False Nothing (Just angle0) Nothing Nothing)+++-- *************************************************************************+--+-- Tactical FSM for Non AI Player+--+-- *************************************************************************++tacticalNonAiFSM :: TacticalState ->+ (FSM TacticalState TacticalPlayerTransition (TacticalStateParam, TacticalPerception) [Message],+ State TacticalState TacticalPlayerTransition (TacticalStateParam, TacticalPerception) [Message])+tacticalNonAiFSM initial =+ let+ s8 = state 8 TSNonAI (const []) (const []) (const [])+ s9 = addTransition TPTKickedOff 8 $+ state 9 TSNonAIKickingOff (const []) (const []) (const [])+ ss = [s8, s9]+ Right fsm = fromList ss+ in (fsm, fromJust $ find ((== initial) . content) ss)++tacticalNonAiSF ::+ TacticalState ->+ SF (TacticalPerception, Event [(TacticalPlayerTransition, TacticalStateParam)])+ ((State TacticalState TacticalPlayerTransition (TacticalStateParam, TacticalPerception) [Message], TacticalStateParam),+ [Message])+tacticalNonAiSF initial =+ uncurry reactMachineMult (tacticalNonAiFSM initial) tspNull
+ README view
@@ -0,0 +1,142 @@+===== R A S E N S C H A C H ======++Single player, mouse controlled soccer game with simple graphics and flexible, +extensible AI. Based on the Yampa arcade and Gerold Meisinger's Yampa/SDL stub.++Backlog:+=================================================================================+No. T A S K S T A T E+=================================================================================+1 graphics rendering for ball and player done (basics)+---------------------------------------------------------------------------------+2 FRP version of Finite State Machine done (basics)+---------------------------------------------------------------------------------+3 basic FRP feedback loop done (basics)+---------------------------------------------------------------------------------+4 rendering for game object (score and game time) done (basics) +---------------------------------------------------------------------------------+5a basic version of player FSM done (basics)+---------------------------------------------------------------------------------+5b basic version of game FSM done (basics)+---------------------------------------------------------------------------------+6 "kickoff-situation": players move from sideline done (basics)+ to pre-kickoff base position+---------------------------------------------------------------------------------+7 add sound to player and ball action done (basics)+---------------------------------------------------------------------------------+8 basic mouse and keyboard input events (see Yampa done (basics)+ arcade parser)+---------------------------------------------------------------------------------+9 single player moves around based on input events done (basics)+---------------------------------------------------------------------------------+10 add ball control to 9 done (basics)+---------------------------------------------------------------------------------+11 add shooting to 10 done (basics)+---------------------------------------------------------------------------------+12 add another player to 10 done (basics)+---------------------------------------------------------------------------------+13 add "on key down"-FSM to parser done (basics)+---------------------------------------------------------------------------------+14 add "take ball from other player" to fsms done (basics)+---------------------------------------------------------------------------------+15 define core player (base for AI and user player) done (basics)+---------------------------------------------------------------------------------+16 add bounce logic to player collision done (basics)+---------------------------------------------------------------------------------+17 define team objects (which will compute AI orders) done (basics)+---------------------------------------------------------------------------------+18 add team membership and position to player object done (basics)+---------------------------------------------------------------------------------+19 define bouncing logic for goal post later+---------------------------------------------------------------------------------+20 add stunning logic (probably on hard collision?) later +---------------------------------------------------------------------------------+21 send proper messages on goal, out (side, end) done "simple events"+---------------------------------------------------------------------------------+22 set up new game afer goal or out (simplistic) done "simple events"+---------------------------------------------------------------------------------+23 enhance offensive ai: shoot on goal when free sprint "playable version"+---------------------------------------------------------------------------------+24 enhance defensive ai: attack when near own goal later +---------------------------------------------------------------------------------+25 add goalie (own player object?) later +---------------------------------------------------------------------------------+26 add proper throw in (ball behind player's head) done "simple events"+---------------------------------------------------------------------------------+27 selection of "designated player" by mouse later +---------------------------------------------------------------------------------+28 new key action: pass to designated player done "playable version"+---------------------------------------------------------------------------------+29 new key action: pass to running player (aim ahead) later +---------------------------------------------------------------------------------+30 write TH parser for AI commands later +---------------------------------------------------------------------------------+31 proper FSM for game object done "simple events"+---------------------------------------------------------------------------------+32 render something nice for designated receiver later +---------------------------------------------------------------------------------+33 new key action: switch to nearest player later +---------------------------------------------------------------------------------+34 pause and resume game action later+---------------------------------------------------------------------------------+35 enhance offensive ai: pass to better positioned later + player +---------------------------------------------------------------------------------+36 add multiple round mechanism a la Yampa Arcade: done "simple events"+ new round would be entered on kick off +---------------------------------------------------------------------------------+37 controlled player can also throw in (very basic) done "playable version"+---------------------------------------------------------------------------------+38 AI action: throw in done "simple events"+ - compute spot for throw in+ - aim for this spot (not throw in immediately)+ - throw in and resume play+---------------------------------------------------------------------------------+39 Bug: when ball goes out of bounce, and then ai done "simple events"+ player touches it, then other team won't take it+---------------------------------------------------------------------------------+40 Bug: when player throws in, he immediately retakes done "simple events"+ the ball since he is in the way of the ball...+---------------------------------------------------------------------------------+41 Hack: on base out, throw in near the base line done "playable version"+---------------------------------------------------------------------------------+42 display controlled player blinking done "playable version"+---------------------------------------------------------------------------------+43 controlled player can also kick off done "playable version"+---------------------------------------------------------------------------------+44 display goal event and score sprint "playable version"+---------------------------------------------------------------------------------+45 fix meterToPixel stuff (y axis kind of weird) done "playable version"+---------------------------------------------------------------------------------+46 player who kicked off or threw in etc. can not be later+ the first to touch the ball again+---------------------------------------------------------------------------------+47 controlled player can aim for throw in (follow up later+ to 37)+---------------------------------------------------------------------------------+48 if controlled player throws in, then stop other later+ player moving_to_throwin from grabbing the ball +---------------------------------------------------------------------------------+49 Bug: if team consists solely of non AI players, later + this line in ObjectBehaviour / player blows:++ let np = nearestNonAIPlayer myTeam vss pd+ +---------------------------------------------------------------------------------+50 Bug: if kick off goes directly to side out, no one later+ throws in and the state remains "GSRunning" instead+ of GSSideOut +---------------------------------------------------------------------------------+51 for test, it would be good to have an editor of sprint "refinement"+ some kind for game situations (player position, + heading and speed, dito for ball)+---------------------------------------------------------------------------------+++Taglist:+=================================================================================+T A G C O N T E N T S+=================================================================================+RSSP-0.0.1 basics+ "simple events" +---------------------------------------------------------------------------------
+ Rasenschach.cabal view
@@ -0,0 +1,40 @@+name: Rasenschach+version: 0.1+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/+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+ chalkboard.png tockH.wav whistle.wav+data-dir: ""+extra-source-files: AI.hs AL.hs Animate.hs BallFSM.hs BasicTypes.hs+ Command.hs Data/FSM.hs GameFSM.hs GameLoop.hs Global.hs Grid.hs+ Helper.hs Lineup.hs Message.hs Object.hs ObjectBehaviour.hs+ ParseTeam.hs Parser.hs Physics.hs PlayerFSM.hs README Render.hs+ RenderBall.hs RenderGame.hs RenderPlayer.hs RenderUtil.hs Rules.hs+ States.hs+ +executable Rasenschach+ build-depends: SDL -any, SDL-gfx -any, SDL-image -any,+ SDL-mixer -any, SDL-ttf -any, Yampa -any, array -any,+ base >=3 && <5, containers -any, convertible -any, directory -any,+ filepath -any, ghc -any, monad-loops -any, template-haskell -any,+ time -any+ main-is: Main.hs+ buildable: True+ 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+
+ Render.hs view
@@ -0,0 +1,107 @@+module Render where++import Control.Monad (forM_)+import Data.List+import Data.Array ((!))+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++import RenderPlayer+import RenderBall+import RenderGame+import RenderUtil++import Object+import States+import BasicTypes++init = do+ SDL.init [SDL.InitVideo]+ TTF.init++ screen <- SDL.setVideoMode (truncate winWidth) (truncate winHeight) 32 []+ openAudio 22050 AudioS16Sys 2 4096+ pitch <- pitchRessources screen+ fonts <- fontsRessources+ balls <- ballRessources screen+ (tockWav, kickWav, whistleWav) <- soundRessources++ return (screen, pitch, fonts, balls, tockWav, kickWav, whistleWav)++exit = do+ closeAudio+ TTF.quit+ SDL.quit++renderObjects param oos (screen, pitch, fonts, balls, tockWav, kickWav, whistleWav) = do+ cf <- chalkFontsRessources+ cfb <- bigChalkFonts+ forM_ sorted $ \os ->+ case os of+ OOSBall oosPos+ oosVelocity+ oosBounced+ oosPState+ -> do renderBall param screen balls tockWav oosPos oosBounced+ renderBallDebug screen oosPState cf (point3Z oosPos)+ OOSPlayer oosPos+ oosVel+ oosAcc+ oosKicked+ oosSelected+ oosDesignated+ oosRadius+ (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+ cf bpDef bpOff oosTeam+ OOSGame oosGameTime+ oosGameScore+ oosGameState+ oosAttacker+ _+ -> renderGame param screen oosGameTime oosGameScore oosGameState+ oosAttacker cfb (fonts ! 4) whistleWav++ where sorted = sortWith (point3Z . oosPos) oos++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 (screen,_, fonts,_,_,_,_) =+ do+ let font = fonts ! 4+ let color = colorFromPixel $ rgbColor 255 255 1++ fontSurface <- TTF.renderTextSolid font ("PRESS <SPACE> TO START") color++ SDL.blitSurface fontSurface Nothing screen (Just $ Rect 250 400 100 100)+ SDL.flip screen++renderEndMsg (screen,_, fonts,_,_,_,whistle) =+ do+ let font = fonts ! 4+ let color = colorFromPixel $ rgbColor 255 255 1++ fontSurface <- TTF.renderTextSolid font ("GAME OVER, TRY AGAIN (Y/N)") color+ playChannel (1) whistle 0++ SDL.blitSurface fontSurface Nothing screen (Just $ Rect 200 400 100 100)+ SDL.flip screen+
+ RenderBall.hs view
@@ -0,0 +1,44 @@+module RenderBall -- (renderBall)++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++import RenderUtil++sizedBall :: Double -> Array Int (Surface, Int) -> (Surface, Int)+sizedBall z balls =+ if z < 0.3 then balls!0+ else if z < 0.5 then balls!1+ else if z < 1.0 then balls!2+ else if z < 2.0 then balls!3+ else if z < 3.0 then balls!4+ else balls!5++renderBall param surface balls tock p bounced = do+ when bounced $ playChannel (-1) tock 0 >> return ()+ let Point3 px py pz = p+ let (x, y) = pitchToPoint param (px, py)+ let (x', y') = (fromIntegral x, fromIntegral y) :: (Int, Int)+ let (ball, points) = sizedBall pz balls+ 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 =+ do+ let color = colorFromPixel $ rgbColor 255 255 1+ fontSurface <- SDLt.renderTextSolid font ("Ball: " ++ show state) color+-- ++ " , z=" ++ show z) color+-- f2 <- SDL.convertSurface fontSurface (SDL.surfaceGetPixelFormat surface) []++ SDL.blitSurface fontSurface Nothing surface (Just $ Rect 850 140 1000 150)+
+ RenderGame.hs view
@@ -0,0 +1,41 @@+module RenderGame++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++import RenderUtil+import States+import Message++renderGame param surface t (scoreHome, scoreAway) (gState, gStateParam)+ attacker 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+ when (gState == GSKickOff && shouldWhistle gStateParam) $ do+ playChannel (1) whistle 0 >> return ()++ SDL.blitSurface fontSurface Nothing surface (Just $ Rect 850 60 950 60)++ 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 ()++ return True++shouldWhistle (GPTeamPosition _ _ _ w) = w
+ RenderPlayer.hs view
@@ -0,0 +1,119 @@+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++import Graphics.UI.SDL as SDL+import Graphics.UI.SDL.Primitives as SDLp+import Graphics.UI.SDL.TTF as SDLt+import Graphics.UI.SDL.Mixer as SDLm++import BasicTypes+import RenderUtil+import Global++orange = rgbColor 0xE7 0x5B 0x12++-- Alles rund um den Fußballer...++r1 z = 3.0 + z -- Punkte zwischen Kreisrand und äußerem Ring+r2 z = 6.0 + z -- Punkte zwischen Kreisrand innerem Ring+angle = 0.45 -- Winkel des Zeiger-Dreiecks++pr1 z = truncate $ r1 z++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)))+ in (a,b,c)++playersizeMin = 25 :: Int16 -- in Pixeln+playersizeMax = 50+maxJump = 3.0 -- in Meter++blinker = do+ t <- fmap ((100 *) . convert) getCurrentTime :: IO Double+ let t' = truncate t `mod` 100+ return $ t' < 50++playerSize :: Param -> Double -> Int16+playerSize param z = -- zwischen 0 und 2 Meter Höhe, dann wechselt der Spieler zwischen 30 und 50 Dicke...+ if z > maxJump then playersizeMax+ 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 =+ do+ when kicked $ playChannel (-1) wav 0 >> return ()++ let Point3 px py pz = p+ let radius = playerSize param pz `shiftR` 1+ 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 radD = fromIntegral radius+ let ((ax, ay),+ (bx, by),+ (cx, cy)) = triangle x y pz radD alpha r1 r2 angle+ let font = if pz < 1 then fonts ! 1+ else if pz < 2 then fonts ! 2+ else fonts ! 3+ let markFont = fonts ! 5++ blinkOn <- blinker++ let cBorderBlinking = if nonai && blinkOn then cCircle else cBorder+ let cTriangleBlinking = if nonai && blinkOn then cCircle else cTriangle+ let cCircleBlinking = if nonai && blinkOn then cBorder else cCircle+++ fontSurface <- SDLt.renderTextSolid font (show number) (colorFromPixel cTriangleBlinking)+-- f2 <- SDL.convertSurface fontSurface (SDL.surfaceGetPixelFormat surface) []++ SDLp.filledCircle surface x y radius cBorderBlinking+ SDLp.filledCircle surface x y (radius - (pr1 pz)) cCircleBlinking++ when designated $ do+ markSurface <- SDLt.renderTextSolid markFont "!" (colorFromPixel orange)+ SDL.blitSurface markSurface Nothing surface (Just $ Rect (fromIntegral (x-xAdjust+1))+ (fromIntegral (y-yAdjust-5))+ (fromIntegral (x-xAdjust+10))+ (fromIntegral (y-yAdjust+10)))+ return ()++ SDLp.filledTrigon surface ax ay bx by cx cy cTriangleBlinking++++ SDL.blitSurface fontSurface Nothing surface (Just $ Rect (fromIntegral (x-xAdjust))+ (fromIntegral (y-yAdjust))+ (fromIntegral (x-xAdjust+10))+ (fromIntegral (y-yAdjust+10)))+++renderPlayerDebug surface sel number bState tState color font baseDef baseOff oosTeam =+ do+ fontSurface <- SDLt.renderTextSolid font (show number ++ ": " +++ show tState ++ ", " +++ show bState ++ ", " -- +++-- show baseDef ++ ", " +++-- show baseOff+ )+ (colorFromPixel color)+-- f2 <- SDL.convertSurface fontSurface (SDL.surfaceGetPixelFormat surface) []+ let adjust = if oosTeam == Home then 150 else 500+ SDL.blitSurface fontSurface Nothing surface (Just $ Rect 850 (adjust+20*number) 950 (adjust+50+20*number))
+ RenderUtil.hs view
@@ -0,0 +1,123 @@+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++rgbColor :: Word8 -> Word8 -> Word8 -> Pixel+rgbColor r g b = Pixel (shiftL (fi r) 24 .|. shiftL (fi g) 16 .|. shiftL (fi b) 8 .|. fi 255)++colorFromPixel (Pixel p) = Color (fi $ shiftR p 24) (fi $ shiftR p 16) (fi $ shiftR p 8)++-- Geometrie++winHeight = 1050 :: Double+winWidth = 1195 :: Double++ratio param = 8.625 -- winHeight / (pPitchLength param + pUpperBorderY param + pLowerBorderY param)++pixelToMeter :: Param -> Int16 -> Double+pixelToMeter param p = fromIntegral p / ratio param++meterToPixel :: Param -> Double -> Int16+meterToPixel param = truncate . (* ratio param)++pitchToPoint param (x,y) = (meterToPixel param $ (pLeftBorderX param) + x,+ meterToPixel param $ (pUpperBorderY param) + y)++pointToPitch param (x,y) = (pixelToMeter param x - pLeftBorderX param, pixelToMeter param y - pUpperBorderY param)++ballRessources :: Surface -> IO (Array Int (Surface, Int))+ballRessources screen = do++ 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"+ 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++ fn30 <- getDataFileName "30ball.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))]++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++ 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 = do+ fn <- getDataFileName "SqueakyChalkSound.ttf"+ TTF.openFont fn 14+-- setFontStyle f [StyleBold]++bigChalkFonts = do+ fn <- getDataFileName "SqueakyChalkSound.ttf"+ TTF.openFont fn 20++pitchRessources screen = do+ fn <- getDataFileName "chalkboard.png"+ pitch <- SDLi.load fn+ convertSurface pitch (surfaceGetPixelFormat screen) []++soundRessources = do+ fnt <- getDataFileName "tockH.wav"+ t <- loadWAV fnt++ fnk <- getDataFileName "ballM.wav"+ k <- loadWAV fnk++ fnw <- getDataFileName "whistle.wav"+ w <- loadWAV fnw+ return (t, k, w)
+ Rules.hs view
@@ -0,0 +1,365 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+module Rules (+ runRules+ ,runner+ ,parseRule+ ,basicRules+ ,Rule(..)+ ,Priority(..)+ ,RuleId(..)+ ,ParseErrorId+ ,ParseErrorMsg)++where++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++-- *************************************************************************+--+-- Framework for defining rules+--+-- ************************************************************************+++concatMaybe Nothing = []+concatMaybe (Just xs) = xs++uncollect :: [(a, [b])] -> [(a, b)]+uncollect = concatMap (\(a, bs) -> zip (repeat a) bs)++runRules' :: [ObjId] -> Facts -> [VisibleState] -> RuleBase -> [(ObjId, [(Priority, MessageBody)])]+runRules' teamMates facts vss =+ collect . map (\(p,(o,m)) -> (o, (p,m))) . uncollect+ . 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 =+ 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+++comparePM :: (Priority, MessageBody) -> (Priority, MessageBody) -> Ordering+comparePM = comparing fst++-- *************************************************************************+--+-- Basic rules for all teams, not changeable by user+--+-- ************************************************************************++rule_kick_off :: RuleFunction+rule_kick_off _ facts vss = do+ factKickOff facts []+ att <- factAttacking facts []+ FPTeam me <- factWhoAmI facts []+ factEq facts [FPTeam me, att]+ let x = if me == Home then 1 else (-1)+ return $ [(vsObjId p, tm (TPTKickedOff, tspNull))| p <- teamPlayers Home vss ++ teamPlayers Away vss]+ -- , vsObjId p /= ballCarrier]+ ++ [(vsObjId game, GameMessage (GTRunGame, (snd . vsGameState) game))]+ ++ [(ballCarrier, pm (PPTLoseMe, BSPShoot (x *^ (vector3 (-19) (-3) 0)))) | isJust bc]+ where game = fetchGameVS vss+ bc@(Just ballCarrier) = playerWithBall vss++-- Weitere Verbesserungsmöglichkeiten:+-- a. checken, dass nicht der einwerfende Spieler der erste ist, der den Ball wieder+-- aufnimmt+-- b. nicht sofort werfen, sondern eine halbe Sekunde oder so warten (vielleicht FactThrowinIn+-- erst dann einstellen, wenn eine Mindestzeit rum ist?) Sonst sieht es doof aus+-- c. der einwerfende Spieler soll in Richtung des Spots schauen, zu dem er werden will;+-- vielleicht wäre ein TS "AimingForThrowIn" gut+-- 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+ FPPlayerId p <- factThrowingIn facts []+ FPFromTo curr dest <- factBestPosition facts []+ return $ (p, pm (PPTLoseMe,+#if DEBUG_MODE+ trace ("RULE=" ++ show (BSPShoot (towards curr dest)) ++ show "; " ++ show dest)+#endif+ BSPShoot (towards curr dest))) :+ [(p, tm (TPTReposition, tspNull))]++rule_stop_idling :: RuleFunction+rule_stop_idling _ facts vss = do+ FPPlayers ps <- factIdling facts []+ return $ map (\p -> (p, tm (TPTHoldPosition, tspNull))) ps+++rule_punt :: RuleFunction+rule_punt _ facts vss = do+ FPPlayerVector p v <- factPunt facts []+ return $ [(p, pm (PPTLoseMe, BSPShoot v))]+++-- was passiert beim Anstoß:+-- * 2 Spieler stehen am Anstoßpunkt+-- * ein Spieler hat den Ball+-- * auf Knopfdruck (bei eigenem Spieler) oder auf AI-Befehl geht der Ball von einem+-- auf den anderen Spieler über+-- * vorher kann sich keiner irgendwie drehen oder sonstwas+-- * Frage: Laufen dann alle in Position? Oder wird "neu aufgestellt?" Letzteres ist+-- wohl deutlich einfacher... Dann braucht es auch das ganze Status-Gehampel nicht...+-- * Frage: Ist man vor dem eigentlich Anstoß innerhalb der reactimate-Schleife oder+-- außerhalb?+-- PRO außerhalb: Ganz wenig Rumgehampel mit Status und Knorz (sonst muss mindestens mal+-- die handgesteuerten Spieler in einen Status versetzen, in dem er nicht+-- gesteuert werden kann AUSSER wenn er selber den Anstoß macht, dann ist der+-- einzige Steuerimpuls aber der Anstoß an sich)+-- CON außerhalb: Rendering und Keyboard-Knorzung muss noch mal gebastelt oder++-- mindestens mal angestoßen werden...+-- klingt so, als sollte man es erst mal mit innerhalb probieren...++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+ ,Rule (RuleId (-1003)) "stop idling" (Priority 10) rule_stop_idling+ ]++-- just some dummy stuff to later integrate more easily...++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)++-- wrapper to run a parsed rule (set of clauses and message function)+runner :: Statement -> (MsgMaker, [RuleParam]) -> RuleFunction+runner clauses msgMaker myTeamMates facts vss =+ run myTeamMates vss facts clauses msgMaker emptyAL++-- first runs a set of clauses and collects facts, then runs messaging function+-- lets only those messages through that are intended for own team (no cheating!)+run :: [ObjId] -> [VisibleState] -> Facts -> Statement ->+ (MsgMaker, [RuleParam]) -> AL ParamId FactParam -> Maybe [Message]+run myTeamMates vss _ [] (msgMaker, params) paramFacts =+ return $ filterTeam myTeamMates $ msgMaker vss $ fetchParams paramFacts params+run myTeamMates vss facts ((pId, clause, clauseParams):rs) msg paramFactsSoFar = do+ fp <- clause facts $ fetchParams paramFactsSoFar clauseParams+ run myTeamMates vss facts rs msg $ maybeInsertAL pId fp paramFactsSoFar++maybeInsertAL Nothing _ paramFactsSoFar = paramFactsSoFar+maybeInsertAL (Just pId) fp paramFactsSoFar = insertAL pId fp paramFactsSoFar++filterTeam teamMates =+ filter (\(oid,_) -> elem oid teamMates)++fetchParams _ [] = []+fetchParams pvs (p:ps) =+ case p of+ PId p -> pvs ! p : fetchParams pvs ps+ PConst c -> c : fetchParams pvs ps+++type ParamName = String+type RulePriority = Int+type ParseErrorId = Int+type ParseErrorMsg = String++parseRule :: [String] ->+ Either (ParseErrorId, ParseErrorMsg)+ (RuleName+ ,RulePriority+ ,Statement+ ,(MsgMaker, [RuleParam]))++parseRule ls = do+-- let ls = lines ruleString+ let ln = length ls+ checkRuleStructure ls+ (ruleName, rulePrio) <- parseRuleHead (ls !! 0)+ (clauses, params) <- gatherClauses (take (ln - 2) (tail ls)) []+ (msg, msgParams) <- parseMsg (last ls) params+ return (ruleName, rulePrio, clauses, (msg, msgParams))++checkRuleStructure ls =+ if length ls < 3 then+ Left $ (10, "rule must consist of rule head, at least one clause and message")+ else+ Right ()++gatherClauses :: [String] -> [(ParamId, ParamName)] ->+ Either (ParseErrorId, ParseErrorMsg)+ (Statement, [(ParamId, ParamName)])+gatherClauses [c] acc = do+-- (Just (paramId, paramName), clause, params) <- parseClause c acc+ (maybeVar, clause, params) <- parseClause c acc+ return ([(fst `fmap` maybeVar, clause, params)], pushIfJust maybeVar acc)+gatherClauses (c:cs) acc = do+ (maybeVar, clause, params) <- parseClause c acc+ (restClauses, newAcc) <- gatherClauses cs (pushIfJust maybeVar acc)+ return ((fst `fmap` maybeVar, clause, params) : restClauses, newAcc)++pushIfJust Nothing xs = xs+pushIfJust (Just x) xs = x : xs++parseRuleHead :: String -> Either (ParseErrorId, ParseErrorMsg)+ (RuleName, RulePriority)+parseRuleHead rh =+ let ws = words rh+ in+ if null ws || head ws /= "rule" || length ws /= 4 ||+ ws !! 2 /= "priority" ||+ null (reads (ws !! 3) :: [(Int, String)])+ then Left (1, "rule head must be of form 'rule rulename priority xxx'")+ else Right (ws !! 1, fst $ head (reads (ws !! 3) :: [(Int, String)]))++parseClause :: String -> [(ParamId, ParamName)] ->+ Either (ParseErrorId, ParseErrorMsg)+ (Maybe (ParamId, ParamName), Clause, [RuleParam])+parseClause clause params = do+ let tokens = words clause+ hasVar <- checkClauseStructure tokens+ maybeVar <- checkVariable params (tokens !! 0) hasVar+ fact <- checkFact (tokens !! (if hasVar then 2 else 1))+ ps <- parseParams params (drop (if hasVar then 3 else 2) tokens)+ return (maybeVar, fact, ps)++checkClauseStructure tokens =+ if length tokens >= 3 && tokens !! 1 == "is"+ then Right True+ else if length tokens >= 2 && tokens !! 0 == "check"+ then Right False+ else Left (2, "clause must be of form 'var is fact params' or 'check fact params': " +++ concat (zipWith (++) tokens (repeat " ")))++checkVariable :: [(ParamId, ParamName)] -> String -> Bool ->+ Either (ParseErrorId, ParseErrorMsg) (Maybe (ParamId, ParamName))+checkVariable params token True =+ 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++newParamId params =+ if null params then 1+ else 1 + (maximum $ map fst params)++parseParams params [] = Right []+parseParams params ("scalar":tokens) = do+ (scalar, rest) <- checkParamScalar tokens+ result <- parseParams params rest+ return $ (PConst (FPScalar scalar)) : result+parseParams params ("spot":tokens) = do+ (x, y, rest) <- checkParamSpot tokens+ result <- parseParams params rest+ return $ (PConst (FPSpot $ Spot x y)) : result+parseParams params (paramName:tokens) = do+ pid <- checkParamName params paramName+ result <- parseParams params tokens+ return $ (PId pid) : result++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 tokens =+ if length tokens < 2 then Left (4, "unexpected end of clause after spot keyword")+ else if null (reads (tokens !! 0) :: [(Double, String)]) ||+ null (reads (tokens !! 1) :: [(Double, String)])+ then Left (5, "no number after spot: " ++ (tokens !! 0) ++ ", " ++ (tokens !! 1))+ else Right (fst $ head (reads (tokens !! 0) :: [(Double, String)]),+ fst $ head (reads (tokens !! 1) :: [(Double, String)]),+ drop 2 tokens)+checkParamName params paramName =+ case find ((paramName ==) . snd) params of+ Just (pid, _) -> Right pid+ Nothing -> Left (6, "parameter not known: " ++ paramName)++parseMsg :: String -> [(ParamId, ParamName)] ->+ Either (ParseErrorId, ParseErrorMsg)+ (MsgMaker, [RuleParam])+parseMsg input params = do+ let tokens = words input+ checkMsgStructure tokens+ msg <- checkMsg (tokens !! 1)+ ps <- parseParams params (drop 2 tokens)+ return (msg, ps)++checkMsgStructure tokens =+ if null tokens || length tokens < 2 ||+ tokens !! 0 /= "send"+ then Left (8, "message must be of form 'send msg params': " +++ concat (zipWith (++) tokens (repeat " ")))+ else Right ()++checkMsg "msgKick" = Right msgKick+checkMsg "msgIntercept" = Right msgIntercept+checkMsg x = Left (3, "no valid message: " ++ x)++checkFact "factCanIntercept" = Right factCanIntercept+checkFact "factIsCloseTo" = Right factIsCloseTo+checkFact "factInLineWith" = Right factInLineWith+checkFact "factBestFreePlayer" = Right factBestFreePlayer+checkFact "factNearestAIPlayer" = Right factNearestAIPlayer+checkFact "factBallIsFree" = Right factBallIsFree+checkFact "factAttacking" = Right factAttacking+checkFact "factThrowingIn" = Right factThrowingIn+checkFact "factBestPosition" = Right factBestPosition+checkFact "factKickOff" = Right factKickOff+checkFact "factBallCarrier" = Right factBallCarrier+checkFact "factPlayerSpot" = Right factPlayerSpot+checkFact "factSpotValue" = Right factSpotValue+checkFact "factBestShootingVector" = Right factBestShootingVector+checkFact "factBestPassingVector" = Right factBestPassingVector+checkFact "factPunt" = Right factPunt+checkFact "factIdling" = Right factIdling+checkFact "factWhoAmI" = Right factWhoAmI+checkFact "factEq" = Right factEq+checkFact "factGT" = Right factGT+checkFact "factGetVector" = Right factGetVector++msgKick :: MsgMaker+msgKick _ [FPPlayerId ballCarrier, FPVector goalVector] =+ [(ballCarrier, tm (TPTKickTowards,+ (TacticalStateParam Nothing (Just goalVector)+ False Nothing Nothing Nothing Nothing)))]++msgIntercept :: MsgMaker+msgIntercept _ [FPPlayerId np, FPSpot p1] =+ [(np, tm (TPTIntercept,+ TacticalStateParam (Just $ spotToPoint p1) Nothing False Nothing Nothing Nothing Nothing))]
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ SqueakyChalkSound.ttf view
binary file changed (absent → 67740 bytes)
+ States.hs view
@@ -0,0 +1,51 @@+module States++where++data BasicState =+ PBSNoBall+ | PBSInPossession+ | PBSStunned+ | PBSKickingOff+ | PBSThrowingIn+ | PBSKickingCorner+ | PBSPrepareThrowIn+ deriving (Show, Eq)++data TacticalState =+ TSNonAI+ | TSNonAIKickingOff+ | TSWaiting+ | TSCovering+ | TSPositioning+ | TSInterceptBall+ | TSHoldingPosition+ | TSMovingToThrowIn+ | TSAimingThrowIn+ | TSWaitingForKickOff+ | TSFrozen+ | TSKickingTowards+ | TSTendingGoal+ | TSGoalieWaitingForKickOff+ deriving (Show, Eq)++data BallState =+ BSFree+ | BSControlled+ | BSChallenged+ | BSOutOfPlay+ | BSControlledOOP+ | BSControlledGoalie+ deriving (Show, Eq)++data GameState =+ GSGoal+ | GSFrozen+ | GSSideOut+ | GSBaseOut+ | GSThrowIn+ | GSCorner+ | GSKickOff+ | GSRunning+ | GSQuit+ deriving (Show, Eq)
+ ballM.wav view
binary file changed (absent → 32044 bytes)
+ chalkboard.png view
binary file changed (absent → 821634 bytes)
+ tockH.wav view
binary file changed (absent → 42028 bytes)
+ whistle.wav view
binary file changed (absent → 284588 bytes)