neocturne/htanks
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Removed IO from Game monad

Browse source
This commit is contained in:
Matthias Schiffer 2010-04-11 01:48:55 +02:00
parent d2be8eb410
commit b694c7705e
5 changed files with 31 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
src/Game.hs
View file

@ -29,8 +29,8 @@ data GameState = GameState
, bullets :: ![Bullet]
} deriving (Show)
newtype Game a = Game (StateT GameState IO a)
deriving (Monad, MonadIO, MonadState GameState)
newtype Game a = Game (State GameState a)
deriving (Monad, MonadState GameState)
runGame :: GameState -> Game a -> IO (a, GameState)
runGame st (Game a) = runStateT a st
runGame :: GameState -> Game a -> (a, GameState)
runGame st (Game a) = runState a st

12
src/HTanks.hs
View file

@ -32,16 +32,16 @@ main = do
when (initialized gl) $ do
currentTime <- getCurrentTime
let mainState = MainState {run = True, driver = SomeDriver gl, time = currentTime, players =
let gamestate = GameState {level = theLevel, tanks = [ Tank 5.0 5.0 0 0 1.5 270 False 3 1 5 1
, Tank 5.0 3.5 0 0 1.5 270 False 3 1 5 1
], bullets = []}
mainstate = MainState {run = True, driver = SomeDriver gl, time = currentTime, players =
[ --SomePlayer $ DefaultPlayer S.empty 0 0 False
SomePlayer $ hwiidPlayer
, SomePlayer $ CPUPlayer 0
], textures = M.empty}
gameState = GameState {level = theLevel, tanks = [ Tank 5.0 5.0 0 0 1.5 270 False 3 1 5 1
, Tank 5.0 3.5 0 0 1.5 270 False 3 1 5 1
], bullets = []}
], textures = M.empty, gameState = gamestate}
runGame gameState $ runMain mainState $ do
runMain mainstate $ do
setup
mainLoop

24
src/MainLoop.hs
View file

@ -1,8 +1,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module MainLoop ( MainState(..)
, MainT(..)
, Main
, Main(..)
, runMain
) where
@ -18,17 +17,16 @@ import qualified Data.Map as M
data MainState = MainState
{ run :: !Bool
, driver :: !SomeDriver
, time :: !UTCTime
, players :: ![SomePlayer]
, textures :: !(M.Map Texture TextureObject)
{ run :: !Bool
, driver :: !SomeDriver
, time :: !UTCTime
, players :: ![SomePlayer]
, textures :: !(M.Map Texture TextureObject)
, gameState :: !GameState
}
newtype MainT m a = MainT (StateT MainState m a)
deriving (Monad, MonadState MainState, MonadIO, MonadTrans)
newtype Main a = Main (StateT MainState IO a)
deriving (Monad, MonadState MainState, MonadIO)
type Main = MainT Game
runMain :: MainState -> Main a -> Game (a, MainState)
runMain st (MainT a) = runStateT a st
runMain :: MainState -> Main a -> IO (a, MainState)
runMain st (Main a) = runStateT a st

6
src/Render.hs
View file

@ -74,8 +74,8 @@ setup = do
render :: Main ()
render = do
tanklist <- lift $ gets tanks
bulletlist <- lift $ gets bullets
tanklist <- gets $ tanks . gameState
bulletlist <- gets $ bullets . gameState
playerlist <- gets players
textureWood <- getTexture TextureWood
@ -84,7 +84,7 @@ render = do
textureBullet <- getTexture TextureBullet
textureCrosshair <- getTexture TextureCrosshair
(lw, lh) <- lift $ gets level >>= \l -> return (fromIntegral . levelWidth $ l :: GLfloat, fromIntegral . levelHeight $ l :: GLfloat)
(lw, lh) <- gets (level . gameState) >>= \l -> return (fromIntegral . levelWidth $ l :: GLfloat, fromIntegral . levelHeight $ l :: GLfloat)
liftIO $ do
clear [ColorBuffer]

13
src/Simulation.hs
View file

@ -105,7 +105,7 @@ updateBullet game = do
simulationStep :: Main ()
simulationStep = do
oldplayers <- gets players
game <- lift get
game <- gets gameState
let oldtanks = tanks game
(p, t, s) <- liftIO $ liftM unzip3 $ mapM (updateTank' game) $ zip oldplayers oldtanks
@ -121,17 +121,16 @@ simulationStep = do
, bulletTank = n
}) shootingtanks
modify $ \state -> state {players = p}
lift $ modify $ \state ->
let thebullets = map (runState $ updateBullet state) $ bullets state
leftbullets = collideBullets $ zipWith (\(left, bullet') bullet -> (left, bullet, bullet')) thebullets $ bullets state
bt = hitBullets $ liftM2 (\(b, (_, b')) (t, t') -> (b, b', t, t')) (zip (bullets state) leftbullets) (zip (tanks state) newtanks)
modify $ \state ->
let thebullets = map (runState $ updateBullet . gameState $ state) $ bullets $ gameState state
leftbullets = collideBullets $ zipWith (\(left, bullet') bullet -> (left, bullet, bullet')) thebullets $ bullets $ gameState state
bt = hitBullets $ liftM2 (\(b, (_, b')) (t, t') -> (b, b', t, t')) (zip (bullets $ gameState state) leftbullets) (zip (tanks $ gameState state) newtanks)
leftbullets2 = map (\(left, bullet) -> (left && (all (\(c, b, _) -> (b /= bullet) || (not c)) bt), bullet)) leftbullets
newtanks2 = map (\tank -> tank {tankLife = (tankLife tank) - (sum . map (\(c, _, t) -> if (t == tank && c) then 1 else 0) $ bt)}) newtanks
thetanks = map (\(tank, n) -> tank {tankBulletsLeft = (tankBulletsLeft tank) + (countLostTankBullets n leftbullets2)}) $ zip newtanks2 [0..]
in state {tanks = thetanks, bullets = newbullets ++ (map snd . filter fst $ leftbullets2)}
in state {players = p, gameState = (gameState state) {tanks = thetanks, bullets = newbullets ++ (map snd . filter fst $ leftbullets2)}}
where
collideBullets [] = []