free-game 1.1 → 1.1.9

raw patch · 16 files changed

+341/−114 lines, 16 filesdep +StateVardep ~JuicyPixels-utildep ~OpenGLdep ~OpenGLRaw

Dependencies added: StateVar

Dependency ranges changed: JuicyPixels-util, OpenGL, OpenGLRaw, colors, mtl, reflection

Files

CHANGELOG.md +22/−6
FreeGame.hs +5/−3
FreeGame/Backend/GLFW.hs +31/−13
FreeGame/Class.hs +10/−11
FreeGame/Data/Bitmap.hs +30/−13
FreeGame/Data/Font.hs +8/−5
FreeGame/Instances.hs +52/−16
FreeGame/Internal/Finalizer.hs +2/−0
FreeGame/Internal/GLFW.hs +31/−12
FreeGame/UI.hs +27/−13
FreeGame/Util.hs +4/−3
examples/demo.hs +10/−7
examples/demo_stateful.hs +23/−0
examples/fib.hs +75/−0
examples/helloworld.hs +1/−1
free-game.cabal +10/−11

CHANGELOG.md view

@@ -1,9 +1,25 @@+1.1.80
+---------------------------------------------------------------------
+* Added `mouseScroll`
+* Fixed the malfunction of FPS management
+
+1.1.79
+---------------------------------------------------------------------
+* Exported `clipBitmap`
+
+1.1.78
+* Added `mouseInWindow`
+
+1.1
+-------------------------------------------------------------------------
+* Use Box instead of drab BoundingBox
+
 1.0.5
-----------------------------------------------------------------------------------------------------
+-------------------------------------------------------------------------
 * No fundamental changes
 
 1.0.4
-----------------------------------------------------------------------------------------------------
+-------------------------------------------------------------------------
 
 * Fixed some potential bugs that appeared on 7.8.1 RC2
 * Added `getBoundingBox` and `setBoundingBox` which accesses the window size and the region to draw.
@@ -11,7 +27,7 @@ * Demoted the precedence of `thickness` and `blendMode` according to other APIs.
 
 1.0.3
-----------------------------------------------------------------------------------------------------
+-------------------------------------------------------------------------
 * Added `runGameDefault` as an alternative of classic `runGame def`.
 * Removed the duplicate instance of `MonadIO`.
 * `free-game` no longer depends on ominous `repa`.
@@ -22,18 +38,18 @@ * Make the window size solid.
 
 1.0.2
-----------------------------------------------------------------------------------------------------
+-------------------------------------------------------------------------
 * Supported changing a blend function. `blendMode mode m` changes the blend mode while `m` is running.
 * Fixed fatal 'keyPress'-related bugs.
 * Special thanks: [@myuon_myon](https://twitter.com/myuon_myon)
 * Re-added `keyChar` and `keySpecial`.
 
 1.0.1
-----------------------------------------------------------------------------------------------------
+-------------------------------------------------------------------------
 * Demoted the precedence of `Affine` APIs to 5.
 
 1.0
-----------------------------------------------------------------------------------------------------
+-------------------------------------------------------------------------
 * Supported free-4.4.
 * Supported GLFW-b-1.3.
 * Use `Double` instead of `Float`.

FreeGame.hs view

@@ -35,12 +35,14 @@     globalize,
     localize,
     -- * Pictures
+    Drawable,
     Picture2D(..),
     BlendMode(..),
     Bitmap,
     bitmapSize,
     readBitmap,
     cropBitmap,
+    clipBitmap,
     loadBitmaps,
     loadBitmapsWith,
     writeBitmap,
@@ -57,6 +59,9 @@     keyDown,
     -- * Mouse
     Mouse(),
+    mouseScroll,
+    mouseInWindow,
+    mousePositionMay,
     mousePosition,
     mouseButtonL,
     mouseButtonR,
@@ -85,9 +90,6 @@     module Data.Color.Names,
     module Linear,
     -- * Deprecated
-    fromBitmap,
-    loadBitmapFromFile,
-    colored,
     keyChar,
     keySpecial

FreeGame/Backend/GLFW.hs view

@@ -21,6 +21,7 @@ import Data.Reflection
 import Data.BoundingBox
 import FreeGame.Class
+import FreeGame.Data.Bitmap
 import FreeGame.Internal.Finalizer
 import FreeGame.UI
 import FreeGame.Types
@@ -35,7 +36,6 @@ import qualified Graphics.UI.GLFW as GLFW
 import qualified Graphics.Rendering.OpenGL.GL as GL
 import Unsafe.Coerce
-import Codec.Picture.RGBA8
 import Control.Concurrent
 import Control.Lens (view)
 
@@ -48,6 +48,10 @@ mouseButtonCallback mouseBuffer _ btn GLFW.MouseButtonState'Pressed _ = modifyIORef' mouseBuffer $ Map.adjust buttonDown (fromEnum btn)
 mouseButtonCallback mouseBuffer _ btn GLFW.MouseButtonState'Released _ = modifyIORef' mouseBuffer $ Map.adjust buttonUp (fromEnum btn)
 
+mouseEnterCallback :: IORef Bool -> GLFW.Window -> GLFW.CursorState -> IO ()
+mouseEnterCallback ref _ GLFW.CursorState'InWindow = writeIORef ref True
+mouseEnterCallback ref _ GLFW.CursorState'NotInWindow = writeIORef ref False
+
 runGame :: WindowMode -> BoundingBox2 -> IterT (F UI) a -> IO (Maybe a)
 runGame mode bbox m = G.withGLFW mode bbox (execGame m)
 
@@ -62,13 +66,18 @@     texs <- newIORef IM.empty
     keyBuffer <- newIORef initialKeyBuffer
     mouseBuffer <- newIORef initialMouseBuffer
+    mouseIn <- newIORef True
+    scroll <- newIORef (V2 0 0)
     GLFW.setKeyCallback (G.theWindow sys) $ Just $ keyCallback keyBuffer
     GLFW.setMouseButtonCallback (G.theWindow sys) $ Just $ mouseButtonCallback mouseBuffer
-
+    GLFW.setCursorEnterCallback (G.theWindow sys) $ Just $ mouseEnterCallback mouseIn
+    GLFW.setScrollCallback (G.theWindow sys) $ Just $ \_ x y -> modifyIORef scroll (+V2 x y)
     execFinalizerT
         $ give (RefKeyStates keyBuffer)
         $ give (RefMouseButtonStates mouseBuffer)
+        $ give (RefMouseInWindow mouseIn)
         $ give (TextureStorage texs)
+        $ give scroll
         $ give sys
         $ gameLoop m
 
@@ -77,6 +86,8 @@     , Given TextureStorage
     , Given KeyStates
     , Given MouseButtonStates
+    , Given MouseInWindow
+    , Given (IORef (V2 Double))
     ) => IterT (F UI) a -> FinalizerT IO (Maybe a)
 gameLoop m = do
     liftIO $ G.beginFrame given
