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