Rasenschach-0.1.2: GameFSM.hs

module GameFSM (gameSF)

where

import FRP.Yampa
import FRP.Yampa.Geometry

import Data.Maybe

import Data.FSM

import Message
import Object
import States
import Helper
import BasicTypes
import Global

type GamePerception = [VisibleState]

s1 :: Param -> State GameState GameTransition (GameStateParam, GamePerception) [Message]
s1 param = addTransition GTTakePossession 1 $
     addTransition GTOutOfPlay 2 $
     addTransition GTGoal 4 $
     addTransition GTQuit 5 $
     addTransition GTFreeze 6 $
     addTransition GTCheckOffsite 8 $
     state 1 GSRunning (checkIfTimeUp param) (const []) (const [])
s2 :: Param -> State GameState GameTransition (GameStateParam, GamePerception) [Message]
s2 param =
     addTransition GTTakePossession 2 $
     addTransition GTQuit 5 $
     addTransition GTBallInPlay 1 $
     state 2 GSOutOfPlay (const []) (sideOutMessages param) (const [])
s4 :: State GameState GameTransition p [a]
s4 = addTransition GTTakePossession 4 $
     state 4 GSGoal (const []) (const []) (const [])
s5 :: State GameState t p [a]
s5 = --addTransition GTTakePossession 5 $ ???
     state 5 GSQuit (const []) (const []) (const [])
s6 :: State GameState GameTransition (GameStateParam, GamePerception) [Message]
s6 = addTransition GTTakePossession 6 $
     addTransition GTFreeze 1 $
     state 6 GSFrozen (const []) freezePlayers thawPlayers
s7 :: State GameState GameTransition (GameStateParam, GamePerception) [Message]
s7 = addTransition GTRunGame 1 $
     addTransition GTQuit 5 $
     addTransition GTWaitKickOff 7 $
     state 7 GSKickOff stopWhistling (const [])  (const [])
s8 :: State GameState GameTransition p [a]
s8 = addTransition GTNoOffsite 1 $
     addTransition GTOutOfPlay 2 $
     addTransition GTGoal 4 $
     addTransition GTQuit 5 $
     addTransition GTOffsite 2 $
--     addTransition GTFreeze 6 $ -- freeze/unfreeze should not break offsite
     state 8 GSOffsitePending (const []) (const []) (const [])

fsm :: Param -> Either [Problem GameTransition] 
                       (FSM GameState GameTransition (GameStateParam, GamePerception) [Message])
fsm param = fromList [s1 param, s2 param, s4, s5, s6, s7, s8]

stopWhistling :: (GameStateParam, GamePerception) -> [Message]
stopWhistling (gsp,vss) =
    let g = fetchGameVS vss
        me = vsObjId g
        GPTeamPosition a b c d e _ _ = gsp
    in [(me, GameMessage (GTWaitKickOff,
                           GPTeamPosition a b c d e False OOPKickOff))]

checkIfTimeUp :: Param -> (GameStateParam, GamePerception) -> [Message]
checkIfTimeUp param (_,vss) =
    let g = fetchGameVS vss
        t = vsGameTime g
        me = vsObjId g
    in [(me, GameMessage (GTQuit,
                           GPTeamPosition Home (-1) [] (Point2 0 0) t True InPlay))
                                 | 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 _ _ _, 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

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 -> GameStateParam -> 
--                      SF (GamePerception, Event [(GameTransition, GameStateParam)]) 
--                         ((State GameState GameTransition (GameStateParam, GamePerception) [Message], GameStateParam), [Message])
-- controlledGameSF param me = reactMachineMult (fromRight (fsm param)) (s2 param) me