@@ -88,6 +99,7 @@     b <- liftIO $ do
         modifyIORef' (getKeyStates given) (Map.map buttonStay)
         modifyIORef' (getMouseButtonStates given) (Map.map buttonStay)
+        writeIORef given (V2 0 0 :: V2 Double)
         G.endFrame given
     liftIO (readIORef fs) >>= finalizer . sequence_
 
@@ -102,12 +114,16 @@ newtype KeyStates = RefKeyStates { getKeyStates :: IORef (Map.Map Key ButtonState) }
 newtype MouseButtonStates = RefMouseButtonStates { getMouseButtonStates :: IORef (Map.Map Int ButtonState) }
 
+newtype MouseInWindow = RefMouseInWindow { getMouseInWindow :: IORef Bool }
+
 runUI :: forall a.
     ( Given G.System
     , Given TextureStorage
     , Given KeyStates
     , Given MouseButtonStates
+    , Given MouseInWindow
     , Given (IORef [IO ()])
+    , Given (IORef (V2 Double))
     ) => UI (FinalizerT IO a) -> FinalizerT IO a
 runUI (Draw m) = do
     (cont, xs) <- liftIO $ do
@@ -118,20 +134,24 @@     unless (null xs) $ finalizer $ forM_ xs $ \(t, h) -> G.releaseTexture t >> modifyIORef' (getTextureStorage given) (IM.delete h)
     cont
 runUI (FromFinalizer m) = join m
-runUI (PreloadBitmap bmp cont) = do
-    t <- liftIO $ G.installTexture bmp
-    h <- liftIO $ addrImage bmp
-    liftIO $ modifyIORef' (getTextureStorage given) (IM.insert h t)
-    finalizer $ G.releaseTexture t >> modifyIORef' (getTextureStorage given) (IM.delete h)
+runUI (PreloadBitmap (Bitmap bmp h) cont) = do
+    m <- liftIO $ readIORef (getTextureStorage given)
+    case IM.lookup h m of
+        Just _ -> return ()
+        Nothing -> do
+            t <- liftIO $ G.installTexture bmp
+            liftIO $ writeIORef (getTextureStorage given) $ IM.insert h t m
+            finalizer $ G.releaseTexture t >> modifyIORef' (getTextureStorage given) (IM.delete h)
     cont
 runUI (KeyStates cont) = liftIO (readIORef $ getKeyStates given) >>= cont
 runUI (MouseButtons cont) = liftIO (readIORef $ getMouseButtonStates given) >>= cont
--- runUI _ _ (MouseWheel cont) = GLFW.getMouseWheel >>= cont
 runUI (MousePosition cont) = do
     (x, y) <- liftIO $ GLFW.getCursorPos (G.theWindow given)
     cont $ V2 x y
+runUI (MouseScroll cont) = liftIO (readIORef given) >>= cont
+runUI (MouseInWindow cont) = liftIO (readIORef $ getMouseInWindow given) >>= cont
 runUI (Bracket m) = join $ iterM runUI m
-runUI (TakeScreenshot cont) = liftIO (G.screenshot given) >>= cont
+runUI (TakeScreenshot cont) = liftIO (G.screenshot given >>= liftBitmapIO) >>= cont
 runUI (ClearColor col cont) = do
     liftIO $ GL.clearColor GL.$= unsafeCoerce col
     cont
@@ -159,7 +179,6 @@     liftIO $ writeIORef (G.refRegion given) bbox
     cont
 
