free-game 0.3.2.5 → 0.3.2.6

raw patch · 7 files changed

+120/−95 lines, 7 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• Graphics/FreeGame.hs +2/−1
• Graphics/FreeGame/Backends/GLFW.hs +76/−73
• Graphics/FreeGame/Base.hs +8/−8
• Graphics/FreeGame/Simple.hs +5/−1
• Graphics/FreeGame/Util.hs +24/−7
• examples/test.hs +4/−4
• free-game.cabal +1/−1

@@ -35,7 +35,8 @@ runGame :: GameParam -> Game a -> IO (Maybe a)
 runGame = GLFW.runGame
 
--- | Run more efficiently.
+-- | In most cases there's no unwrapping (Game a -> GameAction (Game a)).
+-- | The use of ('>>=') is more efficient than 'runGame' in such situation.
 runGame' :: GameParam -> (forall m. MonadFree GameAction m => m a) -> IO (Maybe a)
 runGame' = GLFW.runGame'
 

@@ -32,70 +32,16 @@ import System.Mem
 import Unsafe.Coerce
 
-data Texture = Texture GL.TextureObject Int Int
-
-installTexture :: Bitmap -> FinalizerT IO Texture
-installTexture bmp = do
-    [tex] <- liftIO $ GL.genObjectNames 1
-    liftIO $ GL.textureBinding GL.Texture2D GL.$= Just tex
-
-    let (width, height) = bitmapSize 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
-
-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.textureBinding GL.Texture2D $= Just tex
-    GL.renderPrimitive GL.Polygon $ zipWithM_
-        (\(pX, pY) (tX, tY) -> do
-            GL.texCoord $ GL.TexCoord2 (gf tX) (gf tY)
-            GL.vertex $ GL.Vertex2   (gf pX) (gf pY))
-        [(-w, -h), (w, -h), (w, h), (-w, h)]
-        [(0,0), (1.0,0), (1.0,1.0), (0,1.0)]
-
-preservingMatrix' :: MonadIO m => m () -> m ()
-preservingMatrix' m = do
-    liftIO $ glPushMatrix
-    _ <- m
-    liftIO $ glPopMatrix
-
-drawPic :: (?refTextures :: IORef (IM.IntMap Texture)) => Picture -> FinalizerT IO ()
-drawPic (Bitmap bmp) = case bitmapHash bmp of
-    Just h -> do
-        m <- liftIO $ readIORef ?refTextures
-        case IM.lookup h m of
-            Just t -> liftIO $ drawTexture t
-            Nothing -> do
-                t <- installTexture bmp
-                liftIO $ writeIORef ?refTextures $ IM.insert h t m
-                liftIO $ drawTexture t
-                finalizer $ modifyIORef ?refTextures $ IM.delete h 
-    Nothing -> liftIO $ runFinalizerT $ installTexture bmp >>= liftIO . drawTexture
-drawPic (BitmapPicture bmp) = drawPic (Bitmap bmp)
-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
+runGame :: GameParam -> Game a -> IO (Maybe a)
+runGame param m = launch param $ \r s -> runFreeGame param r s m
 
-drawPic (Translate (Vec2 tx ty) p) = preservingMatrix' $ do
-    liftIO $ GL.translate (GL.Vector3 (gf tx) (gf ty) 0)
-    drawPic p
+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)
 
-drawPic (Pictures ps) = mapM_ drawPic ps
-drawPic (PictureWithFinalizer m) = m >>= drawPic
-drawPic (Colored (Color r g b a) pic) = do
-    oldColor <- liftIO $ get GL.currentColor
-    liftIO $ GL.currentColor $= GL.Color4 (gf r) (gf g) (gf b) (gf a)
-    drawPic pic
-    liftIO $ GL.currentColor $= oldColor
+runFreeGame :: GameParam -> IORef (IM.IntMap Texture) -> IORef Int -> Free GameAction a -> FinalizerT IO (Maybe a)
+runFreeGame p r s = go where
+    go (Free f) = runAction p r s $ go <$> f
+    go (Pure a) = return $ Just a
 
 runAction :: GameParam
     -> IORef (IM.IntMap Texture)
@@ -141,17 +87,7 @@         fcont $ param { windowSize = dim }
     QuitGame -> return Nothing
 
