diff --git a/13ball.png b/13ball.png new file mode 100644 Binary files /dev/null and b/13ball.png differ diff --git a/15ball.png b/15ball.png new file mode 100644 Binary files /dev/null and b/15ball.png differ diff --git a/17ball.png b/17ball.png new file mode 100644 Binary files /dev/null and b/17ball.png differ diff --git a/20THCENT.TTF b/20THCENT.TTF new file mode 100644 Binary files /dev/null and b/20THCENT.TTF differ diff --git a/20ball.png b/20ball.png new file mode 100644 Binary files /dev/null and b/20ball.png differ diff --git a/25ball.png b/25ball.png new file mode 100644 Binary files /dev/null and b/25ball.png differ diff --git a/30ball.png b/30ball.png new file mode 100644 Binary files /dev/null and b/30ball.png differ diff --git a/AI.hs b/AI.hs new file mode 100644 --- /dev/null +++ b/AI.hs @@ -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 + + diff --git a/AL.hs b/AL.hs new file mode 100644 --- /dev/null +++ b/AL.hs @@ -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)]) diff --git a/Animate.hs b/Animate.hs new file mode 100644 --- /dev/null +++ b/Animate.hs @@ -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) diff --git a/BallFSM.hs b/BallFSM.hs new file mode 100644 --- /dev/null +++ b/BallFSM.hs @@ -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 + diff --git a/BasicTypes.hs b/BasicTypes.hs new file mode 100644 --- /dev/null +++ b/BasicTypes.hs @@ -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] + + + + + diff --git a/Command.hs b/Command.hs new file mode 100644 --- /dev/null +++ b/Command.hs @@ -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 diff --git a/Data/FSM.hs b/Data/FSM.hs new file mode 100644 --- /dev/null +++ b/Data/FSM.hs @@ -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))) + diff --git a/GameFSM.hs b/GameFSM.hs new file mode 100644 --- /dev/null +++ b/GameFSM.hs @@ -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 + diff --git a/GameLoop.hs b/GameLoop.hs new file mode 100644 --- /dev/null +++ b/GameLoop.hs @@ -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 + + + + diff --git a/Global.hs b/Global.hs new file mode 100644 --- /dev/null +++ b/Global.hs @@ -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 +} diff --git a/Grid.hs b/Grid.hs new file mode 100644 --- /dev/null +++ b/Grid.hs @@ -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 + diff --git a/Helper.hs b/Helper.hs new file mode 100644 --- /dev/null +++ b/Helper.hs @@ -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 + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Lineup.hs b/Lineup.hs new file mode 100644 --- /dev/null +++ b/Lineup.hs @@ -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)]) diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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}) diff --git a/Message.hs b/Message.hs new file mode 100644 --- /dev/null +++ b/Message.hs @@ -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 diff --git a/Object.hs b/Object.hs new file mode 100644 --- /dev/null +++ b/Object.hs @@ -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] + diff --git a/ObjectBehaviour.hs b/ObjectBehaviour.hs new file mode 100644 --- /dev/null +++ b/ObjectBehaviour.hs @@ -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 diff --git a/ParseTeam.hs b/ParseTeam.hs new file mode 100644 --- /dev/null +++ b/ParseTeam.hs @@ -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 offense defense speed acc cover ', 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" diff --git a/Parser.hs b/Parser.hs new file mode 100644 --- /dev/null +++ b/Parser.hs @@ -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 + + + diff --git a/Physics.hs b/Physics.hs new file mode 100644 --- /dev/null +++ b/Physics.hs @@ -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 + diff --git a/PlayerFSM.hs b/PlayerFSM.hs new file mode 100644 --- /dev/null +++ b/PlayerFSM.hs @@ -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'=yb then Q2 + else if xd' (acos $ 10/t, asin $ 5/t) +--(0.46364760900080615,0.4636476090008061) +--Prelude> (acos $ -10/t, asin $ 5/t) +--(2.677945044588987,0.4636476090008061) +--Prelude> (acos $ -10/t, asin $ -5/t) +--(2.677945044588987,-0.4636476090008061) +--Prelude> (acos $ 10/t, asin $ -5/t) +--(0.46364760900080615,-0.4636476090008061) + +data Quadrant = Q1 | Q2 | Q3 | Q4 + +acosNorm 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 diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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" +--------------------------------------------------------------------------------- diff --git a/Rasenschach.cabal b/Rasenschach.cabal new file mode 100644 --- /dev/null +++ b/Rasenschach.cabal @@ -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 + diff --git a/Render.hs b/Render.hs new file mode 100644 --- /dev/null +++ b/Render.hs @@ -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 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 + diff --git a/RenderBall.hs b/RenderBall.hs new file mode 100644 --- /dev/null +++ b/RenderBall.hs @@ -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) + diff --git a/RenderGame.hs b/RenderGame.hs new file mode 100644 --- /dev/null +++ b/RenderGame.hs @@ -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 diff --git a/RenderPlayer.hs b/RenderPlayer.hs new file mode 100644 --- /dev/null +++ b/RenderPlayer.hs @@ -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)) diff --git a/RenderUtil.hs b/RenderUtil.hs new file mode 100644 --- /dev/null +++ b/RenderUtil.hs @@ -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) diff --git a/Rules.hs b/Rules.hs new file mode 100644 --- /dev/null +++ b/Rules.hs @@ -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))] diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/SqueakyChalkSound.ttf b/SqueakyChalkSound.ttf new file mode 100644 Binary files /dev/null and b/SqueakyChalkSound.ttf differ diff --git a/States.hs b/States.hs new file mode 100644 --- /dev/null +++ b/States.hs @@ -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) diff --git a/ballM.wav b/ballM.wav new file mode 100644 Binary files /dev/null and b/ballM.wav differ diff --git a/chalkboard.png b/chalkboard.png new file mode 100644 Binary files /dev/null and b/chalkboard.png differ diff --git a/tockH.wav b/tockH.wav new file mode 100644 Binary files /dev/null and b/tockH.wav differ diff --git a/whistle.wav b/whistle.wav new file mode 100644 Binary files /dev/null and b/whistle.wav differ