-
 mapReaderWith :: (s -> r) -> (m a -> n b) -> ReaderT r m a -> ReaderT s n b
 mapReaderWith f g m = unsafeCoerce $ \s -> g (unsafeCoerce m (f s))
 {-# INLINE mapReaderWith #-}
@@ -177,9 +196,8 @@ newtype Context = Context { getContext :: IORef [(G.Texture, Int)] }
 
 instance (Given Context, Given TextureStorage) => Picture2D DrawM where
-    bitmap bmp = liftIO $ do
+    bitmap (Bitmap bmp h) = liftIO $ do
         m <- readIORef (getTextureStorage given)
-        h <- addrImage bmp
         case IM.lookup h m of
             Just t -> G.drawTexture t
             Nothing -> do
@@ -187,7 +205,7 @@                 writeIORef (getTextureStorage given) $ IM.insert h t m
                 modifyIORef (getContext given) ((t, h) :)
                 G.drawTexture t
-    bitmapOnce bmp = liftIO $ do
+    bitmapOnce (Bitmap bmp _) = liftIO $ do
         t <- G.installTexture bmp
         G.drawTexture t
         G.releaseTexture t

FreeGame/Class.hs view

@@ -8,18 +8,21 @@ -- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
 -- Stability   :  provisional
 -- Portability :  non-portable
--- 
+--
 ----------------------------------------------------------------------------
 module FreeGame.Class where
 
 import Linear
+#if !MIN_VERSION_base(4,8,0)
 import Control.Applicative
+#endif
 import Unsafe.Coerce
 import FreeGame.Types
 import FreeGame.Data.Bitmap
 import FreeGame.Internal.Finalizer
 import Data.Color
 import Control.Monad.IO.Class
+import Control.Bool
 import qualified Data.Map as Map
 
 infixr 5 `translate`
@@ -27,7 +30,6 @@ infixr 5 `rotateD`
 infixr 5 `scale`
 infixr 5 `color`
-infixr 5 `colored`
 infixr 5 `thickness`
 infixr 5 `blendMode`
 
@@ -54,17 +56,9 @@     circle :: Double -> p ()
     circleOutline :: Double -> p ()
     thickness :: Float -> p a -> p a
-    color :: Color -> p a -> p a
+    color :: Color Float -> p a -> p a
     blendMode :: BlendMode -> p a -> p a
 
-{-# DEPRECATED fromBitmap "Use bitmap instead" #-}
-fromBitmap :: Picture2D p => Bitmap -> p ()
-fromBitmap = bitmap
-
-{-# DEPRECATED colored "Use color instead" #-}
-colored :: Picture2D p => Color -> p a -> p a
-colored = color
-
 class Affine p => Local p where
     getLocation :: p (Location a)
 
@@ -151,10 +145,15 @@ class Functor f => Mouse f where
     globalMousePosition :: f Vec2
     mouseButtons_ :: f (Map.Map Int ButtonState)
+    mouseInWindow :: f Bool
+    mouseScroll :: f Vec2
 
 -- | Returns the relative coordinate of the cursor.
 mousePosition :: (Applicative f, Mouse f, Local f) => f Vec2
 mousePosition = (\v (Location _ g) -> g v) <$> globalMousePosition <*> getLocation
+
+mousePositionMay :: (Applicative f, Mouse f, Local f) => f (Maybe Vec2)
+mousePositionMay = guard' <$> mouseInWindow <*> mousePosition
 
 mouseButtons :: Mouse f => f (Map.Map Int Bool)
 mouseButtons = Map.map isPressed <$> mouseButtons_

FreeGame/Data/Bitmap.hs view

@@ -13,44 +13,61 @@ 
 module FreeGame.Data.Bitmap (
     -- * Basic types and functions
-    Bitmap
+    Bitmap(..)
     ,bitmapSize
-
+    ,liftBitmapIO
     -- * Load and Save
     ,readBitmap
     ,writeBitmap
-    ,loadBitmapFromFile
 
     -- * Bitmap operations
     ,cropBitmap
-    
+    ,clipBitmap
+    -- * V2
+    ,sizeBitmap
     ) where
 
 import qualified Codec.Picture as C
 import qualified Codec.Picture.RGBA8 as C
 import Control.Monad.IO.Class
+import Data.BoundingBox
+import Linear.V2
+import System.Random
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative
+#endif
+import Data.Hashable
 
-type Bitmap = C.Image C.PixelRGBA8
+data Bitmap = Bitmap { bitmapImage :: C.Image C.PixelRGBA8, bitmapHash :: Int }
 
 -- | Get the size of the 'Bitmap'.
 bitmapSize :: Bitmap -> (Int, Int)
-bitmapSize (C.Image w h _) = (w, h)
+bitmapSize (Bitmap (C.Image w h _) _) = (w, h)
 
+liftBitmapIO :: MonadIO m => C.Image C.PixelRGBA8 -> m Bitmap
+liftBitmapIO b = liftIO $ Bitmap b <$> randomIO
+
 -- | Load an image file.
 readBitmap :: MonadIO m => FilePath -> m Bitmap
-readBitmap path = liftIO (C.readImageRGBA8 path)
-
-{-# DEPRECATED loadBitmapFromFile "use readBitmap instead" #-}
-loadBitmapFromFile :: MonadIO m => FilePath -> m Bitmap
-loadBitmapFromFile = readBitmap
+readBitmap path = liftIO $ Bitmap <$> C.readImageRGBA8 path <*> randomIO
 
 -- | Save 'Bitmap' into a file.
 writeBitmap :: MonadIO m => FilePath -> Bitmap -> m ()
-writeBitmap path = liftIO . C.writePng path
+writeBitmap path (Bitmap p _) = liftIO $ C.writePng path p
 
 -- | Extract a 'Bitmap' from the specified range.
 cropBitmap :: Bitmap -- ^original bitmap
     -> (Int, Int) -- ^width and height
     -> (Int, Int) -- ^x and y
     -> Bitmap -- ^result
-cropBitmap = C.trimImage+cropBitmap (Bitmap b k) (w, h) (x, y) = Bitmap
+    (C.trimImage b (w, h) (x, y))
+    (hash (w, h, x, y, k))
+
+clipBitmap :: Bitmap -> Box V2 Int -> Bitmap
+clipBitmap (Bitmap b k) (Box (V2 x0 y0) (V2 x1 y1)) = Bitmap
+    (C.trimImage b (x1 - x0, y1 - y0) (x0, y0))
+    (hash (x0, y0, x1, y1, k))
+
+sizeBitmap :: Bitmap -> V2 Int
+sizeBitmap (Bitmap (C.Image w h _) _) = V2 w h

FreeGame/Data/Font.hs view

@@ -10,7 +10,7 @@ --
 -- Rendering characters
 ----------------------------------------------------------------------------
-module FreeGame.Data.Font 
+module FreeGame.Data.Font
   ( Font
   , loadFontFromFile
   , loadFont
@@ -21,7 +21,9 @@   , RenderedChar(..)
   ) where
 
+#if !MIN_VERSION_base(4,8,0)
 import Control.Applicative
+#endif
 import Control.Monad.IO.Class
 import Control.Monad
 import Data.IORef
@@ -119,7 +121,7 @@     let dpi = fromIntegral resolutionDPI
 
     runFreeType $ ft_Set_Char_Size face 0 (floor $ siz * 64) dpi dpi
-    
+
     ix <- ft_Get_Char_Index face (fromIntegral $ fromEnum ch)
     runFreeType $ ft_Load_Glyph face ix ft_LOAD_DEFAULT
 
@@ -132,12 +134,13 @@ 
     let h = fromIntegral $ B.rows bmp
         w = fromIntegral $ B.width bmp
-    
+
     fptr <- newForeignPtr_ $ castPtr $ buffer bmp
 
     adv <- peek $ GS.advance slot
-
+    b <- liftBitmapIO $ fromColorAndOpacity (PixelRGB8 255 255 255)
+        $ Image w h $ V.unsafeFromForeignPtr0 fptr $ h * w
     return $ RenderedChar
-        (fromColorAndOpacity (PixelRGB8 255 255 255) $ Image w h $ V.unsafeFromForeignPtr0 fptr $ h * w)
+        b
         (V2 (left + fromIntegral w / 2) (-top + fromIntegral h / 2))
         (fromIntegral (V.x adv) / 64)

FreeGame/Instances.hs view

@@ -9,7 +9,11 @@ import Control.Monad.Trans.Cont
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.List
+#if MIN_VERSION_transformers(0,4,0)
+import Control.Monad.Trans.Except
+#else
 import Control.Monad.Trans.Error
+#endif
 import Control.Monad.Trans.Identity
 import qualified Control.Monad.State.Lazy as Lazy
 import qualified Control.Monad.State.Strict as Strict
@@ -17,7 +21,9 @@ import qualified Control.Monad.Writer.Strict as Strict
 import qualified Control.Monad.Trans.RWS.Strict as Strict
 import qualified Control.Monad.Trans.RWS.Lazy as Lazy
+#if !MIN_VERSION_base(4,8,0)
 import Data.Monoid
+#endif
 import Control.Monad.Free.Church as Church
 import Control.Monad.Free as Free
 import FreeGame.Class
@@ -61,7 +67,9 @@ 
 #define MK_MOUSE(cxt, ty, l) instance (Mouse m cxt) => Mouse (ty) where { \
     globalMousePosition = (l) globalMousePosition; \
-    mouseButtons_ = (l) mouseButtons_;\
+    mouseButtons_ = (l) mouseButtons_; \
+    mouseInWindow = (l) mouseInWindow; \
+    mouseScroll = (l) mouseScroll; \
     }
 
 #define MK_FROM_FINALIZER(cxt, ty, l) instance (FromFinalizer m cxt) => FromFinalizer (ty) where { \
@@ -83,21 +91,25 @@     setBoundingBox b = (l) (setBoundingBox b); \
     }
 
-MK_AFFINE(_COMMA_ Functor m, F m, hoistF)
-MK_AFFINE(_COMMA_ Functor m, Free.Free m, Free.hoistFree)
+MK_AFFINE(, F m, hoistF)
+MK_AFFINE(, Free.Free m, Free.hoistFree)
 MK_AFFINE(_COMMA_ Monad m, IterT m, hoistIterT)
-MK_AFFINE(_COMMA_ Monad m, ReaderT r m, mapReaderT)
-MK_AFFINE(_COMMA_ Monad m, Lazy.StateT s m, Lazy.mapStateT)
-MK_AFFINE(_COMMA_ Monad m, Strict.StateT s m, Strict.mapStateT)
-MK_AFFINE(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, Lazy.mapWriterT)
-MK_AFFINE(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, Strict.mapWriterT)
-MK_AFFINE(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, Lazy.mapRWST)
-MK_AFFINE(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, Strict.mapRWST)
-MK_AFFINE(_COMMA_ Monad m, IdentityT m, mapIdentityT)
-MK_AFFINE(_COMMA_ Monad m, MaybeT m, mapMaybeT)
-MK_AFFINE(_COMMA_ Monad m, ListT m, mapListT)
-MK_AFFINE(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, mapErrorT)
-MK_AFFINE(_COMMA_ Monad m, ContT r m, mapContT)
+MK_AFFINE(, ReaderT r m, mapReaderT)
+MK_AFFINE(, Lazy.StateT s m, Lazy.mapStateT)
+MK_AFFINE(, Strict.StateT s m, Strict.mapStateT)
+MK_AFFINE(, Lazy.WriterT w m, Lazy.mapWriterT)
+MK_AFFINE(, Strict.WriterT w m, Strict.mapWriterT)
+MK_AFFINE(, Lazy.RWST r w s m, Lazy.mapRWST)
+MK_AFFINE(, Strict.RWST r w s m, Strict.mapRWST)
+MK_AFFINE(, IdentityT m, mapIdentityT)
+MK_AFFINE(, MaybeT m, mapMaybeT)
+MK_AFFINE(, ListT m, mapListT)
+#if MIN_VERSION_transformers(0,4,0)
+MK_AFFINE(, ExceptT e m, mapExceptT)
+#else
+MK_AFFINE(_COMMA_ Error e, ErrorT e m, mapErrorT)
+#endif
+MK_AFFINE(, ContT r m, mapContT)
 
 MK_PICTURE_2D(_COMMA_ Functor m, F m, Church.liftF, hoistF)
 MK_PICTURE_2D(_COMMA_ Functor m, Free.Free m, Free.liftF, Free.hoistFree)
@@ -112,7 +124,11 @@ MK_PICTURE_2D(_COMMA_ Monad m, IdentityT m, lift, mapIdentityT)
 MK_PICTURE_2D(_COMMA_ Monad m, MaybeT m, lift, mapMaybeT)
 MK_PICTURE_2D(_COMMA_ Monad m, ListT m, lift, mapListT)
+#if MIN_VERSION_transformers(0,4,0)
+MK_PICTURE_2D(_COMMA_ Monad m, ExceptT e m, lift, mapExceptT)
+#else
 MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift, mapErrorT)
+#endif
 MK_PICTURE_2D(_COMMA_ Monad m, ContT r m, lift, mapContT)
 
 MK_LOCAL(_COMMA_ Functor m, F m, Church.liftF)
@@ -128,7 +144,11 @@ MK_LOCAL(_COMMA_ Monad m, IdentityT m, lift)
 MK_LOCAL(_COMMA_ Monad m, MaybeT m, lift)
 MK_LOCAL(_COMMA_ Monad m, ListT m, lift)
+#if MIN_VERSION_transformers(0,4,0)
+MK_LOCAL(_COMMA_ Monad m, ExceptT e m, lift)
+#else
 MK_LOCAL(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift)
+#endif
 MK_LOCAL(_COMMA_ Monad m, ContT r m, lift)
 
 MK_KEYBOARD(_COMMA_ Functor m, F m, Church.liftF)
@@ -144,7 +164,11 @@ MK_KEYBOARD(_COMMA_ Monad m, IdentityT m, lift)
 MK_KEYBOARD(_COMMA_ Monad m, MaybeT m, lift)
 MK_KEYBOARD(_COMMA_ Monad m, ListT m, lift)
+#if MIN_VERSION_transformers(0,4,0)
+MK_KEYBOARD(_COMMA_ Monad m, ExceptT e m, lift)
+#else
 MK_KEYBOARD(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift)
+#endif
 MK_KEYBOARD(_COMMA_ Monad m, ContT r m, lift)
 
 MK_MOUSE(_COMMA_ Functor m, F m, liftF)
@@ -160,7 +184,11 @@ MK_MOUSE(_COMMA_ Monad m, IdentityT m, lift)
 MK_MOUSE(_COMMA_ Monad m, MaybeT m, lift)
 MK_MOUSE(_COMMA_ Monad m, ListT m, lift)
+#if MIN_VERSION_transformers(0,4,0)
+MK_MOUSE(_COMMA_ Monad m, ExceptT e m, lift)
+#else
 MK_MOUSE(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift)
+#endif
 MK_MOUSE(_COMMA_ Monad m, ContT r m, lift)
 
 MK_FROM_FINALIZER(_COMMA_ Functor m, F m, liftF)
@@ -175,7 +203,11 @@ MK_FROM_FINALIZER(_COMMA_ Monad m, IdentityT m, lift)
 MK_FROM_FINALIZER(_COMMA_ Monad m, MaybeT m, lift)
 MK_FROM_FINALIZER(_COMMA_ Monad m, ListT m, lift)
+#if MIN_VERSION_transformers(0,4,0)
+MK_FROM_FINALIZER(_COMMA_ Monad m, ExceptT e m, lift)
+#else
 MK_FROM_FINALIZER(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift)
+#endif
 MK_FROM_FINALIZER(_COMMA_ Monad m, ContT r m, lift)
 
 MK_FREE_GAME(_COMMA_ Functor m, F m, liftF)
@@ -190,5 +222,9 @@ MK_FREE_GAME(_COMMA_ Monad m, IdentityT m, lift)
 MK_FREE_GAME(_COMMA_ Monad m, MaybeT m, lift)
 MK_FREE_GAME(_COMMA_ Monad m, ListT m, lift)
+#if MIN_VERSION_transformers(0,4,0)
+MK_FREE_GAME(_COMMA_ Monad m, ExceptT e m, lift)
+#else
 MK_FREE_GAME(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift)
-MK_FREE_GAME(_COMMA_ Monad m, ContT r m, lift)+#endif
+MK_FREE_GAME(_COMMA_ Monad m, ContT r m, lift)

FreeGame/Internal/Finalizer.hs view

@@ -3,7 +3,9 @@ 
 import Control.Monad.IO.Class
 import Control.Monad.Trans
+#if !MIN_VERSION_base(4,8,0)
 import Control.Applicative
+#endif
 
 -- | An action with explicit releasing action.
 newtype FinalizerT m a = FinalizerT

FreeGame/Internal/GLFW.hs view

@@ -2,15 +2,17 @@ module FreeGame.Internal.GLFW where
 import Control.Concurrent
 import Control.Bool
+#if !MIN_VERSION_base(4,8,0)
 import Control.Applicative
+#endif
 import Control.Monad.IO.Class
 import Control.Lens
 import Data.Color
 import Data.IORef
 import FreeGame.Types
 import Data.BoundingBox
-import Graphics.Rendering.OpenGL.GL.StateVar
-import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility
+import Data.StateVar
+import Graphics.GL.Compatibility30
 import Linear
 import qualified Graphics.Rendering.OpenGL.GL as GL
 import qualified Graphics.UI.GLFW as GLFW
@@ -20,16 +22,26 @@ import Codec.Picture
 import Codec.Picture.RGBA8
 import qualified GHC.IO.Encoding as Encoding
-
+import qualified Data.Sequence as S
+import qualified Data.Foldable as F
 data System = System
     { refFrameCounter :: IORef Int
-    , refFPS :: IORef Int
-    , theFPS :: IORef Int
+    , theFPS :: IORef Double
+    , frameTimes :: IORef (S.Seq Double)
     , currentFPS :: IORef Int
+    , startTime :: IORef Double
     , refRegion :: IORef BoundingBox2
     , theWindow :: GLFW.Window
     }
 
+trim1 :: S.Seq Double -> S.Seq Double
+trim1 s0 = go zs s0 (sum zs) where
+    go (x:xs) s a
+        | a < 1 = s
+        | otherwise = go xs (S.drop 1 s) (a - x)
+    go [] s _ = s
+    zs = F.toList s0
+
 type Texture = (GL.TextureObject, Double, Double)
 
 runVertices :: MonadIO m => [V2 Double] -> m ()
@@ -99,7 +111,7 @@     let s = 2 * pi / 64
     GL.renderPrimitive GL.LineLoop $ runVertices [V2 (cos t * r) (sin t * r) | t <- [0,s..2 * pi]]
 
-color :: Color -> IO a -> IO a
+color :: Color Float -> IO a -> IO a
 color col m = do
     oldColor <- liftIO $ get GL.currentColor
     liftIO $ GL.currentColor $= unsafeCoerce col
@@ -146,6 +158,8 @@     GL.ortho wl wr wb wt 0 (-100)
     GL.matrixMode $= GL.Modelview 0
     GL.clear [GL.ColorBuffer]
+    Just t <- GLFW.getTime
+    writeIORef (startTime sys) t
 
 endFrame :: System -> IO Bool
 endFrame sys = do
@@ -154,10 +168,14 @@     Just t <- GLFW.getTime
     n <- readIORef (refFrameCounter sys)
     fps <- readIORef (theFPS sys)
-    threadDelay $ max 0 $ floor $ (1000000 *) $ fromIntegral n / fromIntegral fps - t
-    if t > 1
-        then GLFW.setTime 0 >> writeIORef (currentFPS sys) n >> writeIORef (refFrameCounter sys) 0
-        else writeIORef (refFrameCounter sys) (succ n)
+    threadDelay $ max 0 $ floor $ (1000000 *) $ fromIntegral n / fps - t
+    writeIORef (refFrameCounter sys) (succ n)
+    t0 <- readIORef (startTime sys)
+    fs <- readIORef (frameTimes sys)
+    Just t1 <- GLFW.getTime
+    let !fs' = trim1 $ fs S.|> (t1 - t0)
+    writeIORef (currentFPS sys) (S.length fs')
+    writeIORef (frameTimes sys) fs'
     GLFW.windowShouldClose (theWindow sys)
 
 withGLFW :: WindowMode -> BoundingBox2 -> (System -> IO a) -> IO a
@@ -191,9 +209,10 @@ 
     sys <- System
         <$> newIORef 0
-        <*> newIORef 0
         <*> newIORef 60
+        <*> newIORef S.empty
         <*> newIORef 60
+        <*> newIORef 0
         <*> pure rbox
         <*> pure win
 
@@ -230,4 +249,4 @@     GL.blendFunc $= blendMode2BlendingFactors mode
     a <- m
     GL.blendFunc $= oldFunc
-    return a+    return a

FreeGame/UI.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, ExistentialQuantification, Rank2Types #-}
+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, Rank2Types, UndecidableInstances #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  FreeGame.UI
@@ -12,6 +12,7 @@ ----------------------------------------------------------------------------
 module FreeGame.UI (
     UI(..)
+    , Drawable
     , reUI
     , reFrame
     , reGame
@@ -23,29 +24,36 @@ import FreeGame.Class
 import FreeGame.Internal.Finalizer
 import FreeGame.Types
+#if !MIN_VERSION_base(4,8,0)
 import Control.Applicative
+#endif
 import qualified Data.Map as Map
 import FreeGame.Data.Bitmap (Bitmap)
 import Data.Color
-import Data.BoundingBox
 import Control.Monad.Free.Church (F, iterM)
 import Control.Monad.Trans.Iter (IterT, foldM)
 import Control.Monad (join)
 
+class (Applicative f, Monad f, Picture2D f, Local f) => Drawable f where { }
+
+instance (Applicative f, Monad f, Picture2D f, Local f) => Drawable f where { }
+
 data UI a =
-    Draw (forall m. (Applicative m, Monad m, Picture2D m, Local m) => m a)
+    Draw (forall m. Drawable m => m a)
     | PreloadBitmap Bitmap a
     | FromFinalizer (FinalizerT IO a)
     | KeyStates (Map.Map Key ButtonState -> a)
     | MouseButtons (Map.Map Int ButtonState -> a)
     | MousePosition (Vec2 -> a)
+    | MouseInWindow (Bool -> a)
+    | MouseScroll (Vec2 -> a)
     | TakeScreenshot (Bitmap -> a)
     | Bracket (Frame a)
-    | SetFPS Int a
+    | SetFPS Double a
     | SetTitle String a
     | ShowCursor a
     | HideCursor a
-    | ClearColor Color a
+    | ClearColor (Color Float) a
     | GetFPS (Int -> a)
     | ForkFrame (Frame ()) a
     | GetBoundingBox (BoundingBox2 -> a)
@@ -60,11 +68,13 @@ reGame :: (FreeGame m, Monad m) => Game a -> m a
 reGame = Control.Monad.Trans.Iter.foldM (join . reFrame)
 {-# RULES "reGame/sameness" reGame = id #-}
+{-# INLINE[1] reGame #-}
 
 -- | Generalize `Frame` to any monad based on `FreeGame`.
 reFrame :: (FreeGame m, Monad m) => Frame a -> m a
 reFrame = iterM (join . reUI)
 {-# RULES "reFrame/sameness" reFrame = id #-}
+{-# INLINE[1] reFrame #-}
 
 reUI :: FreeGame f => UI a -> f a
 reUI (Draw m) = draw m
@@ -73,6 +83,8 @@ reUI (KeyStates cont) = cont <$> keyStates_
 reUI (MouseButtons cont) = cont <$> mouseButtons_
 reUI (MousePosition cont) = cont <$> globalMousePosition
+reUI (MouseInWindow cont) = cont <$> mouseInWindow
+reUI (MouseScroll cont) = cont <$> mouseScroll
 reUI (TakeScreenshot cont) = cont <$> takeScreenshot
 reUI (Bracket m) = bracket m
 reUI (SetFPS i cont) = cont <$ setFPS i
@@ -84,12 +96,12 @@ reUI (ForkFrame m cont) = cont <$ forkFrame m
 reUI (GetBoundingBox cont) = cont <$> getBoundingBox
 reUI (SetBoundingBox bb cont) = cont <$ setBoundingBox bb
-
+{-# INLINE[1] reUI #-}
 {-# RULES "reUI/sameness" reUI = id #-}
 
 class (Picture2D m, Local m, Keyboard m, Mouse m, FromFinalizer m) => FreeGame m where
     -- | Draw an action that consist of 'Picture2D''s methods.
-    draw :: (forall f. (Applicative f, Monad f, Picture2D f, Local f) => f a) -> m a
+    draw :: (forall f. Drawable f => f a) -> m a
     -- | Load a 'Bitmap' to avoid the cost of the first invocation of 'bitmap'.
     preloadBitmap :: Bitmap -> m ()
     -- | Run a 'Frame', and release all the matter happened.
@@ -99,22 +111,22 @@     -- | Generate a 'Bitmap' from the front buffer.
     takeScreenshot :: m Bitmap
     -- | Set the goal FPS.
-    setFPS :: Int -> m ()
+    setFPS :: Double -> m ()
     setTitle :: String -> m ()
     showCursor :: m ()
     hideCursor :: m ()
-    clearColor :: Color -> m ()
+    clearColor :: Color Float -> m ()
     -- | Get the actual FPS value.
     getFPS :: m Int
     getBoundingBox :: m BoundingBox2
     setBoundingBox :: BoundingBox2 -> m ()
-    
+
 instance FreeGame UI where
     draw = Draw
     {-# INLINE draw #-}
     preloadBitmap bmp = PreloadBitmap bmp ()
     {-# INLINE preloadBitmap #-}
-    
+
     bracket = Bracket
     {-# INLINE bracket #-}
     forkFrame m = ForkFrame m ()
@@ -128,7 +140,7 @@     getBoundingBox = GetBoundingBox id
     setBoundingBox s = SetBoundingBox s ()
 
-overDraw :: (forall m. (Applicative m, Monad m, Picture2D m, Local m) => m a -> m a) -> UI a -> UI a
+overDraw :: (forall m. Drawable m => m a -> m a) -> UI a -> UI a
 overDraw f (Draw m) = Draw (f m)
 overDraw _ x = x
 {-# INLINE overDraw #-}
@@ -173,4 +185,6 @@ instance Mouse UI where
     globalMousePosition = MousePosition id
     -- mouseWheel = MouseWheel id
-    mouseButtons_ = MouseButtons id+    mouseButtons_ = MouseButtons id
+    mouseInWindow = MouseInWindow id
+    mouseScroll = MouseScroll id

FreeGame/Util.hs view

@@ -35,7 +35,9 @@     keySpecial
     ) where
 
+#if !MIN_VERSION_base(4,8,0)
 import Control.Applicative
+#endif
 import Control.Monad
 import Control.Monad.Free.Class
 import Control.Monad.Trans.Iter
@@ -62,7 +64,6 @@ -- | An infinite loop that run 'tick' every frame after the given action.
 foreverTick :: (Monad f, MonadFree f m) => m a -> m any
 foreverTick m = let m' = foreverTick m in m >> wrap (return m')
-{-# WARNING foreverTick "In most cases, foreverFrame is good enough and fast." #-}
 
 -- | @foreverFrame :: Frame a -> Game any@
 foreverFrame :: (Monad f, Monad m, MonadTrans t, MonadFree f (t m)) => m a -> t m any
@@ -109,7 +110,7 @@ loadBitmapsWith getFullPath path = do
     loc <- (</>path) <$> takeDirectory <$> loc_filename <$> location
     paths <- runIO $ getFileList loc
-    
+
     sequence $ do
         p <- paths
         let name = pathToName p
@@ -188,4 +189,4 @@ 
 {-# DEPRECATED keySpecial "use keyPress instead" #-}
 keySpecial :: Keyboard f => Key -> f Bool
-keySpecial = keyPress+keySpecial = keyPress

examples/demo.hs view

@@ -40,15 +40,15 @@ bitmapTest :: Bitmap -> Frame ()
 bitmapTest bmp = blendMode Add $ do
     
-    color (Color 1 0 0 1) $ do
+    color (fromRGB 1 0 0) $ do
         translate (V2 300 346) $ bitmap bmp -- 'bitmap' creates an action from the bitmap.
-    color (Color 0 1 0 1) $ do
+    color (fromRGB 0 1 0) $ do
         translate (V2 310 350) $ bitmap bmp -- 'bitmap' creates an action from the bitmap.
-    color (Color 0 0 1 1) $ do
+    color (fromRGB 0 0 1) $ do
         translate (V2 293 359) $ bitmap bmp -- 'bitmap' creates an action from the bitmap.
     
-mouseTest :: Frame ()
-mouseTest = do
+mouseTest :: Font -> Frame ()
+mouseTest font = whenM mouseInWindow $ do
     p <- mousePosition
     l <- mouseButtonL
     r <- mouseButtonR
@@ -58,8 +58,11 @@             (False, True) -> blue
             (True, True) -> blend 0.5 red blue
     translate p $ color col $ thickness 4 $ circleOutline 16
+    translate p $ color white $ do
+        r <- mouseScroll
+        text font 48 $ show r
 
-main = runGame Windowed (BoundingBox 0 0 640 480) $ do
+main = runGame Windowed (Box (V2 0 0) (V2 640 480)) $ do
     bmp <- readBitmap "bird.png"
     bmp' <- readBitmap "logo.png"
     font <- loadFont "VL-PGothic-Regular.ttf"
@@ -74,7 +77,7 @@ 
         fontTest font
         translate (V2 240 240) $ do
-            mouseTest
+            mouseTest font
 
             fps <- getFPS

+ examples/demo_stateful.hs view

@@ -0,0 +1,23 @@+import FreeGame
+
+data StateData = StateData { _counter :: Int
+                           , _font :: Font
+                           }
+    
+loop :: StateData -> Game ()
+loop state = do
+    let fnt = _font state
+        cnt = 1 + _counter state
+        state' = state{_counter = cnt}
+
+    translate (V2 100 240) . color green . text fnt 15 $ show cnt
+    translate (V2 340 240) . rotateD (fromIntegral cnt) . color red $ text fnt 70 "Test"
+
+    key <- keyPress KeyEscape
+    unless key $ tick >> loop state'
+
+main = runGame Windowed (Box (V2 0 0) (V2 640 480)) $ do
+    font <- loadFont "VL-PGothic-Regular.ttf"
+    clearColor black
+    let state = StateData{_counter=0, _font=font}
+    loop state

+ examples/fib.hs view

@@ -0,0 +1,75 @@+{-# LANGUAGE TemplateHaskell #-}
+import FreeGame
+import Control.Lens
+import Control.Monad.State
+import Control.Monad.Trans.Maybe
+
+data Mode = Scroll Double | Dist Double
+
+data World = World
+    { _seq0 :: [Int]
+    , _seq1 :: [Int]
+    , _offset :: Vec2
+    , _target :: Int
+    , _mode :: Mode
+    -- visual
+    , _font :: Font
+    }
+makeLenses ''World
+
+fibs = 1 : 1 : zipWith (+) fibs (tail fibs)
+
+speed = 1
+
+update :: StateT World Game ()
+update = do
+    s0 <- use seq0
+    s1 <- use seq1
+    ofs <- use offset
+    t <- use target
+    font <- use font
+    
+    let v = s0 !! t + s1 !! t
+    color black $ do
+      translate (V2 24 240) $ text font 24 "fibs"
+      translate (V2 24 280) $ text font 24 "tail fibs"
+      forM_ (zip [0..] s0) $ \(i, v) -> translate (ofs + V2 (i * 36) 240) $ text font 24 (show v)
+      forM_ (zip [0..] s1) $ \(i, v) -> translate (ofs + V2 (i * 36) 280) $ text font 24 (show v)
+    color blue $ line [V2 400 480, V2 400 0]
+    ph <- use mode
+    case ph of
+      Scroll ph
+        | ph > 0 -> do
+          mode .= Scroll (ph - 1)
+          
+          color black $ translate (V2 390 320) $ text font 24 (show v)
+          offset .= ofs - V2 speed 0
+        | otherwise -> mode .= Dist 0
+      Dist ph
+        | ph >= 1 -> do
+          seq0 .= s0 ++ [v]
+          seq1 .= s1 ++ [v]
+          mode .= Scroll 36
+          target += 1
+        | otherwise -> color black $ do
+          translate (p0 ^* (1 - ph) + V2 (390+36) 240 ^* ph) $ text font 24 (show v)
+          translate (p0 ^* (1 - ph) + V2 (390) 280 ^* ph) $ text font 24 (show v)
+          mode .= Dist (ph + 1/30)
+    color red $ translate (V2 24 120) $ text font 24 "Press ESC to exit"
+  where
+    p0 = V2 390 320
+
+mainLoop :: World -> Game ()
+mainLoop s = do
+  s' <- execStateT update s
+  tick
+  unlessM (keyDown KeyEscape) $ mainLoop s'
+
+main = runGameDefault $ do
+    font <- loadFont "VL-PGothic-Regular.ttf"
+    runMaybeT $ forever $ do
+      color red $ translate (V2 24 240) $ text font 24 "Press SPACE to start"
+      tick
+      () <- whenM (keyDown KeySpace) mzero
+      return ()
+    mainLoop $ World [1,1] [1] (V2 400 0) 0 (Scroll 36) font

examples/helloworld.hs view

@@ -1,6 +1,6 @@ import FreeGame
 
-main = runGame Windowed (BoundingBox 0 0 640 480) $ do
+main = runGame Windowed (Box (V2 0 0) (V2 640 480)) $ do
     hideCursor
     font <- loadFont "VL-PGothic-Regular.ttf"
     foreverFrame $ translate (V2 80 200) $ color black $ text font 40 "Hello, World"

free-game.cabal view

@@ -1,11 +1,9 @@ name:                free-game
-version:             1.1
+version:             1.1.9
 synopsis:            Create games for free
 description:
     free-game defines a monad that integrates features to create 2D games.
     .
-    A simple playback and effectors will be supported in future versions.
-    .
     Twitter: #hs_free_game
 
 homepage:            https://github.com/fumieval/free-game
@@ -48,11 +46,11 @@     FreeGame.Util
 
   ghc-options: -Wall -fexcess-precision -O2
-  default-extensions: FlexibleContexts, FlexibleInstances
+  default-extensions: FlexibleContexts, FlexibleInstances, CPP
   build-depends:
     array >= 0.4,
     base == 4.*,
-    colors == 0.1.*,
+    colors == 0.3.*,
     containers >= 0.4,
     control-bool,
     directory >= 1.0,
@@ -62,16 +60,17 @@     GLFW-b >= 1.3 && <2,
     hashable >= 1.2,
     JuicyPixels,
-    JuicyPixels-util == 0.1.*,
+    JuicyPixels-util >=0.1.1 && < 0.3,
     linear >= 1.0 && < 2,
-    mtl >= 2.1,
-    OpenGL == 2.9.*,
-    OpenGLRaw == 1.4.*,
+    mtl >= 2.2 && <4,
+    OpenGL >= 3 && <4,
+    OpenGLRaw,
     random == 1.*,
-    reflection == 1.*,
+    reflection,
+    StateVar,
     template-haskell,
     transformers >= 0.3,
     vector >= 0.9 && <0.12,
     void >= 0.5,
     boundingboxes >= 0.2 && < 0.4,
-    lens >= 3.8 && < 5+    lens >= 3.8 && < 5