free-game 0.3.2.2 → 0.3.2.3

raw patch · 12 files changed

+125/−84 lines, 12 filesdep +directorydep +template-haskellbinary-addedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: directory, template-haskell

API changes (from Hackage documentation)

Files

• Graphics/FreeGame/Backends/GLFW.hs +13/−12
• Graphics/FreeGame/Base.hs +8/−4
• Graphics/FreeGame/Data/Bitmap.hs +1/−1
• Graphics/FreeGame/Data/Font.hs +5/−5
• Graphics/FreeGame/Internal/Finalizer.hs +34/−0
• Graphics/FreeGame/Internal/Resource.hs +0/−31
• Graphics/FreeGame/Simple.hs +2/−1
• Graphics/FreeGame/Util.hs +35/−3
• examples/images/logo.png binary
• examples/logo.png binary
• examples/test.hs +11/−11
• free-game.cabal +16/−16

@@ -10,6 +10,7 @@ --
 ----------------------------------------------------------------------------
 {-# LANGUAGE ImplicitParams, ScopedTypeVariables, Rank2Types #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 module Graphics.FreeGame.Backends.GLFW (runGame, runGame') where
 import Control.Applicative
 import Control.Monad
@@ -21,7 +22,7 @@ import Foreign.ForeignPtr
 import Graphics.FreeGame.Base
 import Graphics.FreeGame.Data.Bitmap
-import Graphics.FreeGame.Internal.Resource
+import Graphics.FreeGame.Internal.Finalizer
 import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility
 import Graphics.UI.GLFW as GLFW
 import qualified Data.Array.Repa.Repr.ForeignPtr as RF
@@ -33,7 +34,7 @@ 
 data Texture = Texture GL.TextureObject Int Int
 
-installTexture :: Bitmap -> ResourceT IO Texture
+installTexture :: Bitmap -> FinalizerT IO Texture
 installTexture bmp = do
     [tex] <- liftIO $ GL.genObjectNames 1
     liftIO $ GL.textureBinding GL.Texture2D GL.$= Just tex
@@ -63,8 +64,8 @@     _ <- m
     liftIO $ glPopMatrix
 
-drawPic :: (?refTextures :: IORef (IM.IntMap Texture)) => Picture -> ResourceT IO ()
-drawPic (BitmapPicture bmp) = case bitmapHash bmp of
+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
@@ -74,8 +75,8 @@                 liftIO $ writeIORef ?refTextures $ IM.insert h t m
                 liftIO $ drawTexture t
                 finalizer $ modifyIORef ?refTextures $ IM.delete h 
-    Nothing -> liftIO $ runResourceT $ installTexture bmp >>= liftIO . drawTexture
-
+    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
@@ -89,7 +90,7 @@     drawPic p
 
 drawPic (Pictures ps) = mapM_ drawPic ps
-drawPic (ResourcePicture m) = m >>= drawPic
+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)
@@ -99,11 +100,11 @@ runAction :: GameParam
     -> IORef (IM.IntMap Texture)
     -> IORef Int
-    -> GameAction (ResourceT IO (Maybe a)) -> ResourceT IO (Maybe a)
+    -> GameAction (FinalizerT IO (Maybe a)) -> FinalizerT 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
+    Bracket m -> liftIO (runFinalizerT $ runFreeGame param refTextures refFrame m) >>= maybe (return Nothing) id
     Tick cont -> do
         liftIO $ do
             GL.matrixMode $= GL.Projection
@@ -140,7 +141,7 @@         fcont $ param { windowSize = dim }
     QuitGame -> return Nothing
 
-runFreeGame :: GameParam -> IORef (IM.IntMap Texture) -> IORef Int -> Free GameAction a -> ResourceT IO (Maybe a)
+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
@@ -152,7 +153,7 @@ 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 :: GameParam -> (IORef (IM.IntMap Texture) -> IORef Int -> FinalizerT IO (Maybe a)) -> IO (Maybe a)
 launch param m = do
     True <- initialize
     pf <- openGLProfile
@@ -180,7 +181,7 @@ 
     ref <- newIORef IM.empty
     ref' <- newIORef 0
-    r <- runResourceT $ m ref ref'
+    r <- runFinalizerT $ m ref ref'
 
     closeWindow
     terminate

