summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--GLDriver.hs15
-rw-r--r--GLX.hs12
-rw-r--r--HTanks.hs66
-rw-r--r--Tank.hs1
4 files changed, 71 insertions, 23 deletions
diff --git a/GLDriver.hs b/GLDriver.hs
index 9fb2642..2b55c6f 100644
--- a/GLDriver.hs
+++ b/GLDriver.hs
@@ -4,9 +4,12 @@ module GLDriver ( Driver(..)
, SomeDriver(..)
, Event
, SomeEvent(..)
+ , fromEvent
, QuitEvent(..)
, ResizeEvent(..)
- , fromEvent
+ , Key(..)
+ , KeyPressEvent(..)
+ , KeyReleaseEvent(..)
) where
import Data.Typeable
@@ -45,3 +48,13 @@ instance Event QuitEvent
data ResizeEvent = ResizeEvent Int Int deriving Typeable
instance Event ResizeEvent
+
+
+data Key = KeyLeft | KeyRight | KeyUp | KeyDown
+ deriving (Eq, Ord, Show)
+
+data KeyPressEvent = KeyPressEvent Key deriving Typeable
+instance Event KeyPressEvent
+
+data KeyReleaseEvent = KeyReleaseEvent Key deriving Typeable
+instance Event KeyReleaseEvent
diff --git a/GLX.hs b/GLX.hs
index f457d78..8a1c52d 100644
--- a/GLX.hs
+++ b/GLX.hs
@@ -118,6 +118,18 @@ handleEvent glx disp xevent = do
keysym <- keycodeToKeysym disp (ev_keycode event) 0
case () of
_ | keysym == xK_Escape -> return $ Just $ SomeEvent QuitEvent
+ | keysym == xK_Up -> return $ Just $ SomeEvent $ KeyPressEvent KeyUp
+ | keysym == xK_Down -> return $ Just $ SomeEvent $ KeyPressEvent KeyDown
+ | keysym == xK_Left -> return $ Just $ SomeEvent $ KeyPressEvent KeyLeft
+ | keysym == xK_Right -> return $ Just $ SomeEvent $ KeyPressEvent KeyRight
+ | otherwise -> return Nothing
+ | evtype == keyRelease -> do
+ keysym <- keycodeToKeysym disp (ev_keycode event) 0
+ case () of
+ _ | keysym == xK_Up -> return $ Just $ SomeEvent $ KeyReleaseEvent KeyUp
+ | keysym == xK_Down -> return $ Just $ SomeEvent $ KeyReleaseEvent KeyDown
+ | keysym == xK_Left -> return $ Just $ SomeEvent $ KeyReleaseEvent KeyLeft
+ | keysym == xK_Right -> return $ Just $ SomeEvent $ KeyReleaseEvent KeyRight
| otherwise -> return Nothing
| evtype == clientMessage -> do
if ((glxDeleteWindow glx) == (fromIntegral . head . ev_data $ event))
diff --git a/HTanks.hs b/HTanks.hs
index c2a5437..77684e4 100644
--- a/HTanks.hs
+++ b/HTanks.hs
@@ -11,12 +11,16 @@ import GLX
import Control.Concurrent (threadDelay)
import Control.Monad.State
import Data.Maybe
+import Data.Ratio
+import qualified Data.Set as S
import Data.Time.Clock
data MainState = MainState
- { driver :: !SomeDriver
+ { run :: !Bool
+ , driver :: !SomeDriver
, time :: !UTCTime
+ , keyset :: !(S.Set Key)
}
newtype MainT m a = MainT (StateT MainState m a)
@@ -34,8 +38,8 @@ main = do
when (initialized gl) $ do
currentTime <- getCurrentTime
- let mainState = MainState {driver = SomeDriver gl, time = currentTime}
- gameState = GameState {level = testLevel, tanks = [Tank 0.0 0.0 0]}
+ let mainState = MainState {run = True, driver = SomeDriver gl, time = currentTime, keyset = S.empty}
+ gameState = GameState {level = testLevel, tanks = [Tank 0.0 0.0 0 0]}
setup 800 600
runGame gameState $ runMain mainState $ mainLoop
@@ -49,7 +53,7 @@ mainLoop :: Main ()
mainLoop = do
gl <- gets driver
t <- gets time
- run <- liftIO $ handleEvents gl
+ handleEvents
lift render
@@ -63,30 +67,48 @@ mainLoop = do
currenttime <- liftIO getCurrentTime
let d = round $ 1e3*(diffUTCTime currenttime t)
- lift $ modify $ \state -> state {tanks = (Tank ((posx . head . tanks $ state)+(0.0001* fromIntegral d)) 0.0 0):(tail . tanks $ state)}
-
- liftIO $ print $ d
+ replicateM_ d simulationStep
+ --liftIO $ print $ d
let newtime = addUTCTime ((1e-3)*(fromIntegral d)) t
modify $ \state -> state {time = newtime}
- when run $ mainLoop
+ runnext <- gets run
+ when runnext mainLoop
+
+
+simulationStep :: Main ()
+simulationStep = do
+ keys <- gets keyset
+
+ let x = (if (S.member KeyLeft keys) then (-1) else 0) + (if (S.member KeyRight keys) then 1 else 0)
+ y = (if (S.member KeyDown keys) then (-1) else 0) + (if (S.member KeyUp keys) then 1 else 0)
+
+ let lengthsq = ((x*x)+(y*y))
+
+ when (lengthsq /= 0) $ do
+ let length = sqrt lengthsq
+
+ let dx = fromRational (round (x*1000/length)%1000000)
+ dy = fromRational (round (y*1000/length)%1000000)
+
+ oldtank <- lift $ gets (head . tanks)
+ let tank = oldtank {posx = dx + posx oldtank, posy = dy + posy oldtank}
+
+ lift $ modify $ \state -> state {tanks = tank:(tail . tanks $ state)}
-handleEvents :: Driver a => a -> IO Bool
-handleEvents gl = do
- event <- nextEvent gl
- if (isJust event)
- then
- handleEvent $ fromJust event
- else
- return True
+handleEvents :: Main ()
+handleEvents = do
+ event <- gets driver >>= liftIO . nextEvent
+ when (isJust event) $
+ handleEvent $ fromJust event
-handleEvent :: SomeEvent -> IO Bool
+handleEvent :: SomeEvent -> Main ()
handleEvent ev
- | Just (ResizeEvent w h) <- fromEvent ev = do
- resize w h
- return True
- | Just QuitEvent <- fromEvent ev = return False
- | otherwise = return True
+ | Just (ResizeEvent w h) <- fromEvent ev = liftIO $ resize w h
+ | Just (KeyPressEvent key) <- fromEvent ev = modify $ \state -> state {keyset = S.insert key (keyset state)}
+ | Just (KeyReleaseEvent key) <- fromEvent ev = modify $ \state -> state {keyset = S.delete key (keyset state)}
+ | Just QuitEvent <- fromEvent ev = modify $ \state -> state {run = False}
+ | otherwise = return ()
diff --git a/Tank.hs b/Tank.hs
index 4e1f02a..54322cf 100644
--- a/Tank.hs
+++ b/Tank.hs
@@ -7,4 +7,5 @@ data Tank = Tank
{ posx :: !Micro
, posy :: !Micro
, dir :: !Micro
+ , aim :: !Micro
} deriving Show