Rasenschach 0.1.2 → 0.1.3
raw patch · 28 files changed
+774/−628 lines, 28 filesdep +GLUTdep +OpenGLdep +OpenGLRawdep −SDLdep −SDL-gfxdep −SDL-imagebinary-added
Dependencies added: GLUT, OpenGL, OpenGLRaw, bytestring, cereal
Dependencies removed: SDL, SDL-gfx, SDL-image, SDL-mixer, SDL-ttf, template-haskell
Files
- 20THCENT.TTF binary
- 20redball.png binary
- 23redball.png binary
- 26redball.png binary
- 30redball.png binary
- 35redball.png binary
- 40redball.png binary
- Animate.hs +57/−33
- BasicTypes.hs +36/−6
- GameLoop.hs +3/−3
- Helper.hs +27/−1
- Main.hs +102/−49
- ObjectBehaviour.hs +9/−9
- Parser.hs +53/−50
- Rasenschach.cabal +11/−15
- Render.hs +475/−79
- RenderBall.hs +0/−46
- RenderGame.hs +0/−67
- RenderPlayer.hs +0/−136
- RenderUtil.hs +0/−132
- Rules.hs +1/−2
- SqueakyChalkSound.ttf binary
- argentina.bmp binary
- ballM.wav binary
- chalkboard.png binary
- england2.bmp binary
- tockH.wav binary
- whistle.wav binary
− 20THCENT.TTF
binary file changed (22824 → absent bytes)
− 20redball.png
binary file changed (902 → absent bytes)
− 23redball.png
binary file changed (1097 → absent bytes)
− 26redball.png
binary file changed (1236 → absent bytes)
− 30redball.png
binary file changed (1699 → absent bytes)
− 35redball.png
binary file changed (2122 → absent bytes)
− 40redball.png
binary file changed (2254 → absent bytes)
Animate.hs view
@@ -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)
BasicTypes.hs view
@@ -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
GameLoop.hs view
@@ -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 [] = []
Helper.hs view
@@ -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"
Main.hs view
@@ -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})- +
ObjectBehaviour.hs view
@@ -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
Parser.hs view
@@ -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---
Rasenschach.cabal view
@@ -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+
Render.hs view
@@ -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 <SPACE> 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
− RenderBall.hs
@@ -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)-
− RenderGame.hs
@@ -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)
− RenderPlayer.hs
@@ -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))
− RenderUtil.hs
@@ -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)
Rules.hs view
@@ -17,8 +17,7 @@ import Data.List import Data.Function (on) import Data.Maybe-import Debug.Trace- + import Object import BasicTypes import Message
− SqueakyChalkSound.ttf
binary file changed (67740 → absent bytes)
+ argentina.bmp view
binary file changed (absent → 30054 bytes)
− ballM.wav
binary file changed (32044 → absent bytes)
− chalkboard.png
binary file changed (19340 → absent bytes)
+ england2.bmp view
binary file changed (absent → 30054 bytes)
− tockH.wav
binary file changed (42028 → absent bytes)
− whistle.wav
binary file changed (284588 → absent bytes)