@@ -50,7 +50,7 @@ import Graphics.FreeGame.Data.Color
 import Graphics.FreeGame.Data.Bitmap
 import Graphics.FreeGame.Input
-import Graphics.FreeGame.Internal.Resource
+import Graphics.FreeGame.Internal.Finalizer
 import Control.Monad.IO.Class
 import Data.Vect
 import Data.Void
@@ -121,11 +121,13 @@ -- | A 2D Picture.
 data Picture
     -- | A 'Bitmap' as a 'Picture'.
-    = BitmapPicture Bitmap
+    = Bitmap Bitmap
+    -- | Deprecated synonym for 'Bitmap'.
+    | BitmapPicture Bitmap
     -- | A picture consist of some 'Picture's.
     | Pictures [Picture]
     -- | A picture that may have side effects(for internal use).
-    | ResourcePicture (ResourceT IO Picture)
+    | PictureWithFinalizer (FinalizerT IO Picture)
     -- | Rotated picture by the given angle (in degrees, counterclockwise).
     | Rotate Float Picture
     -- | Scaled picture.
@@ -135,6 +137,8 @@     -- | Colored picture.
     | Colored Color Picture
 
+{-# DEPRECATED BitmapPicture "use Bitmap instead" #-}
+
 -- | Parameters of the application.
 data GameParam = GameParam
     {    framePerSecond :: Int
@@ -150,7 +154,7 @@ defaultGameParam :: GameParam
 defaultGameParam = GameParam 60 (640,480) "free-game" True True white (Vec2 0 0)
 
--- | Deprecated synonym for 'getMouseState'.
+-- | Yields the mouse's state.
 getMouseState :: MonadFree GameAction m => m MouseState
 getMouseState = MouseState
     `liftM` getMousePosition

@@ -66,7 +66,7 @@ 
 -- | Create a 'Bitmap' from the given file.
 loadBitmapFromFile :: FilePath -> IO Bitmap
-loadBitmapFromFile path = readImageRGBA path >>= makeStableBitmap . imgData . either error id
+loadBitmapFromFile path = readImageRGBA path >>= either fail return >>= makeStableBitmap . imgData
 
 -- | Convert the 'Bitmap' by the given function.
 onBitmap :: (R.Array RF.F DIM3 Word8 -> R.Array RF.F DIM3 Word8) -> Bitmap -> Bitmap

@@ -34,7 +34,7 @@ import Graphics.FreeGame.Base
 import Graphics.FreeGame.Types
 import Graphics.FreeGame.Data.Bitmap
-import Graphics.FreeGame.Internal.Resource
+import Graphics.FreeGame.Internal.Finalizer
 import Graphics.Rendering.FreeType.Internal
 import qualified Graphics.Rendering.FreeType.Internal.GlyphSlot as GS
 import qualified Graphics.Rendering.FreeType.Internal.Vector as V
@@ -76,7 +76,7 @@ 
 -- | Render a text by the specified 'Font'.
 text :: Font -> Float -> String -> Picture
-text font siz str = ResourcePicture $ Pictures <$> renderCharacters font siz str
+text font siz str = PictureWithFinalizer $ Pictures <$> renderCharacters font siz str
 
 failFreeType :: Monad m => CInt -> m ()
 failFreeType 0 = return ()
@@ -102,7 +102,7 @@ resolutionDPI :: Int
 resolutionDPI = 300
 
-charToBitmap :: Font -> Float -> Char -> ResourceT IO RenderedChar
+charToBitmap :: Font -> Float -> Char -> FinalizerT IO RenderedChar
 charToBitmap (Font face _ _ refCache) pixel ch = do
     cache <- liftIO $ readIORef refCache
     case M.lookup (siz, ch) cache of
@@ -148,11 +148,11 @@             
             return $ RenderedChar result (Vec2 left (-top)) (fromIntegral (V.x adv) / 64)
  
-renderCharacters :: Font -> Float -> String -> ResourceT IO [Picture]
+renderCharacters :: Font -> Float -> String -> FinalizerT IO [Picture]
 renderCharacters font pixel str = render str 0 where
     render [] _ = return []
     render (c:cs) pen = do
         RenderedChar b (Vec2 x y) adv <- charToBitmap font pixel c
         let (w,h) = bitmapSize b
             offset = Vec2 (pen + x + fromIntegral w / 2) (y + fromIntegral h / 2)
-        (Translate offset (BitmapPicture b):) <$> render cs (pen + adv)
+        (Translate offset (Bitmap b):) <$> render cs (pen + adv)

@@ -0,0 +1,34 @@+{-# LANGUAGE Rank2Types #-}
+module Graphics.FreeGame.Internal.Finalizer (FinalizerT(..), finalizer, runFinalizerT) where
+
+import Control.Monad.IO.Class
+import Control.Applicative
+
+-- | An action with explicit releasing action.
+newtype FinalizerT m a = FinalizerT
+    { unFinalizerT :: forall r. (a -> m r) -> (IO () -> r -> m r) -> m r }
+
+-- | Add a finalizer.
+finalizer :: Monad m => IO () -> FinalizerT m ()
+finalizer m = FinalizerT $ \p f -> p () >>= f m
+
+instance Functor (FinalizerT m) where
+    fmap f (FinalizerT g) = FinalizerT $ \p -> g (p . f)
+
+instance Applicative (FinalizerT m) where
+    pure a = FinalizerT $ \p _ -> p a
+    FinalizerT ff <*> FinalizerT fa = FinalizerT $ \p f -> ff (\a -> fa (\b -> p (a b)) f) f
+
+instance Monad (FinalizerT m) where
+    return a = FinalizerT $ \p _ -> p a
+    FinalizerT rf >>= k = FinalizerT $ \p f -> rf (\x -> unFinalizerT (k x) p f) f
+
+instance MonadIO m => MonadIO (FinalizerT m) where
+    liftIO m = FinalizerT $ \r _ -> liftIO m >>= r
+
+-- | Run the action and run all associated finalizers.
+runFinalizerT :: MonadIO m => FinalizerT m a -> m a
+runFinalizerT (FinalizerT z) = do
+    (fin, a) <- z (\a -> return (return (), a)) (\m (fs, r) -> return (m >> fs,　r))
+    liftIO fin
+    return a

@@ -1,31 +0,0 @@-{-# 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

@@ -17,7 +17,7 @@     ,GameAction
 
     -- * Run the game
-    ,GameParam
+    ,GameParam(..)
     ,defaultGameParam
     ,runSimple
     ,runSimple'
@@ -36,6 +36,7 @@     ,Picture(..)
     ,Bitmap
     ,loadBitmapFromFile
+    ,loadBitmaps
     ,Vec2(..)
 
     -- * Drawing texts

@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Graphics.FreeGame.Util
@@ -11,11 +11,16 @@ --
 ----------------------------------------------------------------------------
 
-module Graphics.FreeGame.Util (untickGame, randomness, degrees, radians, loadPictureFromFile) where
+module Graphics.FreeGame.Util (untickGame, randomness, degrees, radians, loadPictureFromFile, loadBitmaps) where
+import Control.Monad
 import Control.Monad.Free
+import Data.Char
 import Graphics.FreeGame.Base
 import Graphics.FreeGame.Data.Bitmap
 import System.Random
+import Language.Haskell.TH
+import System.Directory
+import System.IO.Unsafe
 
 -- | Run a 'Game' as one frame.
 untickGame :: Free GameAction a -> Free GameAction (Free GameAction a)
@@ -39,4 +44,31 @@ 
 -- | Create a 'Picture' from the given file.
 loadPictureFromFile :: MonadFree GameAction m => FilePath -> m Picture
-loadPictureFromFile = embedIO . fmap BitmapPicture . loadBitmapFromFile+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
+    forM paths $ \p -> let name = pathToName p
+        in funD (mkName name) [clause [] (normalB $ load name $ path ++ '/' : p) []]
+    where
+        load name fp = do
+            runIO $ putStrLn $ "Defined: " ++ fp ++ " as `" ++ name ++ "'"
+            appE (varE 'unsafePerformIO) $ appE (varE 'loadBitmapFromFile) (litE $ StringL fp)
+
+getFileList :: Prelude.FilePath -> IO [FilePath]
+getFileList path = do
+    allContents <- filter notHidden `fmap` getDirectoryContents path
+    files <- filterM (doesFileExist . (path</>)) allContents
+    dirs <- filterM (doesDirectoryExist . (path</>)) allContents
+    fmap ((files++).concat) $ forM dirs $ \i -> map (i</>) `fmap` getFileList (path</>i)
+    where
+        notHidden ('.':_) = False
+        notHidden _ = True
+        p </> q = p ++ '/' : q
+
+pathToName :: FilePath -> String
+pathToName = ('_':) . map p where
+    p c | isAlphaNum c = c
+        | otherwise = '_'

binary file changed (absent → 1893 bytes)

binary file changed (1893 → absent bytes)

@@ -1,4 +1,4 @@-{-# LANGUAGE ImplicitParams, TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell #-}
 import Graphics.FreeGame.Simple
 import Control.Applicative
 import Control.Monad
@@ -7,6 +7,8 @@ 
 import Control.Lens -- using lens (http://hackage.haskell.org/package/lens)
 
+$(loadBitmaps "images")
+
 data Object = Object
     { _position :: Vec2
     , _velocity :: Vec2
@@ -15,7 +17,7 @@ 
 $(makeLenses ''Object)
 
-obj :: (?pic :: Picture) => StateT Object Game ()
+obj :: StateT Object Game ()
 obj = forever $ do
     pos@(Vec2 x y) <- use position
 
@@ -33,27 +35,25 @@ 
     mpos <- getMousePosition
 
-    if norm (mpos &- pos) < 32
+    w <- if norm (mpos &- pos) < 32
         then do
-            drawPicture $ Translate pos ?pic
             btn <- use pressed
             btn' <- getButtonState MouseLeft
             when (not btn && btn') $ velocity <~ (&*4) <$> sinCos <$> randomness (0, 2 * pi)
             pressed .= btn'
+            return id
 
-        else drawPicture $ Translate pos $ Colored (transparent 0.7 white) ?pic
+        else return $ Colored (transparent 0.7 white)
 
+    drawPicture $ Translate pos $ w (Bitmap _logo_png)
+
     tick
 
-initial :: (?pic :: Picture) => Game ()
+initial :: Game ()
 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 = do
-    bmp <- loadBitmapFromFile "logo.png"
-    let ?pic = BitmapPicture bmp
-
-    runSimple defaultGameParam (replicate 100 initial) $ mapM untickGame
+main = runSimple defaultGameParam (replicate 100 initial) $ mapM untickGame

@@ -1,5 +1,5 @@ name:                free-game
-version:             0.3.2.2
+version:             0.3.2.3
 synopsis:            Create graphical applications for free.
 description:         Cross-platform GUI library based on free monads
 homepage:            https://github.com/fumieval/free-game
@@ -14,10 +14,8 @@ stability:           experimental
 cabal-version:       >=1.8
 extra-source-files:
-  examples/test.hs
-  examples/logo.png
-  examples/font.hs
-  examples/bitmap.hs
+  examples/*.hs
+  examples/images/*.png
   examples/VL-PGothic-Regular.ttf
 
 source-repository head
@@ -35,23 +33,25 @@     , Graphics.FreeGame.Data.Color
     , Graphics.FreeGame.Data.Bitmap
     , Graphics.FreeGame.Data.Font
-    , Graphics.FreeGame.Internal.Resource
+    , Graphics.FreeGame.Internal.Finalizer
   ghc-options: -Wall -fexcess-precision -O2
   build-depends: base == 4.*
-    , mtl >= 2.1
-    , transformers >= 0.3
-    , containers >= 0.4
-    , free == 3.*
-    , random == 1.*
-    , repa >= 3.2
-    , JuicyPixels-repa >= 0.4
-    , vect >= 0.4.6
     , array >= 0.3
+    , containers >= 0.4
+    , directory >= 1.0
     , filepath >= 1.3
+    , free == 3.*
     , freetype2 >= 0.1
+    , GLFW-b >= 0.1
     , hashable >= 1.0
+    , JuicyPixels-repa >= 0.4
+    , mtl >= 2.1
     , OpenGL >= 2.5
     , OpenGLRaw >= 1.1
-    , GLFW-b >= 0.1
+    , random == 1.*
+    , repa >= 3.2
     , StateVar
-    , void >= 0.1+    , transformers >= 0.3
+    , vect >= 0.4.6
+    , void >= 0.1
+    , template-haskell