packages feed

free-game 0.9.4.3 → 1.0

raw patch · 25 files changed

+1791/−1369 lines, 25 filesdep +JuicyPixelsdep ~GLFW-bdep ~freedep ~linear

Dependencies added: JuicyPixels

Dependency ranges changed: GLFW-b, free, linear

Files

+ FreeGame.hs view
@@ -0,0 +1,126 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  FreeGame
+-- Copyright   :  (C) 2013 Fumiaki Kinoshita
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  provisional
+-- Portability :  non-portable
+----------------------------------------------------------------------------
+module FreeGame
+  ( -- * Game
+    Game,
+    runGame,
+    WindowMode(..),
+    BoundingBox(..),
+    delay,
+    foreverFrame,
+    untick,
+    untickInfinite,
+    -- * Frame
+    Frame,
+    FreeGame(..),
+    -- * Transformations
+    Vec2,
+    Affine(..),
+    Local(),
+    globalize,
+    localize,
+    -- * Pictures
+    Picture2D(..),
+    Bitmap,
+    readBitmap,
+    cropBitmap,
+    loadBitmaps,
+    loadBitmapsWith,
+    writeBitmap,
+    -- * Text
+    Font,
+    loadFont,
+    text,
+    -- * Keyboard
+    Keyboard(..),
+    Key(..),
+    keyPress,
+    keyUp,
+    keyDown,
+    -- * Mouse
+    Mouse(),
+    mousePosition,
+    mouseButtonL,
+    mouseButtonR,
+    mouseButtonM,
+    mouseDownL,
+    mouseDownR,
+    mouseDownM,
+    mouseUpL,
+    mouseUpR,
+    mouseUpM,
+    -- * IO
+    FromFinalizer(),
+    embedIO,
+    liftIO,
+    randomness,
+    -- * Utility functions
+    unitV2,
+    angleV2,
+    degrees,
+    radians,
+    -- * Reexports
+    module Control.Monad,
+    module Control.Applicative,
+    module Control.Bool,
+    module Data.Color,
+    module Data.Color.Names,
+    module Linear,
+    -- * Deprecated
+    fromBitmap,
+    colored
+) where
+
+import FreeGame.UI
+import FreeGame.Util
+import FreeGame.Types
+import FreeGame.Text
+import FreeGame.Class
+import FreeGame.Instances ()
+import FreeGame.Data.Bitmap
+import FreeGame.Data.Font
+import qualified FreeGame.Backend.GLFW as GLFW
+import Control.Monad.IO.Class
+import Control.Monad
+import Control.Applicative
+import Control.Bool
+import Data.Color
+import Data.Color.Names
+import Linear hiding (rotate)
+import Control.Monad.Trans.Iter
+
+-- | 'Game' is a monad literally expressing games.
+-- This monad is an instance of 'Picture2D' so you can construct it using 'bitmap' and can be transformed with 'translate', 'scale', 'rotate', 'color'.
+--
+-- It is also an instance of 'Keyboard' and 'Mouse'. Note that 'mousePosition' returns a relative position.
+--
+-- > foo = foreverFrame $ do
+-- >   p <- mousePosition
+-- >   translate p $ color blue $ polygonOutline [V2 (-8) (-8), V2 8 (-8), V2 8 8, V2 (-8) 8]
+-- 
+-- When we run @foo@ using 'runGame', a blue square follows the cursor.
+-- And 'translate' (V2 240 240) @foo@, 'rotate' 45 @foo@, 'scale' 1.5 @foo@ also does in the same way.
+--
+-- You have to call 'tick' at the end of the frame.
+--
+-- The only way to embody a 'Game' as a real stuff is to apply 'runGame'.
+--
+-- For more examples, see <https://github.com/fumieval/free-game/tree/master/examples>.
+
+runGame :: WindowMode -> BoundingBox Double -> Game a -> IO (Maybe a)
+runGame = GLFW.runGame
+
+instance MonadIO Game where
+    liftIO = embedIO
+
+instance MonadIO Frame where
+    liftIO = embedIO
+ FreeGame/Backend/GLFW.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE Rank2Types, BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  FreeGame.Backend.GLFW
+-- Copyright   :  (C) 2013 Fumiaki Kinoshita
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+----------------------------------------------------------------------------
+module FreeGame.Backend.GLFW (runGame) where
+import Control.Monad.Free.Church
+import Control.Monad.Trans.Iter
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+import Data.IORef
+import Data.Reflection
+import FreeGame.Class
+import FreeGame.Data.Bitmap
+import FreeGame.Internal.Finalizer
+import FreeGame.UI
+import FreeGame.Types
+import Linear
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Map.Strict as Map
+import qualified FreeGame.Internal.GLFW as G
+import qualified Graphics.UI.GLFW as GLFW
+import qualified Graphics.Rendering.OpenGL.GL as GL
+import Unsafe.Coerce
+
+keyCallback :: IORef (Map.Map Key Bool) -> GLFW.Window -> GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys -> IO ()
+keyCallback keyBuffer _ key _ GLFW.KeyState'Pressed _ = modifyIORef' keyBuffer $ Map.insert (toEnum $ fromEnum key) True
+keyCallback _ _ _ _ _ _ = return ()
+
+mouseButtonCallback :: IORef (Map.Map Int Bool) -> GLFW.Window -> GLFW.MouseButton -> GLFW.MouseButtonState -> GLFW.ModifierKeys -> IO ()
+mouseButtonCallback mouseBuffer _ btn GLFW.MouseButtonState'Pressed _ = modifyIORef' mouseBuffer (Map.insert (fromEnum btn) True)
+mouseButtonCallback _ _ _ _ _ = return ()
+
+runGame :: WindowMode -> BoundingBox Double -> IterT (F UI) a -> IO (Maybe a)
+runGame mode bbox m = G.withGLFW mode bbox (execGame m)
+
+initialKeyBuffer :: Map.Map Key Bool
+initialKeyBuffer = Map.fromList $ zip [minBound..] (repeat False)
+
+initialMouseBuffer :: Map.Map Int Bool
+initialMouseBuffer = Map.fromList $ zip [0..7] (repeat False)
+
+execGame :: IterT (F UI) a -> G.System -> IO (Maybe a)
+execGame m sys = do
+    texs <- newIORef IM.empty
+    keyBuffer <- newIORef initialKeyBuffer
+    mouseBuffer <- newIORef initialMouseBuffer
+    keyBuffer' <- newIORef initialKeyBuffer
+    mouseBuffer' <- newIORef initialMouseBuffer 
+    GLFW.setKeyCallback (G.theWindow sys) $ Just $ keyCallback keyBuffer
+    GLFW.setMouseButtonCallback (G.theWindow sys) $ Just $ mouseButtonCallback mouseBuffer
+
+    execFinalizerT
+        $ give (RefKeyStates keyBuffer)
+        $ give (RefMouseButtonStates mouseBuffer)
+        $ give (Previous (RefKeyStates keyBuffer'))
+        $ give (Previous (RefMouseButtonStates mouseBuffer'))
+        $ give (TextureStorage texs)
+        $ give sys
+        $ gameLoop m
+
+gameLoop ::
+    ( Given G.System
+    , Given TextureStorage
+    , Given KeyStates
+    , Given MouseButtonStates
+    , Given (Previous KeyStates)
+    , Given (Previous MouseButtonStates)
+    ) => IterT (F UI) a -> FinalizerT IO (Maybe a)
+gameLoop m = do
+    liftIO $ G.beginFrame given
+
+    r <- iterM runUI $ runIterT m
+
+    b <- liftIO $ do
+        readIORef (getKeyStates given) >>= writeIORef (getKeyStates (getPrevious given))
+        readIORef (getMouseButtonStates given) >>= writeIORef (getMouseButtonStates (getPrevious given))
+        writeIORef (getKeyStates given) initialKeyBuffer
+        writeIORef (getMouseButtonStates given) initialMouseBuffer
+        G.endFrame given
+
+    if b
+        then return Nothing
+        else either (return . Just) gameLoop r
+
+newtype TextureStorage = TextureStorage { getTextureStorage :: IORef (IM.IntMap G.Texture) }
+
+type DrawM = ReaderT (Location ()) IO
+
+newtype Previous a = Previous { getPrevious :: a }
+
+newtype KeyStates = RefKeyStates { getKeyStates :: IORef (Map.Map Key Bool) }
+newtype MouseButtonStates = RefMouseButtonStates { getMouseButtonStates :: IORef (Map.Map Int Bool) }
+
+
+runUI :: forall a.
+    ( Given G.System
+    , Given TextureStorage
+    , Given KeyStates
+    , Given MouseButtonStates
+    , Given (Previous KeyStates)
+    , Given (Previous MouseButtonStates)
+    ) => UI (FinalizerT IO a) -> FinalizerT IO a
+runUI (Draw m) = do
+    (cont, xs) <- liftIO $ do
+        cxt <- newIORef []
+        cont <- give (Context cxt) $ runReaderT (m :: DrawM (FinalizerT IO a)) (Location id id)
+        xs <- readIORef cxt
+        return (cont, xs)
+    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
+    loadTexture given bmp
+        (\t h -> finalizer $ G.releaseTexture t >> modifyIORef' (getTextureStorage given) (IM.delete h))
+        (const $ return ())
+        (const $ return ())
+    cont
+runUI (KeyStates cont) = do
+    let k = liftIO . readIORef . getKeyStates
+    s <- k given
+    t <- k (getPrevious given)
+    cont s t
+runUI (MouseButtons cont) = do
+    let k = liftIO . readIORef . getMouseButtonStates
+    s <- k given
+    t <- k (getPrevious given)
+    cont s t
+-- runUI _ _ (MouseWheel cont) = GLFW.getMouseWheel >>= cont
+runUI (MousePosition cont) = do
+    (x, y) <- liftIO $ GLFW.getCursorPos (G.theWindow given)
+    cont $ V2 x y
+runUI (Bracket m) = join $ iterM runUI m
+runUI (TakeScreenshot cont) = liftIO (G.screenshot given >>= makeStableBitmap) >>= cont
+runUI (ClearColor col cont) = do
+    liftIO $ GL.clearColor GL.$= unsafeCoerce col
+    cont
+runUI (SetTitle str cont) = do
+    liftIO $ GLFW.setWindowTitle (G.theWindow given) str
+    cont
+runUI (ShowCursor cont) = do
+    liftIO $ GLFW.setCursorInputMode (G.theWindow given) GLFW.CursorInputMode'Normal
+    cont
+runUI (HideCursor cont) = do
+    liftIO $ GLFW.setCursorInputMode (G.theWindow given) GLFW.CursorInputMode'Hidden
+    cont
+runUI (SetFPS n cont) = do
+    liftIO $ writeIORef (G.theFPS given) n
+    cont
+runUI (GetFPS cont) = liftIO (readIORef (G.currentFPS given)) >>= 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 #-}
+
+instance Affine DrawM where
+    translate v = mapReaderWith (translate v) (G.translate v)
+    {-# INLINE translate #-}
+    rotateD t = mapReaderWith (rotateD t) (G.rotateD t)
+    {-# INLINE rotateD #-}
+    rotateR t = let t' = t / pi * 180 in mapReaderWith (rotateR t) (G.rotateD t')
+    {-# INLINE rotateR #-}
+    scale v = mapReaderWith (scale v) (G.scale v)
+    {-# INLINE scale #-}
+
+loadTexture :: MonadIO m => TextureStorage -> Bitmap
+    -> (G.Texture -> Int -> m ())
+    -> (G.Texture -> m ())
+    -> (G.Texture -> m ())
+    -> m ()
+loadTexture (TextureStorage st) (BitmapData img (Just h)) hook cont _ = do
+    m <- liftIO $ readIORef st
+    case IM.lookup h m of
+        Just t -> cont t
+        Nothing -> do
+            t <- liftIO $ G.installTexture img
+            liftIO $ writeIORef st $ IM.insert h t m
+            hook t h
+            cont t
+loadTexture _ (BitmapData img Nothing) _ cont fin = do
+    t <- liftIO $ G.installTexture img
+    cont t
+    fin t
+
+newtype Context = Context { getContext :: IORef [(G.Texture, Int)] }
+
+instance (Given Context, Given TextureStorage) => Picture2D DrawM where
+    bitmap bmp = liftIO $ loadTexture given bmp
+        (\t h -> modifyIORef (getContext given) ((t, h) :))
+        G.drawTexture
+        G.releaseTexture
+    {-# INLINE bitmap #-}
+    circle r = liftIO (G.circle r)
+    {-# INLINE circle #-}
+    circleOutline r = liftIO (G.circleOutline r)
+    {-# INLINE circleOutline #-}
+    polygon vs = liftIO (G.polygon vs)
+    {-# INLINE polygon #-}
+    polygonOutline vs = liftIO (G.polygonOutline vs)
+    {-# INLINE polygonOutline #-}
+    line vs = liftIO (G.line vs)
+    {-# INLINE line #-}
+    thickness t = mapReaderWith id (G.thickness t)
+    {-# INLINE thickness #-}
+    color c = mapReaderWith id (G.color c)
+    {-# INLINE color #-}
+
+instance Local DrawM where
+    getLocation = asks coerceLocation
+ FreeGame/Class.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE BangPatterns, Rank2Types, DeriveFunctor #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  FreeGame.Class
+-- Copyright   :  (C) 2013 Fumiaki Kinoshita
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  provisional
+-- Portability :  non-portable
+-- 
+----------------------------------------------------------------------------
+module FreeGame.Class where
+
+import Linear
+import Control.Applicative
+import Unsafe.Coerce
+import FreeGame.Types
+import FreeGame.Data.Bitmap
+import FreeGame.Internal.Finalizer
+import Data.Color
+import Control.Monad.IO.Class
+import qualified Data.Map as Map
+
+class Functor p => Affine p where
+    -- | (radians)
+    rotateR :: Double -> p a -> p a
+    -- | (degrees)
+    rotateD :: Double -> p a -> p a
+    scale :: Vec2 -> p a -> p a
+    translate :: Vec2 -> p a -> p a
+
+    rotateR = rotateD . (* 180) . (/ pi)
+    rotateD = rotateR . (/ 180) . (* pi)
+
+-- | The class of types that can be regarded as a kind of picture.
+class Affine p => Picture2D p where
+    -- | Construct a 'Picture2D' from a 'Bitmap'.
+    bitmap :: Bitmap -> p ()
+    line :: [Vec2] -> p ()
+    polygon :: [Vec2] -> p ()
+    polygonOutline :: [Vec2] -> p ()
+    circle :: Double -> p ()
+    circleOutline :: Double -> p ()
+    thickness :: Float -> p a -> p a
+    color :: Color -> 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)
+
+data Location a = Location (Vec2 -> Vec2) (Vec2 -> Vec2) deriving Functor
+
+coerceLocation :: Location a -> Location b
+coerceLocation = unsafeCoerce
+
+flipLocation :: Location a -> Location b
+flipLocation (Location f g) = Location g f
+
+localize :: Local f => Vec2 -> f Vec2
+localize v = (\(Location _ g) -> g v) <$> getLocation
+
+globalize :: Local f => Vec2 -> f Vec2
+globalize v = (\(Location f _) -> f v) <$> getLocation
+
+instance Affine Location where
+    translate v (Location f g) = Location (f . (^+^v)) ((^-^v) . g)
+    rotateR t (Location f g) = Location (f . rot2 t) (rot2 (-t) . g)
+    scale v (Location f g) = Location (f . (*v)) ((/v) . g)
+
+rot2 :: Floating a => a -> V2 a -> V2 a
+rot2 t (V2 !x !y) = V2 (p * x + q * y) (-q * x + p * y) where
+    !p = cos t
+    !q = sin t
+
+class Functor f => Keyboard f where
+    keyStates_ :: f (Map.Map Key Bool, Map.Map Key Bool)
+
+keyStates :: Keyboard f => f (Map.Map Key Bool)
+keyStates = fmap fst keyStates_
+
+keyPress :: Keyboard f => Key -> f Bool
+keyPress k = (Map.! k) <$> keyStates
+
+keyDown :: Keyboard f => Key -> f Bool
+keyDown k = (\(m, n) -> m Map.! k && not (n Map.! k)) <$> keyStates_ where
+
+keyUp :: Keyboard f => Key -> f Bool
+keyUp k = (\(m, n) -> not (m Map.! k) && n Map.! k) <$> keyStates_ where
+
+{-
+
+{-# DEPRECATED keySpecial "Use keyPress instead" #-}
+keySpecial :: Keyboard t => SpecialKey -> t Bool
+keySpecial = keyState
+
+{-# DEPRECATED keyChar "Use keyState instead" #-}
+keyChar :: Keyboard t => Char -> t Bool
+keyChar = undefined
+
+-}
+
+class Functor f => Mouse f where
+    globalMousePosition :: f Vec2
+    mouseButtons_ :: f (Map.Map Int Bool, Map.Map Int Bool)
+
+-- | Returns the relative coordinate of the cursor.
+mousePosition :: (Applicative f, Mouse f, Local f) => f Vec2
+mousePosition = (\v (Location _ g) -> g v) <$> globalMousePosition <*> getLocation
+
+mouseButtons :: Mouse f => f (Map.Map Int Bool)
+mouseButtons = fmap fst mouseButtons_
+
+mouseButton :: Mouse f => Int -> f Bool
+mouseButton k = (Map.! k) <$> mouseButtons
+
+mouseDown :: Mouse f => Int -> f Bool
+mouseDown k = (\(m, n) -> m Map.! k && not (n Map.! k)) <$> mouseButtons_
+
+mouseUp :: Mouse f => Int -> f Bool
+mouseUp k = (\(m, n) -> not (m Map.! k) && n Map.! k) <$> mouseButtons_
+
+mouseButtonL :: Mouse f => f Bool
+mouseButtonL = mouseButton 0
+
+mouseButtonR :: Mouse f => f Bool
+mouseButtonR = mouseButton 1
+
+mouseButtonM :: Mouse f => f Bool
+mouseButtonM = mouseButton 2
+
+mouseDownL :: Mouse f => f Bool
+mouseDownL = mouseDown 0
+
+mouseDownR :: Mouse f => f Bool
+mouseDownR = mouseDown 1
+
+mouseDownM :: Mouse f => f Bool
+mouseDownM = mouseDown 2
+
+mouseUpL :: Mouse f => f Bool
+mouseUpL = mouseUp 0
+
+mouseUpR :: Mouse f => f Bool
+mouseUpR = mouseUp 1
+
+mouseUpM :: Mouse f => f Bool
+mouseUpM = mouseUp 2
+
+class FromFinalizer m where
+    fromFinalizer :: FinalizerT IO a -> m a
+
+instance FromFinalizer (FinalizerT IO) where
+    fromFinalizer = id
+
+embedIO :: FromFinalizer m => IO a -> m a
+embedIO m = fromFinalizer (liftIO m)
+{-# INLINE embedIO #-}
+ FreeGame/Data/Bitmap.hs view
@@ -0,0 +1,103 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  FreeGame.Data.Bitmap
+-- Copyright   :  (C) 2013 Fumiaki Kinoshita
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Manipulating bitmaps
+----------------------------------------------------------------------------
+
+module FreeGame.Data.Bitmap (
+    -- * Basic types and functions
+    Bitmap(..)
+    , _BitmapArray
+    , _BitmapHash
+    ,bitmapSize
+
+    -- * Load and Save
+    ,readBitmap
+    ,writeBitmap
+
+    -- * Constructing bitmaps
+    ,toBitmap
+    ,toStableBitmap
+    ,makeStableBitmap
+
+    -- * Bitmap operations
+    ,onBitmapWithHashable
+    ,cropBitmap
+    
+    ) where
+
+import Control.Applicative
+import Codec.Picture.Repa
+import qualified Codec.Picture as C
+import Data.Array.Repa as R
+import qualified Data.Array.Repa.Repr.ForeignPtr as RF
+import Data.Word
+import System.Random
+import Data.Hashable
+import Control.Monad.IO.Class
+import qualified Data.Vector.Storable as V
+
+-- | Bitmap data with unique hashes. 
+data Bitmap = BitmapData (R.Array RF.F DIM3 Word8) (Maybe Int) -- ^ This value is used to ensure that two bitmaps are equivalent.
+
+instance Show Bitmap where
+    show (BitmapData _ h) = "<BitmapData #" Prelude.++ show h Prelude.++ ">"
+
+instance Eq Bitmap where
+    BitmapData _ h == BitmapData _ h' = h == h'
+
+instance Ord Bitmap where
+    BitmapData _ h <= BitmapData _ h' = h <= h'
+
+-- | @'_BitmapArray' :: Lens' 'Bitmap' ('R.Array' 'RF.F' 'DIM3' 'Word8')@
+-- The concrete data is stored as a repa array (y * x * ABGR).
+_BitmapArray :: Functor f => (R.Array RF.F DIM3 Word8 -> f (R.Array RF.F DIM3 Word8)) -> Bitmap -> f Bitmap
+_BitmapArray f (BitmapData a h) = fmap (\a' -> BitmapData a' h) (f a)
+
+-- | @'_BitmapHash' :: Lens' 'Bitmap' ('Maybe' 'Int')@
+_BitmapHash :: Functor f => (Maybe Int -> f (Maybe Int)) -> Bitmap -> f Bitmap
+_BitmapHash f (BitmapData a h) = fmap (\h' -> BitmapData a h') (f h)
+
+-- | Create unstable 'Bitmap' from the given array.
+toBitmap :: R.Array RF.F DIM3 Word8 -> Bitmap
+toBitmap ar = BitmapData ar Nothing
+
+-- | Create stable 'Bitmap' from the given array and compute the hash.
+toStableBitmap :: R.Array RF.F DIM3 Word8 -> Bitmap
+toStableBitmap ar = BitmapData ar $ Just $ foldAllS combine 0 $ R.map fromIntegral ar where
+    combine p q = hash (p, q)
+
+-- | Create stable 'Bitmap' with unique hash from the given array.
+makeStableBitmap :: R.Array RF.F DIM3 Word8 -> IO Bitmap
+makeStableBitmap ar = BitmapData ar <$> Just <$> randomIO
+
+-- | Get the size of the 'Bitmap'.
+bitmapSize :: Bitmap -> (Int, Int)
+bitmapSize (BitmapData a _) = let (Z :. h :. w :. _) = R.extent a in (w, h)
+
+-- | Load an image file.
+readBitmap :: MonadIO m => FilePath -> m Bitmap
+readBitmap path = liftIO $ readImageRGBA path >>= either fail return >>= makeStableBitmap . imgData
+
+-- | Save 'Bitmap' into a file.
+writeBitmap :: MonadIO m => FilePath -> Bitmap -> m ()
+writeBitmap path (BitmapData img _) = liftIO $ C.writePng path (C.Image w h $ V.unsafeFromForeignPtr0 (RF.toForeignPtr img) (h * w * 4) :: C.Image C.PixelRGBA8) where
+    R.Z R.:. h R.:. w R.:. _ = R.extent img
+
+-- | Convert the 'Bitmap' uniformalized by the 'Hashable' value by the given function.
+onBitmapWithHashable :: Hashable h => h -> (R.Array RF.F DIM3 Word8 -> R.Array RF.F DIM3 Word8) -> Bitmap -> Bitmap
+onBitmapWithHashable v f (BitmapData ar h) = BitmapData (f ar) (hash <$> (,) v <$> h)
+
+-- | Extract a 'Bitmap' from the specified range.
+cropBitmap :: Bitmap -- ^original bitmap
+    -> (Int, Int) -- ^width and height
+    -> (Int, Int) -- ^x and y
+    -> Bitmap -- ^result
+cropBitmap bmp (w, h) (x, y) = onBitmapWithHashable (w,h,x,y) (computeS . extract (Z :. y :. x :. 0) (Z :. h :. w :. 4)) bmp
+ FreeGame/Data/Font.hs view
@@ -0,0 +1,149 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  FreeGame.Data.Font
+-- Copyright   :  (C) 2013 Fumiaki Kinoshita
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  provisional
+-- Portability :  non-portable
+--
+-- Rendering characters
+----------------------------------------------------------------------------
+module FreeGame.Data.Font 
+  ( Font
+  , loadFontFromFile
+  , loadFont
+  , fontBoundingBox
+  , metricsAscent
+  , metricsDescent
+  , charToBitmap
+  , RenderedChar(..)
+  ) where
+
+import Control.Applicative
+import Control.Monad.IO.Class
+import Data.IORef
+import Data.Array.Repa as R
+import Data.Array.Repa.Repr.ForeignPtr as R
+import qualified Data.Map as M
+import Data.Word
+import Linear
+import FreeGame.Types
+import FreeGame.Class
+import FreeGame.Data.Bitmap
+import 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
+import Graphics.Rendering.FreeType.Internal.Bitmap as B
+import Graphics.Rendering.FreeType.Internal.PrimitiveTypes as PT
+import Graphics.Rendering.FreeType.Internal.Face as F
+import Graphics.Rendering.FreeType.Internal.Library as L
+import Graphics.Rendering.FreeType.Internal.BBox as BB
+import Foreign.Marshal.Alloc
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.Storable
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import System.IO.Unsafe
+
+-- | Font object
+data Font = Font FT_Face (Double, Double) (BoundingBox Double) (IORef (M.Map (Double, Char) RenderedChar))
+
+-- | Create a 'Font' from the given file.
+loadFontFromFile :: MonadIO m => FilePath -> m Font
+loadFontFromFile path = liftIO $ alloca $ \p -> do
+    runFreeType $ withCString path $ \str -> ft_New_Face freeType str 0 p
+    f <- peek p
+    b <- peek (bbox f)
+    asc <- peek (ascender f)
+    desc <- peek (descender f)
+    u <- fromIntegral <$> peek (units_per_EM f)
+    let box = BoundingBox (fromIntegral (xMin b)/u) (fromIntegral (yMin b)/u)
+                          (fromIntegral (xMax b)/u) (fromIntegral (yMax b)/u)
+    Font f (fromIntegral asc/u, fromIntegral desc/u) box <$> newIORef M.empty
+
+loadFont :: MonadIO m => FilePath -> m Font
+loadFont = loadFontFromFile
+
+-- | Get the font's metrics.
+metricsAscent :: Font -> Double
+metricsAscent (Font _ (a, _) _ _) = a
+
+-- | Get the font's metrics.
+metricsDescent :: Font -> Double
+metricsDescent (Font _ (_, d) _ _) = d
+
+-- | Get the font's boundingbox.
+fontBoundingBox :: Font -> BoundingBox Double
+fontBoundingBox (Font _ _ b _) = b
+
+runFreeType :: IO CInt -> IO ()
+runFreeType m = do
+    r <- m
+    case r of
+        0 -> return ()
+        e -> fail $ "FreeType Error:" Prelude.++ show e
+
+freeType :: FT_Library
+freeType = unsafePerformIO $ alloca $ \p -> do
+    runFreeType $ ft_Init_FreeType p
+    peek p
+
+data RenderedChar = RenderedChar
+    { charBitmap :: Bitmap
+    , charOffset :: V2 Double
+    ,　charAdvance :: Double
+    }
+
+-- | The resolution used to render fonts.
+resolutionDPI :: Int
+resolutionDPI = 300
+
+charToBitmap :: FromFinalizer m => Font -> Double -> Char -> m RenderedChar
+charToBitmap (Font face _ _ refCache) pixel ch = fromFinalizer $ do
+    let siz = pixel * 72 / fromIntegral resolutionDPI
+    cache <- liftIO $ readIORef refCache
+    case M.lookup (siz, ch) cache of
+        Just d -> return d
+        Nothing -> do
+            d <- liftIO $ render face siz ch
+            liftIO $ writeIORef refCache $ M.insert (siz, ch) d cache
+            finalizer $ modifyIORef refCache $ M.delete (siz, ch)
+            return d
+
+render :: FT_Face -> Double -> Char -> IO RenderedChar
+render face siz ch = do
+    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
+
+    slot <- peek $ glyph face
+    runFreeType $ ft_Render_Glyph slot ft_RENDER_MODE_NORMAL
+
+    bmp <- peek $ GS.bitmap slot
+    left <- fmap fromIntegral $ peek $ GS.bitmap_left slot
+    top <- fmap fromIntegral $ peek $ GS.bitmap_top slot
+
+    let h = fromIntegral $ B.rows bmp
+        w = fromIntegral $ B.width bmp
+    
+    fptr <- newForeignPtr_ $ castPtr $ buffer bmp
+
+    adv <- peek $ GS.advance slot
+
+    let ar = fromForeignPtr (Z:.h:.w) fptr :: R.Array F DIM2 Word8
+        pix (crd:.3) = R.index ar crd
+        pix (_:._) = 255
+
+    result <- computeP (fromFunction (Z:.h:.w:.4) pix) >>= makeStableBitmap
+    
+    return $ RenderedChar
+        result
+        (V2 (left + fromIntegral w / 2) (-top + fromIntegral h / 2))
+        (fromIntegral (V.x adv) / 64)
+ FreeGame/Instances.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module FreeGame.Instances () where
+
+import Control.Monad.Trans
+import Control.Monad.Trans.Iter
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.List
+import Control.Monad.Trans.Error
+import Control.Monad.Trans.Identity
+import qualified Control.Monad.State.Lazy as Lazy
+import qualified Control.Monad.State.Strict as Strict
+import qualified Control.Monad.Writer.Lazy as Lazy
+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
+import Data.Monoid
+import Control.Monad.Free.Church as Church
+import Control.Monad.Free as Free
+import FreeGame.Class
+import FreeGame.UI
+
+#define _COMMA_ ,
+
+#define MK_AFFINE(cxt, ty, t) instance (Affine m cxt) => Affine (ty) where { \
+    rotateD a = t (rotateD a); \
+    {-# INLINE rotateD #-}; \
+    rotateR a = t (rotateR a); \
+    {-# INLINE rotateR #-}; \
+    translate a = t (translate a); \
+    {-# INLINE translate #-}; \
+    scale a = t (scale a); \
+    {-# INLINE scale #-}; \
+     }
+
+#define MK_PICTURE_2D(cxt, ty, l, t) instance (Picture2D m cxt) => Picture2D (ty) where { \
+    bitmap b = (l) (bitmap b); \
+    {-# INLINE bitmap #-}; \
+    line = (l) . line; \
+    polygon = (l) . polygon; \
+    polygonOutline = (l) . polygonOutline; \
+    circle = (l) . circle; \
+    circleOutline = (l) . circleOutline; \
+    thickness k = t (thickness k); \
+    color k = t (color k); \
+    {-# INLINE color #-}; \
+    }
+
+#define MK_LOCAL(cxt, ty, l) instance (Local m cxt) => Local (ty) where { \
+    getLocation = (l) getLocation }
+
+#define MK_KEYBOARD(cxt, ty, l) instance (Keyboard m cxt) => Keyboard (ty) where { \
+    keyStates_ = (l) keyStates_; }
+
+#define MK_MOUSE(cxt, ty, l) instance (Mouse m cxt) => Mouse (ty) where { \
+    globalMousePosition = (l) globalMousePosition; \
+    mouseButtons_ = (l) mouseButtons_;\
+    }
+
+#define MK_FROM_FINALIZER(cxt, ty, l) instance (FromFinalizer m cxt) => FromFinalizer (ty) where { \
+    fromFinalizer = (l) . fromFinalizer }
+
+#define MK_FREE_GAME(cxt, ty, l) instance (FreeGame m cxt) => FreeGame (ty) where { \
+    draw = (l) . draw; \
+    preloadBitmap = (l) . preloadBitmap; \
+    takeScreenshot = (l) takeScreenshot; \
+    bracket m = (l) (bracket m); \
+    setFPS a = (l) (setFPS a); \
+    setTitle t = (l) (setTitle t); \
+    showCursor = (l) showCursor; \
+    hideCursor = (l) hideCursor; \
+    clearColor c = (l) (clearColor c); \
+    getFPS = (l) getFPS; \
+    }
+
+
+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)
+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_PICTURE_2D(_COMMA_ Functor m, F m, Church.liftF, hoistF)
+MK_PICTURE_2D(_COMMA_ Functor m, Free.Free m, Free.liftF, Free.hoistFree)
+MK_PICTURE_2D(_COMMA_ Monad m, IterT m, lift, hoistIterT)
+MK_PICTURE_2D(_COMMA_ Monad m, ReaderT r m, lift, mapReaderT)
+MK_PICTURE_2D(_COMMA_ Monad m, Lazy.StateT s m, lift, Lazy.mapStateT)
+MK_PICTURE_2D(_COMMA_ Monad m, Strict.StateT s m, lift, Strict.mapStateT)
+MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift, Lazy.mapWriterT)
+MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift, Strict.mapWriterT)
+MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift, Lazy.mapRWST)
+MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift, Strict.mapRWST)
+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)
+MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift, mapErrorT)
+MK_PICTURE_2D(_COMMA_ Monad m, ContT r m, lift, mapContT)
+
+MK_LOCAL(_COMMA_ Functor m, F m, Church.liftF)
+MK_LOCAL(_COMMA_ Functor m, Free.Free m, Free.liftF)
+MK_LOCAL(_COMMA_ Monad m, IterT m, lift)
+MK_LOCAL(_COMMA_ Monad m, ReaderT s m, lift)
+MK_LOCAL(_COMMA_ Monad m, Lazy.StateT s m, lift)
+MK_LOCAL(_COMMA_ Monad m, Strict.StateT s m, lift)
+MK_LOCAL(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift)
+MK_LOCAL(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift)
+MK_LOCAL(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift)
+MK_LOCAL(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift)
+MK_LOCAL(_COMMA_ Monad m, IdentityT m, lift)
+MK_LOCAL(_COMMA_ Monad m, MaybeT m, lift)
+MK_LOCAL(_COMMA_ Monad m, ListT m, lift)
+MK_LOCAL(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift)
+MK_LOCAL(_COMMA_ Monad m, ContT r m, lift)
+
+MK_KEYBOARD(_COMMA_ Functor m, F m, Church.liftF)
+MK_KEYBOARD(_COMMA_ Functor m, Free.Free m, Free.liftF)
+MK_KEYBOARD(_COMMA_ Monad m, IterT m, lift)
+MK_KEYBOARD(_COMMA_ Monad m, ReaderT s m, lift)
+MK_KEYBOARD(_COMMA_ Monad m, Lazy.StateT s m, lift)
+MK_KEYBOARD(_COMMA_ Monad m, Strict.StateT s m, lift)
+MK_KEYBOARD(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift)
+MK_KEYBOARD(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift)
+MK_KEYBOARD(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift)
+MK_KEYBOARD(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift)
+MK_KEYBOARD(_COMMA_ Monad m, IdentityT m, lift)
+MK_KEYBOARD(_COMMA_ Monad m, MaybeT m, lift)
+MK_KEYBOARD(_COMMA_ Monad m, ListT m, lift)
+MK_KEYBOARD(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift)
+MK_KEYBOARD(_COMMA_ Monad m, ContT r m, lift)
+
+MK_MOUSE(_COMMA_ Functor m, F m, liftF)
+MK_MOUSE(_COMMA_ Functor m, Free.Free m, Free.liftF)
+MK_MOUSE(_COMMA_ Monad m, IterT m, lift)
+MK_MOUSE(_COMMA_ Monad m, ReaderT r m, lift)
+MK_MOUSE(_COMMA_ Monad m, Lazy.StateT s m, lift)
+MK_MOUSE(_COMMA_ Monad m, Strict.StateT s m, lift)
+MK_MOUSE(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift)
+MK_MOUSE(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift)
+MK_MOUSE(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift)
+MK_MOUSE(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift)
+MK_MOUSE(_COMMA_ Monad m, IdentityT m, lift)
+MK_MOUSE(_COMMA_ Monad m, MaybeT m, lift)
+MK_MOUSE(_COMMA_ Monad m, ListT m, lift)
+MK_MOUSE(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift)
+MK_MOUSE(_COMMA_ Monad m, ContT r m, lift)
+
+MK_FROM_FINALIZER(_COMMA_ Functor m, F m, liftF)
+MK_FROM_FINALIZER(_COMMA_ Functor m, Free.Free m, Free.liftF)
+MK_FROM_FINALIZER(_COMMA_ Monad m, IterT m, lift)
+MK_FROM_FINALIZER(_COMMA_ Monad m, Lazy.StateT s m, lift)
+MK_FROM_FINALIZER(_COMMA_ Monad m, Strict.StateT s m, lift)
+MK_FROM_FINALIZER(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift)
+MK_FROM_FINALIZER(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift)
+MK_FROM_FINALIZER(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift)
+MK_FROM_FINALIZER(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift)
+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)
+MK_FROM_FINALIZER(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift)
+MK_FROM_FINALIZER(_COMMA_ Monad m, ContT r m, lift)
+
+MK_FREE_GAME(_COMMA_ Functor m, F m, liftF)
+MK_FREE_GAME(_COMMA_ Functor m, Free.Free m, Free.liftF)
+MK_FREE_GAME(_COMMA_ Monad m, IterT m, lift)
+MK_FREE_GAME(_COMMA_ Monad m, Lazy.StateT s m, lift)
+MK_FREE_GAME(_COMMA_ Monad m, Strict.StateT s m, lift)
+MK_FREE_GAME(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift)
+MK_FREE_GAME(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift)
+MK_FREE_GAME(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift)
+MK_FREE_GAME(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift)
+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)
+MK_FREE_GAME(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift)
+MK_FREE_GAME(_COMMA_ Monad m, ContT r m, lift)
+ FreeGame/Internal/Finalizer.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE Rank2Types #-}
+module FreeGame.Internal.Finalizer (FinalizerT(..), finalizer, runFinalizerT, execFinalizerT, mapFinalizerT) where
+
+import Control.Monad.IO.Class
+import Control.Monad.Trans
+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
+    {-# INLINE liftIO #-}
+
+instance MonadTrans FinalizerT where
+    lift m = FinalizerT $ \r _ -> m >>= r
+    {-# INLINE lift #-}
+
+-- | Run the action and run all associated finalizers.
+runFinalizerT :: Monad m => FinalizerT m a -> m (a, IO ())
+runFinalizerT (FinalizerT z) = z (\a -> return (a, return ())) (\m (r, fs) -> return (r, m >> fs))
+
+execFinalizerT :: MonadIO m => FinalizerT m a -> m a
+execFinalizerT m = do
+    (a, fin) <- runFinalizerT m
+    liftIO fin
+    return a
+
+mapFinalizerT :: (Monad m, Monad n) => (forall x. m x -> n x) -> FinalizerT m a -> FinalizerT n a
+mapFinalizerT t m = FinalizerT $ \p f -> do
+    (a, fin) <- t (runFinalizerT m)
+    r <- p a
+    f fin r
+ FreeGame/Internal/GLFW.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE BangPatterns #-}
+module FreeGame.Internal.GLFW where
+import Control.Concurrent
+import Control.Bool
+import Control.Applicative
+import Control.Monad.IO.Class
+import Data.Color
+import Data.IORef
+import Foreign.ForeignPtr
+import FreeGame.Types
+import Graphics.Rendering.OpenGL.GL.StateVar
+import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility
+import Linear
+import qualified Data.Array.Repa.Repr.ForeignPtr as RF
+import qualified Graphics.Rendering.OpenGL.GL as GL
+import qualified Graphics.UI.GLFW as GLFW
+import Unsafe.Coerce
+import Foreign.Marshal.Alloc
+import qualified Data.Array.Repa as R
+import Data.Word
+import qualified Data.Array.Repa.Operators.IndexSpace as R
+
+data System = System
+    { refFrameCounter :: IORef Int
+    , refFPS :: IORef Int
+    , theFPS :: IORef Int
+    , currentFPS :: IORef Int
+    , theRegion :: BoundingBox Double
+    , theWindow :: GLFW.Window
+    }
+
+type Texture = (GL.TextureObject, Double, Double)
+
+runVertices :: MonadIO m => [V2 Double] -> m ()
+runVertices = liftIO . mapM_ (GL.vertex . mkVertex2)
+{-# INLINE runVertices #-}
+
+preservingMatrix' :: MonadIO m => m a -> m a
+preservingMatrix' m = do
+    liftIO glPushMatrix
+    r <- m
+    liftIO glPopMatrix
+    return r
+{-# INLINE preservingMatrix' #-}
+
+drawTexture :: Texture -> IO ()
+drawTexture (tex, !w, !h) = drawTextureAt tex (V2 (-w) (-h)) (V2 w (-h)) (V2 w h) (V2 (-w) h)
+{-# INLINE drawTexture #-}
+
+drawTextureAt :: GL.TextureObject -> V2 Double -> V2 Double -> V2 Double -> V2 Double -> IO ()
+drawTextureAt tex a b c d = do
+    GL.texture GL.Texture2D $= GL.Enabled
+    GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest)
+    GL.textureBinding GL.Texture2D $= Just tex
+    GL.unsafeRenderPrimitive GL.TriangleStrip $ do
+        GL.texCoord $ GL.TexCoord2 (0 :: GL.GLdouble) 0
+        GL.vertex $ mkVertex2 a
+        GL.texCoord $ GL.TexCoord2 (1 :: GL.GLdouble) 0
+        GL.vertex $ mkVertex2 b
+        GL.texCoord $ GL.TexCoord2 (0 :: GL.GLdouble) 1
+        GL.vertex $ mkVertex2 d
+        GL.texCoord $ GL.TexCoord2 (1 :: GL.GLdouble) 1
+        GL.vertex $ mkVertex2 c
+    GL.texture GL.Texture2D $= GL.Disabled
+
+mkVertex2 :: V2 Double -> GL.Vertex2 GL.GLdouble
+{-# INLINE mkVertex2 #-}
+mkVertex2 = unsafeCoerce
+
+gf :: Float -> GL.GLfloat
+{-# INLINE gf #-}
+gf = unsafeCoerce
+
+gd :: Double -> GL.GLdouble
+{-# INLINE gd #-}
+gd = unsafeCoerce
+
+gsizei :: Int -> GL.GLsizei
+{-# INLINE gsizei #-}
+gsizei = unsafeCoerce
+
+translate :: V2 Double -> IO a -> IO a
+translate (V2 tx ty) m = preservingMatrix' $ GL.translate (GL.Vector3 (gd tx) (gd ty) 0) >> m
+
+rotateD :: Double -> IO a -> IO a
+rotateD theta m = preservingMatrix' $ GL.rotate (gd (-theta)) (GL.Vector3 0 0 1) >> m
+
+scale :: V2 Double -> IO a -> IO a
+scale (V2 sx sy) m = preservingMatrix' $ GL.scale (gd sx) (gd sy) 1 >> m
+
+circle :: Double -> IO ()
+circle r = do
+    let s = 2 * pi / 64
+    GL.renderPrimitive GL.Polygon $ runVertices [V2 (cos t * r) (sin t * r) | t <- [0,s..2 * pi]]
+
+circleOutline :: Double -> IO ()
+circleOutline r = do
+    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 col m = do
+    oldColor <- liftIO $ get GL.currentColor
+    liftIO $ GL.currentColor $= unsafeCoerce col
+    res <- m
+    liftIO $ GL.currentColor $= oldColor
+    return res
+
+polygon :: [V2 Double] -> IO ()
+polygon path = GL.renderPrimitive GL.Polygon $ runVertices path
+
+polygonOutline :: [V2 Double] -> IO ()
+polygonOutline path = GL.renderPrimitive GL.LineLoop $ runVertices path
+
+line :: [V2 Double] -> IO ()
+line path = GL.renderPrimitive GL.LineStrip $ runVertices path
+
+thickness :: Float -> IO a -> IO a
+thickness t m = do
+    oldWidth <- liftIO $ get GL.lineWidth
+    liftIO $ GL.lineWidth $= gf t
+    res <- m
+    liftIO $ GL.lineWidth $= oldWidth
+    return res
+
+installTexture :: R.Array RF.F R.DIM3 Word8 -> IO Texture
+installTexture ar = do
+    [tex] <- GL.genObjectNames 1
+    GL.textureBinding GL.Texture2D GL.$= Just tex
+    let R.Z R.:. height R.:. width R.:. _ = R.extent ar
+    let siz = GL.TextureSize2D (gsizei width) (gsizei height)
+    withForeignPtr (RF.toForeignPtr ar)
+        $ GL.texImage2D GL.Texture2D GL.NoProxy 0 GL.RGBA8 siz 0
+        . GL.PixelData GL.ABGR GL.UnsignedInt8888
+    return (tex, fromIntegral width / 2, fromIntegral height / 2)
+
+releaseTexture :: Texture -> IO ()
+releaseTexture (tex, _, _) = GL.deleteObjectNames [tex]
+
+beginFrame :: System -> IO ()
+beginFrame sys = do
+    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]
+
+endFrame :: System -> IO Bool
+endFrame sys = do
+    GLFW.swapBuffers $ theWindow sys
+    GLFW.pollEvents
+    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)
+    GLFW.windowShouldClose (theWindow sys)
+
+withGLFW :: WindowMode -> BoundingBox Double -> (System -> IO a) -> IO a
+withGLFW full 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
+        FullScreen -> GLFW.getPrimaryMonitor
+        Windowed -> return Nothing
+
+    Just win <- GLFW.createWindow ww wh title mon Nothing
+    GLFW.makeContextCurrent (Just win)
+    GL.lineSmooth $= GL.Enabled
+    GL.blend      $= GL.Enabled
+    GL.blendFunc  $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
+    GL.shadeModel $= GL.Flat
+    GL.textureFunction $= GL.Combine
+    GLFW.swapInterval 1
+    GL.clearColor $= GL.Color4 1 1 1 1
+
+    sys <- System
+        <$> newIORef 0
+        <*> newIORef 0
+        <*> newIORef 60
+        <*> newIORef 60
+        <*> pure bbox
+        <*> pure win
+
+    res <- m sys
+
+    GLFW.destroyWindow win
+    GLFW.terminate
+    return res
+
+screenshotFlipped :: System -> IO (R.Array RF.F R.DIM3 Word8)
+screenshotFlipped sys = do
+    let BoundingBox x0 y0 x1 y1 = theRegion sys
+        w = floor $ x1 - x0
+        h = floor $ y1 - y0
+        sh = R.Z R.:. h R.:. w R.:. 4
+    
+    ptr <- mallocBytes (w * h * 4)
+    GL.readBuffer $= GL.FrontBuffers
+    GL.readPixels (GL.Position 0 0) (GL.Size (gsizei w) (gsizei h)) (GL.PixelData GL.RGBA GL.UnsignedByte ptr)
+
+    ptr' <- newForeignPtr_ ptr
+    return $ RF.fromForeignPtr sh ptr'
+
+screenshot :: System -> IO (R.Array RF.F R.DIM3 Word8)
+screenshot sys = screenshotFlipped sys >>= flipVertically 
+
+flipVertically :: Monad m => R.Array RF.F R.DIM3 Word8 -> m (R.Array RF.F R.DIM3 Word8)
+flipVertically img = R.computeP $ R.unsafeBackpermute e order img where
+    e@(R.Z R.:. r R.:. _ R.:. _) = R.extent img
+    order (R.Z R.:. y R.:. x R.:. c) = R.Z R.:. r - 1 - y R.:. x R.:. c
+    {-# INLINE order #-}
+ FreeGame/Internal/Raindrop.hs view
@@ -0,0 +1,32 @@+-----------------------------------------------------------------------------+-- |+-- 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
@@ -0,0 +1,47 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveFunctor #-}
+module FreeGame.Text (TextF(..), TextT, runTextT, runTextT_, text) where
+
+import Data.String
+import FreeGame.Types
+import FreeGame.Internal.Raindrop
+import FreeGame.Data.Font
+import FreeGame.Class
+import FreeGame.Instances ()
+import Control.Monad.Trans.Free
+import Control.Monad.State
+import Linear
+
+data TextF a = TypeChar Char a deriving Functor
+
+type TextT = FreeT TextF
+
+instance Monad m => IsString (TextT m ()) where
+    fromString str = mapM_ (\c -> liftF (TypeChar c ())) str
+
+-- | 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
+    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)
+            go cont
+        Free (TypeChar ch cont) -> do
+            RenderedChar bmp offset adv <- fromFinalizer $ charToBitmap font size ch
+            pen <- get
+            translate (pen + offset) $ bitmap bmp
+            let pen' = over _x (+adv) pen
+            put $ if cond pen'
+                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
+
+runTextT_ :: (FromFinalizer m, Monad m, Picture2D m) => Maybe (BoundingBox Double) -> Font -> Double -> TextT m () -> m ()
+runTextT_ = runTextT
+{-# INLINE runTextT_ #-}
+
+-- | Render a 'String'.
+text :: (FromFinalizer m, Monad m, Picture2D m) => Font -> Double -> String -> m ()
+text font size str = runTextT Nothing font size (fromString str)
+ FreeGame/Types.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveDataTypeable #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  FreeGame.Types
+-- Copyright   :  (C) 2013 Fumiaki Kinoshita
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  provisional
+-- Portability :  non-portable
+--
+----------------------------------------------------------------------------
+module FreeGame.Types (
+    WindowMode(..),
+    Vec2,
+    BoundingBox(..),
+    inBoundingBox,
+    _Corners, 
+    _TopLeft,
+    _TopRight,
+    _BottomLeft,
+    _BottomRight
+    , Key(..)
+    ) 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)
+
+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
+    | KeySpace
+    | KeyApostrophe
+    | KeyComma
+    | KeyMinus
+    | KeyPeriod
+    | KeySlash
+    | Key0
+    | Key1
+    | Key2
+    | Key3
+    | Key4
+    | Key5
+    | Key6
+    | Key7
+    | Key8
+    | Key9
+    | KeySemicolon
+    | KeyEqual
+    | KeyA
+    | KeyB
+    | KeyC
+    | KeyD
+    | KeyE
+    | KeyF
+    | KeyG
+    | KeyH
+    | KeyI
+    | KeyJ
+    | KeyK
+    | KeyL
+    | KeyM
+    | KeyN
+    | KeyO
+    | KeyP
+    | KeyQ
+    | KeyR
+    | KeyS
+    | KeyT
+    | KeyU
+    | KeyV
+    | KeyW
+    | KeyX
+    | KeyY
+    | KeyZ
+    | KeyLeftBracket
+    | KeyBackslash
+    | KeyRightBracket
+    | KeyGraveAccent
+    | KeyWorld1
+    | KeyWorld2
+    | KeyEscape
+    | KeyEnter
+    | KeyTab
+    | KeyBackspace
+    | KeyInsert
+    | KeyDelete
+    | KeyRight
+    | KeyLeft
+    | KeyDown
+    | KeyUp
+    | KeyPageUp
+    | KeyPageDown
+    | KeyHome
+    | KeyEnd
+    | KeyCapsLock
+    | KeyScrollLock
+    | KeyNumLock
+    | KeyPrintScreen
+    | KeyPause
+    | KeyF1
+    | KeyF2
+    | KeyF3
+    | KeyF4
+    | KeyF5
+    | KeyF6
+    | KeyF7
+    | KeyF8
+    | KeyF9
+    | KeyF10
+    | KeyF11
+    | KeyF12
+    | KeyF13
+    | KeyF14
+    | KeyF15
+    | KeyF16
+    | KeyF17
+    | KeyF18
+    | KeyF19
+    | KeyF20
+    | KeyF21
+    | KeyF22
+    | KeyF23
+    | KeyF24
+    | KeyF25
+    | KeyPad0
+    | KeyPad1
+    | KeyPad2
+    | KeyPad3
+    | KeyPad4
+    | KeyPad5
+    | KeyPad6
+    | KeyPad7
+    | KeyPad8
+    | KeyPad9
+    | KeyPadDecimal
+    | KeyPadDivide
+    | KeyPadMultiply
+    | KeyPadSubtract
+    | KeyPadAdd
+    | KeyPadEnter
+    | KeyPadEqual
+    | KeyLeftShift
+    | KeyLeftControl
+    | KeyLeftAlt
+    | KeyLeftSuper
+    | KeyRightShift
+    | KeyRightControl
+    | KeyRightAlt
+    | KeyRightSuper
+    | KeyMenu
+    deriving (Enum, Eq, Ord, Read, Show, Typeable)
+
+instance Bounded Key where
+    minBound = KeyUnknown
+    maxBound = KeyMenu
+ FreeGame/UI.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE DeriveFunctor, ExistentialQuantification, Rank2Types #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  FreeGame.UI
+-- Copyright   :  (C) 2013 Fumiaki Kinoshita
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  provisional
+-- Portability :  non-portable
+-- Provides the "free" embodiment.
+----------------------------------------------------------------------------
+module FreeGame.UI (
+    UI(..)
+    , Frame
+    , Game
+    , FreeGame(..)
+) where
+
+import FreeGame.Class
+import FreeGame.Internal.Finalizer
+import FreeGame.Types
+import Control.Applicative
+import qualified Data.Map as Map
+import FreeGame.Data.Bitmap (Bitmap)
+import Data.Color
+import Control.Monad.Free.Church
+import Control.Monad.Trans.Iter
+
+data UI a =
+    Draw (forall m. (Applicative m, Monad m, Picture2D m, Local m) => m a)
+    | PreloadBitmap Bitmap a
+    | FromFinalizer (FinalizerT IO a)
+    | KeyStates (Map.Map Key Bool -> Map.Map Key Bool -> a)
+    | MouseButtons (Map.Map Int Bool -> Map.Map Int Bool -> a)
+    | MousePosition (Vec2 -> a)
+    | TakeScreenshot (Bitmap -> a)
+    | Bracket (Frame a)
+    | SetFPS Int a
+    | SetTitle String a
+    | ShowCursor a
+    | HideCursor a
+    | ClearColor Color a
+    | GetFPS (Int -> a)
+    deriving Functor
+
+type Game = IterT Frame
+
+type Frame = F UI
+
+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
+    -- | 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
+    -- | Generate a 'Bitmap' from the front buffer.
+    takeScreenshot :: m Bitmap
+
+    setFPS :: Int -> m ()
+    setTitle :: String -> m ()
+    showCursor :: m ()
+    hideCursor :: m ()
+    clearColor :: Color -> m ()
+    getFPS :: m Int
+
+instance FreeGame UI where
+    draw = Draw
+    {-# INLINE draw #-}
+    preloadBitmap bmp = PreloadBitmap bmp ()
+    {-# INLINE preloadBitmap #-}
+    bracket = Bracket
+    {-# INLINE bracket #-}
+    takeScreenshot = TakeScreenshot id
+    setFPS a = SetFPS a ()
+    setTitle t = SetTitle t ()
+    showCursor = ShowCursor ()
+    hideCursor = HideCursor ()
+    clearColor c = ClearColor c ()
+    getFPS = GetFPS id
+
+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)
+overDraw _ x = x
+{-# INLINE overDraw #-}
+
+instance Affine UI where
+    translate v = overDraw (translate v)
+    {-# INLINE translate #-}
+    rotateR t = overDraw (rotateR t)
+    {-# INLINE rotateR #-}
+    rotateD t = overDraw (rotateD t)
+    {-# INLINE rotateD #-}
+    scale v = overDraw (scale v)
+    {-# INLINE scale #-}
+
+instance Picture2D UI where
+    bitmap x = Draw (bitmap x)
+    line vs = Draw (line vs)
+    polygon vs = Draw (polygon vs)
+    polygonOutline vs = Draw (polygonOutline vs)
+    circle r = Draw (circle r)
+    circleOutline r = Draw (circleOutline r)
+    thickness t = overDraw (thickness t)
+    color c = overDraw (color c)
+
+instance Local UI where
+    getLocation = Draw getLocation
+
+instance FromFinalizer UI where
+    fromFinalizer = FromFinalizer
+
+instance Keyboard UI where
+    keyStates_ = KeyStates (,)
+
+instance Mouse UI where
+    globalMousePosition = MousePosition id
+    -- mouseWheel = MouseWheel id
+    mouseButtons_ = MouseButtons (,)
+ FreeGame/Util.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE TemplateHaskell #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  FreeGame.Util
+-- Copyright   :  (C) 2013 Fumiaki Kinoshita
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+----------------------------------------------------------------------------
+
+module FreeGame.Util (
+    -- * Controlling
+    tick,
+    foreverTick,
+    foreverFrame,
+    untick,
+    untickInfinite,
+    -- * Random
+    randomness,
+    -- * Helper
+    degrees,
+    radians,
+    unitV2,
+    angleV2,
+    -- * Loading
+    loadPictureFromFile,
+    loadBitmaps,
+    loadBitmapsWith
+    ) where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Free.Class
+import Control.Monad.Trans.Iter
+import Control.Monad.Trans
+import Control.Monad.Free.Church
+import Data.Char
+import Data.Void
+import FreeGame.Data.Bitmap
+import FreeGame.Class
+import Language.Haskell.TH
+import Linear
+import System.Directory
+import System.FilePath
+import System.IO.Unsafe
+import System.Random
+import System.Environment
+
+-- | Delimit the computation to yield a frame.
+tick :: (Monad f, MonadFree f m) => m ()
+tick = delay (return ())
+
+-- | 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')
+
+-- | @foreverFrame :: Frame a -> Game any@
+foreverFrame :: (Monad f, Monad m, MonadTrans t, MonadFree f (t m)) => m a -> t m any
+foreverFrame m = foreverTick (lift m)
+
+-- | Extract the next frame of the action.
+untick :: (Functor f, MonadFree f m) => IterT (F f) a -> m (Either (IterT (F f) a) a)
+untick = liftM (either Right Left) . iterM wrap . runIterT where
+
+-- | An infinite version of 'untick'.
+untickInfinite :: (Functor f, MonadFree f m) => IterT (F f) Void -> m (IterT (F f) Void)
+untickInfinite = liftM (either absurd id) . iterM wrap . runIterT where
+
+-- | An unit vector with the specified angle.
+unitV2 :: Floating a => a -> V2 a
+unitV2 t = V2 (cos t) (sin t)
+
+-- | An angle of the given vector.
+angleV2 :: RealFloat a => V2 a -> a
+angleV2 (V2 a b) = atan2 b a
+
+-- | Get a given range of value.
+randomness :: (Random r, FromFinalizer m) => (r, r) -> m r
+randomness r = embedIO $ randomRIO r
+{-# INLINE randomness #-}
+
+-- | Convert radians to degrees.
+degrees :: Floating a => a -> a
+{-# INLINE degrees #-}
+degrees x = x / pi * 180
+
+-- | Convert degrees to radians.
+radians :: Floating a => a -> a
+{-# INLINE radians #-}
+radians x = x / 180 * pi
+
+-- | Create a 'Picture' from the given file.
+loadPictureFromFile :: (Picture2D p, FromFinalizer m) => FilePath -> m (p ())
+loadPictureFromFile = embedIO . fmap bitmap . readBitmap
+
+-- | The type of the given 'Name' must be @FilePath -> IO FilePath@
+loadBitmapsWith :: ExpQ -> 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 $ loc </> p) []]
+            ]
+    where
+        load name fp = do
+            runIO $ putStrLn $ "Defined: " ++ fp ++ " as `" ++ name ++ "'"
+
+            appE (varE 'unsafePerformIO) $ uInfixE (appE getFullPath $ litE $ StringL fp)
+                (varE '(>>=))
+                (varE 'readBitmap)
+
+-- | Load and define all pictures in the specified directory.
+loadBitmaps :: FilePath -> Q [Dec]
+loadBitmaps path = do
+    v <- newName "v"
+    loadBitmapsWith (lamE [varP v] $
+        appsE [varE 'fmap, uInfixE
+                    (infixE Nothing (varE '(</>)) (Just (varE v)))
+                    (varE '(.))
+                    (varE 'takeDirectory)
+                , varE 'getExecutablePath]) path
+
+getFileList :: 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
+
+pathToName :: FilePath -> String
+pathToName = ('_':) . map p where
+    p c | isAlphaNum c = c
+        | otherwise = '_'
− Graphics/UI/FreeGame.hs 
@@ -1,69 +0,0 @@-{-|
-Module      :  Graphics.UI.FreeGame
-Copyright   :  (C) 2013 Fumiaki Kinoshita
-License     :  BSD-style (see the file LICENSE)
-Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
-
-This module just re-exports other submodules.
--}
-module Graphics.UI.FreeGame
-  ( -- * Main
-    Game,
-    runGame,
-    def,
-    -- * Reexports
-    module Graphics.UI.FreeGame.Base,
-    module Graphics.UI.FreeGame.Data.Bitmap,
-    module Graphics.UI.FreeGame.Data.Font,
-    module Graphics.UI.FreeGame.GUI,
-    module Graphics.UI.FreeGame.Util,
-    module Graphics.UI.FreeGame.Text,
-    module Graphics.UI.FreeGame.Types,
-    module Control.Monad,
-    module Control.Applicative,
-    module Control.Bool,
-    module Data.Color,
-    module Data.Color.Names,
-    module Linear
-) where
-
-import Graphics.UI.FreeGame.Base
-import Graphics.UI.FreeGame.GUI (GUI, GUIParam(..))
-import Graphics.UI.FreeGame.Util
-import Graphics.UI.FreeGame.Types
-import Graphics.UI.FreeGame.Text
-import Graphics.UI.FreeGame.Data.Bitmap
-import Graphics.UI.FreeGame.Data.Font
-import qualified Graphics.UI.FreeGame.GUI.GLFW as GLFW
-import Control.Monad.Free.Church
-import Data.Default
-import Control.Monad
-import Control.Applicative
-import Control.Bool
-import Data.Color
-import Data.Color.Names
-import Linear hiding (rotate)
-
--- | 'Game' is a "free" monad which describes GUIs.
--- This monad is an instance of 'Picture2D' so you can construct it using 'fromBitmap' and can be transformed with 'translate', 'scale', 'rotate', 'colored'.
---
--- It is also an instance of 'Keyboard' and 'Mouse'. Note that 'mousePosition' returns a relative position. For example:
---
--- > foo = foreverTick $ do
--- >   p <- mousePosition
--- >   translate p $ colored blue $ polygonOutline [V2 (-8) (-8), V2 8 (-8), V2 8 8, V2 (-8) 8]
--- 
--- When we run @foo@ using 'runGame', a blue square follows the cursor.
--- And 'translate' (V2 240 240) @foo@, 'rotate' 45 @foo@, 'scale' 1.5 @foo@ also does in the same way.
---
--- You have to call 'tick' at the end of the frame.
---
--- The only way to embody a 'Game' as a real stuff is to apply 'runGame'.
---
--- for more examples, see <https://github.com/fumieval/free-game/tree/master/examples>.
-
-type Game = F GUI
-
--- | Run a 'Game'.
-runGame :: GUIParam -> Game a -> IO (Maybe a)
-runGame = GLFW.runGame
− Graphics/UI/FreeGame/Base.hs 
@@ -1,354 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Graphics.UI.FreeGame.Base--- Copyright   :  (C) 2012-2013 Fumiaki Kinoshita--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability   :  experimental--- Portability :  non-portable----------------------------------------------------------------------------------module Graphics.UI.FreeGame.Base (-    -- * Types-    UI(..)-    ,Vec2-    -- * Basic operations-    ,tick-    ,bracket-    ,_Bracket-    ,quit-    ,embedIO-    ,_EmbedIO-    ,liftUI-    ,_LiftUI-    ,getFPS--    -- * Classes-    ,Picture2D(..)-    ,rotate-    ,Figure2D(..)-    ,Keyboard(..)-    ,Mouse(..)-    ,FromFinalizer(..)-    ,SpecialKey(..)-) where--import Control.Applicative-import Control.Applicative.Free as Ap-import Control.Monad.IO.Class-import Data.Monoid-import Data.Color-import Graphics.UI.FreeGame.Data.Bitmap-import Graphics.UI.FreeGame.Internal.Finalizer-import Graphics.UI.FreeGame.Internal.Raindrop-import Linear hiding (rotate)--import Control.Monad.Free.Class-import Control.Monad.Free.Church-import qualified Control.Monad.Free as Free--import Control.Monad.Trans-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Cont-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.List-import Control.Monad.Trans.Error-import Control.Monad.Trans.Identity-import qualified Control.Monad.State.Lazy as Lazy-import qualified Control.Monad.State.Strict as Strict-import qualified Control.Monad.Writer.Lazy as Lazy-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--infixr 5 `translate`-infixr 5 `rotate`-infixr 5 `scale`-infixr 5 `colored`--type Vec2 = V2 Float--instance (Functor m) => MonadIO (F (UI m)) where-    liftIO = embedIO--instance (Functor m) => MonadIO (Free.Free (UI m)) where-    liftIO = embedIO---- | A functor enriches given functor with control structure.-data UI m a-    = Tick a-    | EmbedIO (IO a)-    | LiftUI (m a)-    | Bracket (F (UI m) a)-    | GetFPS (Int -> a)-    | Quit-    deriving Functor---- | Finalize the current frame and refresh the screen.-tick :: MonadFree (UI n) m => m ()-tick = wrap $ Tick (return ())---- | Run a Game monad in a Game monad. Resources (e.g. pictures) will be released when inner computation is done.-bracket :: MonadFree (UI n) m => F (UI n) a -> m a-bracket = wrap . Bracket . fmap return---- | Break the entire computation.-quit :: MonadFree (UI n) m => m a-quit = wrap Quit---- | Lift 'UI''s base functor.-liftUI :: (Functor n, MonadFree (UI n) m) => n a -> m a-liftUI = wrap . LiftUI . fmap return---- | Lift an arbitrary 'IO' action.-embedIO :: (MonadFree (UI n) m) => IO a -> m a-embedIO = wrap . EmbedIO . fmap return--getFPS :: MonadFree (UI n) m => m Int-getFPS = wrap $ GetFPS return---- | @'_EmbedIO' :: Traversal' ('UI' m a) (IO a)@-_EmbedIO :: Applicative f => (IO a -> f (IO a)) -> UI m a -> f (UI m a)-_EmbedIO f (EmbedIO m) = fmap EmbedIO (f m)-_EmbedIO _ x = pure x---- | @'_Bracket' :: Traversal' ('UI' m a) (F (UI m) a)@-_Bracket :: Applicative f => (F (UI m) a -> f (F (UI m) a)) -> UI m a -> f (UI m a)-_Bracket f (Bracket m) = fmap Bracket (f m)-_Bracket _ x = pure x---- | @'_LiftUI' :: Traversal' ('UI' m a) (m a)@-_LiftUI :: Applicative f => (m a -> f (m a)) -> UI m a -> f (UI m a)-_LiftUI f (LiftUI m) = fmap LiftUI (f m)-_LiftUI _ x = pure x--hoistFreeR :: (Functor f, MonadFree g m) => (f (m a) -> g (m a)) -> Free.Free f a -> m a-hoistFreeR _ (Free.Pure a) = return a-hoistFreeR t (Free.Free f) = wrap . t $ fmap (hoistFreeR t) f-{-# INLINE[~4] hoistFreeR #-}--hoistFR :: MonadFree g m => (f (m a) -> g (m a)) -> F f a -> m a-hoistFR t (F m) = m return (wrap . t)-{-# INLINE[~4] hoistFR #-}--{-# RULES-"hoistFreeR/hoistFreeR"[5]   forall f g m. hoistFreeR f (hoistFreeR g m) = hoistFreeR (f . g) m-"hoistFR/hoistFR"[5]     forall f g m. hoistFR f (hoistFR g m) = hoistFR (f . g) m- #-}---- | The class of types that can be regarded as a kind of picture.-class Picture2D p where-    -- | Construct a 'Picture2D' from a 'Bitmap'.-    fromBitmap :: Bitmap -> p ()-    -- | (radians)-    rotateR :: Float -> p a -> p a-    -- | (degrees)-    rotateD :: Float -> p a -> p a-    scale :: Vec2 -> p a -> p a-    translate :: Vec2 -> p a -> p a-    colored :: Color -> p a -> p a--    rotateR = rotateD . (* 180) . (/ pi)-    rotateD = rotateR . (/ 180) . (* pi)---- | Deprecated synonym for 'rotateD'.-rotate :: Picture2D p => Float -> p a -> p a-rotate = rotateD--{-# DEPRECATED rotate "Use rotateD instead" #-} --class Picture2D p => Figure2D p where-    line :: [Vec2] -> p ()-    polygon :: [Vec2] -> p ()-    polygonOutline :: [Vec2] -> p ()-    circle :: Float -> p ()-    circleOutline :: Float -> p ()-    thickness :: Float -> p a -> p a---- | The class of types that can handle inputs of the keyboard.-class Keyboard t where-    keyChar :: Char -> t Bool-    keySpecial :: SpecialKey -> t Bool---- | The class of types that can handle inputs of the mouse.-class Mouse t where-    mousePosition :: t Vec2-    mouseWheel :: t Int-    mouseButtonL :: t Bool-    mouseButtonM :: t Bool-    mouseButtonR :: t Bool--class FromFinalizer m where-    fromFinalizer :: FinalizerT IO a -> m a--instance FromFinalizer (FinalizerT IO) where-    fromFinalizer = id--data SpecialKey = KeySpace-    | KeyEsc-    | KeyLeftShift-    | KeyRightShift-    | KeyLeftControl-    | KeyRightControl-    | KeyUp-    | KeyDown-    | KeyLeft-    | KeyRight-    | KeyTab-    | KeyEnter-    | KeyBackspace-    | KeyInsert-    | KeyDelete-    | KeyPageUp-    | KeyPageDown-    | KeyHome-    | KeyEnd-    | KeyF1-    | KeyF2-    | KeyF3-    | KeyF4-    | KeyF5-    | KeyF6-    | KeyF7-    | KeyF8-    | KeyF9-    | KeyF10-    | KeyF11-    | KeyF12-    | KeyPad0-    | KeyPad1-    | KeyPad2-    | KeyPad3-    | KeyPad4-    | KeyPad5-    | KeyPad6-    | KeyPad7-    | KeyPad8-    | KeyPad9-    | KeyPadDivide-    | KeyPadMultiply-    | KeyPadSubtract-    | KeyPadAdd-    | KeyPadDecimal-    | KeyPadEqual-    | KeyPadEnter-    deriving (Show, Eq, Ord, Enum)--#define _COMMA_ ,--#define MK_PICTURE_2D(cxt, ty, l, t) instance (Picture2D m cxt) => Picture2D (ty) where { \-    fromBitmap = (l) . fromBitmap; \-    rotateD = (t) . rotateD; \-    rotateR = (t) . rotateR; \-    translate = (t) . translate; \-    scale = (t) . scale; \-    colored = (t) . colored }--#define MK_FIGURE_2D(cxt, ty, l, t) instance (Figure2D m cxt) => Figure2D (ty) where { \-    line = (l) . line; \-    polygon = (l) . polygon; \-    polygonOutline = (l) . polygonOutline; \-    circle = (l) . circle; \-    circleOutline = (l) . circleOutline; \-    thickness = (t) . thickness }--#define MK_KEYBOARD(cxt, ty, l) instance (Keyboard m cxt) => Keyboard (ty) where { \-    keyChar = (l) . keyChar; \-    keySpecial = (l) . keySpecial }--#define MK_MOUSE(cxt, ty, l) instance (Mouse m cxt) => Mouse (ty) where { \-    mousePosition = (l) mousePosition; \-    mouseWheel = (l) mouseWheel; \-    mouseButtonL = (l) mouseButtonL; \-    mouseButtonR = (l) mouseButtonR; \-    mouseButtonM = (l) mouseButtonM }--#define MK_FROM_FINALIZER(cxt, ty, l) instance (FromFinalizer m cxt) => FromFinalizer (ty) where { \-    fromFinalizer = (l) . fromFinalizer }--MK_PICTURE_2D(_COMMA_ Functor m, F m, liftF, hoistFR)-MK_PICTURE_2D( , UI m, LiftUI, over _LiftUI)-MK_PICTURE_2D(_COMMA_ Functor m, Free.Free m, Free.liftF, hoistFreeR)-MK_PICTURE_2D(_COMMA_ Monad m, ReaderT r m, lift, mapReaderT)-MK_PICTURE_2D(_COMMA_ Monad m, Lazy.StateT s m, lift, Lazy.mapStateT)-MK_PICTURE_2D(_COMMA_ Monad m, Strict.StateT s m, lift, Strict.mapStateT)-MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift, Lazy.mapWriterT)-MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift, Strict.mapWriterT)-MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift, Lazy.mapRWST)-MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift, Strict.mapRWST)-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)-MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift, mapErrorT)-MK_PICTURE_2D(_COMMA_ Monad m, ContT r m, lift, mapContT)--MK_FIGURE_2D(_COMMA_ Functor m, F m, liftF, hoistFR)-MK_FIGURE_2D( , UI m, LiftUI, over _LiftUI)-MK_FIGURE_2D(_COMMA_ Functor m, Free.Free m, Free.liftF, hoistFreeR)-MK_FIGURE_2D(_COMMA_ Monad m, ReaderT r m, lift, mapReaderT)-MK_FIGURE_2D(_COMMA_ Monad m, Lazy.StateT s m, lift, Lazy.mapStateT)-MK_FIGURE_2D(_COMMA_ Monad m, Strict.StateT s m, lift, Strict.mapStateT)-MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift, Lazy.mapWriterT)-MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift, Strict.mapWriterT)-MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift, Lazy.mapRWST)-MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift, Strict.mapRWST)-MK_FIGURE_2D(_COMMA_ Monad m, IdentityT m, lift, mapIdentityT)-MK_FIGURE_2D(_COMMA_ Monad m, MaybeT m, lift, mapMaybeT)-MK_FIGURE_2D(_COMMA_ Monad m, ListT m, lift, mapListT)-MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift, mapErrorT)-MK_FIGURE_2D(_COMMA_ Monad m, ContT r m, lift, mapContT)--MK_KEYBOARD(, Ap m, liftAp)-MK_KEYBOARD(, UI m, LiftUI)-MK_KEYBOARD(_COMMA_ Functor m, F m, liftF)-MK_KEYBOARD(_COMMA_ Functor m, Free.Free m, Free.liftF)-MK_KEYBOARD(_COMMA_ Monad m, ReaderT s m, lift)-MK_KEYBOARD(_COMMA_ Monad m, Lazy.StateT s m, lift)-MK_KEYBOARD(_COMMA_ Monad m, Strict.StateT s m, lift)-MK_KEYBOARD(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift)-MK_KEYBOARD(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift)-MK_KEYBOARD(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift)-MK_KEYBOARD(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift)-MK_KEYBOARD(_COMMA_ Monad m, IdentityT m, lift)-MK_KEYBOARD(_COMMA_ Monad m, MaybeT m, lift)-MK_KEYBOARD(_COMMA_ Monad m, ListT m, lift)-MK_KEYBOARD(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift)-MK_KEYBOARD(_COMMA_ Monad m, ContT r m, lift)--MK_MOUSE(, Ap m, liftAp)-MK_MOUSE(, UI m, LiftUI)-MK_MOUSE(_COMMA_ Functor m, F m, liftF)-MK_MOUSE(_COMMA_ Functor m, Free.Free m, Free.liftF)-MK_MOUSE(_COMMA_ Monad m, ReaderT r m, lift)-MK_MOUSE(_COMMA_ Monad m, Lazy.StateT s m, lift)-MK_MOUSE(_COMMA_ Monad m, Strict.StateT s m, lift)-MK_MOUSE(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift)-MK_MOUSE(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift)-MK_MOUSE(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift)-MK_MOUSE(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift)-MK_MOUSE(_COMMA_ Monad m, IdentityT m, lift)-MK_MOUSE(_COMMA_ Monad m, MaybeT m, lift)-MK_MOUSE(_COMMA_ Monad m, ListT m, lift)-MK_MOUSE(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift)-MK_MOUSE(_COMMA_ Monad m, ContT r m, lift)--MK_FROM_FINALIZER(, UI m, LiftUI)-MK_FROM_FINALIZER(_COMMA_ Functor m, F m, liftF)-MK_FROM_FINALIZER(_COMMA_ Functor m, Free.Free m, Free.liftF)-MK_FROM_FINALIZER(_COMMA_ Monad m, Lazy.StateT s m, lift)-MK_FROM_FINALIZER(_COMMA_ Monad m, Strict.StateT s m, lift)-MK_FROM_FINALIZER(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift)-MK_FROM_FINALIZER(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift)-MK_FROM_FINALIZER(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift)-MK_FROM_FINALIZER(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift)-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)-MK_FROM_FINALIZER(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift)-MK_FROM_FINALIZER(_COMMA_ Monad m, ContT r m, lift)
− Graphics/UI/FreeGame/Data/Bitmap.hs 
@@ -1,94 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.FreeGame.Data.Bitmap
--- Copyright   :  (C) 2013 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
--- Manipulating bitmaps
-----------------------------------------------------------------------------
-
-module Graphics.UI.FreeGame.Data.Bitmap (
-    -- * Basic types and functions
-    Bitmap(..)
-    , _BitmapArray
-    , _BitmapHash
-    ,bitmapSize
-
-    -- * Loading from a file
-    ,loadBitmapFromFile
-
-    -- * Constructing bitmaps
-    ,toBitmap
-    ,toStableBitmap
-    ,makeStableBitmap
-
-    -- * Bitmap operations
-    ,onBitmapWithHashable
-    ,cropBitmap
-    
-    ) where
-
-import Control.Applicative
-import Codec.Picture.Repa
-import Data.Array.Repa as R
-import qualified Data.Array.Repa.Repr.ForeignPtr as RF
-import Data.Word
-import System.Random
-import Data.Hashable
-import Control.Monad.IO.Class
-
--- | Concrete bitmap data. Internal representation is stored as y * x * RGBA.
-data Bitmap = BitmapData (R.Array RF.F DIM3 Word8) (Maybe Int) -- ^ This value is used to ensure that two bitmaps are equivalent.
-
-instance Show Bitmap where
-    show (BitmapData _ h) = "<BitmapData #" Prelude.++ show h Prelude.++ ">"
-
-instance Eq Bitmap where
-    BitmapData _ h == BitmapData _ h' = h == h'
-
-instance Ord Bitmap where
-    BitmapData _ h <= BitmapData _ h' = h <= h'
-
--- | @'_BitmapArray' :: Lens' 'Bitmap' ('R.Array' 'RF.F' 'DIM3' 'Word8')@
-_BitmapArray :: Functor f => (R.Array RF.F DIM3 Word8 -> f (R.Array RF.F DIM3 Word8)) -> Bitmap -> f Bitmap
-_BitmapArray f (BitmapData a h) = fmap (\a' -> BitmapData a' h) (f a)
-
--- | @'_BitmapHash' :: Lens' 'Bitmap' ('Maybe' 'Int')@
-_BitmapHash :: Functor f => (Maybe Int -> f (Maybe Int)) -> Bitmap -> f Bitmap
-_BitmapHash f (BitmapData a h) = fmap (\h' -> BitmapData a h') (f h)
-
--- | Create unstable 'Bitmap' from the given array.
-toBitmap :: R.Array RF.F DIM3 Word8 -> Bitmap
-toBitmap ar = BitmapData ar Nothing
-
--- | Create stable 'Bitmap' from the given array and compute the hash.
-toStableBitmap :: R.Array RF.F DIM3 Word8 -> Bitmap
-toStableBitmap ar = BitmapData ar $ Just $ foldAllS combine 0 $ R.map fromIntegral ar where
-    combine p q = hash (p, q)
-
--- | Create stable 'Bitmap' with unique hash from the given array.
-makeStableBitmap :: R.Array RF.F DIM3 Word8 -> IO Bitmap
-makeStableBitmap ar = BitmapData ar <$> Just <$> randomIO
-
--- | Get the size of the 'Bitmap'.
-bitmapSize :: Bitmap -> (Int, Int)
-bitmapSize (BitmapData a _) = let (Z :. h :. w :. _) = R.extent a in (w, h)
-
--- | Create a 'Bitmap' from the given file.
-loadBitmapFromFile :: MonadIO m => FilePath -> m Bitmap
-loadBitmapFromFile path = liftIO $ readImageRGBA path >>= either fail return >>= makeStableBitmap . imgData . reverseColorChannel
-
--- | Convert the 'Bitmap' uniformalized by the 'Hashable' value by the given function.
-onBitmapWithHashable :: Hashable h => h -> (R.Array RF.F DIM3 Word8 -> R.Array RF.F DIM3 Word8) -> Bitmap -> Bitmap
-onBitmapWithHashable v f (BitmapData ar h) = BitmapData (f ar) (hash <$> (,) v <$> h)
-
--- | Extract a 'Bitmap' from the specified range.
-cropBitmap :: Bitmap -- ^original bitmap
-    -> (Int, Int) -- ^width and height
-    -> (Int, Int) -- ^x and y
-    -> Bitmap -- ^result
-cropBitmap bmp (w, h) (x, y) = onBitmapWithHashable (w*4421,h*4441,x*3581,y*3571) (computeS . extract (Z :. y :. x :. 0) (Z :. h :. w :. 4)) bmp
− Graphics/UI/FreeGame/Data/Font.hs 
@@ -1,144 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.FreeGame.Data.Font
--- Copyright   :  (C) 2013 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  provisional
--- Portability :  non-portable
---
--- Rendering characters
-----------------------------------------------------------------------------
-module Graphics.UI.FreeGame.Data.Font 
-  ( Font
-  , loadFont
-  , fontBoundingBox
-  , metricsAscent
-  , metricsDescent
-  , charToBitmap
-  , RenderedChar(..)
-  ) where
-
-import Control.Applicative
-import Control.Monad.IO.Class
-import Data.IORef
-import Data.Array.Repa as R
-import Data.Array.Repa.Eval
-import qualified Data.Map as M
-import Data.Word
-import Linear
-import Graphics.UI.FreeGame.Base
-import Graphics.UI.FreeGame.Types
-import Graphics.UI.FreeGame.Data.Bitmap
-import Graphics.UI.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
-import Graphics.Rendering.FreeType.Internal.Bitmap as B
-import Graphics.Rendering.FreeType.Internal.PrimitiveTypes as PT
-import Graphics.Rendering.FreeType.Internal.Face as F
-import Graphics.Rendering.FreeType.Internal.Library as L
-import Graphics.Rendering.FreeType.Internal.BBox as BB
-import Foreign.Marshal.Alloc
-import Foreign.C.Types
-import Foreign.C.String
-import Foreign.Storable
-import System.IO.Unsafe
-import Unsafe.Coerce
-
--- | Font object
-data Font = Font FT_Face (Float, Float) (BoundingBox Float) (IORef (M.Map (Float, Char) RenderedChar))
-
--- | Create a 'Font' from the given file.
-loadFont :: MonadIO m => FilePath -> m Font
-loadFont path = liftIO $ alloca $ \p -> do
-    runFreeType $ withCString path $ \str -> ft_New_Face freeType str 0 p
-    f <- peek p
-    b <- peek (bbox f)
-    asc <- peek (ascender f)
-    desc <- peek (descender f)
-    u <- fromIntegral <$> peek (units_per_EM f)
-    let box = BoundingBox (fromIntegral (xMin b)/u) (fromIntegral (yMin b)/u)
-                          (fromIntegral (xMax b)/u) (fromIntegral (yMax b)/u)
-    Font f (fromIntegral asc/u, fromIntegral desc/u) box <$> newIORef M.empty
-
--- | Get the font's metrics.
-metricsAscent :: Font -> Float
-metricsAscent (Font _ (a, _) _ _) = a
-
--- | Get the font's metrics.
-metricsDescent :: Font -> Float
-metricsDescent (Font _ (_, d) _ _) = d
-
--- | Get the font's boundingbox.
-fontBoundingBox :: Font -> BoundingBox Float
-fontBoundingBox (Font _ _ b _) = b
-
-runFreeType :: IO CInt -> IO ()
-runFreeType m = do
-    r <- m
-    case r of
-        0 -> return ()
-        e -> fail $ "FreeType Error:" Prelude.++ show e
-
-freeType :: FT_Library
-freeType = unsafePerformIO $ alloca $ \p -> do
-    runFreeType $ ft_Init_FreeType p
-    peek p
-
-data RenderedChar = RenderedChar
-    { charBitmap :: Bitmap
-    , charOffset :: V2 Float
-    ,　charAdvance :: Float
-    }
-
--- | The resolution used to render fonts.
-resolutionDPI :: Int
-resolutionDPI = 300
-
-charToBitmap :: FromFinalizer m => Font -> Float -> Char -> m RenderedChar
-charToBitmap (Font face _ _ refCache) pixel ch = fromFinalizer $ do
-    cache <- liftIO $ readIORef refCache
-    case M.lookup (siz, ch) cache of
-        Nothing -> do
-            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
-        siz = pixel * 72 / fromIntegral resolutionDPI
-        render = do
-            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
-
-            slot <- peek $ glyph face
-            runFreeType $ ft_Render_Glyph slot ft_RENDER_MODE_NORMAL
-
-            bmp <- peek $ GS.bitmap slot
-            left <- fmap fromIntegral $ peek $ GS.bitmap_left slot
-            top <- fmap fromIntegral $ peek $ GS.bitmap_top slot
-
-            let h = fromIntegral $ B.rows bmp
-                w = fromIntegral $ B.width bmp
-                
-            mv <- newMVec (w * h)
-
-            fillChunkedIOP (w * h) (unsafeWriteMVec mv) $ const $ return
-                $ fmap unsafeCoerce . peekElemOff (buffer bmp)
-
-            adv <- peek $ GS.advance slot
-
-            ar <- unsafeFreezeMVec (Z:.h:.w) mv :: IO (R.Array U DIM2 Word8)
-
-            let pix (crd:.0) = R.index ar crd
-                pix (_:._) = 255
-
-            result <- computeP (fromFunction (Z:.h:.w:.4) pix) >>= makeStableBitmap
-            
-            return $ RenderedChar result (V2 left (-top)) (fromIntegral (V.x adv) / 64)
− Graphics/UI/FreeGame/GUI.hs 
@@ -1,98 +0,0 @@-{-# LANGUAGE DeriveFunctor, BangPatterns #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.FreeGame.GUI
--- Copyright   :  (C) 2013 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  provisional
--- Portability :  non-portable
--- Provides the "free" embodiment.
-----------------------------------------------------------------------------
-module Graphics.UI.FreeGame.GUI (
-    GUI
-    , GUIBase(..)
-    , GUIParam(..)
-) where
-
-import Graphics.UI.FreeGame.Base
-import Graphics.UI.FreeGame.Data.Bitmap
-import Graphics.UI.FreeGame.Internal.Finalizer
-import Graphics.UI.FreeGame.Types
-import Data.Default
-import Data.Color
-
--- | A 'Functor' which represents graphical user interfaces.
-type GUI = UI GUIBase
-
--- | The base of 'GUI'.
-data GUIBase a = FromBitmap Bitmap a
-    | FromFinalizer (FinalizerT IO a)
-    | RotateD Float (GUIBase a)
-    | Scale Vec2 (GUIBase a)
-    | Translate Vec2 (GUIBase a)
-    | Colored Color (GUIBase a)
-    | Line [Vec2] a
-    | Polygon [Vec2] a
-    | PolygonOutline [Vec2] a
-    | Circle Float a
-    | CircleOutline Float a
-    | Thickness Float (GUIBase a)
-    | KeyChar Char (Bool -> a)
-    | KeySpecial SpecialKey (Bool -> a)
-    | MousePosition (Vec2 -> a)
-    | MouseWheel (Int -> a)
-    | MouseButtonL (Bool -> a)
-    | MouseButtonM (Bool -> a)
-    | MouseButtonR (Bool -> a)
-    deriving Functor
-
-instance Picture2D GUIBase where
-    fromBitmap b = FromBitmap b ()
-    rotateD = RotateD
-    scale = Scale
-    translate = Translate
-    colored = Colored
-
-instance Figure2D GUIBase where
-    line = flip Line ()
-    polygon = flip Polygon ()
-    polygonOutline = flip PolygonOutline ()
-    circle = flip Circle ()
-    circleOutline = flip CircleOutline ()
-    thickness = Thickness
-
-instance Keyboard GUIBase where
-    keyChar x = KeyChar x id
-    keySpecial x = KeySpecial x id
-
-instance Mouse GUIBase where
-    mousePosition = MousePosition id
-    mouseWheel = MouseWheel id
-    mouseButtonL = MouseButtonL id
-    mouseButtonR = MouseButtonR id
-    mouseButtonM = MouseButtonM id
-
-instance FromFinalizer GUIBase where
-    fromFinalizer = FromFinalizer
-
--- | Parameters of the application.
-data GUIParam = GUIParam
-    { _framePerSecond :: Int
-    , _windowRegion :: BoundingBox Float
-    , _windowTitle :: String
-    , _windowed :: Bool
-    , _cursorVisible :: Bool
-    , _clearColor :: Color
-    } deriving Show
-
-instance Default GUIParam where
-    def = GUIParam
-        { _framePerSecond = 60
-        , _windowTitle = "free-game"
-        , _windowed = True
-        , _cursorVisible = True
-        , _clearColor = Color 1 1 1 1
-        , _windowRegion = BoundingBox 0 0 640 480
-        }
− Graphics/UI/FreeGame/GUI/GLFW.hs 
@@ -1,278 +0,0 @@-{-# LANGUAGE FlexibleContexts, Rank2Types #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.FreeGame.GUI.GLFW
--- Copyright   :  (C) 2013 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
-----------------------------------------------------------------------------
-module Graphics.UI.FreeGame.GUI.GLFW (runGame) where
-import Control.Applicative
-import Control.Monad
-import Control.Monad.Free.Church
-import Control.Monad.IO.Class
-import Data.IORef
-import Data.Color
-import Foreign.ForeignPtr
-import Graphics.UI.FreeGame.Base
-import Graphics.UI.FreeGame.Data.Bitmap
-import Graphics.UI.FreeGame.Internal.Finalizer
-import Graphics.UI.FreeGame.Internal.Raindrop
-import Graphics.UI.FreeGame.GUI
-import Graphics.UI.FreeGame.Types
-import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility
-import qualified Data.Array.Repa.Repr.ForeignPtr as RF
-import qualified Graphics.UI.GLFW as GLFW
-import Graphics.Rendering.OpenGL.GL.StateVar
-import qualified Data.IntMap as IM
-import qualified Graphics.Rendering.OpenGL.GL as GL
-import System.Mem
-import Unsafe.Coerce
-import Control.Bool
-import Linear
-import Data.Reflection
-
-runGame :: GUIParam -> F GUI a -> IO (Maybe a)
-runGame param m = launch param $ runF m (return . Just) runAction
-
-data System = System
-    { refTextures :: IORef (IM.IntMap Texture)
-    , refFrame :: IORef Int
-    , refFPS :: IORef Int
-    , theParameter :: GUIParam
-    }
-
-runAction :: Given System => GUI (FinalizerT IO (Maybe a)) -> FinalizerT IO (Maybe a)
-runAction (LiftUI f) = join $ runUI id f
-runAction (EmbedIO m) = join (liftIO m)
-runAction (Bracket m) = liftIO $ runFinalizerT $ runF m (return.Just) runAction
-        >>= maybe (return Nothing) id
-runAction Quit = return Nothing
-runAction (Tick cont) = do
-    liftIO $ do
-        GL.matrixMode $= GL.Projection
-        GLFW.swapBuffers
-        -- performGC
-        t <- GLFW.getTime
-        n <- readIORef (refFrame given)
-        GLFW.sleep $ fromIntegral n / fromIntegral (_framePerSecond $ theParameter given) - t
-        if t >= 1
-            then GLFW.resetTime >> writeIORef (refFrame given) 0 >> writeIORef (refFPS given) n
-            else writeIORef (refFrame given) (succ n)
-
-    r <- liftIO $ GLFW.windowIsOpen
-    if not r then return Nothing else do
-        liftIO $ do
-            GL.clear [GL.ColorBuffer] 
-            GL.loadIdentity
-            let BoundingBox wl wt wr wb = fmap realToFrac $ _windowRegion $ theParameter given
-            GL.ortho wl wr wb wt 0 (-100)
-            GL.matrixMode $= GL.Modelview 0
-        cont
-runAction (GetFPS cont) = liftIO (readIORef (refFPS given)) >>= cont
-
-type Texture = (GL.TextureObject, Int, Int)
-
-launch :: GUIParam -> (Given System => FinalizerT IO (Maybe a)) -> IO (Maybe a)
-launch param m = do
-    GLFW.initialize >>= bool (fail "Failed to initialize") (return ())
-    pf <- GLFW.openGLProfile
-    let V2 ww wh = fmap floor (view _BottomRight (_windowRegion param) - view _TopLeft (_windowRegion param))
-    (>>=bool (fail "Failed to initialize") (return ())) $ GLFW.openWindow $ GLFW.defaultDisplayOptions {
-        GLFW.displayOptions_width = ww
-        ,GLFW.displayOptions_height = wh
-        ,GLFW.displayOptions_displayMode = if _windowed param then GLFW.Window else GLFW.Fullscreen
-        ,GLFW.displayOptions_windowIsResizable = False
-        ,GLFW.displayOptions_openGLProfile = pf
-        }
-
-    GLFW.setWindowTitle $ _windowTitle param
-    GL.lineSmooth $= GL.Enabled
-    GL.blend      $= GL.Enabled
-    GL.blendFunc  $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
-    GL.shadeModel $= GL.Flat
-    GL.textureFunction $= GL.Combine
-
-    let Color r g b a = _clearColor param in GL.clearColor $= GL.Color4 (gf r) (gf g) (gf b) (gf a)
-
-    sys <- System <$> newIORef IM.empty <*> newIORef 0 <*> newIORef 0 <*> pure param
-    res <- runFinalizerT $ give sys m
-
-    GLFW.closeWindow
-    GLFW.terminate
-    return res
-
-installTexture :: Bitmap -> FinalizerT IO Texture
-installTexture bmp@(BitmapData ar _) = do
-    [tex] <- liftIO $ GL.genObjectNames 1
-    liftIO $ GL.textureBinding GL.Texture2D GL.$= Just tex
-    let (width, height) = bitmapSize bmp
-    let siz = GL.TextureSize2D (gsizei width) (gsizei height)
-    liftIO $ withForeignPtr (RF.toForeignPtr ar)
-        $ GL.texImage2D GL.Texture2D GL.NoProxy 0 GL.RGBA8 siz 0
-        . GL.PixelData GL.RGBA GL.UnsignedInt8888
-    finalizer $ GL.deleteObjectNames [tex]
-    return (tex, width, height)
-
-rot2 :: Floating a => a -> V2 a -> V2 a
-rot2 a (V2 x y) = V2 (p * x + q * y) (-q * x + p * y) where
-    d = a * (pi / 180) 
-    p = cos d
-    q = sin d
-
-runUI :: Given System => (V2 Float -> V2 Float) -> GUIBase a -> FinalizerT IO a
-runUI _ (FromBitmap bmp@(BitmapData _ (Just h)) r) = do
-    m <- liftIO $ readIORef $ refTextures given
-    case IM.lookup h m of
-        Just t -> liftIO $ drawTexture t
-        Nothing -> do
-            t <- installTexture bmp
-            liftIO $ writeIORef (refTextures given) $ IM.insert h t m
-            liftIO $ drawTexture t
-            finalizer $ modifyIORef (refTextures given) $ IM.delete h
-    return r
-runUI _ (FromBitmap bmp@(BitmapData _ Nothing) r) = do
-    liftIO $ runFinalizerT $ installTexture bmp >>= liftIO . drawTexture
-    return r
-runUI f (Translate t@(V2 tx ty) inner) = preservingMatrix' $ do
-    liftIO $ GL.translate (GL.Vector3 (gf tx) (gf ty) 0)
-    runUI (subtract t . f) inner
-runUI f (RotateD theta inner) = preservingMatrix' $ do
-    liftIO $ GL.rotate (gf (-theta)) (GL.Vector3 0 0 1)
-    runUI (rot2 (-theta) . f) inner
-runUI f (Scale s@(V2 sx sy) inner) = preservingMatrix' $ do
-    liftIO $ GL.scale (gf sx) (gf sy) 1
-    runUI ((/s) . f) inner
-runUI _ (FromFinalizer m) = m
-runUI f (Colored col inner) = do
-    oldColor <- liftIO $ get GL.currentColor
-    liftIO $ GL.currentColor $= unsafeCoerce col
-    res <- runUI f inner
-    liftIO $ GL.currentColor $= oldColor
-    return res
-runUI _ (Line path r) = do
-    liftIO $ GL.renderPrimitive GL.LineStrip $ runVertices path
-    return r
-runUI _ (Polygon path r) = do
-    liftIO $ GL.renderPrimitive GL.Polygon $ runVertices path
-    return r
-runUI _ (PolygonOutline path r) = do
-    liftIO $ GL.renderPrimitive GL.LineLoop $ runVertices path
-    return r
-runUI _ (Circle r cont) = do
-    let s = 2 * pi / r
-    liftIO $ GL.renderPrimitive GL.Polygon $ runVertices [V2 (cos t * r) (sin t * r) | t <- [0,s..2 * pi]]
-    return cont
-runUI _ (CircleOutline r cont) = do
-    let s = 2 * pi / r
-    liftIO $ GL.renderPrimitive GL.LineLoop $ runVertices [V2 (cos t * r) (sin t * r) | t <- [0,s..2 * pi]]
-    return cont
-runUI f (Thickness t inner) = do
-    oldWidth <- liftIO $ get GL.lineWidth
-    liftIO $ GL.lineWidth $= gf t
-    res <- runUI f inner
-    liftIO $ GL.lineWidth $= oldWidth
-    return res
-runUI _ (KeyChar ch cont) = cont <$> liftIO (GLFW.keyIsPressed (GLFW.CharKey ch))
-runUI _ (KeySpecial x cont) = cont <$> liftIO (GLFW.keyIsPressed (mapSpecialKey x))
-runUI _ (MouseButtonL cont) = cont <$> liftIO (GLFW.mouseButtonIsPressed GLFW.MouseButton0)
-runUI _ (MouseButtonR cont) = cont <$> liftIO (GLFW.mouseButtonIsPressed GLFW.MouseButton1)
-runUI _ (MouseButtonM cont) = cont <$> liftIO (GLFW.mouseButtonIsPressed GLFW.MouseButton2)
-runUI f (MousePosition cont) = do
-    (x, y) <- liftIO GLFW.getMousePosition
-    let pos = f $ V2 (fromIntegral x) (fromIntegral y)
-    return $ cont pos
-runUI _ (MouseWheel cont) = cont <$> liftIO GLFW.getMouseWheel
-
-runVertices :: MonadIO m => [V2 Float] -> m ()
-runVertices = liftIO . mapM_ (GL.vertex . mkVertex2)
-
-preservingMatrix' :: MonadIO m => m a -> m a
-preservingMatrix' m = do
-    liftIO $ glPushMatrix
-    r <- m
-    liftIO $ glPopMatrix
-    return r
-
-drawTexture :: Texture -> IO ()
-drawTexture (tex, width, height) = do
-    let (w, h) = (fromIntegral width / 2, fromIntegral height / 2) :: (GL.GLfloat, GL.GLfloat)
-    GL.texture GL.Texture2D $= GL.Enabled
-    GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest)
-    GL.textureBinding GL.Texture2D $= Just tex
-    GL.renderPrimitive GL.Polygon $ do
-        GL.texCoord $ GL.TexCoord2 (0 :: GL.GLfloat) 0
-        GL.vertex $ GL.Vertex2 (-w) (-h)
-        GL.texCoord $ GL.TexCoord2 (1 :: GL.GLfloat) 0
-        GL.vertex $ GL.Vertex2 w (-h)
-        GL.texCoord $ GL.TexCoord2 (1 :: GL.GLfloat) 1
-        GL.vertex $ GL.Vertex2 w h
-        GL.texCoord $ GL.TexCoord2 (0 :: GL.GLfloat) 1
-        GL.vertex $ GL.Vertex2 (-w) h
-    GL.texture GL.Texture2D $= GL.Disabled
-
-mapSpecialKey :: SpecialKey -> GLFW.Key
-mapSpecialKey KeySpace = GLFW.KeySpace
-mapSpecialKey KeyEsc = GLFW.KeyEsc
-mapSpecialKey KeyLeftShift = GLFW.KeyLeftShift
-mapSpecialKey KeyRightShift = GLFW.KeyRightShift
-mapSpecialKey KeyLeftControl = GLFW.KeyLeftCtrl
-mapSpecialKey KeyRightControl = GLFW.KeyRightCtrl
-mapSpecialKey KeyUp = GLFW.KeyUp
-mapSpecialKey KeyDown = GLFW.KeyDown
-mapSpecialKey KeyLeft = GLFW.KeyLeft
-mapSpecialKey KeyRight = GLFW.KeyRight
-mapSpecialKey KeyTab = GLFW.KeyTab
-mapSpecialKey KeyEnter = GLFW.KeyEnter
-mapSpecialKey KeyBackspace = GLFW.KeyBackspace
-mapSpecialKey KeyInsert = GLFW.KeyInsert
-mapSpecialKey KeyDelete = GLFW.KeyDel
-mapSpecialKey KeyPageUp = GLFW.KeyPageup
-mapSpecialKey KeyPageDown = GLFW.KeyPagedown
-mapSpecialKey KeyHome = GLFW.KeyHome
-mapSpecialKey KeyEnd = GLFW.KeyEnd
-mapSpecialKey KeyF1 = GLFW.KeyF1
-mapSpecialKey KeyF2 = GLFW.KeyF2
-mapSpecialKey KeyF3 = GLFW.KeyF3
-mapSpecialKey KeyF4 = GLFW.KeyF4
-mapSpecialKey KeyF5 = GLFW.KeyF5
-mapSpecialKey KeyF6 = GLFW.KeyF6
-mapSpecialKey KeyF7 = GLFW.KeyF7
-mapSpecialKey KeyF8 = GLFW.KeyF8
-mapSpecialKey KeyF9 = GLFW.KeyF9
-mapSpecialKey KeyF10 = GLFW.KeyF10
-mapSpecialKey KeyF11 = GLFW.KeyF11
-mapSpecialKey KeyF12 = GLFW.KeyF12
-mapSpecialKey KeyPad0 = GLFW.KeyPad0
-mapSpecialKey KeyPad1 = GLFW.KeyPad1
-mapSpecialKey KeyPad2 = GLFW.KeyPad2
-mapSpecialKey KeyPad3 = GLFW.KeyPad3
-mapSpecialKey KeyPad4 = GLFW.KeyPad4
-mapSpecialKey KeyPad5 = GLFW.KeyPad5
-mapSpecialKey KeyPad6 = GLFW.KeyPad6
-mapSpecialKey KeyPad7 = GLFW.KeyPad7
-mapSpecialKey KeyPad8 = GLFW.KeyPad8
-mapSpecialKey KeyPad9 = GLFW.KeyPad9
-mapSpecialKey KeyPadDivide = GLFW.KeyPadDivide
-mapSpecialKey KeyPadMultiply = GLFW.KeyPadMultiply
-mapSpecialKey KeyPadSubtract = GLFW.KeyPadSubtract
-mapSpecialKey KeyPadAdd = GLFW.KeyPadAdd
-mapSpecialKey KeyPadDecimal = GLFW.KeyPadDecimal
-mapSpecialKey KeyPadEqual = GLFW.KeyPadEqual
-mapSpecialKey KeyPadEnter = GLFW.KeyPadEnter
-
-mkVertex2 :: V2 Float -> GL.Vertex2 GL.GLfloat
-mkVertex2 = unsafeCoerce
-{-# INLINE mkVertex2 #-}
-
-gf :: Float -> GL.GLfloat
-{-# INLINE gf #-}
-gf x = unsafeCoerce x
-
-gsizei :: Int -> GL.GLsizei
-{-# INLINE gsizei #-}
-gsizei x = unsafeCoerce x
− Graphics/UI/FreeGame/Internal/Finalizer.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE Rank2Types #-}
-module Graphics.UI.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
− Graphics/UI/FreeGame/Internal/Raindrop.hs 
@@ -1,36 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Graphics.UI.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 Graphics.UI.FreeGame.Internal.Raindrop (view, over, biover) 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 #-}--biover :: ((a -> Identity b) -> (c -> Identity d) -> (s -> Identity t)) -> (a -> b) -> (c -> d) -> s -> t-biover l f g = runIdentity #. l (Identity #. f) (Identity #. g)-{-# INLINE biover #-}
− Graphics/UI/FreeGame/Text.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveFunctor #-}
-module Graphics.UI.FreeGame.Text (TextF(..), TextT, runTextT, runTextT_, text) where
-
-import Data.String
-import Graphics.UI.FreeGame.Base
-import Graphics.UI.FreeGame.Types
-import Graphics.UI.FreeGame.Internal.Raindrop
-import Graphics.UI.FreeGame.Data.Font
-import Graphics.UI.FreeGame.Data.Bitmap
-import Control.Monad.Trans.Free
-import Control.Monad.State
-import Linear
-
-data TextF a = TypeChar Char a deriving Functor
-
-type TextT = FreeT TextF
-
-instance Monad m => IsString (TextT m ()) where
-    fromString str = mapM_ (\c -> liftF (TypeChar c ())) str
-
--- | Render a 'TextT'.
-runTextT :: (FromFinalizer m, Monad m, Picture2D m) => Maybe (BoundingBox Float) -> Font -> Float -> TextT m a -> m a
-runTextT bbox font size = 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)
-            go cont
-        Free (TypeChar ch cont) -> do
-            RenderedChar bmp (V2 x y) adv <- fromFinalizer $ charToBitmap font size ch
-            pen <- get
-            let (w,h) = bitmapSize bmp
-                offset = pen ^+^ V2 (x + fromIntegral w / 2) (y + fromIntegral h / 2)
-            translate offset $ fromBitmap bmp
-            let pen' = over _x (+adv) pen
-            put $ if cond pen'
-                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
-
-runTextT_ :: (FromFinalizer m, Monad m, Picture2D m) => Maybe (BoundingBox Float) -> Font -> Float -> TextT m () -> m ()
-runTextT_ = runTextT
-{-# INLINE runTextT_ #-}
-
--- | Render a 'String'.
-text :: (FromFinalizer m, Monad m, Picture2D m) => Font -> Float -> String -> m ()
-text font size str = runTextT Nothing font size (fromString str)
− Graphics/UI/FreeGame/Types.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.FreeGame.Types
--- Copyright   :  (C) 2013 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  provisional
--- Portability :  non-portable
---
-----------------------------------------------------------------------------
-module Graphics.UI.FreeGame.Types (
-    BoundingBox(..),
-    inBoundingBox,
-    _Corners, 
-    _TopLeft,
-    _TopRight,
-    _BottomLeft,
-    _BottomRight
-    ) where
-
-import Linear.V2
-import Control.Applicative
-
--- | 2D bounding box (x0, y0, x1, y1)
-data BoundingBox a = BoundingBox a a a a deriving (Show, Eq, Ord, Functor, Read)
-
--- | 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))
− Graphics/UI/FreeGame/Util.hs 
@@ -1,132 +0,0 @@-{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.FreeGame.Util
--- Copyright   :  (C) 2013 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
-----------------------------------------------------------------------------
-
-module Graphics.UI.FreeGame.Util (
-    -- * Controlling
-    foreverTick,
-    untick,
-    untickInfinite,
-    -- * Random
-    randomness,
-    -- * Helper
-    degrees,
-    radians,
-    unitV2,
-    angleV2,
-    -- * Loading
-    loadPictureFromFile,
-    loadBitmaps,
-    loadBitmapsWith
-    ) where
-
-import Control.Applicative
-import Control.Monad
-import Control.Monad.Free
-import Data.Char
-import Data.Void
-import Graphics.UI.FreeGame.Base
-import Graphics.UI.FreeGame.Data.Bitmap
-import Language.Haskell.TH
-import Linear
-import System.Directory
-import System.FilePath
-import System.IO.Unsafe
-import System.Random
-import System.Environment
-
--- | An infinite loop that run 'tick' every frame after the given action.
-foreverTick :: MonadFree (UI n) m => m a -> m any
-foreverTick m = m >> (tick >> foreverTick m)
-
--- | An unit vector with given angle.
-unitV2 :: Floating a => a -> V2 a
-unitV2 t = V2 (cos t) (sin t)
-
--- | An angle of given vector.
-angleV2 :: RealFloat a => V2 a -> a
-angleV2 (V2 a b) = atan2 b a
-
--- | Extract the next frame of the action.
-untick :: (Functor n, MonadFree (UI n) m) => Free (UI n) a -> m (Either (Free (UI n) a) a)
-untick (Pure a) = return (Right a)
-untick (Free (Tick cont)) = return (Left cont)
-untick (Free f) = wrap $ fmap untick f
-
--- | An infinite version of 'untick'.
-untickInfinite :: (Functor n, MonadFree (UI n) m) => Free (UI n) Void -> m (Free (UI n) Void)
-untickInfinite = liftM (either id absurd) . untick
-
--- | Get a given range of value.
-randomness :: (Random r, MonadFree (UI n) m) => (r, r) -> m r
-randomness = embedIO . randomRIO
-
--- | Convert radians to degrees.
-degrees :: Float -> Float
-{-# INLINE degrees #-}
-degrees x = x / pi * 180
-
--- | Convert degrees to radians.
-radians :: Float -> Float
-{-# INLINE radians #-}
-radians x = x / 180 * pi
-
--- | Create a 'Picture' from the given file.
-loadPictureFromFile :: (Picture2D p, MonadFree (UI n) m) => FilePath -> m (p ())
-loadPictureFromFile = embedIO . fmap fromBitmap . loadBitmapFromFile
-
--- | The type of the given 'Name' must be @String -> IO String@
-loadBitmapsWith :: ExpQ -> 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 $ loc </> p) []]
-            ]
-    where
-        load name fp = do
-            runIO $ putStrLn $ "Defined: " ++ fp ++ " as `" ++ name ++ "'"
-
-            appE (varE 'unsafePerformIO) $ uInfixE (appE getFullPath $ litE $ StringL fp)
-                (varE '(>>=))
-                (varE 'loadBitmapFromFile)
-
--- | Load and define all pictures in the specified directory.
-loadBitmaps :: FilePath -> Q [Dec]
-loadBitmaps path = do
-    v <- newName "v"
-    loadBitmapsWith (lamE [varP v] $
-        appsE [varE 'fmap, uInfixE
-                    (infixE Nothing (varE '(</>)) (Just (varE v)))
-                    (varE '(.))
-                    (varE 'takeDirectory)
-                , varE 'getExecutablePath]) path
-
-getFileList :: 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
-
-pathToName :: FilePath -> String
-pathToName = ('_':) . map p where
-    p c | isAlphaNum c = c
-        | otherwise = '_'
free-game.cabal view
@@ -1,8 +1,14 @@ name:                free-game
-version:             0.9.4.3
-synopsis:            Cross-platform GUI library based on free monads
-description:         free-game is a library that abstracts graphical applications with simple interfaces. Twitter: #hs_free_game
-homepage:            https://github.com/fumieval/free-game/tree/maintainance0.9
+version:             1.0
+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
 bug-reports:         https://github.com/fumieval/free-game/issues
 license:             BSD3
 license-file:        LICENSE
@@ -21,42 +27,45 @@ library
   default-language:   Haskell2010
   exposed-modules:
-    Graphics.UI.FreeGame
-    Graphics.UI.FreeGame.Base
-    Graphics.UI.FreeGame.Data.Bitmap
-    Graphics.UI.FreeGame.Data.Font
-    Graphics.UI.FreeGame.Text
-    Graphics.UI.FreeGame.GUI
-    Graphics.UI.FreeGame.GUI.GLFW
-    Graphics.UI.FreeGame.Internal.Finalizer
-    Graphics.UI.FreeGame.Internal.Raindrop
-    Graphics.UI.FreeGame.Types
-    Graphics.UI.FreeGame.Util
-
-  ghc-options: -Wall -fexcess-precision -O2
+    FreeGame
+    FreeGame.Class
+    FreeGame.Data.Bitmap
+    FreeGame.Data.Font
+    FreeGame.Text
+    FreeGame.UI
+    FreeGame.Instances
+    FreeGame.Backend.GLFW
+    FreeGame.Internal.Finalizer
+    FreeGame.Internal.Raindrop
+    FreeGame.Internal.GLFW
+    FreeGame.Types
+    FreeGame.Util
 
+  ghc-options: -Wall -fexcess-precision -O2 -threaded
+  default-extensions: FlexibleContexts, FlexibleInstances
   build-depends:
-    base == 4.*,
     array >= 0.4,
+    base == 4.*,
+    colors == 0.1.*,
     containers >= 0.4,
+    control-bool,
+    data-default,
     directory >= 1.0,
     filepath >= 1.3,
-    free >= 3.2 && <5,
-    repa,
+    free >= 4.4 && < 5,
     freetype2 >= 0.1,
-    GLFW-b == 0.1.*,
+    GLFW-b >= 1.3 && <2,
     hashable >= 1.2,
+    JuicyPixels,
+    JuicyPixels-repa >= 0.7 && <1,
+    linear >= 1.1 && < 1.5,
     mtl >= 2.1,
     OpenGL == 2.9.*,
     OpenGLRaw == 1.4.*,
     random == 1.*,
-    transformers >= 0.3,
-    void >= 0.5,
+    reflection==1.*,
+    repa,
     template-haskell,
-    linear >= 1.1 && < 1.4,
+    transformers >= 0.3,
     vector == 0.10.*,
-    JuicyPixels-repa >= 0.7 && < 1,
-    data-default,
-    reflection == 1.*,
-    colors == 0.1.*,
-    control-bool+    void >= 0.5