packages feed

free-game 1.0.3 → 1.0.4

raw patch · 11 files changed

+68/−109 lines, 11 filesdep +boundingboxesdep +lensdep ~freedep ~linear

Dependencies added: boundingboxes, lens

Dependency ranges changed: free, linear

Files

FreeGame.hs view
@@ -16,6 +16,8 @@     runGameDefault,
     WindowMode(..),
     BoundingBox(..),
+    inBoundingBox,
+    _Corners,
     delay,
     tick,
     foreverFrame,
@@ -104,7 +106,8 @@ import Control.Bool
 import Data.Color
 import Data.Color.Names
-import Linear hiding (rotate)
+import Linear
+import Data.BoundingBox.Dim2 (BoundingBox(..), inBoundingBox, _Corners)
 import Control.Monad.Trans.Iter
 
 -- | 'Game' is a kind of procedure but you can also use it like a value.
FreeGame/Backend/GLFW.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Rank2Types, BangPatterns #-}
+{-# LANGUAGE Rank2Types, BangPatterns, ViewPatterns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 -----------------------------------------------------------------------------
@@ -19,6 +19,7 @@ import Control.Monad.Reader
 import Data.IORef
 import Data.Reflection
+import Data.BoundingBox.Dim2
 import FreeGame.Class
 import FreeGame.Internal.Finalizer
 import FreeGame.UI
@@ -32,6 +33,7 @@ import Unsafe.Coerce
 import Codec.Picture.RGBA8
 import Control.Concurrent
+import Control.Lens (view)
 
 keyCallback :: IORef (Map.Map Key ButtonState) -> GLFW.Window -> GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys -> IO ()
 keyCallback keyBuffer _ key _ GLFW.KeyState'Pressed _ = modifyIORef' keyBuffer $ Map.adjust buttonDown (toEnum $ fromEnum key)
@@ -147,6 +149,12 @@         (_, f) <- runFinalizerT $ iterM runUI m
         modifyIORef' given (f:)
     cont
+runUI (GetBoundingBox cont) = liftIO (readIORef (G.refRegion given)) >>= cont
+runUI (SetBoundingBox bbox@(view (size C)-> V2 w h) cont) = do
+    liftIO $ GLFW.setWindowSize (G.theWindow given) (floor w) (floor h)
+    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))
FreeGame/Class.hs view
@@ -28,6 +28,8 @@ infixr 5 `scale`
 infixr 5 `color`
 infixr 5 `colored`
+infixr 5 `thickness`
+infixr 5 `blendMode`
 
 class Functor p => Affine p where
     -- | (radians)
FreeGame/Data/Font.hs view
@@ -28,7 +28,7 @@ import qualified Data.Map as M
 import qualified Data.Vector.Storable as V
 import Linear
-import FreeGame.Types
+import Data.BoundingBox.Dim2
 import FreeGame.Class
 import FreeGame.Data.Bitmap
 import FreeGame.Internal.Finalizer
FreeGame/Instances.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE Rank2Types, ImpredicativeTypes #-}
 {-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module FreeGame.Instances () where
@@ -79,11 +79,9 @@     hideCursor = (l) hideCursor; \
     clearColor c = (l) (clearColor c); \
     getFPS = (l) getFPS; \
+    getBoundingBox = (l) getBoundingBox; \
+    setBoundingBox b = (l) (setBoundingBox b); \
     }
-
-hoistF :: (Functor f, Functor g) => (forall x. f x -> g x) -> Church.F f a -> Church.F g a
-hoistF t = Church.iterM (wrap . t)
-{-# INLINE hoistF #-}
 
 MK_AFFINE(_COMMA_ Functor m, F m, hoistF)
 MK_AFFINE(_COMMA_ Functor m, Free.Free m, Free.hoistFree)
FreeGame/Internal/GLFW.hs view
@@ -7,6 +7,7 @@ import Data.Color
 import Data.IORef
 import FreeGame.Types
+import Data.BoundingBox.Dim2
 import Graphics.Rendering.OpenGL.GL.StateVar
 import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility
 import Linear
@@ -23,7 +24,7 @@     , refFPS :: IORef Int
     , theFPS :: IORef Int
     , currentFPS :: IORef Int
-    , theRegion :: BoundingBox Double
+    , refRegion :: IORef (BoundingBox Double)
     , theWindow :: GLFW.Window
     }
 
@@ -136,9 +137,10 @@ 
 beginFrame :: System -> IO ()
 beginFrame sys = do
