Rasenschach-0.1: GameFSM.hs

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