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) import Data.Convertible import Data.Time.Clock import Data.List import Data.Ord (comparing) import FRP.Yampa import FRP.Yampa.Geometry import qualified Render import Object import Animate import AL import States import BasicTypes import Message import Global import Grid import Parser import ParseTeam 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 timeState <- newIORef 0.0 :: IO (IORef Double) frameCounter <- newIORef 0 :: IO (IORef Int) newInput <- newMVar [] shifted <- newIORef False :: IO (IORef Bool) (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 0 timeState frameCounter $ mergeAL lObj lOO displayCallback $= return () keyboardMouseCallback $= Just (\k ks mods (Position x y) -> do when (shift mods == Down) $ do -- putStrLn "-------------Down------------" writeIORef shifted True when (shift mods == Up) $ do -- putStrLn "+++++++++++++Up++++++++++++++" writeIORef shifted False sh <- readIORef shifted -- putStrLn $ "SHIFT=" ++ show sh let e = transformButton k ks sh -- putStrLn $ "Event=" ++ show e 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 terminate <- animate' param graphData rh timeState frameCounter newInput when terminate $ 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 = if sh then [RSKeyModShift] else [] 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})