free-game 0.3.2.1 → 0.3.2.2

raw patch · 11 files changed

+231/−151 lines, 11 filesdep +OpenGLRawdep +voiddep ~transformersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: OpenGLRaw, void

Dependency ranges changed: transformers

API changes (from Hackage documentation)

Files

• Graphics/FreeGame.hs +8/−1
• Graphics/FreeGame/Backends/GLFW.hs +105/−111
• Graphics/FreeGame/Base.hs +9/−3
• Graphics/FreeGame/Data/Color.hs +28/−8
• Graphics/FreeGame/Data/Font.hs +12/−9
• Graphics/FreeGame/Input.hs +0/−1
• Graphics/FreeGame/Internal/Resource.hs +31/−0
• Graphics/FreeGame/Simple.hs +22/−2
• Graphics/FreeGame/Util.hs +2/−2
• examples/test.hs +8/−11
• free-game.cabal +6/−3

@@ -1,3 +1,4 @@+{-# LANGUAGE Rank2Types, FlexibleContexts #-}
 {-|
 Module      :  Graphics.FreeGame
 Copyright   :  (C) 2012 Fumiaki Kinoshita
@@ -16,7 +17,8 @@     module Graphics.FreeGame.Data.Font,
     module Graphics.FreeGame.Input,
     module Graphics.FreeGame.Util,
-    runGame
+    runGame,
+    runGame'
 ) where
 
 import Graphics.FreeGame.Base
@@ -25,10 +27,15 @@ import Graphics.FreeGame.Data.Bitmap
 import Graphics.FreeGame.Data.Font
 import qualified Graphics.FreeGame.Backends.GLFW as GLFW
+import Control.Monad.Free
 
 -- | Run a 'Game' computation.
 runGame :: GameParam -> Game a -> IO (Maybe a)
 runGame = GLFW.runGame
+
+-- | Run more efficiently.
+runGame' :: GameParam -> (forall m. MonadFree GameAction m => m a) -> IO (Maybe a)
+runGame' = GLFW.runGame'
 
 {- $example
 

@@ -9,44 +9,46 @@ -- Portability :  non-portable
 --
 ----------------------------------------------------------------------------
-{-# LANGUAGE ImplicitParams, ScopedTypeVariables #-}
-module Graphics.FreeGame.Backends.GLFW (runGame) where
-import Graphics.UI.GLFW as GLFW
-import qualified Graphics.Rendering.OpenGL.GL as GL
-import Graphics.FreeGame.Base
-import Graphics.FreeGame.Data.Bitmap
-import qualified Graphics.FreeGame.Input as I
+{-# LANGUAGE ImplicitParams, ScopedTypeVariables, Rank2Types #-}
+module Graphics.FreeGame.Backends.GLFW (runGame, runGame') where
 import Control.Applicative
-import Control.Monad.Free
 import Control.Monad
+import Control.Monad.Free
+import Control.Monad.Free.Church
+import Control.Monad.IO.Class
 import Data.IORef
 import Data.StateVar
-import qualified Data.Array.Repa.Repr.ForeignPtr as RF
 import Foreign.ForeignPtr
+import Graphics.FreeGame.Base
+import Graphics.FreeGame.Data.Bitmap
+import Graphics.FreeGame.Internal.Resource
+import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility
+import Graphics.UI.GLFW as GLFW
+import qualified Data.Array.Repa.Repr.ForeignPtr as RF
 import qualified Data.IntMap as IM
-import Unsafe.Coerce
+import qualified Graphics.FreeGame.Input as I
+import qualified Graphics.Rendering.OpenGL.GL as GL
 import System.Mem
+import Unsafe.Coerce
 
 data Texture = Texture GL.TextureObject Int Int
 
-installTexture :: Bitmap -> IO Texture
+installTexture :: Bitmap -> ResourceT IO Texture
 installTexture bmp = do
-    [tex] <- GL.genObjectNames 1
-    GL.textureBinding GL.Texture2D GL.$= Just tex
+    [tex] <- liftIO $ GL.genObjectNames 1
+    liftIO $ GL.textureBinding GL.Texture2D GL.$= Just tex
 
     let (width, height) = bitmapSize bmp
-    withForeignPtr (RF.toForeignPtr $ bitmapData bmp)
+    liftIO $ withForeignPtr (RF.toForeignPtr $ bitmapData bmp)
         $ GL.texImage2D Nothing GL.NoProxy 0 GL.RGBA8 (GL.TextureSize2D (gsizei width) (gsizei height)) 0
         . GL.PixelData GL.RGBA GL.UnsignedInt8888
+    finalizer $ GL.deleteObjectNames [tex]
     return $ Texture tex width height
 
-freeTexture :: Texture -> IO ()
-freeTexture (Texture tex _ _) = GL.deleteObjectNames [tex]
-
 drawTexture :: Texture -> IO ()
 drawTexture (Texture tex width height) = do
     let (w, h) = (fromIntegral width / 2, fromIntegral height / 2)
-    GL.textureFilter   GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest)
+    GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest)
     GL.textureBinding GL.Texture2D $= Just tex
     GL.renderPrimitive GL.Polygon $ zipWithM_
         (\(pX, pY) (tX, tY) -> do
@@ -55,123 +57,118 @@         [(-w, -h), (w, -h), (w, h), (-w, h)]
         [(0,0), (1.0,0), (1.0,1.0), (0,1.0)]
 
-drawPic :: (?refTextures :: IORef (IM.IntMap Texture)) => Picture -> IO [Int]
+preservingMatrix' :: MonadIO m => m () -> m ()
+preservingMatrix' m = do
+    liftIO $ glPushMatrix
+    _ <- m
+    liftIO $ glPopMatrix
+
+drawPic :: (?refTextures :: IORef (IM.IntMap Texture)) => Picture -> ResourceT IO ()
 drawPic (BitmapPicture bmp) = case bitmapHash bmp of
-    Nothing -> do
-        t <- installTexture bmp
-        drawTexture t
-        freeTexture t
-        return []
     Just h -> do
-        m <- readIORef ?refTextures
+        m <- liftIO $ readIORef ?refTextures
         case IM.lookup h m of
-            Just t -> [] <$ drawTexture t
+            Just t -> liftIO $ drawTexture t
             Nothing -> do
                 t <- installTexture bmp
-                writeIORef ?refTextures $ IM.insert h t m
-                drawTexture t
-                return [h]
+                liftIO $ writeIORef ?refTextures $ IM.insert h t m
+                liftIO $ drawTexture t
+                finalizer $ modifyIORef ?refTextures $ IM.delete h 
+    Nothing -> liftIO $ runResourceT $ installTexture bmp >>= liftIO . drawTexture
 
-drawPic (Rotate theta p) = GL.preservingMatrix $ GL.rotate (gf (-theta)) (GL.Vector3 0 0 1) >> drawPic p
-drawPic (Scale (Vec2 sx sy) p) = GL.preservingMatrix $ GL.scale (gf sx) (gf sy) 1 >> drawPic p
-drawPic (Translate (Vec2 tx ty) p) = GL.preservingMatrix $ GL.translate (GL.Vector3 (gf tx) (gf ty) 0) >> drawPic p
-drawPic (Pictures ps) = concat <$> mapM drawPic ps
-drawPic (IOPicture m) = m >>= drawPic
+drawPic (Rotate theta p) = preservingMatrix' $ do
+    liftIO $ GL.rotate (gf (-theta)) (GL.Vector3 0 0 1)
+    drawPic p
+
+drawPic (Scale (Vec2 sx sy) p) = preservingMatrix' $ do
+    liftIO $ GL.scale (gf sx) (gf sy) 1
+    drawPic p
+
+drawPic (Translate (Vec2 tx ty) p) = preservingMatrix' $ do
+    liftIO $ GL.translate (GL.Vector3 (gf tx) (gf ty) 0)
+    drawPic p
+
+drawPic (Pictures ps) = mapM_ drawPic ps
+drawPic (ResourcePicture m) = m >>= drawPic
 drawPic (Colored (Color r g b a) pic) = do
-    oldColor <- get GL.currentColor
-    GL.currentColor  $= GL.Color4 (gf r) (gf g) (gf b) (gf a)
-    xs <- drawPic pic
-    GL.currentColor $= oldColor
-    return xs
+    oldColor <- liftIO $ get GL.currentColor
+    liftIO $ GL.currentColor $= GL.Color4 (gf r) (gf g) (gf b) (gf a)
+    drawPic pic
+    liftIO $ GL.currentColor $= oldColor
 
-run :: (?windowT :: GL.GLdouble, ?windowB :: GL.GLdouble, ?windowL :: GL.GLdouble, ?windowR :: GL.GLdouble
-    , ?refTextures :: IORef (IM.IntMap Texture)
-    , ?refFrame :: IORef Int
-    , ?frameTime :: Double
-    , ?windowTitle :: String
-    , ?windowMode :: Bool
-    , ?cursorVisible :: Bool
-    ) => [Int] -> Game a -> IO (Maybe a)
-run is (Free f) = case f of
-    DrawPicture pic cont -> do
-        ls <- drawPic pic
-        flip run cont $! ls Prelude.++ is -- Strict!!!
-    EmbedIO m -> m >>= run is
-    Bracket m -> run [] m >>= maybe (return Nothing) (run is)
+runAction :: GameParam
+    -> IORef (IM.IntMap Texture)
+    -> IORef Int
+    -> GameAction (ResourceT IO (Maybe a)) -> ResourceT IO (Maybe a)
+runAction param refTextures refFrame _f = case _f of
+    DrawPicture pic cont -> let ?refTextures = refTextures in drawPic pic >> cont
+    EmbedIO m -> join (liftIO m)
+    Bracket m -> liftIO (runResourceT $ runFreeGame param refTextures refFrame m) >>= maybe (return Nothing) id
     Tick cont -> do
-        GL.matrixMode   $= GL.Projection
-        swapBuffers
-        t <- getTime
-        n <- readIORef ?refFrame
-        sleep (fromIntegral n * ?frameTime - t)
-        if t > 1
-            then resetTime >> writeIORef ?refFrame 0
-            else writeIORef ?refFrame (succ n)
+        liftIO $ do
+            GL.matrixMode $= GL.Projection
+            swapBuffers
+            t <- getTime
+            n <- readIORef refFrame
+            sleep (fromIntegral n / fromIntegral (framePerSecond param) - t)
+            if t > 1
+                then resetTime >> writeIORef refFrame 0
+                else writeIORef refFrame (succ n)
 
-        r <- windowIsOpen
-        if r
-            then do
+        r <- liftIO $ windowIsOpen
+        if not r then return Nothing else do
+            liftIO $ do
                 GL.clear [GL.ColorBuffer] 
                 performGC
-                GL.preservingMatrix $ do
                 GL.loadIdentity
                 GL.scale (gf 1) (-1) 1
-                GL.ortho ?windowL ?windowR ?windowT ?windowB 0 (-100)
-                GL.matrixMode   $= GL.Modelview 0
-                run is cont
-            else return Nothing
-    GetButtonState key fcont -> either keyIsPressed mouseButtonIsPressed (mapKey key) >>= run is . fcont
+                let Vec2 ox oy = windowOrigin param
+                    windowL = realToFrac ox
+                    windowR = realToFrac ox + fromIntegral (fst $ windowSize param)
+                    windowT = realToFrac oy
+                    windowB = realToFrac oy + fromIntegral (snd $ windowSize param)
+                GL.ortho windowL windowR windowT windowB 0 (-100)
+                GL.matrixMode $= GL.Modelview 0
+            cont
+    GetButtonState key fcont -> liftIO (either keyIsPressed mouseButtonIsPressed (mapKey key)) >>= fcont
     GetMousePosition fcont -> do
-        (x, y) <- GLFW.getMousePosition
-        run is $ fcont $ Vec2 (fromIntegral x) (fromIntegral y)
-    GetMouseWheel fcont -> GLFW.getMouseWheel >>= run is . fcont
-    GetGameParam fcont -> do
-        dim <- GLFW.getWindowDimensions
-        GL.Color4 r g b a <- get GL.clearColor
-        run is $ fcont $ GameParam { framePerSecond = floor $ 1 / ?frameTime
-                                   , windowSize = dim
-                                   , windowTitle = ?windowTitle
-                                   , windowed = ?windowMode
-                                   , cursorVisible = ?cursorVisible
-                                   , clearColor = Color (realToFrac r) 
-                                                        (realToFrac g) 
-                                                        (realToFrac b) 
-                                                        (realToFrac a)
-                                   , windowOrigin = Vec2 (realToFrac ?windowL) (realToFrac ?windowT)
-                                   }
+        (x, y) <- liftIO $ GLFW.getMousePosition
+        fcont $ Vec2 (fromIntegral x) (fromIntegral y)
+    GetMouseWheel fcont -> liftIO GLFW.getMouseWheel >>= fcont
+    GetGameParam fcont -> do -- There may be a better way
+        dim <- liftIO GLFW.getWindowDimensions
+        fcont $ param { windowSize = dim }
     QuitGame -> return Nothing
-run is (Pure x) = do
-    m <- readIORef ?refTextures
-    GL.deleteObjectNames [obj | i <- is, let Texture obj _ _ = m IM.! i]
-    modifyIORef ?refTextures $ flip (foldr IM.delete) is
-    return (Just x)
 
+runFreeGame :: GameParam -> IORef (IM.IntMap Texture) -> IORef Int -> Free GameAction a -> ResourceT IO (Maybe a)
+runFreeGame p r s = go where
+    go (Free f) = runAction p r s $ go <$> f
+    go (Pure a) = return $ Just a
+
 -- | Run 'Game' using OpenGL and GLFW.
 runGame :: GameParam -> Game a -> IO (Maybe a)
-runGame param game = do
+runGame param m = launch param $ \r s -> runFreeGame param r s m
+
+runGame' :: GameParam -> (forall m. MonadFree GameAction m => m a) -> IO (Maybe a)
+runGame' param m = launch param $ \r s -> runF m (return . Just) (runAction param r s)
+
+launch :: GameParam -> (IORef (IM.IntMap Texture) -> IORef Int -> ResourceT IO (Maybe a)) -> IO (Maybe a)
+launch param m = do
     True <- initialize
     pf <- openGLProfile
-    let Vec2 ox oy = windowOrigin param
-    let ?windowL = realToFrac ox
-        ?windowR = realToFrac ox + fromIntegral (fst $ windowSize param)
-        ?windowT = realToFrac oy
-        ?windowB = realToFrac oy + fromIntegral (snd $ windowSize param)
-        ?windowTitle = windowTitle param
-        ?windowMode = windowed param
-        ?cursorVisible = cursorVisible param
     True <- openWindow $ defaultDisplayOptions {
         displayOptions_width = fromIntegral $ fst $ windowSize param
         ,displayOptions_height = fromIntegral $ snd $ windowSize param
-        ,displayOptions_displayMode = if ?windowMode then Window else Fullscreen
+        ,displayOptions_displayMode = if windowed param then Window else Fullscreen
         ,displayOptions_windowIsResizable = False
         ,displayOptions_openGLProfile = pf
-    }
+        }
     
-    if ?cursorVisible then enableMouseCursor 
-                      else disableMouseCursor
+    if cursorVisible param
+        then enableMouseCursor 
+        else disableMouseCursor
 
-    setWindowTitle $ ?windowTitle
-    
+    setWindowTitle $ windowTitle param
     GL.lineSmooth $= GL.Enabled
     GL.blend      $= GL.Enabled
     GL.blendFunc  $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
@@ -183,10 +180,7 @@ 
     ref <- newIORef IM.empty
     ref' <- newIORef 0
-    let ?refTextures = ref
-        ?refFrame = ref'
-        ?frameTime = 1 / fromIntegral (framePerSecond param)
-    r <- run [] game
+    r <- runResourceT $ m ref ref'
 
     closeWindow
     terminate

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts, DeriveFunctor, FlexibleInstances #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Graphics.FreeGame.Base
@@ -50,7 +50,10 @@ import Graphics.FreeGame.Data.Color
 import Graphics.FreeGame.Data.Bitmap
 import Graphics.FreeGame.Input
+import Graphics.FreeGame.Internal.Resource
+import Control.Monad.IO.Class
 import Data.Vect
+import Data.Void
 
 infixr 5 `Translate`
 infixr 5 `Rotate`
@@ -60,6 +63,9 @@ -- | 'Game' is a 'Monad' that abstracts user interfaces.
 type Game = Free GameAction
 
+instance MonadIO Game where
+    liftIO = embedIO
+
 -- | A base for 'Game' monad.
 data GameAction a
     = Tick a
@@ -86,7 +92,7 @@ bracket m = wrap $ Bracket $ liftM return m
 
 -- | Break the current computation.
-quitGame :: MonadFree GameAction m => m a
+quitGame :: MonadFree GameAction m => m Void
 quitGame = wrap QuitGame
 
 -- | Draw a 'Picture'.
@@ -119,7 +125,7 @@     -- | A picture consist of some 'Picture's.
     | Pictures [Picture]
     -- | A picture that may have side effects(for internal use).
-    | IOPicture (IO Picture)
+    | ResourcePicture (ResourceT IO Picture)
     -- | Rotated picture by the given angle (in degrees, counterclockwise).
     | Rotate Float Picture
     -- | Scaled picture.

@@ -13,36 +13,56 @@ module Graphics.FreeGame.Data.Color (
     -- * The type
     Color(..)
-    , colorAsWord8
     -- * Color operations
     , transparent
+    , lighten
+    , darken
     , intermediate
+    -- * Deprecated
     , halfD
     , halfB
     -- * Basic colors
     , white, black, red, green, blue, yellow, cyan, magenta
     ) where
 
-import Data.Word
+import Data.String
+import Data.Char
 
 -- | A color that has red, green, blue, alpha as its component.
 data Color = Color Float Float Float Float deriving (Show, Eq, Ord)
 
-colorAsWord8 :: Color -> (Word8, Word8, Word8, Word8)
-colorAsWord8 (Color r g b a) = (floor $ r * 255, floor $ g * 255, floor $ b * 255, floor $ a * 255)
+hf :: Char -> Float
+hf x = fromIntegral (digitToInt x) / 15
 
--- | An intermediate between the given colors.
-intermediate :: Color -> Color -> Color
-intermediate (Color r0 g0 b0 a0) (Color r1 g1 b1 a1) = Color ((r0 + r1)/2) ((g0 + g1)/2) ((b0 + b1)/2) ((a0 + a1)/2)
+hf' :: Char -> Char -> Float
+hf' x y = fromIntegral (digitToInt x * 16 + digitToInt y) / 255
 
--- | Give a transparency to the color.
+instance IsString Color where
+    fromString xs@[r,g,b,a] | all isHexDigit xs = Color (hf r) (hf g) (hf b) (hf a)
+    fromString xs@[r,g,b] | all isHexDigit xs = Color (hf r) (hf g) (hf b) 1
+    fromString xs@[r1,r0,g1,g0,b1,b0,a1,a0] | all isHexDigit xs = Color (hf' r1 r0) (hf' g1 g0) (hf' b1 b0) (hf' a1 a0)
+    fromString xs@[r1,r0,g1,g0,b1,b0] | all isHexDigit xs = Color (hf' r1 r0) (hf' g1 g0) (hf' b1 b0) 1
+    fromString x = error $ "Invalid color representation: " ++ x
+
 transparent :: Float -> Color -> Color
 transparent f (Color r g b a) = Color r g b (f * a)
 
+lighten :: Float -> Color -> Color
+lighten f (Color r g b a) = Color (r * (1 - f) + f) (g * (1 - f) + f) (b * (1 - f) + f) a
+
+darken :: Float -> Color -> Color
+darken f (Color r g b a) = Color (r * (1 - f) + f) (g * (1 - f) + f) (b * (1 - f) + f) a
+
+-- | An intermediate between the given colors.
+intermediate :: Color -> Color -> Color
+intermediate (Color r0 g0 b0 a0) (Color r1 g1 b1 a1) = Color ((r0 + r1)/2) ((g0 + g1)/2) ((b0 + b1)/2) ((a0 + a1)/2)
+
+{-# DEPRECATED halfD "use darken 0.5 instead" #-}
 -- | An intermediate between the black and the given color
 halfD :: Color -> Color
 halfD = intermediate black
 
+{-# DEPRECATED halfB "use lighten 0.5 instead" #-}
 -- | An intermediate between the white and the given color
 halfB :: Color -> Color
 halfB = intermediate white

@@ -24,6 +24,7 @@   ) where
 
 import Control.Applicative
+import Control.Monad.IO.Class
 import Data.Array.Repa as R
 import Data.Array.Repa.Eval
 import Data.Vect
@@ -33,6 +34,7 @@ import Graphics.FreeGame.Base
 import Graphics.FreeGame.Types
 import Graphics.FreeGame.Data.Bitmap
+import Graphics.FreeGame.Internal.Resource
 import Graphics.Rendering.FreeType.Internal
 import qualified Graphics.Rendering.FreeType.Internal.GlyphSlot as GS
 import qualified Graphics.Rendering.FreeType.Internal.Vector as V
@@ -74,7 +76,7 @@ 
 -- | Render a text by the specified 'Font'.
 text :: Font -> Float -> String -> Picture
-text font siz str = IOPicture $ Pictures <$> renderCharacters font siz str
+text font siz str = ResourcePicture $ Pictures <$> renderCharacters font siz str
 
 failFreeType :: Monad m => CInt -> m ()
 failFreeType 0 = return ()
@@ -100,13 +102,14 @@ resolutionDPI :: Int
 resolutionDPI = 300
 
-charToBitmap :: Font -> Float -> Char -> IO RenderedChar
+charToBitmap :: Font -> Float -> Char -> ResourceT IO RenderedChar
 charToBitmap (Font face _ _ refCache) pixel ch = do
-    cache <- readIORef refCache
+    cache <- liftIO $ readIORef refCache
     case M.lookup (siz, ch) cache of
         Nothing -> do
-            d <- render
-            writeIORef refCache $ M.insert (siz, ch) d cache
+            d <- liftIO render
+            liftIO $ writeIORef refCache $ M.insert (siz, ch) d cache
+            finalizer $ modifyIORef refCache $ M.delete (siz, ch)
             return d
         Just d -> return d
     where
@@ -138,14 +141,14 @@ 
             ar :: R.Array U DIM2 Word8 <- unsafeFreezeMVec (Z:.h:.w) mv
 
-            let pixel (crd:.0) = R.index ar crd
-                pixel (_:._) = 255
+            let pix (crd:.0) = R.index ar crd
+                pix (_:._) = 255
 
-            result <- computeP (fromFunction (Z:.h:.w:.4) pixel) >>= makeStableBitmap
+            result <- computeP (fromFunction (Z:.h:.w:.4) pix) >>= makeStableBitmap
             
             return $ RenderedChar result (Vec2 left (-top)) (fromIntegral (V.x adv) / 64)
  
-renderCharacters :: Font -> Float -> String -> IO [Picture]
+renderCharacters :: Font -> Float -> String -> ResourceT IO [Picture]
 renderCharacters font pixel str = render str 0 where
     render [] _ = return []
     render (c:cs) pen = do

@@ -74,7 +74,6 @@     | MouseMiddle
     deriving (Show, Eq, Ord)
 
-{-# DEPRECATED MouseState "no longer needed" #-}
 data MouseState = MouseState
     { mousePosition :: Vec2
     , leftButton :: Bool

@@ -0,0 +1,31 @@+{-# LANGUAGE Rank2Types #-}
+module Graphics.FreeGame.Internal.Resource (ResourceT(..), finalizer, runResourceT) where
+
+import Control.Monad.IO.Class
+import Control.Applicative
+
+newtype ResourceT m a = ResourceT
+    { unResourceT :: forall r. (a -> m r) -> (IO () -> r -> m r) -> m r }
+
+finalizer :: Monad m => IO () -> ResourceT m ()
+finalizer m = ResourceT $ \p f -> p () >>= f m
+
+instance Functor (ResourceT m) where
+    fmap f (ResourceT g) = ResourceT $ \p -> g (p . f)
+
+instance Applicative (ResourceT m) where
+    pure a = ResourceT $ \p _ -> p a
+    ResourceT ff <*> ResourceT fa = ResourceT $ \p f -> ff (\a -> fa (\b -> p (a b)) f) f
+
+instance Monad (ResourceT m) where
+    return a = ResourceT $ \p _ -> p a
+    ResourceT rf >>= k = ResourceT $ \p f -> rf (\x -> unResourceT (k x) p f) f
+
+instance MonadIO m => MonadIO (ResourceT m) where
+    liftIO m = ResourceT $ \r _ -> liftIO m >>= r
+
+runResourceT :: MonadIO m => ResourceT m a -> m a
+runResourceT (ResourceT z) = do
+    (fin, a) <- z (\a -> return (return (), a)) (\m (fs, r) -> return (m >> fs,　r))
+    liftIO fin
+    return a

@@ -1,3 +1,4 @@+{-# LANGUAGE RankNTypes, FlexibleContexts #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Graphics.FreeGame.Simple
@@ -13,16 +14,19 @@ module Graphics.FreeGame.Simple (
     -- * Basic type
     Game
+    ,GameAction
 
     -- * Run the game
     ,GameParam
     ,defaultGameParam
     ,runSimple
+    ,runSimple'
 
     -- * In the Game monad
     ,drawPicture
-    ,askInput
-    ,getMouseState
+    ,getButtonState
+    ,getMousePosition
+    ,getMouseWheel
     ,embedIO
     ,quitGame
     ,tick
@@ -43,6 +47,10 @@     ,randomness
     ,degrees
 
+    -- * Deprecated
+    ,askInput
+    ,getMouseState
+
     -- * Reexports
     ,module Graphics.FreeGame.Input
     ,module Graphics.FreeGame.Data.Color
@@ -54,6 +62,7 @@ import Graphics.FreeGame.Data.Color
 import Graphics.FreeGame.Input
 import Control.Monad
+import Control.Monad.Free
 
 -- | Run a 'Game' by the given initial state and updating function.
 runSimple :: GameParam
@@ -61,6 +70,17 @@     -> (world -> Game world) -- ^ A computation yielding new world
     -> IO ()
 runSimple param initial m = void $ runGame param $ looping initial where
+    looping world = do
+        world' <- m world
+        tick
+        looping world'
+
+-- | Run more efficiently.
+runSimple' :: GameParam
+    -> world -- ^ An initial world
+    -> (world -> forall m. MonadFree GameAction m => m world) -- ^ A computation yielding new world
+    -> IO ()
+runSimple' param initial m = void $ runGame' param $ looping initial where
     looping world = do
         world' <- m world
         tick

@@ -18,7 +18,7 @@ import System.Random
 
 -- | Run a 'Game' as one frame.
-untickGame :: Game a -> Game (Game a)
+untickGame :: Free GameAction a -> Free GameAction (Free GameAction a)
 untickGame (Pure a) = Pure (Pure a)
 untickGame (Free (Tick cont)) = Pure cont
 untickGame (Free fm) = Free $ fmap untickGame fm
@@ -38,5 +38,5 @@ radians x = x / 180 * pi
 
 -- | Create a 'Picture' from the given file.
-loadPictureFromFile :: FilePath -> Game Picture
+loadPictureFromFile :: MonadFree GameAction m => FilePath -> m Picture
 loadPictureFromFile = embedIO . fmap BitmapPicture . loadBitmapFromFile

@@ -8,10 +8,9 @@ import Control.Lens -- using lens (http://hackage.haskell.org/package/lens)
 
 data Object = Object
-    {
-        _position :: Vec2
-        , _velocity :: Vec2
-        , _pressed :: Bool
+    { _position :: Vec2
+    , _velocity :: Vec2
+    , _pressed :: Bool
     }
 
 $(makeLenses ''Object)
@@ -32,17 +31,15 @@     position .= pos &+ vel
     velocity .= Vec2 dx' dy'
 
-    mouse <- getMouseState
+    mpos <- getMousePosition
 
-    if norm (mousePosition mouse &- pos) < 32
+    if norm (mpos &- pos) < 32
         then do
             drawPicture $ Translate pos ?pic
             btn <- use pressed
-            when (not btn && leftButton mouse) $ do
-                vel' <- (&*4) <$> sinCos <$> randomness (0, 2 * pi)
-                velocity .= vel'
-
-            pressed .= leftButton mouse
+            btn' <- getButtonState MouseLeft
+            when (not btn && btn') $ velocity <~ (&*4) <$> sinCos <$> randomness (0, 2 * pi)
+            pressed .= btn'
 
         else drawPicture $ Translate pos $ Colored (transparent 0.7 white) ?pic
 

@@ -1,5 +1,5 @@ name:                free-game
-version:             0.3.2.1
+version:             0.3.2.2
 synopsis:            Create graphical applications for free.
 description:         Cross-platform GUI library based on free monads
 homepage:            https://github.com/fumieval/free-game
@@ -35,10 +35,11 @@     , Graphics.FreeGame.Data.Color
     , Graphics.FreeGame.Data.Bitmap
     , Graphics.FreeGame.Data.Font
+    , Graphics.FreeGame.Internal.Resource
   ghc-options: -Wall -fexcess-precision -O2
   build-depends: base == 4.*
     , mtl >= 2.1
-    , transformers
+    , transformers >= 0.3
     , containers >= 0.4
     , free == 3.*
     , random == 1.*
@@ -50,5 +51,7 @@     , freetype2 >= 0.1
     , hashable >= 1.0
     , OpenGL >= 2.5
+    , OpenGLRaw >= 1.1
     , GLFW-b >= 0.1
-    , StateVar+    , StateVar
+    , void >= 0.1