22nd lesson.

22/Main.hs

@@ -0,0 +1,130 @@
+{-# LANGUAGE Arrows, PatternGuards, ViewPatterns #-}
+
+module Main (main)
+       where
+
+import Control.Arrow (returnA, (&&&))
+import Control.Concurrent (threadDelay)
+import Control.Monad (when)
+
+import Data.Maybe (isNothing)
+
+import FRP.Yampa (Event(..), SF,
+                  tag, repeatedly, accumHoldBy)
+import qualified Graphics.UI.SDL as SDL
+
+import qualified Timer
+import SDLUtils (loadImage, setColorKey)
+import YampaUtils (reactimate)
+
+screenWidth     = 640
+screenHeight    = 480
+screenBPP       = 32
+
+framesPerSecond = 20
+ticksPerFrame   = 1 / framesPerSecond
+
+data Dot = Dot Int Int
+
+dotD            = 20
+dotR            = dotD `div` 2
+
+-- starting position of the dot controlled by user
+dotX = 320
+dotY = 240
+
+data ArrowKey = UpKey | DownKey | LeftKey | RightKey
+              deriving (Show, Eq)
+
+data GContext =
+  GContext { c_screen :: SDL.Surface
+           , c_bg     :: SDL.Surface
+           , c_dot    :: SDL.Surface }
+
+initSDL :: IO GContext
+initSDL = do
+  SDL.init [SDL.InitEverything]
+
+  screen <- SDL.setVideoMode screenWidth screenHeight screenBPP [SDL.SWSurface]
+  bg     <- loadImage "bg.png"
+  dot    <- (`setColorKey` (0x00, 0xff, 0xff)) =<< loadImage "dot.bmp"
+
+  SDL.setCaption "Move the Dot" ""
+
+  return $ GContext screen bg dot
+
+quitSDL :: IO ()
+quitSDL = SDL.quit
+
+renderScreen :: GContext -> Dot -> IO ()
+renderScreen (GContext screen bg dot) (Dot x y) = do
+  fillBg
+  drawDot x' y'
+  SDL.flip screen
+
+  where fillBg = do
+          SDL.blitSurface bg (Just bgLeftR) screen Nothing
+          SDL.blitSurface bg (Just bgRightR) screen (Just screenRightR)
+          where cx' = cx `mod` screenWidth
+                cw' = screenWidth - cx'
+
+                bgLeftR      = SDL.Rect cx' cy cw' screenHeight
+                bgRightR     = SDL.Rect 0   cy cx' screenHeight
+                screenRightR = SDL.Rect cw' cy cx' screenHeight
+
+        drawDot x y =
+          SDL.blitSurface dot Nothing
+                          screen (Just $ SDL.Rect (x - dotR) (y - dotR) 0 0)
+
+        cx = x - screenWidth `div` 2
+        cy = y - screenHeight `div` 2
+
+        x' = x - cx
+        y' = y - cy
+
+main :: IO ()
+main = do
+  gcontext <- initSDL
+
+  timer <- Timer.mkTimer
+  let init  = Timer.start timer >> return False
+
+  let sense = do
+        event <- SDL.pollEvent
+
+        let input =
+              case event of
+                SDL.Quit           -> Just $ True
+                _                  -> Nothing
+
+        when (isNothing input) $
+          threadDelay 10000
+
+        time <- fmap ((/1000) . fromIntegral) (Timer.getTicks timer)
+        Timer.restart timer
+
+        if isNothing input
+          then return (time, Just False)
+          else return (time, input)
+
+  let actuate Nothing    _       = return True
+      actuate _          NoEvent = return False
+      actuate (Just dot) _       = do
+        renderScreen gcontext dot
+        return False
+
+  let beat = repeatedly ticksPerFrame ()
+
+  reactimate init sense (uncurry actuate) (dot beat &&& beat)
+
+  quitSDL
+
+dot :: SF () (Event ()) -> SF Bool (Maybe Dot)
+dot beat =
+  proc closed -> do
+    beat' <- beat -< ()
+
+    let vx = 2
+    x <- accumHoldBy (+) dotX -< beat' `tag` vx
+
+    returnA -< if closed then Nothing else Just (Dot x dotY)

22/SDLUtils.hs

@@ -0,0 +1,19 @@
+module SDLUtils ( loadImage, setColorKey )
+       where
+
+import qualified Graphics.UI.SDL as SDL
+import qualified Graphics.UI.SDL.Image as IMG
+
+loadImage path = do
+  image   <- IMG.load path
+  dfImage <- SDL.displayFormat image
+
+  return dfImage
+
+setColorKey surface (r, g, b) = do
+  let format =  SDL.surfaceGetPixelFormat surface
+  colorkey   <- SDL.mapRGB format r g b
+
+  SDL.setColorKey surface [SDL.SrcColorKey] colorkey
+
+  return surface

22/Timer.hs

@@ -0,0 +1,137 @@
+module Timer ( Timer,
+               mkTimer,
+               start, stop, toggleStart, restart,
+               pause, unpause, togglePause,
+               isStarted, isPaused,
+               getTicks )
+       where
+
+import Control.Applicative ((<$>), (<*>))
+import Control.Monad.STM (STM, atomically)
+import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVar, writeTVar)
+import Control.Monad (when)
+
+import Data.Word (Word32)
+
+import GHC.Conc (unsafeIOToSTM)
+
+import qualified Graphics.UI.SDL as SDL
+
+
+data TimerState = Started | Stopped | Paused
+                deriving Eq
+
+data Timer =
+  Timer { state       :: TVar TimerState
+        , startTicks  :: TVar Word32
+        , pausedTicks :: TVar Word32 }
+
+mkTimer :: IO Timer
+mkTimer = do
+  Timer <$> newTVarIO Stopped
+        <*> newTVarIO 0
+        <*> newTVarIO 0
+
+start :: Timer -> IO ()
+start = atomically . startSTM
+
+startSTM :: Timer -> STM ()
+startSTM (Timer state startTicks _) = do
+  ticks <- unsafeIOToSTM SDL.getTicks
+
+  state' <- readTVar state
+  when (state' /= Started) $ do
+    writeTVar state Started
+    writeTVar startTicks ticks
+
+stop :: Timer -> IO ()
+stop = atomically . stopSTM
+
+stopSTM :: Timer -> STM ()
+stopSTM (Timer state startTicks pausedTicks) = do
+  state' <- readTVar state
+  when (state' /= Stopped) $ do
+    writeTVar state Stopped
+    writeTVar startTicks 0
+    writeTVar pausedTicks 0
+
+restart :: Timer -> IO ()
+restart = atomically . restartSTM
+
+restartSTM :: Timer -> STM ()
+restartSTM timer = do
+  stopSTM timer
+  startSTM timer
+
+toggleStart :: Timer -> IO ()
+toggleStart timer =
+  atomically $ do
+    started <- isStartedSTM timer
+    if started
+      then stopSTM timer
+      else startSTM timer
+
+pause :: Timer -> IO ()
+pause = atomically . pauseSTM
+
+pauseSTM :: Timer -> STM ()
+pauseSTM (Timer state startTicks pausedTicks) = do
+  ticks <- unsafeIOToSTM $ SDL.getTicks
+
+  state' <- readTVar state
+  when (state' == Started) $ do
+    start <- readTVar startTicks
+    writeTVar state Paused
+    writeTVar pausedTicks (ticks - start)
+
+unpause :: Timer -> IO ()
+unpause = atomically . unpauseSTM
+
+unpauseSTM :: Timer -> STM ()
+unpauseSTM (Timer state startTicks pausedTicks) = do
+  ticks <- unsafeIOToSTM $ SDL.getTicks
+
+  state' <- readTVar state
+  when (state' == Paused) $ do
+    paused <- readTVar pausedTicks
+    writeTVar state Started
+    writeTVar startTicks (ticks - paused)
+
+togglePause :: Timer -> IO ()
+togglePause timer =
+  atomically $ do
+    paused <- isPausedSTM timer
+    if paused
+      then unpauseSTM timer
+      else pauseSTM timer
+
+getTicks :: Timer -> IO Word32
+getTicks (Timer state startTicks pausedTicks) = do
+  atomically $ do
+    ticks <- unsafeIOToSTM SDL.getTicks
+
+    state' <- readTVar state
+    case state' of
+      Started -> (ticks -) <$> readTVar startTicks
+      Paused  -> readTVar pausedTicks
+      _       -> return 0
+
+isPaused :: Timer -> IO Bool
+isPaused = atomically . isPausedSTM
+
+isPausedSTM :: Timer -> STM Bool
+isPausedSTM (Timer state _ _) = do
+  state' <- readTVar state
+  case state' of
+    Paused -> return True
+    _      -> return False
+
+isStarted :: Timer -> IO Bool
+isStarted = atomically . isStartedSTM
+
+isStartedSTM :: Timer -> STM Bool
+isStartedSTM (Timer state _ _) = do
+  state' <- readTVar state
+  case state' of
+    Started -> return True
+    _       -> return False

22/YampaUtils.hs

@@ -0,0 +1,9 @@
+module YampaUtils (reactimate)
+       where
+
+import FRP.Yampa (SF, DTime)
+import qualified FRP.Yampa (reactimate)
+
+reactimate :: IO a -> IO (DTime, Maybe a) -> (b -> IO Bool) -> SF a b -> IO ()
+reactimate init sense actuate sf =
+  FRP.Yampa.reactimate init (const sense) (const actuate) sf