diff --git a/20THCENT.TTF b/20THCENT.TTF deleted file mode 100644 Binary files a/20THCENT.TTF and /dev/null differ diff --git a/20redball.png b/20redball.png deleted file mode 100644 Binary files a/20redball.png and /dev/null differ diff --git a/23redball.png b/23redball.png deleted file mode 100644 Binary files a/23redball.png and /dev/null differ diff --git a/26redball.png b/26redball.png deleted file mode 100644 Binary files a/26redball.png and /dev/null differ diff --git a/30redball.png b/30redball.png deleted file mode 100644 Binary files a/30redball.png and /dev/null differ diff --git a/35redball.png b/35redball.png deleted file mode 100644 Binary files a/35redball.png and /dev/null differ diff --git a/40redball.png b/40redball.png deleted file mode 100644 Binary files a/40redball.png and /dev/null differ diff --git a/Animate.hs b/Animate.hs --- a/Animate.hs +++ b/Animate.hs @@ -1,18 +1,17 @@ module Animate where + +import Graphics.UI.GLUT (GLuint) -import Graphics.UI.SDL -import Graphics.UI.SDL.TTF -import Graphics.UI.SDL.Mixer as Mix import Control.Monad.Loops import Control.Monad -import Data.Array +import Data.Array import Data.IORef +import Control.Concurrent.MVar import Data.Convertible import Data.Time.Clock import FRP.Yampa -import qualified Graphics.UI.SDL as SDL import qualified Render as Render @@ -23,30 +22,66 @@ import Global import GameLoop -animate :: (Num i, Ix i) => Param -> - IORef (Maybe (Surface, Surface, Array i Font, Array Int (Surface, Int), Chunk, Chunk, Chunk)) -> Double -> IORef Double -> IORef Int -> [(ObjId, Object, ObjOutput)] -> IO () -animate param sdlState tInit timeState frameCounter objs = do - reactimate (initialize tInit) - (input tInit timeState frameCounter) - (output param sdlState) - (gameLoop param - (AL $ map (\(id', _, oo) -> (id', oo)) objs) - (AL $ map (\(id', o, _) -> (id', o)) objs) - ) --- reactimation IO ---------- +animate' parm graphData rh timeState frameCounter newInput = do + t <- getCurrentTime + let t' = convert t :: Double + t0 <- readIORef timeState + writeIORef timeState t' + inp <- input' parm graphData (t'-t0) frameCounter newInput True + react rh inp -initialize :: Double -> IO (Double, [SDL.Event]) -initialize tInit = do - events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent - t <- getCurrentTime - return ((convert t :: Double) - tInit, events) +animateInit param graphData dt timeState frameCounter objs = do + (dt, Just gi0) <- input dt timeState frameCounter True + reactInit (return gi0) + (output' param graphData) + (gameLoop param + (AL $ map (\(id, o, oo) -> (id, oo)) objs) + (AL $ map (\(id, o, oo) -> (id, o)) objs)) + +input' :: Param -> + GraphicsData -> + Time -> + IORef Int -> + MVar [RSEvent] -> + Bool -> + IO (DTime, Maybe GameInput) +input' parm graphData dt counter newInput b = do + maybeEvents <- tryTakeMVar newInput + putMVar newInput [] + count <- readIORef counter + let events = case maybeEvents of + Nothing -> [] + Just es -> es + writeIORef counter (count + 1) +-- putStrLn . show $ events + return (dt, Just (dt * (fromIntegral count), events)) + + +output' :: (Eq a, Num a) => --(Eq a, Num i, Num a, Ix i) => + Param + -> GraphicsData + -> t + -> t1 + -> AL a ObjOutput + -> IO Bool +output' param graphData rh _ oal@(AL oos) = do + Render.render param (map (ooObsObjState . snd) oos) graphData + let ol = (AL.!) oal 1 + + when (((fst . oosGameState . ooObsObjState) ol) == GSQuit) $ putStrLn "Quit" + return (((fst . oosGameState . ooObsObjState) ol) == GSQuit) +-- neuer Kram endet hier + + +-- reactimation IO ---------- + input :: Time -> IORef Double -> IORef Int -> Bool -> IO (DTime, Maybe GameInput) input tInit stateTime counter _ = do count <- readIORef counter writeIORef counter (count + 1) - events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent + let events = [] -- events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent t1 <- getCurrentTime let t1' = convert t1 :: Double t0 <- readIORef stateTime @@ -54,14 +89,3 @@ return (t1'-t0, Just (t1'-tInit, events)) -output :: (Eq k, Num k, Num i, Ix i) => - Param -> IORef (Maybe (Surface, Surface, Array i Font, Array Int (Surface, Int), Chunk, Chunk, Chunk)) -> - t -> AL k ObjOutput -> - IO Bool -output param sdlState _ oal@(AL oos) = do - Just sdl <- readIORef sdlState - Render.render param (map (ooObsObjState . snd) oos) sdl - let ol = (AL.!) oal 1 - - when (((fst . oosGameState . ooObsObjState) ol) == GSQuit) $ putStrLn "Hallo" - return (((fst . oosGameState . ooObsObjState) ol) == GSQuit) diff --git a/BasicTypes.hs b/BasicTypes.hs --- a/BasicTypes.hs +++ b/BasicTypes.hs @@ -1,15 +1,45 @@ {-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-} - + module BasicTypes - + where import FRP.Yampa import FRP.Yampa.Geometry -import qualified Graphics.UI.SDL as SDL (Pixel, Event) +import Data.IORef + +import Graphics.UI.GLUT (GLuint, GLdouble) + import Physics + +------------------------------------------------------------------------------ +type R = GLdouble + +data GraphicsData = GraphicsData { + gdWinSize :: !(IORef (Int, Int)) + ,gdMaxHeigth :: !Double + ,gdCurrentTranslate :: !(IORef (Double, Double, Double)) + ,gdTextureHome :: !GLuint + ,gdTextureGoalieHome :: !GLuint + ,gdTextureSelHome :: !GLuint + ,gdTextureDesHome :: !GLuint + ,gdTextureAway :: !GLuint + ,gdTextureGoalieAway :: !GLuint +} +data RSKey = RSK_a | RSK_s | RSK_d | RSK_e | RSK_w | RSK_q | RSK_c | RSK_y | RSK_n | RSK_SPACE | RSK_ESCAPE | RSK_f + deriving (Eq, Ord, Show) +data RSModifier = RSKeyModLeftShift | RSKeyModRightShift | RSKeyModShift + deriving (Eq, Ord, Show) +data RSPixel = RSPixel Int Int Int + +data RSEvent = RSKeyUp RSKey [RSModifier] | RSKeyDown RSKey [RSModifier] | RSMouseButtonDownLeft + | RSMouseButtonDownRight | RSMouseMotion Double Double + | RSMouseWheelDown | RSMouseWheelUp | RSBoring + deriving (Eq, Ord, Show) + + ------------------------------------------------------------------------------ type ObjId = Int @@ -21,8 +51,8 @@ data Team = Home | Away deriving (Eq, Show) type TeamInfo = (Team, -- True = Home, False = Away - SDL.Pixel, -- Team color 1 - SDL.Pixel) -- Team color 2 + RSPixel, -- Team color 1 + RSPixel) -- Team color 2 data PlayerInfo = PlayerInfo { piNumber :: Int -- Number on jersey @@ -40,7 +70,7 @@ type CurrentTime = Time type StateTime = Time -type GameInput = (CurrentTime, [SDL.Event]) +type GameInput = (CurrentTime, [RSEvent]) type Input = (Event TimerEvent, GameInput) type FactFunction = [FactParam] -> Maybe FactParam diff --git a/GameLoop.hs b/GameLoop.hs --- a/GameLoop.hs +++ b/GameLoop.hs @@ -112,9 +112,9 @@ ++ hitsAux kooss hit :: ObsObjState -> ObsObjState -> Bool - OOSPlayer {oosPos = p1} `hit` OOSPlayer {oosPos = p2} = distance p1 p2 < 3.0 - OOSPlayer {oosPos = p1} `hit` OOSBall {oosPos = p2} = distance p1 p2 < 1.4 - OOSBall {oosPos = p1} `hit` OOSPlayer {oosPos = p2} = distance p1 p2 < 1.4 + OOSPlayer {oosPos = p1} `hit` OOSPlayer {oosPos = p2} = distance p1 p2 < 2.6 --3.0 + OOSPlayer {oosPos = p1} `hit` OOSBall {oosPos = p2} = distance p1 p2 < 1.2 -- 1.2 + OOSBall {oosPos = p1} `hit` OOSPlayer {oosPos = p2} = distance p1 p2 < 1.2 -- 1.4 _ `hit` _ = False mirror [] = [] diff --git a/Helper.hs b/Helper.hs --- a/Helper.hs +++ b/Helper.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} - + module Helper where @@ -10,6 +10,8 @@ import Data.Function import GHC.Exts +import GHC.Int + import FRP.Yampa import FRP.Yampa.Geometry @@ -22,6 +24,22 @@ import BasicTypes import AL +ratio param winy maxh currh = --8.625 + (currh/maxh)*(pPitchLength param/winy) + +pointToPitch :: (Integral b, Integral b1) => Param -> Double -> + (t, t1, Double) -> (b, b1) -> (Double, Double) -> + (Double, Double) +pointToPitch param maxHeight currTrans winSize (x,y) = + let (winX, winY) = (fromIntegral . fst $ winSize, fromIntegral . snd $ winSize) + (_,_,currHeight) = currTrans + (pWidth,pLength) = (pPitchWidth param, pPitchLength param) + mPp = ratio param winY maxHeight currHeight + pLeft = pWidth/2 - (winX/2) * mPp + pUpper = pLength/2 - (winY/2) * mPp + in (pLeft+x*mPp, pUpper+y*mPp) + + -- ************************************************************************* -- -- Various geometric functions @@ -160,6 +178,14 @@ case v of VSGame {} -> v _ -> fetchGameVS vs + +fetchBallOOS :: [ObsObjState] -> ObsObjState +fetchBallOOS [] = error "Helper/fetchBallVS: No ball in OOS" +fetchBallOOS (v:vs) = + case v of + OOSBall {} -> v + _ -> fetchBallOOS vs + fetchBallVS :: [VisibleState] -> VisibleState fetchBallVS [] = error "Helper/fetchBallVS: No ball in Visible States" diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,26 +1,20 @@ module Main where - -import Graphics.UI.SDL (Surface) -import Graphics.UI.SDL.TTF -import Graphics.UI.SDL.Mixer as Mix + +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 -import Data.Array -import Control.Monad - +import Data.Ord (comparing) import FRP.Yampa import FRP.Yampa.Geometry -import qualified Graphics.UI.SDL as SDL - -import qualified Render -import RenderUtil +import qualified Render import Object import Animate @@ -35,58 +29,117 @@ import Helper import Lineup -spainBorder :: SDL.Pixel -spainBorder = rgbColor 252 0 2 -spainCircle :: SDL.Pixel -spainCircle = rgbColor 255 255 1 +spainBorder :: RSPixel +spainBorder = RSPixel 252 0 2 +spainCircle :: RSPixel +spainCircle = RSPixel 255 255 1 -germanyBorder :: SDL.Pixel -germanyBorder = rgbColor 0 0 0 -germanyCircle :: SDL.Pixel -germanyCircle = rgbColor 255 255 255 +germanyBorder :: RSPixel +germanyBorder = RSPixel 0 0 0 +germanyCircle :: RSPixel +germanyCircle = RSPixel 255 255 255 -tiHome :: (Team, SDL.Pixel, SDL.Pixel) +tiHome :: (Team, RSPixel, RSPixel) tiHome = (Home, spainBorder, spainCircle) -tiAway :: (Team, SDL.Pixel, SDL.Pixel) +tiAway :: (Team, RSPixel, RSPixel) tiAway = (Away, germanyBorder, germanyCircle) - + main :: IO () main = do + (win, graphData) <- Render.initGL + setupBasicFiles - sdl <- Render.init + + 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 - mainLoop sdl playersHome playersAway param - SDL.quit -mainLoop :: (Num i, Ix i) => (Surface, Surface, Array i Font, Array Int (Surface, Int), Chunk, Chunk, Chunk) -> [PlayerInfo] -> [PlayerInfo] -> Param -> IO () -mainLoop sdl playersHome playersAway param = do - sdlState <- newIORef Nothing - writeIORef sdlState (Just sdl) bos <- baseObjs param let pls = playersInit param playersHome playersAway let alout = appendAL bos pls - frameCounter <- newIORef 0 :: IO (IORef Int) - t <- getCurrentTime - let t' = convert t :: Double - timeState <- newIORef t' --(convert t :: Double) let (lOO,lObj) = lineupKickoff param alout 0 Home 0 0 - Render.render param (map ooObsObjState $ elemsAL lOO) sdl - Render.renderStartMsg sdl - waitForSpaceKey - animate param sdlState t' timeState frameCounter $ mergeAL lObj lOO - count <- readIORef frameCounter - rightNow <- getCurrentTime - let seconds = convert rightNow - t' - putStrLn $ "Frames per second: " ++ show (fromIntegral count / seconds) - Render.renderEndMsg sdl - continue <- shouldContinue - if continue then mainLoop sdl playersHome playersAway param else return () + 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 []) + 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)) @@ -100,7 +153,7 @@ 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 (\p1 p2 -> comparing dist p1 p2) playersHome + 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) @@ -157,4 +210,4 @@ pGrid = undefined } return (pHome, pAway, param {pGrid = grid param 10 10}) - + diff --git a/ObjectBehaviour.hs b/ObjectBehaviour.hs --- a/ObjectBehaviour.hs +++ b/ObjectBehaviour.hs @@ -9,7 +9,6 @@ import Data.List import Data.Maybe import Control.Monad (guard) ---import Graphics.UI.SDL (Pixel) import FRP.Yampa import FRP.Yampa.Geometry @@ -143,7 +142,7 @@ -- position and velocity of the ball are taken from the player's -- respective values - let p = vsPos playerVS .-^ fromPolar3 (foot + pi + vsDir playerVS) 2.1 0 + let p = vsPos playerVS .-^ fromPolar3 (foot + pi + vsDir playerVS) 1.7 0 -- 2.1 0 let v = vsVel playerVS lostPossession <- edge -< content st == BSFree @@ -152,7 +151,8 @@ returnA -< ObjOutput (OOSBall p v False ((content st), stParam)) (lostPossession `merge` outOfPlay) ( - (lostPossession `tag` [snd3 $ mkBall (param, me, currPlayer, t1, p, (fetchVel stParam), (makeBreakVector (fetchVel stParam)), cNext)]) + (lostPossession `tag` [snd3 $ mkBall (param, me, currPlayer, t1, + p, (fetchVel stParam), (makeBreakVector (fetchVel stParam)), cNext)]) `merge` (outOfPlay `tag` [let BPOutOfPlay team oop pos _ = stParam in ballOutOfPlay param me currPlayer team oop pos]) ) @@ -236,7 +236,7 @@ -- position is above and behind player let posAdjust = if (content st) == BSControlledOOP then - vsPos playerVS .-^ fromPolar3 (vsDir playerVS) 3 (-posZ) + vsPos playerVS .-^ fromPolar3 (vsDir playerVS) 2 (-posZ) else pos .+! posZ backInPlay <- edge -< not $ content st `elem` [BSOutOfPlay, BSControlledOOP, BSChallenged] @@ -379,7 +379,8 @@ proc (ObjInput {oiGameInput = gi@(_,(t1,_)), oiGameState = vss, oiMessages = (mi, colls)}) -> do -- desired position is current mouse position - (pd, commands) <- playerInput param -< gi + -- jetzt passt es fast, weil die Position des Spielers eingeht, ganz richtig wäre die Position der Maus... + (pd, commands) <- playerInput param p0 -< gi -- mark designated receiver let myTeam = fst3 ti @@ -399,9 +400,8 @@ oosBS' <- iPre pbsInit -< oosBS let markMsg = messageForNearestPlayer param npId myTeam pos' commands vss - let teamMateMsg = messageForTeamMate me myTeam pos' commands vss - + let teamMateMsg = messageForTeamMate me myTeam pos' commands vss ((st',stParam), _) <- tacticalNonAiSF initState -< ((t1, me, vss, commands), Event tms) let st = @@ -423,7 +423,7 @@ results@(ObjOutput oop@OOSPlayer{oosPos = pos, oosVel = vel, oosDir = angle, oosBasicState = (oosBS, _)} _ - _ + _ msgs) <- playerCore param me t0 p0 v0 sel des ti pI pbsInit -< (pdAdjusted, not (null comMsgs), angleAdjusted, t1, commands, (mi ++ comMsgs, colls), vss) @@ -501,7 +501,7 @@ let velBounce = adjust *^ bouncePower vsVel vss (me:pCollsIn) toggled <- edge -< cmdToggleFoot commands - + rec let ad = ((20 *^ (pd .-. p)) ^-^ (10 *^ v)) -- Desired acceleration let acc = if inPlayerCollision then accBounce else limit (piPlayerAccMax pI) ad diff --git a/Parser.hs b/Parser.hs --- a/Parser.hs +++ b/Parser.hs @@ -3,9 +3,7 @@ module Parser (playerInput, shouldContinue, gameKeysSF, GameInput, Input, TimerEvent (..), waitForSpaceKey) where - -import qualified Graphics.UI.SDL as SDL -import Graphics.UI.SDL.Keysym + import Data.Maybe import Control.Monad (when) import Control.Monad.Loops (unfoldWhileM) @@ -13,12 +11,12 @@ import FRP.Yampa import FRP.Yampa.Geometry -import RenderUtil import Physics import Command import Data.FSM import Global import BasicTypes +import Helper -- ************************************************************************* -- @@ -26,12 +24,13 @@ -- -- ************************************************************************* + data Trigger = OnUp | OnDown type KeyFSM = FSM String -- Just the state's name, only for debugging - (KeyAction, SDL.SDLKey, Shifted) -- Transition is directe by the action (Up or Down), + (KeyAction, RSKey, Shifted) -- Transition is directe by the action (Up or Down), -- The key (a, s, ...) and the information whether -- The shift key was held down during release (StateTime, (CurrentTime, StateTime)) -- Whoa, that's kind of messy: first StateTime indicates @@ -44,7 +43,7 @@ -- first StateTime is ignored. [Command] -- Resulting command list. Will be only one, but needs to be a Monoid, -- so probably Maybe Command should also work? -type KeyState = State String (KeyAction, SDL.SDLKey, Shifted) (StateTime, (CurrentTime, StateTime)) [Command] +type KeyState = State String (KeyAction, RSKey, Shifted) (StateTime, (CurrentTime, StateTime)) [Command] -- ************************************************************************* @@ -59,21 +58,20 @@ p <- hold pInit -< me returnA -< p -mouseEvent :: Param -> [SDL.Event] -> Event Position2 +mouseEvent :: Param -> [RSEvent] -> Event Position2 mouseEvent _ [] = NoEvent mouseEvent param (e:es) = case e of - SDL.MouseMotion x y _ _ -> let (x', y') = pointToPitch param (fromIntegral x, fromIntegral y) - in Event (Point2 x' y') + RSMouseMotion x y -> Event (Point2 x y) _ -> mouseEvent param es -mouseCommand :: [SDL.Event] -> [Command] +mouseCommand :: [RSEvent] -> [Command] mouseCommand [] = [] mouseCommand (e:es) = case e of - SDL.MouseButtonDown _ _ SDL.ButtonLeft -> [CmdTakeOver] - SDL.MouseButtonDown _ _ SDL.ButtonRight -> [] + RSMouseButtonDownLeft -> [CmdTakeOver] + RSMouseButtonDownRight -> [] _ -> mouseCommand es @@ -83,7 +81,7 @@ -- -- ************************************************************************* -singleKeyCommand :: KeyFSM -> KeyState -> SF (CurrentTime, Event ([(KeyAction, SDL.SDLKey, Shifted)], StateTime)) [Command] +singleKeyCommand :: KeyFSM -> KeyState -> SF (CurrentTime, Event ([(KeyAction, RSKey, Shifted)], StateTime)) [Command] singleKeyCommand fsm initState = proc event' -> do ((_,_),command) <- reactMachineHist fsm initState 0 -< event' returnA -< command @@ -92,7 +90,7 @@ data KeyAction = Up | Down deriving (Ord, Eq, Show) data Shifted = Shifted | Unshifted deriving (Ord, Eq, Show) -newKeyOnUpFSM :: SDL.SDLKey -> Command -> Command -> (KeyFSM, KeyState) +newKeyOnUpFSM :: RSKey -> Command -> Command -> (KeyFSM, KeyState) newKeyOnUpFSM key commandShifted commandUnshifted = let onEnterSmA (_, (p, sOld)) = [commandShifted {dt = p-sOld}] @@ -118,7 +116,7 @@ in (fsm, s0) -newKeyOnDownFSM :: SDL.SDLKey -> Command -> Command -> (KeyFSM, KeyState) +newKeyOnDownFSM :: RSKey -> Command -> Command -> (KeyFSM, KeyState) newKeyOnDownFSM key commandShifted commandUnshifted = let onEnterSmA _ = [commandShifted] @@ -141,19 +139,25 @@ in (fsm, s0) -keySF :: (t -> t1 -> a -> (KeyFSM, KeyState)) -> t -> t1 -> a -> SF (CurrentTime, Event ([(KeyAction, SDLKey, Shifted)], StateTime)) [Command] +keySF :: (t -> t1 -> a -> (KeyFSM, KeyState)) -> t -> t1 -> a -> SF (CurrentTime, Event ([(KeyAction, RSKey, Shifted)], StateTime)) [Command] keySF newKeyFSM key commandShifted = uncurry singleKeyCommand . newKeyFSM key commandShifted -mapKeyEvent :: [SDL.SDLKey] -> SDL.Event -> Maybe (KeyAction, SDL.SDLKey, Shifted) -mapKeyEvent keys (SDL.KeyUp (SDL.Keysym key mods _)) = if elem key keys then Just (Up, key, checkModifiers mods) else Nothing -mapKeyEvent keys (SDL.KeyDown (SDL.Keysym key mods _)) = if elem key keys then Just (Down, key, checkModifiers mods) else Nothing -mapKeyEvent _ _ = Nothing +mapKeyEvent :: [RSKey] -> RSEvent -> Maybe (KeyAction, RSKey, Shifted) +mapKeyEvent keys rse = + case rse of + RSKeyUp key mods -> if elem key keys then Just (Up, key, checkModifiers mods) else Nothing + RSKeyDown key mods -> if elem key keys then Just (Down, key, checkModifiers mods) else Nothing + _ -> Nothing +-- mapKeyEvent keys (RSKeyUp key mods) = if elem key keys then Just (Up, key, checkModifiers mods) else Nothing +-- mapkeyevent keys (RSKeyDown key mods) = if elem key keys then Just (Down, key, checkModifiers mods) else Nothing +-- mapKeyEvent _ _ = Nothing -checkModifiers :: [Modifier] -> Shifted + +checkModifiers :: [RSModifier] -> Shifted checkModifiers mods = - if elem SDL.KeyModLeftShift mods || elem SDL.KeyModRightShift mods || elem SDL.KeyModShift mods + if elem RSKeyModLeftShift mods || elem RSKeyModRightShift mods || elem RSKeyModShift mods then Shifted else Unshifted @@ -163,7 +167,7 @@ -- -- ************************************************************************* -keyCommandSF' :: [(SDL.SDLKey, Trigger, (Command, Command))] -> SF (CurrentTime, Event ([(KeyAction, SDL.SDLKey, Shifted)], StateTime)) [Command] +keyCommandSF' :: [(RSKey, Trigger, (Command, Command))] -> SF (CurrentTime, Event ([(KeyAction, RSKey, Shifted)], StateTime)) [Command] keyCommandSF' keys = let fsms = map (\(sdlKey, trigger, (cShifted, cUnshifted)) -> case trigger of @@ -172,13 +176,13 @@ in concat ^<< parB fsms -- not really efficient, could also broadcast only those messages that -- are of interest to a given FSM -keyCommandSF :: [(SDL.SDLKey, Trigger, (Command, Command))] -> SF Input [Command] +keyCommandSF :: [(RSKey, Trigger, (Command, Command))] -> SF Input [Command] keyCommandSF keysCommands = proc (_, (gametime, input)) -> do - let keys = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [SDL.SDLK_a, SDL.SDLK_s, - SDL.SDLK_d, SDL.SDLK_e, - SDL.SDLK_w, SDL.SDLK_q, SDL.SDLK_c, - SDL.SDLK_SPACE, SDL.SDLK_ESCAPE, - SDL.SDLK_f]) input + let keys = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [RSK_a, RSK_s, + RSK_d, RSK_e, + RSK_w, RSK_q, RSK_c, + RSK_SPACE, RSK_ESCAPE, + RSK_f]) input let keyEvents = if keys == [] then NoEvent else Event (keys, gametime) result <- keyCommandSF' keysCommands -< (gametime, keyEvents) returnA -< result @@ -192,14 +196,14 @@ -- Caution: When adding more commands, remember to put the additional key in keyCommandSF!! playerKeysSF :: SF Input [Command] -playerKeysSF = keyCommandSF [(SDL.SDLK_a, OnUp, (CmdPassLow 0, CmdPassHigh 0)), - (SDL.SDLK_d, OnDown, (CmdFlipLow, CmdFlipHigh)), - (SDL.SDLK_e, OnDown, (CmdMoveForward, CmdMoveBackward)), - (SDL.SDLK_w, OnDown, (CmdMoveLeft, CmdMoveRight)), - (SDL.SDLK_q, OnDown, (CmdMoveToGoal, CmdMoveToMe)), - (SDL.SDLK_s, OnUp, (CmdKickLow 0, CmdKickHigh 0)), - (SDL.SDLK_c, OnDown, (CmdFlipMeLow, CmdFlipMeHigh)), - (SDL.SDLK_SPACE, OnDown, (CmdToggleFoot, CmdToggleFoot))] +playerKeysSF = keyCommandSF [(RSK_a, OnUp, (CmdPassLow 0, CmdPassHigh 0)), + (RSK_d, OnDown, (CmdFlipLow, CmdFlipHigh)), + (RSK_e, OnDown, (CmdMoveForward, CmdMoveBackward)), + (RSK_w, OnDown, (CmdMoveLeft, CmdMoveRight)), + (RSK_q, OnDown, (CmdMoveToGoal, CmdMoveToMe)), + (RSK_s, OnUp, (CmdKickLow 0, CmdKickHigh 0)), + (RSK_c, OnDown, (CmdFlipMeLow, CmdFlipMeHigh)), + (RSK_SPACE, OnDown, (CmdToggleFoot, CmdToggleFoot))] -- ************************************************************************* -- @@ -209,14 +213,14 @@ -- Caution: When adding more commands, remember to put the additional key in keyCommandSF!! gameKeysSF :: SF Input [Command] -gameKeysSF = keyCommandSF [(SDL.SDLK_ESCAPE, OnDown, (CmdQuit, CmdQuit)), - (SDL.SDLK_f, OnDown, (CmdFreeze, CmdFreeze))] +gameKeysSF = keyCommandSF [(RSK_ESCAPE, OnDown, (CmdQuit, CmdQuit)), + (RSK_f, OnDown, (CmdFreeze, CmdFreeze))] -playerInput :: Param -> SF Input (Position2, [Command]) -playerInput param = proc gi@(_,(_,incoming)) -> do - pd <- mousePos param (Point2 0 0) -< gi +playerInput :: Param -> Position2 -> SF Input (Position2, [Command]) +playerInput param p0 = proc gi@(_,(_,incoming)) -> do + pd <- mousePos param p0 -< gi commands <- playerKeysSF -< gi let allCommands = mouseCommand incoming ++ commands @@ -231,16 +235,15 @@ waitForSpaceKey :: IO () waitForSpaceKey = do - events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent - let keys = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [SDL.SDLK_SPACE]) events +-- events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent + let events = [] + let keys = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [RSK_SPACE]) events when (null keys) waitForSpaceKey shouldContinue :: IO Bool shouldContinue = do - events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent - let yess = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [SDL.SDLK_y]) events - let nos = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [SDL.SDLK_n]) events +-- events <- unfoldWhileM (/= SDL.NoEvent) SDL.pollEvent + let events = [] + let yess = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [RSK_y]) events + let nos = map fromJust $ filter (/= Nothing) $ map (mapKeyEvent [RSK_n]) events if null $ yess ++ nos then shouldContinue else return $ null nos - - - diff --git a/Rasenschach.cabal b/Rasenschach.cabal --- a/Rasenschach.cabal +++ b/Rasenschach.cabal @@ -1,5 +1,5 @@ name: Rasenschach -version: 0.1.2 +version: 0.1.3 cabal-version: >=1.2 build-type: Simple license: BSD3 @@ -10,23 +10,19 @@ description: Soccer simulation with simple graphics and highly configurable AI category: Game author: Martin Wöhrle -data-files: 20redball.png 23redball.png 26redball.png 20THCENT.TTF - 30redball.png 35redball.png 40redball.png SqueakyChalkSound.ttf ballM.wav - chalkboard.png tockH.wav whistle.wav +data-files: england2.bmp argentina.bmp data-dir: "" extra-source-files: AI.hs AL.hs Animate.hs BallFSM.hs BasicTypes.hs Command.hs Data/FSM.hs GameFSM.hs GameLoop.hs Global.hs Grid.hs Helper.hs Lineup.hs Message.hs Object.hs ObjectBehaviour.hs ParseTeam.hs Parser.hs Physics.hs PlayerFSM.hs README Render.hs - RenderBall.hs RenderGame.hs RenderPlayer.hs RenderUtil.hs Rules.hs - States.hs + Rules.hs States.hs executable Rasenschach - build-depends: SDL -any, SDL-gfx -any, SDL-image -any, - SDL-mixer -any, SDL-ttf -any, Yampa -any, array -any, + build-depends: GLUT -any, OpenGL -any, Yampa -any, array -any, base >=3 && <5, containers -any, convertible -any, directory -any, - filepath -any, ghc -any, monad-loops -any, template-haskell -any, - time -any + filepath -any, ghc -any, monad-loops -any, + time -any, OpenGLRaw -any, bytestring -any, cereal, directory main-is: Main.hs buildable: True cpp-options: -D NO_DEBUG_MODE @@ -34,9 +30,9 @@ hs-source-dirs: . other-modules: GameLoop Physics ParseTeam PlayerFSM Render Main AL ObjectBehaviour GameFSM Message Rules Object BasicTypes Animate - Helper RenderGame Global Command RenderUtil BallFSM RenderPlayer - Main States AI Grid RenderBall Parser Lineup Main Data.FSM + Helper Global Command BallFSM + Main States AI Grid Parser Lineup Main Data.FSM Physics + Render AL Message Object BasicTypes Main States Render Main ghc-prof-options: --enable-executable-profiling --- ghc-options: -O2 -prof -Wall - ghc-options: -O2 -Wall - + ghc-options: -O2 + diff --git a/Render.hs b/Render.hs --- a/Render.hs +++ b/Render.hs @@ -1,118 +1,514 @@ -module Render where - -import Control.Monad (forM_) -import Data.Array as A (Array, Ix,(!)) -import GHC.Exts +module Render (render, initGL) where -import Graphics.UI.SDL as SDL -import Graphics.UI.SDL.TTF as TTF -import Graphics.UI.SDL.Mixer as Mix import FRP.Yampa.Geometry +import GHC.Exts (sortWith) +import Graphics.UI.GLUT +import Graphics.Rendering.OpenGL.Raw +import qualified Graphics.UI.GLUT as G(Vector3(..)) +import Foreign ( withForeignPtr, plusPtr, alloca, peek ) +import qualified Data.ByteString.Internal as BSI +import Data.Time.Clock -import RenderPlayer -import RenderBall -import RenderGame -import RenderUtil +import Data.IORef +import Control.Monad -import Object +import Physics import States -import BasicTypes import Global +import Object +import BasicTypes +import Util +import Message +import Helper +import Paths_Rasenschach -init :: IO (Surface, Surface, A.Array Integer Font, Array Int (Surface, Int), Chunk, Chunk, Chunk) -init = do - SDL.init [SDL.InitVideo] - TTF.init - screen <- SDL.setVideoMode (truncate winWidth) (truncate winHeight) 32 [] - openAudio 22050 AudioS16Sys 2 4096 - pitch <- pitchRessources screen - fonts <- fontsRessources - balls <- ballRessources screen - (tockWav, kickWav, whistleWav) <- soundRessources +win2pitch :: Param -> Int -> Int -> Int -> Int -> Position2 +win2pitch param winX winY x y = + Point2 (fromIntegral x) (fromIntegral y) + +renderObjects :: Param + -> [ObsObjState] + -> GraphicsData + -> IO () +renderObjects param oos graphData = do + let texHome = gdTextureHome graphData + let texAway = gdTextureAway graphData + (oldX, oldY, currTZ) <- readIORef (gdCurrentTranslate graphData) + (winX, winY) <- readIORef $ gdWinSize graphData - return (screen, pitch, fonts, balls, tockWav, kickWav, whistleWav) + clear [ ColorBuffer, DepthBuffer ] + loadIdentity -exit :: IO () -exit = do - closeAudio - TTF.quit - SDL.quit + let ballOOS = fetchBallOOS oos + let Point3 ballX ballY _ = oosPos ballOOS + let adjY = ballY - (0.5*pPitchLength param) + let adjX = ballX - (0.5*pPitchWidth param) -renderObjects :: (Num i, A.Ix i) => Param -> [ObsObjState] - -> (Surface, t, A.Array i Font, A.Array Int (Surface, Int), Chunk, Chunk, Chunk) - -> IO () -renderObjects param oos (screen, _, fonts, balls, tockWav, kickWav, whistleWav) = do - cf <- chalkFontsRessources - cfb <- bigChalkFonts + -- don't allow too big adjustments, otherwise ugly flipping around + let adjX' = if (adjX - oldX) > 0.5 then oldX + 0.1 * (adjX - oldX) else adjX + let adjY' = if (adjY - oldY) > 0.5 then oldY + 0.1 * (adjY - oldY) else adjY + + writeIORef (gdCurrentTranslate graphData) (adjX', adjY', currTZ) + + translate $ G.Vector3 (realToFrac $ -adjX'::R) (realToFrac adjY') (-(realToFrac currTZ)) + -- -141 -71 scheint so: wenn sich die Entfernung verdoppelt, + -- dann doppelt so viel Spielfeld; (29) schiebt den Platz um ein Viertel + + position (Light 0) $= Vertex4 100 (-100) 50 1 -- 1 0.4 0.8 1 + playingField pW pL + forM_ sorted $ \os -> case os of OOSBall oosPos' _ oosBounced' oosPState - -> do renderBall param screen balls tockWav oosPos' oosBounced' - renderBallDebug screen oosPState cf (point3Z oosPos') + -> renderBall + (Point3 (fst (translateToScreen pW pL (realToFrac . point3X $ oosPos') + (realToFrac . point3Y $ oosPos'))) + (snd (translateToScreen pW pL (realToFrac . point3X $ oosPos') + (realToFrac . point3Y $ oosPos'))) + (realToFrac . point3Z $ oosPos')) + OOSPlayer oosPos' _ _ - oosKicked' - oosSelected' - oosDesignated' _ - (oosTeam, oosBorder, oosBody) - (PlayerInfo oosNumber _ bpOff bpDef _ _ _) - oosDir' - (bs, _) + _ + designated + _ + (team,_,_) + _ + _ + _ (ts, _) _ - -> do renderPlayer param screen oosPos' oosDir' oosSelected' oosNumber - oosBody oosBorder oosBorder oosKicked' - (ts==TSNonAI) oosDesignated' fonts kickWav - renderPlayerDebug screen oosSelected' oosNumber bs ts oosBody - cf bpDef bpOff oosTeam + -> renderPlayer texHome texAway team (ts==TSNonAI) designated + (translateToScreen pW pL (realToFrac . point3X $ oosPos') + (realToFrac . point3Y $ oosPos')) OOSGame oosGameTime' oosGameScore' oosGameState' oosAttacker' _ - -> do renderGame param screen oosGameTime' oosGameScore' oosGameState' - oosAttacker' cfb (fonts ! 4) whistleWav - renderGameDebug screen oosGameState' cf + -> renderGame adjX' adjY' oosGameTime' oosGameScore' oosGameState' + + + flush + swapBuffers + where sorted = sortWith (point3Z . oosPos) oos + pW = realToFrac $ pPitchWidth param + pL = realToFrac $ pPitchLength param -render :: (Num i, Ix i) => - Param -> [ObsObjState] - -> (Surface, Surface, Array i Font, Array Int (Surface, Int), Chunk, Chunk, Chunk) - -> IO () -render param oos (screen, pitch, fonts, balls, tockWav, kickWav, whistleWav) = do - SDL.blitSurface pitch Nothing screen Nothing - renderObjects param oos (screen, pitch, fonts, balls, tockWav, kickWav, whistleWav) - SDL.flip screen +renderGame adjX' adjY' t (scoreHome, scoreAway) (gState, gStateParam) = do + preservingMatrix $ do -renderStartMsg :: (Num i, Ix i) => - (Surface, t, Array i Font, t1, t2, t3, t4) -> IO () -renderStartMsg (screen,_, fonts,_,_,_,_) = - do - let font = fonts ! 4 - let color = colorFromPixel $ rgbColor 255 255 1 + translate $ G.Vector3 (realToFrac $ adjX'-30::R) (realToFrac (-(adjY'-20))) 0 + scale 0.04 0.04 (0.04::GLfloat) - fontSurface <- TTF.renderTextSolid font ("PRESS TO START") color + let tt = truncate t + let (min', sec) = (tt `div` 60, tt `mod` 60) :: (Int, Int) - SDL.blitSurface fontSurface Nothing screen (Just $ Rect 250 400 100 100) - SDL.flip screen + renderString Roman $ show scoreHome ++ " - " ++ show scoreAway ++ " " ++ show min' ++ ":" ++ show sec -renderEndMsg :: (Num i, Ix i) => (Surface, t, Array i Font, t1, t2, t3, Chunk) -> IO () -renderEndMsg (screen,_, fonts,_,_,_,whistle) = - do - let font = fonts ! 4 - let color = colorFromPixel $ rgbColor 255 255 1 + when (gState == GSKickOff && scoreHome + scoreAway > 0) $ do + preservingMatrix $ do + translate $ G.Vector3 (realToFrac $ adjX'-10::R) (realToFrac (-(adjY'-5))) 0 + scale 0.04 0.04 (0.04::GLfloat) + renderString Roman "GOAL!" - fontSurface <- TTF.renderTextSolid font ("GAME OVER, TRY AGAIN (Y/N)") color - playChannel (1) whistle 0 + let (GPTeamPosition _ _ _ _ _ _ oop) = gStateParam - SDL.blitSurface fontSurface Nothing screen (Just $ Rect 200 400 100 100) - SDL.flip screen + when (oop == OOPSideOut) $ do + preservingMatrix $ do + translate $ G.Vector3 (realToFrac $ adjX'-10::R) (realToFrac (-(adjY'-5))) 0 + scale 0.04 0.04 (0.04::GLfloat) + renderString Roman "THROW IN!" + + when (oop == OOPOffsite) $ do + preservingMatrix $ do + translate $ G.Vector3 (realToFrac $ adjX'-10::R) (realToFrac (-(adjY'-5))) 0 + scale 0.04 0.04 (0.04::GLfloat) + renderString Roman "OFFSITE!" + + when (oop == OOPBaseOut) $ do + preservingMatrix $ do + translate $ G.Vector3 (realToFrac $ adjX'-10::R) (realToFrac (-(adjY'-5))) 0 + scale 0.04 0.04 (0.04::GLfloat) + renderString Roman "CORNER!" + + +translateToScreen pW pL u v = + (u - pW/2, (pL-v)-pL/2) + +render :: Param -> [ObsObjState] -> GraphicsData -> IO () +render param oos gd = renderObjects param oos gd + +renderPlayer :: GLuint -> GLuint-> Team -> Bool -> Bool -> (GLfloat, GLfloat) -> DisplayCallback +renderPlayer texHome texAway team selected designated pos = do + let tex = if team==Home then texHome else texAway + blink <- blinker + when (team==Home && (not selected || (selected && not blink))) $ + color $ Color3 (1.0::GLfloat) (1.0::GLfloat) (1.0::GLfloat) + when (team==Away) $ + color $ Color3 (1.0::GLfloat) (1.0::GLfloat) (1.0::GLfloat) + when (selected && blink) $ do + color $ Color3 (116/255::GLfloat) (172/255::GLfloat) (223/255::GLfloat) + + preservingMatrix $ do + translate $ Vector3 x y (0.5) + renderChip tex 12 6 0.10 + when designated $ do + translate $ Vector3 (-0.3) (2::R) 0 + scale 0.02 0.02 (0.02::GLfloat) + renderString Roman "!" + + where (x,y) = pos + +renderBall pPos = do + preservingMatrix $ do + (color red >>) . (renderShapeAt $ Sphere' 0.60 20 20) $ v + where red = Color4 1.0 0.7 0.8 1.0 :: Color4 R + Point3 x y z = pPos + v = vector3 (realToFrac x) (realToFrac y) (realToFrac z) + renderShapeAt s p = preservingMatrix $ do + translate $ Vector3 (vector3X p :: R) + (vector3Y p :: R) + ((vector3Z p :: R)*5) + renderObject Solid s + + +playingField a b = do + color $ Color3 (1.0::GLfloat) (1.0::GLfloat) (1.0::GLfloat) + renderPrimitive Lines $ mapM_ (pushV a b) vs + circle FullCircle 15 0 10 + preservingMatrix $ do + translate $ G.Vector3 0 41 (0::R) + circle LowerHalfCircle 15 6 10 + preservingMatrix $ do + translate $ G.Vector3 0 (-41) (0::R) + circle UpperHalfCircle 15 6 10 + + + where + pushV :: GLfloat -> GLfloat -> (GLfloat, GLfloat, GLfloat) -> IO () + pushV a b (u,v,w) = + vertex $ Vertex3 (a*u/2) (b*v/2) w + + vs :: [(GLfloat, GLfloat, GLfloat)] + vs = [((-1),(-1),0) + ,((-1),(1), 0) + + ,((-1),(1), 0) + ,(( 1),(1), 0) + + ,(( 1),(1), 0) + ,((1),(-1),0) + + ,((1),(-1),0) + ,((-1),(-1),0) + + ,((-1),(0),0) + ,((1),(0),0) + + -- lower box + ,((-0.6),(-0.60),0) + ,((0.6),(-0.60),0) + + ,((-0.6),(-0.60),0) + ,((-0.6),(-1.0),0) + + ,((0.6),(-0.60),0) + ,((0.6),(-1.0),0) + + -- goalie box + ,((-0.3),(-0.85),0) + ,((0.3),(-0.85),0) + + ,((-0.3),(-0.85),0) + ,((-0.3),(-1.0),0) + + ,((0.3),(-0.85),0) + ,((0.3),(-1.0),0) + + -- goal + ,((-0.12),(-0.999),0) + ,((-0.12),(-0.999),0.1) + + ,((0.12),(-0.999),0) + ,((0.12),(-0.999),0.1) + + ,((-0.12),(-0.999),0.1) + ,((0.12),(-0.999),0.1) + + ,((-0.12),(-0.999),0.1) + ,((-0.12),(-1.05),0) + + ,((0.12),(-0.999),0.1) + ,((0.12),(-1.05),0) + + ,((-0.12),(-1.05),0) + ,((0.12),(-1.05),0) + + -- upper box + ,((-0.6),(0.60),0) + ,((0.6),(0.60),0) + + ,((-0.6),(0.60),0) + ,((-0.6),(1.0),0) + + ,((0.6),(0.60),0) + ,((0.6),(1.0),0) + + + -- goalie box + ,((-0.3),(0.85),0) + ,((0.3),(0.85),0) + + ,((-0.3),(0.85),0) + ,((-0.3),(1.0),0) + + ,((0.3),(0.85),0) + ,((0.3),(1.0),0) + + -- goal + ,((-0.12),(0.999),0) + ,((-0.12),(0.999),0.1) + + ,((0.12),(0.999),0) + ,((0.12),(0.999),0.1) + + ,((-0.12),(0.999),0.1) + ,((0.12),(0.999),0.1) + + ,((-0.12),(0.999),0.1) + ,((-0.12),(1.05),0) + + ,((0.12),(0.999),0.1) + ,((0.12),(1.05),0) + + ,((-0.12),(1.05),0) + ,((0.12),(1.05),0) + + ] + +initGL :: IO (Window, GraphicsData) +initGL = do + ws <- newIORef (1200,1000) + ct <- newIORef (0,0,71) + getArgsAndInitialize + initialDisplayMode $= [DoubleBuffered] + initialWindowSize $= Size 1200 1000 + win <- createWindow "Rasenschach!" + initialDisplayMode $= [ WithDepthBuffer ] + depthFunc $= Just Less + glEnable gl_TEXTURE_2D + glShadeModel gl_SMOOTH + clearColor $= Color4 (151/255) (197/255) (7/255) 0 -- 151 197 7 + light (Light 0) $= Enabled + lighting $= Enabled + lightModelAmbient $= Color4 0.5 0.5 0.5 1 + diffuse (Light 0) $= Color4 1 1 1 1 + blend $= Enabled + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse) + reshapeCallback $= Just (resizeScene ws) + fn1 <- getDataFileName "argentina.bmp" + texHome <-loadTexture fn1 + fn2 <- getDataFileName "england2.bmp" + texAway <-loadTexture fn2 + return $ (win, GraphicsData ws 141 ct texHome texHome texHome texAway texAway texAway) + +-- Copied from reactive-glut +resizeScene :: IORef (Int, Int) -> Size -> IO () +resizeScene ws (Size w 0) = resizeScene ws (Size w 1) -- prevent divide by zero +resizeScene ws s@(Size width height) = do + writeIORef ws (fromIntegral width, fromIntegral height) + viewport $= (Position 0 0, s) + matrixMode $= Projection + loadIdentity + perspective 45 (w2/h2) 1 1000 + matrixMode $= Modelview 0 + flush + where + w2 = half width + h2 = half height + half z = realToFrac z / 2 + +-- -------------------------------------------------------------------- +-- A B H I E R C H I P - C O D E +-- -------------------------------------------------------------------- + +quadrToTripel :: (t, t1, t2, t3) -> (t1, t2, t3) +quadrToTripel (_,b,c,d) = (b,c,d) + +pushTriangle :: ((GLfloat, GLfloat, GLfloat, GLfloat) + ,(GLfloat, GLfloat, GLfloat, GLfloat) + ,(GLfloat, GLfloat, GLfloat, GLfloat)) -> + IO () +pushTriangle (p0, p1, p2) = do + let (dir,_,d0,_)=p0 + let (_,_,d1,_)=p1 + let (_,_,d2,_)=p2 + + let (p0',p1',p2') = (quadrToTripel p0, quadrToTripel p1, quadrToTripel p2) + + --if it points upwards, reverse normal + let d=if d0+d1+d2>0 then (-1) else 1 + let n = cross (minus p1' p0') (minus p2' p1') + let nL = 1/lenVec n + let (n1, n2, n3) = scaleVec n (nL*d*dir) + normal $ Normal3 n1 n2 n3 + + vertex3f (dir>0) p0' + vertex3f (dir>0) p1' + vertex3f (dir>0) p2' + +vertex3f :: Bool -> (GLfloat, GLfloat, GLfloat) -> IO () +vertex3f texture (x, y, z) = do + let (x',y') = ((x+1)/2, (y+1)/2) + when texture $ texCoord (TexCoord2 x' y') + vertex $ Vertex3 x y z + +lenVec :: Floating a => (a, a, a) -> a +lenVec (a1,a2,a3) = sqrt $ a1*a1 + a2*a2 + a3*a3 + +scaleVec :: Num t => (t, t, t) -> t -> (t, t, t) +scaleVec (a1,a2,a3) x = (a1*x,a2*x,a3*x) + +cross :: Num t => (t, t, t) -> (t, t, t) -> (t, t, t) +cross (a1,a2,a3) (b1,b2,b3) = + (a2*b3-a3*b2 + ,a3*b1-a1*b3 + ,a1*b2-a2*b1) + +minus :: (Num t, Num t1, Num t2) => (t, t1, t2) -> (t, t1, t2) -> (t, t1, t2) +minus (a1,a2,a3) (b1,b2,b3) = + (a1-b1, a2-b2, a3-b3) + +innerCircle :: Int -> Int -> [(GLfloat, GLfloat)] +innerCircle numSegs skip = upperInnerCircle numSegs skip ++ (lowerInnerCircle numSegs skip) + +upperOutSegment :: Int -> Int -> Int -> [(GLfloat, GLfloat)] +upperOutSegment numSegs ring seg = + [x,y,u, v,u,y] + where + seg'=pi/(fromIntegral numSegs) + (a, b) = (fromIntegral seg * seg', fromIntegral (seg+1) * seg') + x = (fromIntegral ring * cos a, fromIntegral ring * sqrt(1-(cos a)*(cos a))) + y = (fromIntegral ring * cos b, fromIntegral ring * sqrt(1-(cos b)*(cos b))) + u = (fromIntegral (ring+1) * cos a, fromIntegral (ring+1) * sqrt(1-(cos a)*(cos a))) + v = (fromIntegral (ring+1) * cos b, fromIntegral (ring+1) * sqrt(1-(cos b)*(cos b))) + +lowerOutSegment :: Int -> Int -> Int -> [(GLfloat, GLfloat)] +lowerOutSegment numSegs ring seg = + map (\(x,y) -> (x,-y)) $ upperOutSegment numSegs ring seg + +outSegment :: Int -> Int -> Int -> [(GLfloat, GLfloat)] +outSegment numSegs ring seg = upperOutSegment numSegs ring seg ++ (lowerOutSegment numSegs ring seg) + +outerRing :: Int -> Int -> [(GLfloat, GLfloat)] +outerRing numSegs ring = + concat [outSegment numSegs ring n | n<-[0..numSegs-1]] + +toTriples :: [a] -> [(a,a,a)] +toTriples [] = [] +toTriples (a:b:c:rest) = (a,b,c):toTriples rest + +renderChip tex numSegs numRings factor = + let ips = innerCircle numSegs 0 + ops = concat [outerRing numSegs i | i<-[1..numRings]] + height dir ps = + map (\(x,y) -> + let dist = sqrt(x*x+y*y)/(fromIntegral (numRings+1)) + height' = sqrt(1.001-dist*dist)*factor*(fromIntegral (numRings+1))*0.2 + in (dir,x*factor,y*factor,dir*height')) $ ps + ups = height 1 $ ips ++ ops + lps = height (-1) $ ips ++ ops + in do + glBindTexture gl_TEXTURE_2D tex + + renderPrimitive Triangles $ mapM_ pushTriangle (toTriples (ups++lps)) + +loadTexture :: String -> IO GLuint +loadTexture fp = do + putStrLn $ "loading texture: " ++ fp + Just (Image w h pd) <- bitmapLoad fp + putStrLn $ "Image width = " ++ show w + putStrLn $ "Image height = " ++ show h + tex <- alloca $ \p -> do + glGenTextures 1 p + peek p + let (ptr, off, _) = BSI.toForeignPtr pd + withForeignPtr ptr $ \p -> do + let p' = p `plusPtr` off + glBindTexture gl_TEXTURE_2D tex + glTexImage2D gl_TEXTURE_2D 0 3 + (fromIntegral w) (fromIntegral h) 0 gl_RGB gl_UNSIGNED_BYTE + p' + let glLinear = fromIntegral gl_LINEAR + glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MIN_FILTER glLinear + glTexParameteri gl_TEXTURE_2D gl_TEXTURE_MAG_FILTER glLinear + return tex + + +-- -------------------------------------------------------------------- +-- Half circle +-- -------------------------------------------------------------------- + +skipBothEnds xs n = + let xs' = drop n xs + in reverse $ drop n (reverse xs') + +upperInnerCircle :: Int -> Int -> [(GLfloat, GLfloat)] +upperInnerCircle numSegs skip = + skipBothEnds ps skip + where + seg'=pi/(fromIntegral numSegs) + as = [(fromIntegral n * seg', fromIntegral (n+1) * seg') | n<-[0..numSegs-1]] + ps = concat [[(cos a, sqrt(1-(cos a)*(cos a))) + ,(cos b, sqrt(1-(cos b)*(cos b)))] + | (a,b)<-as ] + +lowerInnerCircle :: Int -> Int -> [(GLfloat, GLfloat)] +lowerInnerCircle numSegs skip = + map (\(x,y) -> (x,-y)) $ upperInnerCircle numSegs skip + +pushLine :: ((GLfloat, GLfloat, GLfloat) + ,(GLfloat, GLfloat, GLfloat)) + -> IO () +pushLine ((x,y,z), (a,b,c)) = do + vertex $ Vertex3 x y z + vertex $ Vertex3 a b c + +data WhichCircle = FullCircle | UpperHalfCircle | LowerHalfCircle + +circle whichCircle numSegs skip factor = + let ips = case whichCircle of + LowerHalfCircle -> lowerInnerCircle numSegs skip + UpperHalfCircle -> upperInnerCircle numSegs skip + fullCircle -> lowerInnerCircle numSegs skip ++ upperInnerCircle numSegs skip + applyFactor dir ps = + map (\(x,y) -> (x*factor,y*factor,0)) $ ps + ups = applyFactor 1 $ ips + in renderPrimitive Lines $ mapM_ pushLine (toTuples ups) + +toTuples :: [a] -> [(a,a)] +toTuples [] = [] +toTuples (a:b:rest) = (a,b):toTuples rest + +-- Helpful OpenGL constants for rotation +xAxis = G.Vector3 1 0 0 :: G.Vector3 R +yAxis = G.Vector3 0 1 0 :: G.Vector3 R +zAxis = G.Vector3 0 0 1 :: G.Vector3 R + +blinker :: IO Bool +blinker = do + t <- fmap utctDayTime getCurrentTime + let tFrac = t - fromIntegral (truncate t) + return $ tFrac < 0.5 diff --git a/RenderBall.hs b/RenderBall.hs deleted file mode 100644 --- a/RenderBall.hs +++ /dev/null @@ -1,46 +0,0 @@ -module RenderBall -- (renderBall) - -where - -import Data.Array -import Control.Monad -import Data.Bits - -import FRP.Yampa.Geometry - -import Graphics.UI.SDL as SDL -import Graphics.UI.SDL.TTF as SDLt -import Graphics.UI.SDL.Mixer as Mix - -import RenderUtil -import Global - -sizedBall :: Double -> Array Int (Surface, Int) -> (Surface, Int) -sizedBall z balls = - if z < 0.3 then balls!0 - else if z < 0.5 then balls!1 - else if z < 1.0 then balls!2 - else if z < 2.0 then balls!3 - else if z < 3.0 then balls!4 - else balls!5 - -renderBall :: Param -> Surface -> Array Int (Surface, Int) -> Chunk -> Point3 Double -> Bool -> IO Bool -renderBall param surface balls tock p bounced = do - when bounced $ playChannel (-1) tock 0 >> return () - let Point3 px py pz = p - let (x, y) = pitchToPoint param (px, py) - let (x', y') = (fromIntegral x, fromIntegral y) :: (Int, Int) - let (ball, points) = sizedBall pz balls - let adjust = fromIntegral $ points `shiftR` 2 - SDL.blitSurface ball Nothing surface (Just $ Rect (x'-adjust) (y'-adjust) (x'+adjust) (y'+adjust)) - -renderBallDebug :: Show a => Surface -> a -> Font -> t -> IO Bool -renderBallDebug surface state font _ = - do - let color = colorFromPixel $ rgbColor 255 255 1 - fontSurface <- SDLt.renderTextSolid font ("Ball: " ++ show state) color --- ++ " , z=" ++ show z) color --- f2 <- SDL.convertSurface fontSurface (SDL.surfaceGetPixelFormat surface) [] - - SDL.blitSurface fontSurface Nothing surface (Just $ Rect 850 140 1000 150) - diff --git a/RenderGame.hs b/RenderGame.hs deleted file mode 100644 --- a/RenderGame.hs +++ /dev/null @@ -1,67 +0,0 @@ -module RenderGame - -where - -import Control.Monad - -import Graphics.UI.SDL as SDL -import Graphics.UI.SDL.TTF as SDLt -import Graphics.UI.SDL.Mixer as Mix - -import RenderUtil -import States -import Message -import BasicTypes - -renderGame :: (Num a1, Ord a1, RealFrac a, Show a1) => - t -> Surface -> a -> (a1, a1) -> - (GameState, GameMsgParam) -> t1 -> Font -> Font -> Chunk -> - IO Bool -renderGame _ surface t (scoreHome, scoreAway) (gState, gStateParam) - _ font bigfont whistle = - do - let color = colorFromPixel $ rgbColor 255 255 1 - let tt = truncate t - let (min', sec) = (tt `div` 60, tt `mod` 60) :: (Int, Int) - fontSurface <- SDLt.renderTextSolid font ("Score " ++ show scoreHome ++ "-" ++ show scoreAway) color - timeSurface <- SDLt.renderTextSolid font ("Time" ++ show min' ++ "min " ++ show sec ++ "sec") color - when (gState == GSKickOff && shouldWhistle gStateParam) $ do --- when (shouldWhistle gStateParam) $ do - playChannel (1) whistle 0 >> return () - - SDL.blitSurface fontSurface Nothing surface (Just $ Rect 850 50 950 50) - SDL.blitSurface timeSurface Nothing surface (Just $ Rect 850 80 950 80) - - when (gState == GSKickOff && scoreHome + scoreAway > 0) $ do - goalSurface <- SDLt.renderTextSolid bigfont ("GOAL!!") color - SDL.blitSurface goalSurface Nothing surface (Just $ Rect 380 400 100 100) - return () - - let (GPTeamPosition _ _ _ _ _ _ oop) = gStateParam - - when (oop == OOPSideOut) $ do - goalSurface <- SDLt.renderTextSolid bigfont ("Throw in") color - SDL.blitSurface goalSurface Nothing surface (Just $ Rect 380 300 100 100) - return () - - when (oop == OOPOffsite) $ do - goalSurface <- SDLt.renderTextSolid bigfont ("Offsite") color - SDL.blitSurface goalSurface Nothing surface (Just $ Rect 380 300 100 100) - return () - - when (oop == OOPBaseOut) $ do - goalSurface <- SDLt.renderTextSolid bigfont ("Corner") color - SDL.blitSurface goalSurface Nothing surface (Just $ Rect 380 300 100 100) - return () - - return True - -shouldWhistle :: GameMsgParam -> Bool -shouldWhistle (GPTeamPosition _ _ _ _ _ w _) = w - -renderGameDebug :: Show a => Surface -> a -> Font -> IO Bool -renderGameDebug surface state font = - do - let color = colorFromPixel $ rgbColor 255 255 1 - fontSurface <- SDLt.renderTextSolid font ("Game: " ++ show state) color - SDL.blitSurface fontSurface Nothing surface (Just $ Rect 850 120 1000 140) diff --git a/RenderPlayer.hs b/RenderPlayer.hs deleted file mode 100644 --- a/RenderPlayer.hs +++ /dev/null @@ -1,136 +0,0 @@ -module RenderPlayer (renderPlayer, renderPlayerDebug) - -where - -import Data.Bits -import GHC.Int -import Data.Array -import Control.Monad -import Data.Time.Clock - -import FRP.Yampa.Geometry - -import Graphics.UI.SDL as SDL -import Graphics.UI.SDL.Primitives as SDLp -import Graphics.UI.SDL.TTF as SDLt -import Graphics.UI.SDL.Mixer as SDLm - -import BasicTypes -import RenderUtil -import Global - -orange :: Pixel -orange = rgbColor 0xE7 0x5B 0x12 - --- Alles rund um den Fußballer... - -r1 :: Fractional a => a -> a -r1 z = 3.0 + z -- Punkte zwischen Kreisrand und äußerem Ring -r2 :: Fractional a => a -> a -r2 z = 6.0 + z -- Punkte zwischen Kreisrand innerem Ring -angle :: Double -angle = 0.45 -- Winkel des Zeiger-Dreiecks - -pr1 :: (Integral b, RealFrac a) => a -> b -pr1 z = truncate $ r1 z - -triangle :: (Floating a, Integral t2, Integral t1, RealFrac a) => - t1 -> t2 -> t -> a -> a -> (t -> a) -> (t -> a) -> a - -> ((t1, t2), (t1, t2), (t1, t2)) -triangle x y height radD alpha r1' r2' angle' = - let l1 = radD - (r1' height) - l2 = radD - (r2' height) - a = (x + truncate (l1 * cos alpha), y + truncate (l1 * sin alpha)) - b = (x + truncate (l2 * cos (alpha-angle')), y + truncate (l2 * sin (alpha-angle'))) - c = (x + truncate (l2 * cos (alpha+angle')), y + truncate (l2 * sin (alpha+angle'))) - in (a,b,c) - -playersizeMin :: Int16 -playersizeMin = 25 :: Int16 -- in Pixeln -playersizeMax :: Int16 -playersizeMax = 50 -maxJump :: Double -maxJump = 3.0 -- in Meter - -blinker :: IO Bool -blinker = do - t <- fmap utctDayTime getCurrentTime - let tFrac = t - fromIntegral (truncate t) - return $ tFrac < 0.5 - -playerSize :: Param -> Double -> Int16 -playerSize param z = -- zwischen 0 und 2 Meter Höhe, dann wechselt der Spieler zwischen 30 und 50 Dicke... - if z > maxJump then playersizeMax - else if z < pGround param then playersizeMin - else truncate $ fromIntegral playersizeMin + z * (fromIntegral playersizeMax - fromIntegral playersizeMin) / 10.0 - -renderPlayer :: (Num i, Num a, Ord a, Show a, Ix i) => - Param -> Surface -> Point3 Double -> Double -> t -> a -> - Pixel -> Pixel -> Pixel -> Bool -> Bool -> Bool -> Array i Font -> Chunk -> - IO Bool -renderPlayer param surface p alpha _ number cCircle cTriangle cBorder kicked nonai designated fonts wav = - do - when kicked $ playChannel (-1) wav 0 >> return () - - let Point3 px py pz = p - let radius = playerSize param pz `shiftR` 1 - let radius' = (radius `shiftR` 1)-4 -- hacky: try to align exactly with ball... - let (x', y') = pitchToPoint param (px, py) - let (x, y) = (x'+radius', y'+radius') - let xAdjust = truncate (-0.4*pz) + if number > 9 then 5 else 2 :: Int16 -- Zentrieren der Rückennummer - let yAdjust = if pz < 1 then 6 else if pz < 2 then 4 else 4 :: Int16 -- Zentrieren der Rückennummer - let radD = fromIntegral radius - let ((ax, ay), - (bx, by), - (cx, cy)) = triangle x y pz (2*radD) alpha r1 r2 angle - let font = if pz < 1 then fonts ! 1 - else if pz < 2 then fonts ! 2 - else fonts ! 3 - let markFont = fonts ! 5 - - blinkOn <- blinker - - let cBorderBlinking = if nonai && blinkOn then cCircle else cBorder - let cTriangleBlinking = if nonai && blinkOn then cCircle else cTriangle - let cCircleBlinking = if nonai && blinkOn then cBorder else cCircle - - - fontSurface <- SDLt.renderTextSolid font (show number) (colorFromPixel cTriangleBlinking) --- f2 <- SDL.convertSurface fontSurface (SDL.surfaceGetPixelFormat surface) [] - - SDLp.filledCircle surface x y radius cBorderBlinking - SDLp.filledCircle surface x y (radius - (pr1 pz)) cCircleBlinking - - when designated $ do - markSurface <- SDLt.renderTextSolid markFont "!" (colorFromPixel orange) - SDL.blitSurface markSurface Nothing surface (Just $ Rect (fromIntegral (x-xAdjust+1)) - (fromIntegral (y-yAdjust-5)) - (fromIntegral (x-xAdjust+10)) - (fromIntegral (y-yAdjust+10))) - return () - - SDLp.filledTrigon surface ax ay bx by cx cy cTriangleBlinking - - - - SDL.blitSurface fontSurface Nothing surface (Just $ Rect (fromIntegral (x-xAdjust)) - (fromIntegral (y-yAdjust)) - (fromIntegral (x-xAdjust+10)) - (fromIntegral (y-yAdjust+10))) - - -renderPlayerDebug :: (Show a1, Show a) => - Surface -> t -> Int -> a1 -> a -> Pixel -> Font -> t1 -> t2 -> Team -> - IO Bool -renderPlayerDebug surface _ number bState tState color font _ _ oosTeam = - do - fontSurface <- SDLt.renderTextSolid font (show number ++ ": " ++ - show tState ++ ", " ++ - show bState ++ ", " -- ++ --- show baseDef ++ ", " ++ --- show baseOff - ) - (colorFromPixel color) --- f2 <- SDL.convertSurface fontSurface (SDL.surfaceGetPixelFormat surface) [] - let adjust = if oosTeam == Home then 150 else 500 - SDL.blitSurface fontSurface Nothing surface (Just $ Rect 850 (adjust+20*number) 950 (adjust+50+20*number)) diff --git a/RenderUtil.hs b/RenderUtil.hs deleted file mode 100644 --- a/RenderUtil.hs +++ /dev/null @@ -1,132 +0,0 @@ -module RenderUtil where - -import Graphics.UI.SDL as SDL -import Graphics.UI.SDL.Image as SDLi -import Graphics.UI.SDL.Types as SDLt -import Graphics.UI.SDL.TTF as TTF -import Graphics.UI.SDL.Mixer as Mix - -import GHC.Int -import GHC.Word -import Data.Bits - -import Data.Array - -import Global -import Paths_Rasenschach - -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral - -rgbColor :: Word8 -> Word8 -> Word8 -> Pixel -rgbColor r g b = Pixel (shiftL (fi r) (24::Int) .|. shiftL (fi g) (16::Int) .|. shiftL (fi b) (8::Int) .|. fi (255::Int)) - -colorFromPixel :: Pixel -> Color -colorFromPixel (Pixel p) = Color (fi $ shiftR p 24) (fi $ shiftR p 16) (fi $ shiftR p 8) - --- Geometrie - -winHeight :: Double -winHeight = 1050 :: Double -winWidth :: Double -winWidth = 1096 :: Double - -ratio :: Fractional a => t -> a -ratio _ = 8.625 -- winHeight / (pPitchLength param + pUpperBorderY param + pLowerBorderY param) - -pixelToMeter :: Param -> Int16 -> Double -pixelToMeter param p = fromIntegral p / ratio param - -meterToPixel :: Param -> Double -> Int16 -meterToPixel param = truncate . (* ratio param) - -pitchToPoint :: Param -> (Double, Double) -> (Int16, Int16) -pitchToPoint param (x,y) = (meterToPixel param $ (pLeftBorderX param) + x, - meterToPixel param $ (pUpperBorderY param) + y) - -pointToPitch :: Param -> (Int16, Int16) -> (Double, Double) -pointToPitch param (x,y) = (pixelToMeter param x - pLeftBorderX param, pixelToMeter param y - pUpperBorderY param) - -ballRessources :: Surface -> IO (Array Int (Surface, Int)) -ballRessources screen = do - - t <- mapRGB (surfaceGetPixelFormat screen) 0 255 0 - - fn20 <- getDataFileName "20redball.png" - png20 <- SDLi.load fn20 - b20 <- convertSurface png20 (surfaceGetPixelFormat screen) [] - setColorKey b20 [SrcColorKey, RLEAccel] t - - fn23 <- getDataFileName "23redball.png" - png23 <- SDLi.load fn23 - b23 <- convertSurface png23 (surfaceGetPixelFormat screen) [] - setColorKey b23 [SrcColorKey, RLEAccel] t - - fn26 <- getDataFileName "26redball.png" - png26 <- SDLi.load fn26 - b26 <- convertSurface png26 (surfaceGetPixelFormat screen) [] - setColorKey b26 [SrcColorKey, RLEAccel] t - - fn30 <- getDataFileName "30redball.png" - png30 <- SDLi.load fn30 - b30 <- convertSurface png30 (surfaceGetPixelFormat screen) [] - setColorKey b30 [SrcColorKey, RLEAccel] t - - fn35 <- getDataFileName "35redball.png" - png35 <- SDLi.load fn35 - b35 <- convertSurface png35 (surfaceGetPixelFormat screen) [] - setColorKey b35 [SrcColorKey, RLEAccel] t - - fn40 <- getDataFileName "40redball.png" - png40 <- SDLi.load fn40 - b40 <- convertSurface png40 (surfaceGetPixelFormat screen) [] - setColorKey b40 [SrcColorKey, RLEAccel] t - - return $ array (0,5) [(0,(b20, SDLt.surfaceGetWidth b20)), - (1,(b23, SDLt.surfaceGetWidth b23)), - (2,(b26, SDLt.surfaceGetWidth b26)), - (3,(b30, SDLt.surfaceGetWidth b30)), - (4,(b35, SDLt.surfaceGetWidth b35)), - (5,(b40, SDLt.surfaceGetWidth b40))] - -fontsRessources :: IO (Array Integer Font) -fontsRessources = do --- fn <- getDataFileName "C64_User_Mono_v1.0-STYLE.ttf" - fn <- getDataFileName "20THCENT.TTF" - - f1 <- TTF.openFont fn 14 --8 - f2 <- TTF.openFont fn 16 -- 9 - f3 <- TTF.openFont fn 18 --10 - - f4 <- TTF.openFont fn 30 -- for messages - f5 <- TTF.openFont fn 20 -- for marking designated player - return $ array (1,5) [(1,f1),(2,f2),(3,f3),(4,f4),(5,f5)] - -chalkFontsRessources :: IO Font -chalkFontsRessources = do - fn <- getDataFileName "SqueakyChalkSound.ttf" - TTF.openFont fn 14 --- setFontStyle f [StyleBold] - -bigChalkFonts :: IO Font -bigChalkFonts = do - fn <- getDataFileName "SqueakyChalkSound.ttf" - TTF.openFont fn 20 - -pitchRessources :: Surface -> IO Surface -pitchRessources screen = do - fn <- getDataFileName "chalkboard.png" - pitch <- SDLi.load fn - convertSurface pitch (surfaceGetPixelFormat screen) [] - -soundRessources :: IO (Chunk, Chunk, Chunk) -soundRessources = do - fnt <- getDataFileName "tockH.wav" - t <- loadWAV fnt - - fnk <- getDataFileName "ballM.wav" - k <- loadWAV fnk - - fnw <- getDataFileName "whistle.wav" - w <- loadWAV fnw - return (t, k, w) diff --git a/Rules.hs b/Rules.hs --- a/Rules.hs +++ b/Rules.hs @@ -17,8 +17,7 @@ import Data.List import Data.Function (on) import Data.Maybe -import Debug.Trace - + import Object import BasicTypes import Message diff --git a/SqueakyChalkSound.ttf b/SqueakyChalkSound.ttf deleted file mode 100644 Binary files a/SqueakyChalkSound.ttf and /dev/null differ diff --git a/argentina.bmp b/argentina.bmp new file mode 100644 Binary files /dev/null and b/argentina.bmp differ diff --git a/ballM.wav b/ballM.wav deleted file mode 100644 Binary files a/ballM.wav and /dev/null differ diff --git a/chalkboard.png b/chalkboard.png deleted file mode 100644 Binary files a/chalkboard.png and /dev/null differ diff --git a/england2.bmp b/england2.bmp new file mode 100644 Binary files /dev/null and b/england2.bmp differ diff --git a/tockH.wav b/tockH.wav deleted file mode 100644 Binary files a/tockH.wav and /dev/null differ diff --git a/whistle.wav b/whistle.wav deleted file mode 100644 Binary files a/whistle.wav and /dev/null differ