-runFreeGame :: GameParam -> IORef (IM.IntMap Texture) -> IORef Int -> Free GameAction a -> FinalizerT 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 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)
+data Texture = Texture GL.TextureObject Int Int
 
 launch :: GameParam -> (IORef (IM.IntMap Texture) -> IORef Int -> FinalizerT IO (Maybe a)) -> IO (Maybe a)
 launch param m = do
@@ -186,6 +122,73 @@     closeWindow
     terminate
     return r
+
+installTexture :: Bitmap -> FinalizerT IO Texture
+installTexture bmp = do
+    [tex] <- liftIO $ GL.genObjectNames 1
+    liftIO $ GL.textureBinding GL.Texture2D GL.$= Just tex
+
+    let (width, height) = bitmapSize 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
+
+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.textureBinding GL.Texture2D $= Just tex
+    GL.renderPrimitive GL.Polygon $ zipWithM_
+        (\(pX, pY) (tX, tY) -> do
+            GL.texCoord $ GL.TexCoord2 (gf tX) (gf tY)
+            GL.vertex $ GL.Vertex2   (gf pX) (gf pY))
+        [(-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 -> FinalizerT IO ()
+drawPic (Bitmap bmp) = case bitmapHash bmp of
+    Just h -> do
+        m <- liftIO $ readIORef ?refTextures
+        case IM.lookup h m of
+            Just t -> liftIO $ drawTexture t
+            Nothing -> do
+                t <- installTexture bmp
+                liftIO $ writeIORef ?refTextures $ IM.insert h t m
+                liftIO $ drawTexture t
+                finalizer $ modifyIORef ?refTextures $ IM.delete h 
+    Nothing -> liftIO $ runFinalizerT $ installTexture bmp >>= liftIO . drawTexture
+
+drawPic (BitmapPicture bmp) = drawPic (Bitmap bmp)
+
+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 (PictureWithFinalizer m) = m >>= drawPic
+
+drawPic (Colored (Color r g b a) pic) = do
+    oldColor <- liftIO $ get GL.currentColor
+    liftIO $ GL.currentColor $= GL.Color4 (gf r) (gf g) (gf b) (gf a)
+    drawPic pic
+    liftIO $ GL.currentColor $= oldColor
+
+preservingMatrix' :: MonadIO m => m () -> m ()
+preservingMatrix' m = do
+    liftIO $ glPushMatrix
+    _ <- m
+    liftIO $ glPopMatrix
 
 mapKey :: I.Button -> Either Key MouseButton
 mapKey k = case k of

@@ -126,7 +126,7 @@     | BitmapPicture Bitmap
     -- | A picture consist of some 'Picture's.
     | Pictures [Picture]
-    -- | A picture that may have side effects(for internal use).
+    -- | A picture that may have side effects(internal use only).
     | PictureWithFinalizer (FinalizerT IO Picture)
     -- | Rotated picture by the given angle (in degrees, counterclockwise).
     | Rotate Float Picture
@@ -141,13 +141,13 @@ 
 -- | Parameters of the application.
 data GameParam = GameParam
-    {    framePerSecond :: Int
-        ,windowSize :: (Int, Int)
-        ,windowTitle :: String
-        ,windowed :: Bool
-        ,cursorVisible :: Bool
-        ,clearColor :: Color
-        ,windowOrigin :: Vec2
+    { framePerSecond :: Int
+    , windowSize :: (Int, Int)
+    , windowTitle :: String
+    , windowed :: Bool
+    , cursorVisible :: Bool
+    , clearColor :: Color
+    , windowOrigin :: Vec2
     } deriving Show
 
 -- | 640*480(windowed), 60fps

@@ -30,6 +30,8 @@     ,embedIO
     ,quitGame
     ,tick
+    ,untick
+    ,untickInfinite
     ,untickGame
 
     -- * About Picture
@@ -37,6 +39,7 @@     ,Bitmap
     ,loadBitmapFromFile
     ,loadBitmaps
+    ,loadBitmapsWith
     ,Vec2(..)
 
     -- * Drawing texts
@@ -76,7 +79,8 @@         tick
         looping world'
 
--- | Run more efficiently.
+-- | In most cases there's no unwrapping (Game a -> GameAction (Game a)).
+-- | The use of ('>>=') is more efficient than 'runGame' in such situation.
 runSimple' :: GameParam
     -> world -- ^ An initial world
     -> (world -> forall m. MonadFree GameAction m => m world) -- ^ A computation yielding new world

@@ -11,15 +11,26 @@ --
 ----------------------------------------------------------------------------
 
-module Graphics.FreeGame.Util (untick, untickGame, untickInfinite, randomness, degrees, radians, loadPictureFromFile, loadBitmaps) where
+module Graphics.FreeGame.Util (
+    untick,
+    untickGame,
+    untickInfinite,
+    randomness,
+    degrees,
+    radians,
+    loadPictureFromFile,
+    loadBitmaps,
+    loadBitmapsWith) where
 import Control.Monad
 import Control.Monad.Free
+import Control.Applicative
 import Data.Char
 import Graphics.FreeGame.Base
 import Graphics.FreeGame.Data.Bitmap
 import System.Random
 import Language.Haskell.TH
 import System.Directory
+import System.FilePath
 import System.IO.Unsafe
 import Data.Void
 
@@ -58,21 +69,28 @@ loadPictureFromFile = embedIO . fmap Bitmap . loadBitmapFromFile
 
 -- | Load and define all pictures in the specified directory.
-loadBitmaps :: FilePath -> Q [Dec]
-loadBitmaps path = do
-    paths <- runIO $ getFileList path
+loadBitmapsWith :: Name -> FilePath -> Q [Dec]
+loadBitmapsWith getFullPath path = do
+    loc <- (</>path) <$> takeDirectory <$> loc_filename <$> location
+    paths <- runIO $ getFileList loc
     
     sequence $ do
         p <- paths
         let name = pathToName p
         [ return $ SigD (mkName name) (ConT ''Bitmap)
-            , funD (mkName name) [clause [] (normalB $ load name $ path ++ '/' : p) []]
+            , funD (mkName name) [clause [] (normalB $ load name $ loc </> p) []]
             ]
     where
         load name fp = do
             runIO $ putStrLn $ "Defined: " ++ fp ++ " as `" ++ name ++ "'"
-            appE (varE 'unsafePerformIO) $ appE (varE 'loadBitmapFromFile) (litE $ StringL fp)
+            appE (varE 'unsafePerformIO) $ uInfixE (appE (varE getFullPath) (litE $ StringL fp))
+                (varE '(>>=))
+                (varE 'loadBitmapFromFile)
 
+-- | use with getDataFileName
+loadBitmaps :: FilePath -> Q [Dec]
+loadBitmaps = loadBitmapsWith 'canonicalizePath
+
 getFileList :: FilePath -> IO [FilePath]
 getFileList path = do
     allContents <- filter notHidden `fmap` getDirectoryContents path
@@ -82,7 +100,6 @@     where
         notHidden ('.':_) = False
         notHidden _ = True
-        p </> q = p ++ '/' : q
 
 pathToName :: FilePath -> String
 pathToName = ('_':) . map p where

@@ -4,7 +4,7 @@ import Control.Monad
 import Data.Vect
 import Control.Monad.State
-
+import Data.Void
 import Control.Lens -- using lens (http://hackage.haskell.org/package/lens)
 
 $(loadBitmaps "images")
@@ -17,7 +17,7 @@ 
 $(makeLenses ''Object)
 
-obj :: StateT Object Game ()
+obj :: StateT Object Game Void
 obj = forever $ do
     pos@(Vec2 x y) <- use position
 
@@ -49,11 +49,11 @@ 
     tick
 
-initial :: Game ()
+initial :: Game Void
 initial = do
     x <- randomness (0,640)
     y <- randomness (0,480)
     a <- randomness (0, 2 * pi)
     evalStateT obj $ Object (Vec2 x y) (sinCos a &* 4) False
 
-main = runSimple defaultGameParam (replicate 100 initial) $ mapM untickGame
+main = runSimple defaultGameParam (replicate 100 initial) $ mapM untickInfinite

@@ -1,5 +1,5 @@ name:                free-game
-version:             0.3.2.5
+version:             0.3.2.6
 synopsis:            Create graphical applications for free.
 description:         Cross-platform GUI library based on free monads
 homepage:            https://github.com/fumieval/free-game