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})