+    BoundingBox wl wt wr wb <- fmap realToFrac <$> readIORef (refRegion sys)
+    GL.viewport $= (GL.Position 0 0, GL.Size (floor $ wr - wl) (floor $ wb - wt))
     GL.matrixMode $= GL.Projection
     GL.loadIdentity
-    let BoundingBox wl wt wr wb = fmap realToFrac (theRegion sys)
     GL.ortho wl wr wb wt 0 (-100)
     GL.matrixMode $= GL.Modelview 0
     GL.clear [GL.ColorBuffer]
@@ -157,18 +159,18 @@     GLFW.windowShouldClose (theWindow sys)
 
 withGLFW :: WindowMode -> BoundingBox Double -> (System -> IO a) -> IO a
-withGLFW full bbox@(BoundingBox x0 y0 x1 y1) m = do
+withGLFW mode bbox@(BoundingBox x0 y0 x1 y1) m = do
     let title = "free-game"
         ww = floor $ x1 - x0
         wh = floor $ y1 - y0
     () <- unlessM GLFW.init (fail "Failed to initialize")
 
-    mon <- case full of
+    mon <- case mode of
         FullScreen -> GLFW.getPrimaryMonitor
-        Windowed -> return Nothing
+        _ -> return Nothing
 
-    GLFW.windowHint (GLFW.WindowHint'Resizable False)
-    Just win <- GLFW.createWindow ww wh title mon Nothing
+    GLFW.windowHint $ GLFW.WindowHint'Resizable $ mode == Resizable
+    win <- GLFW.createWindow ww wh title mon Nothing >>= maybe (fail "Failed to create a window") return
     GLFW.makeContextCurrent (Just win)
     GL.lineSmooth $= GL.Enabled
     GL.blend      $= GL.Enabled
@@ -179,12 +181,18 @@     GLFW.swapInterval 1
     GL.clearColor $= GL.Color4 1 1 1 1
 
+    rbox <- newIORef bbox
+
+    GLFW.setFramebufferSizeCallback win $ Just $ \_ w h -> do
+        BoundingBox x y _ _ <- readIORef rbox
+        writeIORef rbox $ BoundingBox x y (x + fromIntegral w) (y + fromIntegral h)
+
     sys <- System
         <$> newIORef 0
         <*> newIORef 0
         <*> newIORef 60
         <*> newIORef 60
-        <*> pure bbox
+        <*> pure rbox
         <*> pure win
 
     res <- m sys
@@ -195,8 +203,8 @@ 
 screenshotFlipped :: System -> IO (Image PixelRGBA8)
 screenshotFlipped sys = do
-    let BoundingBox x0 y0 x1 y1 = theRegion sys
-        w = floor $ x1 - x0
+    BoundingBox x0 y0 x1 y1 <- readIORef (refRegion sys)
+    let w = floor $ x1 - x0
         h = floor $ y1 - y0
     
     mv <- MV.unsafeNew (w * h * 4)
− FreeGame/Internal/Raindrop.hs 
@@ -1,32 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  FreeGame.Internal.Raindrop--- Copyright   :  (C) 2013 Fumiaki Kinoshita--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ A portable implementation of lens(<http://hackage.haskell.org/package/lens>)------------------------------------------------------------------------------module FreeGame.Internal.Raindrop (view, over) where--import Data.Functor.Identity-import Control.Monad.Reader-import Control.Applicative-import Unsafe.Coerce--(#.) :: (b -> c) -> (a -> b) -> (a -> c)-(#.) _ = unsafeCoerce-{-# INLINE (#.) #-}---- | @'view' :: 'MonadReader' s m => Getting a s a -> m a@-view :: MonadReader s m => ((a -> Const a b) -> (s -> Const a t)) -> m a-view f = asks (getConst #. f Const)-{-# INLINE view #-}---- | @'over' :: ASetter s t a b -> (a -> b) -> s -> t@-over :: ((a -> Identity b) -> (s -> Identity t)) -> (a -> b) -> s -> t-over l f = runIdentity #. l (Identity #. f)-{-# INLINE over #-}
FreeGame/Text.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveFunctor #-}
 module FreeGame.Text (TextF(..), TextT, runTextT, runTextT_, text) where
 
+import Control.Lens
 import Data.String
-import FreeGame.Types
-import FreeGame.Internal.Raindrop
+import Data.BoundingBox.Dim2
 import FreeGame.Data.Font
 import FreeGame.Class
 import FreeGame.Instances ()
@@ -20,14 +20,15 @@ 
 -- | Render a 'TextT'.
 runTextT :: (FromFinalizer m, Monad m, Picture2D m) => Maybe (BoundingBox Double) -> Font -> Double -> TextT m a -> m a
-runTextT bbox font size = flip evalStateT (V2 x0 y0) . go where
+runTextT bbox font siz = flip evalStateT (V2 x0 y0) . go where
     go m = lift (runFreeT m) >>= \r -> case r of
         Pure a -> return a
         Free (TypeChar '\n' cont) -> do
-            modify $ over _x (const x0) . over _y (+advV)
+            _x .= x0
+            _y += advV
             go cont
         Free (TypeChar ch cont) -> do
-            RenderedChar bmp offset adv <- fromFinalizer $ charToBitmap font size ch
+            RenderedChar bmp offset adv <- fromFinalizer $ charToBitmap font siz ch
             pen <- get
             translate (pen + offset) $ bitmap bmp
             let pen' = over _x (+adv) pen
@@ -35,8 +36,8 @@                 then pen'
                 else V2 x0 (view _y pen + advV)
             go cont
-    advV = size * (metricsAscent font - metricsDescent font) * 1.1
-    (V2 x0 y0, cond) = maybe (zero, const True) (\b -> (view _TopLeft b, flip inBoundingBox b)) bbox
+    advV = siz * (metricsAscent font - metricsDescent font) * 1.1
+    (V2 x0 y0, cond) = maybe (zero, const True) (\b -> (b ^. position TL, flip inBoundingBox b)) bbox
 
 runTextT_ :: (FromFinalizer m, Monad m, Picture2D m) => Maybe (BoundingBox Double) -> Font -> Double -> TextT m () -> m ()
 runTextT_ = runTextT
@@ -44,4 +45,4 @@ 
 -- | Render a 'String'.
 text :: (FromFinalizer m, Monad m, Picture2D m) => Font -> Double -> String -> m ()
-text font size str = runTextT Nothing font size (fromString str)+text font siz str = runTextT Nothing font siz (fromString str)
FreeGame/Types.hs view
@@ -11,56 +11,18 @@ --
 ----------------------------------------------------------------------------
 module FreeGame.Types (
-    WindowMode(..),
-    Vec2,
-    BoundingBox(..),
-    inBoundingBox,
-    _Corners, 
-    _TopLeft,
-    _TopRight,
-    _BottomLeft,
-    _BottomRight
+    WindowMode(..)
+    , Vec2
     , Key(..)
     , BlendMode(..)
     ) where
 
 import Linear.V2
-import Control.Applicative
-import Data.Foldable
-import Data.Traversable
 import Data.Typeable
 
-data WindowMode = Windowed | FullScreen
-
--- | 2D bounding box
-data BoundingBox a = BoundingBox a a a a deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Read, Typeable)
+data WindowMode = Windowed | Resizable | FullScreen deriving (Show, Eq, Ord, Read)
 
 type Vec2 = V2 Double
-
--- | Determine whether the given point is in the 'BoundingBox'.
-inBoundingBox :: Ord a => V2 a -> BoundingBox a -> Bool
-inBoundingBox (V2 x y) (BoundingBox x0 y0 x1 y1) = x0 <= x && x <= x1 && y0 <= y && y <= y1
-
--- | @'_Corners' :: Traversal' ('BoundingBox' a) ('V2' a)@
-_Corners :: Applicative f => (V2 a -> f (V2 a)) -> (BoundingBox a -> f (BoundingBox a))
-_Corners f (BoundingBox x0 y0 x1 y1) = go <$> f (V2 x0 y0) <*> f (V2 x1 y0) <*> f (V2 x1 y1) <*> f (V2 x0 y1) where
-    go (V2 x0' _) (V2 _ y1') (V2 x2' _) (V2 _ y3') = BoundingBox x0' y1' x2' y3'
-
--- | @'_TopLeft' :: Lens' ('BoundingBox' a) ('V2' a)@
-_TopLeft :: Functor f => (V2 a -> f (V2 a)) -> (BoundingBox a -> f (BoundingBox a))
-_TopLeft f (BoundingBox x0 y0 x1 y1) = fmap (\(V2 x0' y0') -> BoundingBox x0' y0' x1 y1) (f (V2 x0 y0))
-
--- | @'_TopRight' :: Lens' ('BoundingBox' a) ('V2' a)@
-_TopRight :: Functor f => (V2 a -> f (V2 a)) -> (BoundingBox a -> f (BoundingBox a))
-_TopRight f (BoundingBox x0 y0 x1 y1) = fmap (\(V2 x1' y0') -> BoundingBox x0 y0' x1' y1) (f (V2 x1 y0))
-
--- | @'_BottomLeft' :: Lens' ('BoundingBox' a) ('V2' a)@
-_BottomLeft :: Functor f => (V2 a -> f (V2 a)) -> (BoundingBox a -> f (BoundingBox a))
-_BottomLeft f (BoundingBox x0 y0 x1 y1) = fmap (\(V2 x0' y1') -> BoundingBox x0' y0 x1 y1') (f (V2 x0 y1))
-
--- | @'_BottomRight' :: Lens' ('BoundingBox' a) ('V2' a)@
-_BottomRight :: Functor f => (V2 a -> f (V2 a)) -> (BoundingBox a -> f (BoundingBox a))
-_BottomRight f (BoundingBox x0 y0 x1 y1) = fmap (\(V2 x1' y1') -> BoundingBox x0 y0 x1' y1') (f (V2 x1 y1))
 
 data Key =
       KeyUnknown
FreeGame/UI.hs view
@@ -25,6 +25,7 @@ import qualified Data.Map as Map
 import FreeGame.Data.Bitmap (Bitmap)
 import Data.Color
+import Data.BoundingBox.Dim2
 import Control.Monad.Free.Church
 import Control.Monad.Trans.Iter
 
@@ -44,6 +45,8 @@     | ClearColor Color a
     | GetFPS (Int -> a)
     | ForkFrame (Frame ()) a
+    | GetBoundingBox (BoundingBox Double -> a)
+    | SetBoundingBox (BoundingBox Double) a
     deriving Functor
 
 type Game = IterT Frame
@@ -66,17 +69,19 @@ reUI (ClearColor col cont) = cont <$ clearColor col
 reUI (GetFPS cont) = cont <$> getFPS
 reUI (ForkFrame m cont) = cont <$ forkFrame m
+reUI (GetBoundingBox cont) = cont <$> getBoundingBox
+reUI (SetBoundingBox bb cont) = cont <$ setBoundingBox bb
 
-{-# RULES "reUI/Frame" reUI = id #-}
+{-# 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. (Applicative f, Monad f, Picture2D f, Local 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.
     bracket :: Frame a -> m a
-    -- | Run a 'Frame' action concurrently. Please do not use this function to draw pictures.
+    -- | Run a 'Frame' action concurrently. Do not use this function to draw pictures.
     forkFrame :: Frame () -> m ()
     -- | Generate a 'Bitmap' from the front buffer.
     takeScreenshot :: m Bitmap
@@ -86,6 +91,8 @@     hideCursor :: m ()
     clearColor :: Color -> m ()
     getFPS :: m Int
+    getBoundingBox :: m (BoundingBox Double)
+    setBoundingBox :: BoundingBox Double -> m ()
     
 instance FreeGame UI where
     draw = Draw
@@ -103,7 +110,8 @@     hideCursor = HideCursor ()
     clearColor c = ClearColor c ()
     getFPS = GetFPS id
-    
+    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 f (Draw m) = Draw (f m)
free-game.cabal view
@@ -1,5 +1,5 @@ name:                free-game
-version:             1.0.3
+version:             1.0.4
 synopsis:            Create games for free
 description:
     free-game defines a monad that integrates features to create 2D games.
@@ -36,7 +36,6 @@     FreeGame.Instances
     FreeGame.Backend.GLFW
     FreeGame.Internal.Finalizer
-    FreeGame.Internal.Raindrop
     FreeGame.Internal.GLFW
     FreeGame.Types
     FreeGame.Util
@@ -51,19 +50,21 @@     control-bool,
     directory >= 1.0,
     filepath >= 1.3,
-    free >= 4.5 && < 5,
+    free >= 4.6.1 && < 5,
     freetype2 >= 0.1,
     GLFW-b >= 1.3 && <2,
     hashable >= 1.2,
     JuicyPixels,
     JuicyPixels-util == 0.1.*,
-    linear >= 1.0 && < 1.7,
+    linear >= 1.0 && < 2,
     mtl >= 2.1,
     OpenGL == 2.9.*,
     OpenGLRaw == 1.4.*,
     random == 1.*,
-    reflection==1.*,
+    reflection == 1.*,
     template-haskell,
     transformers >= 0.3,
     vector >= 0.9 && <0.12,
-    void >= 0.5+    void >= 0.5,
+    boundingboxes >= 0.1.1 && < 0.2,
+    lens >= 3.8