Added keyboard events

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

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

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}
+         let mainState = MainState {run = True, driver = SomeDriver gl, time = currentTime, keyset = S.empty}
-             gameState = GameState {level = testLevel, tanks = [Tank 0.0 0.0 0]}
+             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)}
+  replicateM_ d simulationStep
-  
+  --liftIO $ print $ d
-  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
 
 
-handleEvents :: Driver a => a -> IO Bool
+simulationStep :: Main ()
-handleEvents gl = do
+simulationStep = do
-  event <- nextEvent gl
+  keys <- gets keyset
-  if (isJust event)
-      then
-          handleEvent $ fromJust event
-      else
-          return True
   
-handleEvent :: SomeEvent -> IO Bool
+  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 :: Main ()
+handleEvents = do
+  event <- gets driver >>= liftIO . nextEvent
+  when (isJust event) $
+      handleEvent $ fromJust event
+
+handleEvent :: SomeEvent -> Main ()
 handleEvent ev
-    | Just (ResizeEvent w h) <- fromEvent ev = do
+    | Just (ResizeEvent w h)     <- fromEvent ev = liftIO $ resize w h
-                                  resize w h
+    | Just (KeyPressEvent key)   <- fromEvent ev = modify $ \state -> state {keyset = S.insert key (keyset state)}
-                                  return True
+    | Just (KeyReleaseEvent key) <- fromEvent ev = modify $ \state -> state {keyset = S.delete key (keyset state)}
-    | Just QuitEvent <- fromEvent ev = return False
+    | Just QuitEvent             <- fromEvent ev = modify $ \state -> state {run = False}
-    | otherwise                      = return True
+    | otherwise = return ()

Tank.hs

@@ -7,4 +7,5 @@ data Tank = Tank
           { posx :: !Micro
           , posy :: !Micro
           , dir  :: !Micro
+          , aim  :: !Micro
           } deriving Show