reactive-thread 0.3.1.0 → 0.3.2.1

raw patch · 2 files changed

+190/−3 lines, 2 filesdep +reactive-threaddep ~basenew-component:exe:example-sdl

Dependencies added: reactive-thread

Dependency ranges changed: base

Files

• examples/sdl/Main.hs +164/−0
• reactive-thread.cabal +26/−3

@@ -0,0 +1,164 @@+module Main where++-- import Control.Applicative+import Control.Concurrent.Chan+import Control.Concurrent hiding (yield)+import Control.Monad hiding (forever)+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.State+import Data.List++import qualified Graphics.UI.SDL as SDL++import Reactive.Thread++data UpOrDown = Up | Down+  deriving (Eq, Ord, Show)++type KeyboardChan = Chan (UpOrDown, SDL.Keysym)++heldOf :: KeyboardChan -> [SDL.SDLKey] -> Update o (UpdateVar [SDL.SDLKey])+heldOf origKeyChan keys = parallel [] $ do+  keyChan <- liftIO $ dupChan origKeyChan+  evalStateT (foreverT $ go keyChan) []+  where+    go keyChan = do+      (upOrDown, sym) <- liftIO $ readChan keyChan+      let key = SDL.symKey sym+      when (key `elem` keys) $ do+        held <- get+        let held' = case upOrDown of+              Up -> delete key held+              Down -> key : held+        put held'+        lift $ yield held'++keyboard+  :: KeyboardChan+  -> a+  -> [(SDL.SDLKey, a)]+  -> Update o (UpdateVar a)+keyboard keyChan z keys = parallel z $ do+  held <- heldOf keyChan (map fst keys)+  forever $ do+    heldKeys <- query held+    case heldKeys of+      [] -> yield z+      (key:_) -> maybe (return ()) yield $ lookup key keys++type Thread o = Update o ()++type Time = Double++constantTick :: Double {-FPS-} -> Update o (UpdateVar Time)+constantTick fps = parallel 0 $ evalStateT (foreverT go) 0+  where+    go = do+      liftIO . threadDelay $ floor (1000 * 1000 / fps)++      t' <- gets succ+      put t'+      lift $ yield t'++velocity+  :: Double            -- ^ Initial position.+  -> UpdateVar Time    -- ^ Time.+  -> UpdateVar Double  -- ^ Velocity.+  -> Update o (UpdateVar Double)+velocity z timeVar velVar = parallel z $ do+  zeroTime <- query timeVar+  evalStateT (foreverT go) (z, zeroTime)+  where+    go = do+      (pos, time) <- get+      time' <- lift $ query timeVar+      vel <- lift $ query velVar++      let dt = time' - time+      pos' <- if dt > 0 && vel /= 0+        then do+          let pos' = pos + dt * vel+          lift $ yield pos'+          return pos'+        else return pos++      put (pos', time')++data Sprite = Sprite !Double !Double+  deriving (Show)++player+  :: UpdateVar Time+  -> KeyboardChan+  -> Update o (UpdateVar Sprite)+player timer keyChan = parallel (Sprite 0 0) $ do+  xVel <- keyboard keyChan 0 [(SDL.SDLK_LEFT, -1), (SDL.SDLK_RIGHT, 1)]+  yVel <- keyboard keyChan 0 [(SDL.SDLK_UP, -1), (SDL.SDLK_DOWN, 1)]+  x <- velocity 0 timer xVel+  y <- velocity 0 timer yVel++  forever $ do+    sprite <- Sprite+      `liftM` query x+      `ap` query y+    yield sprite++gameLoop :: SDL.Surface -> KeyboardChan -> Thread ()+gameLoop surface keyChan = do+  timer <- constantTick 60+  p <- player timer keyChan+  forever $ do+    sprite <- query p++    liftIO $ do+      let format = SDL.surfaceGetPixelFormat surface+      black <- SDL.mapRGB format 0 0 0+      void $ SDL.fillRect surface Nothing black++      drawSprite surface sprite+      SDL.flip surface++drawSprite :: SDL.Surface -> Sprite -> IO ()+drawSprite surface (Sprite x y) = do+  let format = SDL.surfaceGetPixelFormat surface+  color <- SDL.mapRGB format 0 128 255+  void $ SDL.fillRect surface (Just region) color++  where+    region = SDL.Rect+      (floor x) (floor y)+      width height++    width = 32+    height = 32++main :: IO ()+main = SDL.withInit [SDL.InitEverything] $ do+  surface <- SDL.setVideoMode initialWidth initialHeight 32+    [SDL.HWSurface, SDL.Resizable, SDL.RLEAccel, SDL.DoubleBuf]++  keyboardChan <- newChan+  gameThreadID <- forkIO $ runUpdate (gameLoop surface keyboardChan)+  _ <- eventLoop keyboardChan+  killThread gameThreadID++  where+    initialWidth = 640+    initialHeight = 480++    eventLoop keyboardChan = pollEvent+      where+        pollEvent = SDL.pollEvent >>= handleEvent++        handleEvent event = case event of+          SDL.NoEvent -> SDL.waitEvent >>= handleEvent+          SDL.KeyDown SDL.Keysym { SDL.symKey = SDL.SDLK_ESCAPE }+            -> return ()  -- Stop.+          SDL.KeyDown sym -> do+            writeChan keyboardChan (Down, sym)+            pollEvent+          SDL.KeyUp sym -> do+            writeChan keyboardChan (Up, sym)+            pollEvent+          _ -> pollEvent

@@ -7,7 +7,7 @@ -- 5. Push branches and tags.  name: reactive-thread-version: 0.3.1.0+version: 0.3.2.1  author: Matt "strager" Glazar build-type: Simple@@ -25,8 +25,13 @@ source-repository this   type: git   location: https://github.com/strager/reactive-thread.git-  tag: 0.3.1.0+  tag: 0.3.2.1 +flag profile+  default: False+  description:+    Enables profiling (i.e. -fprof-auto).+ library   exposed-modules:     Reactive.Thread,@@ -43,11 +48,29 @@     Reactive.Thread.Internal.VarSource    build-depends:-    base == 4.5.*,+    base == 4.5.* || == 4.6.*,     monad-parallel,+    stm,+    transformers++  ghc-options:+    -Wall++  if flag(profile)+    ghc-options:+      -fprof-auto++executable example-sdl+  main-is: examples/sdl/Main.hs++  build-depends:+    base,+    monad-parallel,+    reactive-thread,     SDL,     stm,     transformers    ghc-options:     -Wall+    -rtsopts