module Main where
import Graphics.UI.GLUT hiding (Level,Vector3(..),normalize)
import System.Directory
import System.FilePath ((</>))
import Data.IORef
import Control.Concurrent.MVar
import Control.Monad (when, unless)
import Data.List
import Data.Ord (comparing)
import FRP.Yampa
import FRP.Yampa.Geometry
import Data.Time.Clock
import Data.Convertible
import qualified Render
import Object
import Animate
import AL
import States
import BasicTypes
import Message
import Global
import Grid
import ParseTeam
import Data.FSM
import Menu
import Helper
import Lineup
spainBorder :: RSPixel
spainBorder = RSPixel 252 0 2
spainCircle :: RSPixel
spainCircle = RSPixel 255 255 1
germanyBorder :: RSPixel
germanyBorder = RSPixel 0 0 0
germanyCircle :: RSPixel
germanyCircle = RSPixel 255 255 255
tiHome :: (Team, RSPixel, RSPixel)
tiHome = (Home, spainBorder, spainCircle)
tiAway :: (Team, RSPixel, RSPixel)
tiAway = (Away, germanyBorder, germanyCircle)
main :: IO ()
main = do
(win, graphData) <- Render.initGL
setupBasicFiles
runGame win graphData
runGame :: Window -> GraphicsData -> IO ()
runGame win graphData = do
timeState <- newIORef 0.0 :: IO (IORef Double)
frameCounter <- newIORef 0 :: IO (IORef Int)
newInput <- newMVar []
shifted <- newIORef False :: IO (IORef Bool)
let (mFsm, mState) = menuFsm
menuMode <- newIORef mState
lastMenuPos <- newIORef (0, 0) :: IO (IORef (GLfloat, GLfloat))
gameRunning <- newIORef False
resultRef <- newIORef (False, 0, 0)
(playersHome, playersAway, param) <- paramFromOutside
bos <- baseObjs param
let pls = playersInit param playersHome playersAway
let alout = appendAL bos pls
let (lOO,lObj) = lineupKickoff param alout 0 Home 0 0
rh <- animateInit param graphData resultRef 0 timeState frameCounter $ mergeAL lObj lOO
rhRef <- newIORef rh
t0 <- getCurrentTime
t0State <- newIORef (convert t0) :: IO (IORef Double)
displayCallback $= return ()
keyboardMouseCallback $= Just
(\k ks mods _ -> do
when (shift mods == Down) $
writeIORef shifted True
when (shift mods == Up) $
writeIORef shifted False
sh <- readIORef shifted
let e = transformButton k ks sh
modifyIORef' (gdCurrentTranslate graphData) $ \(x, y, z) ->
(x, y, case e of
RSMouseWheelUp -> z + 2
RSMouseWheelDown -> z - 2
_ -> z)
modifyMVar_ newInput $ \rs ->
return $ e:rs)
passiveMotionCallback $= Just
(\(Position x y) -> modifyMVar_ newInput $ \rs -> do
let maxH = realToFrac $ gdMaxHeigth graphData
currT@(adjX, adjY, _) <- readIORef (gdCurrentTranslate graphData)
winS <- readIORef (gdWinSize graphData)
let (u, v) = pointToPitch param maxH currT winS (fromIntegral x, fromIntegral y)
return $
RSMouseMotion (u + realToFrac adjX) (v + realToFrac adjY):rs)
idleCallback $= Just ( do
mSt <- readIORef menuMode
currRh <- readIORef rhRef
running <- readIORef gameRunning
terminate <- if running then do
t0' <- readIORef t0State
animate' currRh t0' timeState frameCounter newInput
else return False
when (running && terminate) $
writeIORef gameRunning False
unless running $ do
mis <- tryTakeMVar newInput
modifyIORef' (gdCurrentTranslate graphData) $ const (0, 0, 71)
putMVar newInput []
(newRunning, trans) <- Render.runMenu lastMenuPos mis (content mSt)
let Just (newSt,_) = case trans of
Just trans' -> runTrans mFsm mSt trans' ()
Nothing -> Just (mSt, [])
writeIORef menuMode newSt
when newRunning $ do
-- Reset game state before starting new game
writeIORef gameRunning True
r@(aborted, hg, ag) <- readIORef resultRef
print $ "RESULT=" ++ show r
writeIORef timeState 0.0
writeIORef shifted False
t0New <- getCurrentTime
writeIORef t0State (convert t0New)
rh' <- animateInit param graphData resultRef
0 timeState frameCounter $ mergeAL lObj lOO
writeIORef rhRef rh'
when (content mSt == MSTerminated) $ do
fc <- readIORef frameCounter
putStrLn $ "Frames: " ++ show fc
destroyWindow win
)
mainLoop
transformButton :: Key -> KeyState -> Bool -> RSEvent
transformButton k ks sh =
case k of
Char 'a' -> rsks RSK_a rsms
Char 'A' -> rsks RSK_a rsms -- muss wohl so bei opengl, dann die Shift-Logik eigentlich unnötig...
Char 's' -> rsks RSK_s rsms
Char 'S' -> rsks RSK_s rsms
Char 'd' -> rsks RSK_d rsms
Char 'D' -> rsks RSK_d rsms
Char 'e' -> rsks RSK_e rsms
Char 'E' -> rsks RSK_e rsms
Char 'w' -> rsks RSK_w rsms
Char 'W' -> rsks RSK_w rsms
Char 'q' -> rsks RSK_q rsms
Char 'Q' -> rsks RSK_q rsms
Char 'c' -> rsks RSK_c rsms
Char 'y' -> rsks RSK_y rsms
Char 'n' -> rsks RSK_n rsms
Char ' ' -> rsks RSK_SPACE rsms
Char '\ESC' -> rsks RSK_ESCAPE rsms
Char 'f' -> rsks RSK_f rsms
MouseButton LeftButton -> if ks==Down then RSMouseButtonDownLeft else RSBoring
MouseButton RightButton -> if ks==Down then RSMouseButtonDownRight else RSBoring
MouseButton WheelUp -> if ks==Down then RSMouseWheelUp else RSBoring
MouseButton WheelDown -> if ks==Down then RSMouseWheelDown else RSBoring
_ -> RSBoring
where rsks = if ks == Up then RSKeyUp else RSKeyDown
rsms = [RSKeyModShift | sh]
baseObjs :: (Monad m, Num k) => t -> m (AL k ObjOutput)
baseObjs _ =
let
g = (1, ObjOutput (OOSGame 100 (0, 0) (GSKickOff, GPTeamPosition Home 100 []
(Point2 0 0) 0 False OOPKickOff) Home (Point3 0 0 0))
NoEvent NoEvent [])
-- CAUTION: Always start with a valid player id!!
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 :: (Enum k, Num k) => Param -> [PlayerInfo] -> [PlayerInfo] -> AL k ObjOutput
playersInit param playersHome playersAway =
let h = zip [100..] $ map (\pI -> op (kicksOff == piNumber pI) tiHome pI) playersHome
a = zip [200..] $ map (op False tiAway . mirrorPlayer) playersAway
axis = Point2 (pPitchWidth param / 2) (pPitchLength param / 2)
kicksOff = piNumber $ minimumBy (comparing dist) 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 pl@(PlayerInfo { piBasePosDefense = pd, piBasePosOffense = po }) =
pl{ 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 = 3.0, --8.9,
pRightBorderX = 43.0, --46.1,
pUpperBorderY = 2.0, --9.3,
pLowerBorderY = 4.0, --10,
pPitchLength = 116.8,
pPitchWidth = 89.5,
pGoalWidth = 10.32,
pMaxheight = 60.0, -- in Meter
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})