packages feed

free-game 0.3.2.7 → 0.9

raw patch · 27 files changed

+1294/−1281 lines, 27 filesdep +data-defaultdep +lineardep +profunctorsdep −vectdep ~OpenGLRawdep ~repa

Dependencies added: data-default, linear, profunctors, vector

Dependencies removed: vect

Dependency ranges changed: OpenGLRaw, repa

Files

− Graphics/FreeGame.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE Rank2Types, FlexibleContexts #-}
-{-|
-Module      :  Graphics.FreeGame
-Copyright   :  (C) 2012 Fumiaki Kinoshita
-License     :  BSD-style (see the file LICENSE)
-Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
-
-free-game is a library that abstracts and purifies GUI applications with simple interfaces.
--}
-module Graphics.FreeGame
-  ( -- * Examples
-    -- $example
-
-    -- * Reexports
-    module Graphics.FreeGame.Base,
-    module Graphics.FreeGame.Data.Bitmap,
-    module Graphics.FreeGame.Data.Font,
-    module Graphics.FreeGame.Data.Color,
-    module Graphics.FreeGame.Input,
-    module Graphics.FreeGame.Util,
-    runGame,
-    runGame'
-) where
-
-import Graphics.FreeGame.Base
-import Graphics.FreeGame.Input
-import Graphics.FreeGame.Util
-import Graphics.FreeGame.Data.Bitmap
-import Graphics.FreeGame.Data.Font
-import Graphics.FreeGame.Data.Color
-import qualified Graphics.FreeGame.Backends.GLFW as GLFW
-import Control.Monad.Free
-
--- | Run a 'Game' computation.
-runGame :: GameParam -> Game a -> IO (Maybe a)
-runGame = GLFW.runGame
-
--- | In most cases there's no unwrapping (Game a -> GameAction (Game a)).
--- | The use of ('>>=') is more efficient than 'runGame' in such situation.
-runGame' :: GameParam -> (forall m. MonadFree GameAction m => m a) -> IO (Maybe a)
-runGame' = GLFW.runGame'
-
-{- $example
-
-> import Graphics.FreeGame.Simple
-> main = runSimple defaultGameParam () return
-
-shows a window and does nothing.
-
-for more examples, see <https://github.com/fumieval/free-game/tree/master/examples>.
-
--}
− Graphics/FreeGame/Backends/GLFW.hs 
@@ -1,254 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.FreeGame.Backends.GLFW
--- Copyright   :  (C) 2013 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
-----------------------------------------------------------------------------
-{-# LANGUAGE ImplicitParams, ScopedTypeVariables, Rank2Types, FlexibleContexts #-}
-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
-module Graphics.FreeGame.Backends.GLFW (runGame, runGame') where
-import Control.Applicative
-import Control.Monad
-import Control.Monad.Free
-import Control.Monad.Free.Church
-import Control.Monad.IO.Class
-import Data.IORef
-import Foreign.ForeignPtr
-import Graphics.FreeGame.Base
-import Graphics.FreeGame.Data.Bitmap
-import Graphics.FreeGame.Internal.Finalizer
-import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility
-import Graphics.UI.GLFW as GLFW
-import Graphics.Rendering.OpenGL.GL.StateVar
-import qualified Data.Array.Repa.Repr.ForeignPtr as RF
-import qualified Data.IntMap as IM
-import qualified Graphics.FreeGame.Input as I
-import qualified Graphics.Rendering.OpenGL.GL as GL
-import System.Mem
-import Unsafe.Coerce
-
-runGame :: GameParam -> Game a -> IO (Maybe a)
-runGame param m = launch param $ \r s -> runFreeGame param r s m
-
-runGame' :: GameParam -> (forall m. MonadFree GameAction m => m a) -> IO (Maybe a)
-runGame' param m = launch param $ \r s -> runF m (return . Just) (runAction param r s)
-
-runFreeGame :: GameParam -> IORef (IM.IntMap Texture) -> IORef Int -> Free GameAction a -> FinalizerT IO (Maybe a)
-runFreeGame p r s = go where
-    go (Free f) = runAction p r s $ go <$> f
-    go (Pure a) = return $ Just a
-
-runAction :: GameParam
-    -> IORef (IM.IntMap Texture)
-    -> IORef Int
-    -> GameAction (FinalizerT IO (Maybe a)) -> FinalizerT IO (Maybe a)
-runAction param refTextures refFrame _f = case _f of
-    DrawPicture pic cont -> let ?refTextures = refTextures in drawPic pic >> cont
-    EmbedIO m -> join (liftIO m)
-    Bracket m -> liftIO (runFinalizerT $ runFreeGame param refTextures refFrame m) >>= maybe (return Nothing) id
-    Tick cont -> do
-        liftIO $ do
-            GL.matrixMode $= GL.Projection
-            swapBuffers
-            t <- getTime
-            n <- readIORef refFrame
-            sleep (fromIntegral n / fromIntegral (framePerSecond param) - t)
-            if t > 1
-                then resetTime >> writeIORef refFrame 0
-                else writeIORef refFrame (succ n)
-
-        r <- liftIO $ windowIsOpen
-        if not r then return Nothing else do
-            liftIO $ do
-                GL.clear [GL.ColorBuffer] 
-                performGC
-                GL.loadIdentity
-                GL.scale (gf 1) (-1) 1
-                let Vec2 ox oy = windowOrigin param
-                    windowL = realToFrac ox
-                    windowR = realToFrac ox + fromIntegral (fst $ windowSize param)
-                    windowT = realToFrac oy
-                    windowB = realToFrac oy + fromIntegral (snd $ windowSize param)
-                GL.ortho windowL windowR windowT windowB 0 (-100)
-                GL.matrixMode $= GL.Modelview 0
-            cont
-    GetButtonState key fcont -> liftIO (either keyIsPressed mouseButtonIsPressed (mapKey key)) >>= fcont
-    GetMousePosition fcont -> do
-        (x, y) <- liftIO $ GLFW.getMousePosition
-        fcont $ Vec2 (fromIntegral x) (fromIntegral y)
-    GetMouseWheel fcont -> liftIO GLFW.getMouseWheel >>= fcont
-    GetGameParam fcont -> do -- There may be a better way
-        dim <- liftIO GLFW.getWindowDimensions
-        fcont $ param { windowSize = dim }
-    QuitGame -> return Nothing
-
-data Texture = Texture GL.TextureObject Int Int
-
-launch :: GameParam -> (IORef (IM.IntMap Texture) -> IORef Int -> FinalizerT IO (Maybe a)) -> IO (Maybe a)
-launch param m = do
-    True <- initialize
-    pf <- openGLProfile
-    True <- openWindow $ defaultDisplayOptions {
-        displayOptions_width = fromIntegral $ fst $ windowSize param
-        ,displayOptions_height = fromIntegral $ snd $ windowSize param
-        ,displayOptions_displayMode = if windowed param then Window else Fullscreen
-        ,displayOptions_windowIsResizable = False
-        ,displayOptions_openGLProfile = pf
-        }
-    
-    if cursorVisible param
-        then enableMouseCursor 
-        else disableMouseCursor
-
-    setWindowTitle $ windowTitle param
-    GL.lineSmooth $= GL.Enabled
-    GL.blend      $= GL.Enabled
-    GL.blendFunc  $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
-    GL.shadeModel $= GL.Smooth
-    GL.texture GL.Texture2D $= GL.Enabled
-    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)
-
-    ref <- newIORef IM.empty
-    ref' <- newIORef 0
-    r <- runFinalizerT $ m ref ref'
-
-    closeWindow
-    terminate
-    return r
-
-installTexture :: Bitmap -> FinalizerT IO Texture
-installTexture bmp = do
-    [tex] <- liftIO $ GL.genObjectNames 1
-    liftIO $ GL.textureBinding GL.Texture2D GL.$= Just tex
-
-    let (width, height) = bitmapSize bmp
-    liftIO $ withForeignPtr (RF.toForeignPtr $ bitmapData bmp)
-        $ GL.texImage2D Nothing GL.NoProxy 0 GL.RGBA8 (GL.TextureSize2D (gsizei width) (gsizei height)) 0
-        . GL.PixelData GL.RGBA GL.UnsignedInt8888
-    finalizer $ GL.deleteObjectNames [tex]
-    return $ Texture tex width height
-
-drawTexture :: Texture -> IO ()
-drawTexture (Texture tex width height) = do
-    let (w, h) = (fromIntegral width / 2, fromIntegral height / 2)
-    GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest)
-    GL.textureBinding GL.Texture2D $= Just tex
-    GL.renderPrimitive GL.Polygon $ zipWithM_
-        (\(pX, pY) (tX, tY) -> do
-            GL.texCoord $ GL.TexCoord2 (gf tX) (gf tY)
-            GL.vertex $ GL.Vertex2   (gf pX) (gf pY))
-        [(-w, -h), (w, -h), (w, h), (-w, h)]
-        [(0,0), (1.0,0), (1.0,1.0), (0,1.0)]
-
-drawPic :: (?refTextures :: IORef (IM.IntMap Texture)) => Picture -> FinalizerT IO ()
-drawPic (Bitmap bmp) = case bitmapHash bmp of
-    Just h -> do
-        m <- liftIO $ readIORef ?refTextures
-        case IM.lookup h m of
-            Just t -> liftIO $ drawTexture t
-            Nothing -> do
-                t <- installTexture bmp
-                liftIO $ writeIORef ?refTextures $ IM.insert h t m
-                liftIO $ drawTexture t
-                finalizer $ modifyIORef ?refTextures $ IM.delete h 
-    Nothing -> liftIO $ runFinalizerT $ installTexture bmp >>= liftIO . drawTexture
-
-drawPic (BitmapPicture bmp) = drawPic (Bitmap bmp)
-
-drawPic (Rotate theta p) = preservingMatrix' $ do
-    liftIO $ GL.rotate (gf (-theta)) (GL.Vector3 0 0 1)
-    drawPic p
-
-drawPic (Scale (Vec2 sx sy) p) = preservingMatrix' $ do
-    liftIO $ GL.scale (gf sx) (gf sy) 1
-    drawPic p
-
-drawPic (Translate (Vec2 tx ty) p) = preservingMatrix' $ do
-    liftIO $ GL.translate (GL.Vector3 (gf tx) (gf ty) 0)
-    drawPic p
-
-drawPic (Pictures ps) = mapM_ drawPic ps
-
-drawPic (PictureWithFinalizer m) = m >>= drawPic
-
-drawPic (Colored (Color r g b a) pic) = do
-    oldColor <- liftIO $ get GL.currentColor
-    liftIO $ GL.currentColor $= GL.Color4 (gf r) (gf g) (gf b) (gf a)
-    drawPic pic
-    liftIO $ GL.currentColor $= oldColor
-
-preservingMatrix' :: MonadIO m => m () -> m ()
-preservingMatrix' m = do
-    liftIO $ glPushMatrix
-    _ <- m
-    liftIO $ glPopMatrix
-
-mapKey :: I.Button -> Either Key MouseButton
-mapKey k = case k of
-    I.KeyChar c -> Left $ CharKey c
-    I.KeySpace -> Left KeySpace
-    I.KeyF1 -> Left KeyF1
-    I.KeyF2 -> Left KeyF2
-    I.KeyF3 -> Left KeyF3
-    I.KeyF4 -> Left KeyF4
-    I.KeyF5 -> Left KeyF5
-    I.KeyF6 -> Left KeyF6
-    I.KeyF7 -> Left KeyF7
-    I.KeyF8 -> Left KeyF8
-    I.KeyF9 -> Left KeyF9
-    I.KeyF10 -> Left KeyF10
-    I.KeyF11 -> Left KeyF11
-    I.KeyF12 -> Left KeyF12
-    I.KeyEsc -> Left KeyEsc
-    I.KeyUp -> Left KeyUp
-    I.KeyDown -> Left KeyDown
-    I.KeyLeft -> Left KeyLeft
-    I.KeyRight -> Left KeyRight
-    I.KeyLeftShift -> Left KeyLeftShift
-    I.KeyRightShift -> Left KeyLeftShift
-    I.KeyLeftControl -> Left KeyLeftCtrl
-    I.KeyRightControl -> Left KeyRightCtrl
-    I.KeyTab -> Left KeyTab
-    I.KeyEnter -> Left KeyEnter
-    I.KeyBackspace -> Left KeyBackspace
-    I.KeyInsert -> Left KeyInsert
-    I.KeyDelete -> Left KeyDel
-    I.KeyPageUp -> Left KeyPageup
-    I.KeyPageDown -> Left KeyPagedown
-    I.KeyHome -> Left KeyHome
-    I.KeyEnd -> Left KeyEnd
-    I.KeyPad0 -> Left KeyPad0
-    I.KeyPad1 -> Left KeyPad1
-    I.KeyPad2 -> Left KeyPad2
-    I.KeyPad3 -> Left KeyPad3
-    I.KeyPad4 -> Left KeyPad4
-    I.KeyPad5 -> Left KeyPad5
-    I.KeyPad6 -> Left KeyPad6
-    I.KeyPad7 -> Left KeyPad7
-    I.KeyPad8 -> Left KeyPad8
-    I.KeyPad9 -> Left KeyPad9
-    I.KeyPadDivide -> Left KeyPadDivide
-    I.KeyPadMultiply -> Left KeyPadMultiply
-    I.KeyPadSubtract -> Left KeyPadSubtract
-    I.KeyPadAdd -> Left KeyPadAdd
-    I.KeyPadDecimal -> Left KeyPadDecimal
-    I.KeyPadEqual -> Left KeyPadEqual
-    I.KeyPadEnter -> Left KeyPadEnter
-    I.MouseLeft -> Right MouseButton0
-    I.MouseRight -> Right MouseButton1
-    I.MouseMiddle -> Right MouseButton2
-
-gf :: Float -> GL.GLfloat
-{-# INLINE gf #-}
-gf x = unsafeCoerce x
-
-gsizei :: Int -> GL.GLsizei
-{-# INLINE gsizei #-}
-gsizei x = unsafeCoerce x
− Graphics/FreeGame/Base.hs 
@@ -1,170 +0,0 @@-{-# LANGUAGE FlexibleContexts, DeriveFunctor, FlexibleInstances #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.FreeGame.Base
--- Copyright   :  (C) 2012-2013 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
--- Abstract structures that represents user interfaces
-----------------------------------------------------------------------------
-
-module Graphics.FreeGame.Base (
-    -- * Types
-    Game
-    ,GameAction(..)
-
-    -- * Basic operations
-    ,tick
-    ,embedIO
-    ,bracket
-    ,quitGame
-
-    -- * Pictures
-    ,Vec2(..)
-    ,Color(..)
-    ,Picture(..)
-    ,transPicture
-    ,drawPicture
-    
-    -- * Inputs
-    ,getButtonState
-    ,getMousePosition
-    ,getMouseWheel
-
-    -- * Settings
-    ,GameParam(..)
-    ,defaultGameParam
-    ,getCurrentGameParam
-
-    -- * Deprecated
-    ,askInput
-    ,getMouseState
-) where
-
-import Control.Monad.Free
-import Control.Monad
-import Graphics.FreeGame.Data.Color
-import Graphics.FreeGame.Data.Bitmap
-import Graphics.FreeGame.Input
-import Graphics.FreeGame.Internal.Finalizer
-import Control.Monad.IO.Class
-import Data.Vect
-import Data.Void
-
-infixr 5 `Translate`
-infixr 5 `Rotate`
-infixr 5 `Scale`
-infixr 5 `Colored`
-
--- | 'Game' is a 'Monad' that abstracts user interfaces.
-type Game = Free GameAction
-
-instance MonadIO Game where
-    liftIO = embedIO
-
--- | A base for 'Game' monad.
-data GameAction a
-    = Tick a
-    | EmbedIO (IO a)
-    | Bracket (Game a)
-    | DrawPicture Picture a
-    | GetButtonState Button (Bool -> a)
-    | GetMousePosition (Vec2 -> a)
-    | GetMouseWheel (Int -> a)
-    | GetGameParam (GameParam -> a)
-    | QuitGame
-    deriving Functor
-
--- | Finalize the current frame and refresh the screen.
-tick :: MonadFree GameAction m => m ()
-tick = wrap $ Tick (return ())
-
--- | Embed arbitrary 'IO' actions into a 'Game' monad.
-embedIO :: MonadFree GameAction m => IO a -> m a
-embedIO m = wrap $ EmbedIO $ liftM return m
-
--- | Run a Game monad in a Game monad. resources (e.g. pictures) will be released when inner computation is done.
-bracket :: MonadFree GameAction m => Game a -> m a
-bracket m = wrap $ Bracket $ liftM return m
-
--- | Break the current computation.
-quitGame :: MonadFree GameAction m => m Void
-quitGame = wrap QuitGame
-
--- | Draw a 'Picture'.
-drawPicture :: MonadFree GameAction m => Picture -> m ()
-drawPicture pic = wrap $ DrawPicture pic (return ())
-
--- | Is the specified 'Button' is pressed?
-getButtonState :: MonadFree GameAction m => Button -> m Bool
-getButtonState key = wrap $ GetButtonState key return
-
-getMouseWheel :: MonadFree GameAction m => m Int
-getMouseWheel = wrap $ GetMouseWheel return
-
-getMousePosition :: MonadFree GameAction m => m Vec2
-getMousePosition = wrap $ GetMousePosition return
-
--- | Get the game params that apply to the currently running game.
-getCurrentGameParam :: MonadFree GameAction m => m GameParam
-getCurrentGameParam = wrap $ GetGameParam return
-
--- | Lift a picture transformation into transformation of 'GameAction'
-transPicture :: (Picture -> Picture) -> GameAction cont -> GameAction cont
-transPicture f (DrawPicture p cont) = DrawPicture (f p) cont
-transPicture _ x = x
-
--- | A 2D Picture.
-data Picture
-    -- | A 'Bitmap' as a 'Picture'.
-    = Bitmap Bitmap
-    -- | Deprecated synonym for 'Bitmap'.
-    | BitmapPicture Bitmap
-    -- | A picture consist of some 'Picture's.
-    | Pictures [Picture]
-    -- | A picture that may have side effects(internal use only).
-    | PictureWithFinalizer (FinalizerT IO Picture)
-    -- | Rotated picture by the given angle (in degrees, counterclockwise).
-    | Rotate Float Picture
-    -- | Scaled picture.
-    | Scale Vec2 Picture
-    -- | A picture translated by the given coordinate.
-    | Translate Vec2 Picture
-    -- | Colored picture.
-    | Colored Color Picture
-
-{-# DEPRECATED BitmapPicture "use Bitmap instead" #-}
-
--- | Parameters of the application.
-data GameParam = GameParam
-    { framePerSecond :: Int
-    , windowSize :: (Int, Int)
-    , windowTitle :: String
-    , windowed :: Bool
-    , cursorVisible :: Bool
-    , clearColor :: Color
-    , windowOrigin :: Vec2
-    } deriving Show
-
--- | 640*480(windowed), 60fps
-defaultGameParam :: GameParam
-defaultGameParam = GameParam 60 (640,480) "free-game" True True white (Vec2 0 0)
-
--- | Yields the mouse's state.
-getMouseState :: MonadFree GameAction m => m MouseState
-getMouseState = MouseState
-    `liftM` getMousePosition
-    `ap` askInput MouseLeft
-    `ap` askInput MouseMiddle
-    `ap` askInput MouseRight
-    `ap` getMouseWheel
-{-# DEPRECATED getMouseState "use getMousePosition and getMouseWheel instead." #-}
-
--- | Deprecated synonym for 'getButtonState'.
-askInput :: MonadFree GameAction m => Button -> m Bool
-askInput = getButtonState
-{-# DEPRECATED askInput "use getButtonState instead." #-}
− Graphics/FreeGame/Data/Bitmap.hs 
@@ -1,84 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.FreeGame.Data.Bitmap
--- Copyright   :  (C) 2013 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
--- Manipulating bitmaps
-----------------------------------------------------------------------------
-
-module Graphics.FreeGame.Data.Bitmap (
-    -- * Basic types and functions
-    Bitmap
-    ,bitmapData
-    ,bitmapHash
-    ,bitmapSize
-
-    -- * Loading from a file
-    ,loadBitmapFromFile
-
-    -- * Constructing bitmaps
-    ,toBitmap
-    ,toStableBitmap
-    ,makeStableBitmap
-
-    -- * Bitmap operations
-    ,onBitmap
-    ,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
-
--- | Concrete bitmap data
-data Bitmap = Bitmap {
-    bitmapData :: R.Array RF.F DIM3 Word8 -- ^ Bare the 'Bitmap''s internal representation (y * x * RGBA).
-    ,bitmapHash :: Maybe Int -- ^ This value is used to ensure that two bitmaps are equivalent.
-    }
-
--- | Create unstable 'Bitmap' from the given array.
-toBitmap :: R.Array RF.F DIM3 Word8 -> Bitmap
-toBitmap ar = Bitmap ar Nothing
-
--- | Create stable 'Bitmap' from the given array and compute the hash.
-toStableBitmap :: R.Array RF.F DIM3 Word8 -> Bitmap
-toStableBitmap ar = Bitmap ar $ Just $ head $ foldAllP 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 = Bitmap ar <$> Just <$> randomIO
-
--- | Get the size of the 'Bitmap'.
-bitmapSize :: Bitmap -> (Int, Int)
-bitmapSize bmp = let (Z :. h :. w :. _) = R.extent (bitmapData bmp) in (w, h)
-
--- | Create a 'Bitmap' from the given file.
-loadBitmapFromFile :: FilePath -> IO Bitmap
-loadBitmapFromFile path = readImageRGBA path >>= either fail return >>= makeStableBitmap . imgData
-
--- | Convert the 'Bitmap' by the given function.
-onBitmap :: (R.Array RF.F DIM3 Word8 -> R.Array RF.F DIM3 Word8) -> Bitmap -> Bitmap
-onBitmap f = toStableBitmap . f . bitmapData
-
--- | 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 (Bitmap ar h) = Bitmap (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) (head . computeP . extract (Z :. y :. x :. 0) (Z :. h :. w :. 4)) bmp
− Graphics/FreeGame/Data/Color.hs 
@@ -1,92 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.FreeGame.Data.Color
--- Copyright   :  (C) 2013 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
--- Stability   :  provisional
--- Portability :  non-portable
---
--- Colors and its operations
-----------------------------------------------------------------------------
-module Graphics.FreeGame.Data.Color (
-    -- * The type
-    Color(..)
-    -- * Color operations
-    , transparent
-    , lighten
-    , darken
-    , intermediate
-    -- * Deprecated
-    , halfD
-    , halfB
-    -- * Basic colors
-    , white, black, red, green, blue, yellow, cyan, magenta
-    ) where
-
-import Data.String
-import Data.Char
-
--- | A color that has red, green, blue, alpha as its component.
-data Color = Color Float Float Float Float deriving (Show, Eq, Ord)
-
-hf :: Char -> Float
-hf x = fromIntegral (digitToInt x) / 15
-
-hf' :: Char -> Char -> Float
-hf' x y = fromIntegral (digitToInt x * 16 + digitToInt y) / 255
-
-instance IsString Color where
-    fromString xs@[r,g,b,a] | all isHexDigit xs = Color (hf r) (hf g) (hf b) (hf a)
-    fromString xs@[r,g,b] | all isHexDigit xs = Color (hf r) (hf g) (hf b) 1
-    fromString xs@[r1,r0,g1,g0,b1,b0,a1,a0] | all isHexDigit xs = Color (hf' r1 r0) (hf' g1 g0) (hf' b1 b0) (hf' a1 a0)
-    fromString xs@[r1,r0,g1,g0,b1,b0] | all isHexDigit xs = Color (hf' r1 r0) (hf' g1 g0) (hf' b1 b0) 1
-    fromString x = error $ "Invalid color representation: " ++ x
-
-transparent :: Float -> Color -> Color
-transparent f (Color r g b a) = Color r g b (f * a)
-
-lighten :: Float -> Color -> Color
-lighten f (Color r g b a) = Color (r * (1 - f) + f) (g * (1 - f) + f) (b * (1 - f) + f) a
-
-darken :: Float -> Color -> Color
-darken f (Color r g b a) = Color (r * (1 - f)) (g * (1 - f)) (b * (1 - f)) a
-
--- | An intermediate between the given colors.
-intermediate :: Color -> Color -> Color
-intermediate (Color r0 g0 b0 a0) (Color r1 g1 b1 a1) = Color ((r0 + r1)/2) ((g0 + g1)/2) ((b0 + b1)/2) ((a0 + a1)/2)
-
-{-# DEPRECATED halfD "use darken 0.5 instead" #-}
--- | An intermediate between the black and the given color
-halfD :: Color -> Color
-halfD = intermediate black
-
-{-# DEPRECATED halfB "use lighten 0.5 instead" #-}
--- | An intermediate between the white and the given color
-halfB :: Color -> Color
-halfB = intermediate white
-
-white :: Color
-white = Color 1.0 1.0 1.0 1.0
-
-black :: Color
-black = Color 0.0 0.0 0.0 1.0
-
-red :: Color
-red = Color 1.0 0.0 0.0 1.0
-
-green :: Color
-green = Color 0.0 1.0 0.0 1.0
-
-blue :: Color
-blue = Color 0.0 0.0 1.0 1.0
-
-yellow :: Color
-yellow = Color 1.0 1.0 0.0 1.0
-
-cyan :: Color
-cyan = Color 0.0 1.0 1.0 1.0
-
-magenta :: Color
-magenta = Color 1.0 0.0 1.0 1.0
− Graphics/FreeGame/Data/Font.hs 
@@ -1,158 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.FreeGame.Data.Font
--- Copyright   :  (C) 2013 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
--- Stability   :  provisional
--- Portability :  non-portable
---
--- Rendering characters
-----------------------------------------------------------------------------
-module Graphics.FreeGame.Data.Font 
-  ( Font
-  , loadFont
-  , Metrics(..)
-  , Graphics.FreeGame.Data.Font.metrics
-  , fontBoundingBox
-  , charToBitmap
-  , RenderedChar(..)
-  , text
-  , renderCharacters
-  ) where
-
-import Control.Applicative
-import Control.Monad.IO.Class
-import Data.Array.Repa as R
-import Data.Array.Repa.Eval
-import Data.Vect
-import Data.IORef
-import qualified Data.Map as M
-import Data.Word
-import Graphics.FreeGame.Base
-import Graphics.FreeGame.Types
-import Graphics.FreeGame.Data.Bitmap
-import Graphics.FreeGame.Internal.Finalizer
-import Graphics.Rendering.FreeType.Internal
-import qualified Graphics.Rendering.FreeType.Internal.GlyphSlot as GS
-import qualified Graphics.Rendering.FreeType.Internal.Vector as V
-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 Metrics BoundingBox (IORef (M.Map (Float, Char) RenderedChar))
-
--- | Create a 'Font' from the given file.
-loadFont :: FilePath -> IO Font
-loadFont path = alloca $ \p -> do
-    e <- withCString path $ \str -> ft_New_Face freeType str 0 p
-    failFreeType e
-    f <- peek p
-    b <- peek (bbox f)
-    asc <- peek (ascender f)
-    desc <- peek (descender f)
-    u <- fromIntegral <$> peek (units_per_EM f)
-    let m = Metrics (fromIntegral asc/u) (fromIntegral desc/u)
-        box = BoundingBox (Vec2 (fromIntegral (xMin b)/u) (fromIntegral (yMin b)/u))
-                          (Vec2 (fromIntegral (xMax b)/u) (fromIntegral (yMin b)/u))
-    Font f m box <$> newIORef M.empty
--- | Get the font's metrics.
-metrics :: Font -> Metrics
-metrics (Font _ m _ _) = m
-
-fontBoundingBox :: Font -> BoundingBox
-fontBoundingBox (Font _ _ b _) = b
-
--- | Render a text by the specified 'Font'.
-text :: Font -> Float -> String -> Picture
-text font siz str = PictureWithFinalizer $ Pictures <$> renderCharacters font siz str
-
-failFreeType :: Monad m => CInt -> m ()
-failFreeType 0 = return ()
-failFreeType e = fail $ "FreeType Error:" Prelude.++ show e
-
-freeType :: FT_Library
-freeType = unsafePerformIO $ alloca $ \p -> do
-    failFreeType =<< ft_Init_FreeType p
-    peek p
-
-data RenderedChar = RenderedChar
-    { charBitmap :: Bitmap
-    , charOffset :: Vec2
-    ,　charAdvance :: Float
-    }
-
-data Metrics = Metrics
-    { metricsAscent :: Float
-    , metricsDescent :: Float
-    }
-
--- | The resolution used to render fonts.
-resolutionDPI :: Int
-resolutionDPI = 300
-
-charToBitmap :: Font -> Float -> Char -> FinalizerT IO RenderedChar
-charToBitmap (Font face _ _ refCache) pixel ch = do
-    cache <- liftIO $ readIORef refCache
-    case M.lookup (siz, ch) cache of
-        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
-
-            failFreeType =<< ft_Set_Char_Size face 0 (floor $ siz * 64) dpi dpi
-            
-            ix <- ft_Get_Char_Index face (fromIntegral $ fromEnum ch)
-            failFreeType =<< ft_Load_Glyph face ix ft_LOAD_DEFAULT
-
-            slot <- peek $ glyph face
-            failFreeType =<< 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 :: R.Array U DIM2 Word8 <- unsafeFreezeMVec (Z:.h:.w) mv
-
-            let pix (crd:.0) = R.index ar crd
-                pix (_:._) = 255
-
-            result <- computeP (fromFunction (Z:.h:.w:.4) pix) >>= makeStableBitmap
-            
-            return $ RenderedChar result (Vec2 left (-top)) (fromIntegral (V.x adv) / 64)
- 
-renderCharacters :: Font -> Float -> String -> FinalizerT IO [Picture]
-renderCharacters font pixel str = render str 0 where
-    render [] _ = return []
-    render (c:cs) pen = do
-        RenderedChar b (Vec2 x y) adv <- charToBitmap font pixel c
-        let (w,h) = bitmapSize b
-            offset = Vec2 (pen + x + fromIntegral w / 2) (y + fromIntegral h / 2)
-        (Translate offset (Bitmap b):) <$> render cs (pen + adv)
− Graphics/FreeGame/Input.hs 
@@ -1,87 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.FreeGame.Input
--- Copyright   :  (C) 2013 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
-----------------------------------------------------------------------------
-module Graphics.FreeGame.Input (
-    Button(..)
-    -- * Deprecated
-    , Key
-    , MouseState(..)
-    ) where
-
-import Data.Vect
-
--- | Buttons.
-data Button
-    = KeyChar Char
-    | KeySpace
-    | KeyEsc
-    | KeyF1
-    | KeyF2
-    | KeyF3
-    | KeyF4
-    | KeyF5
-    | KeyF6
-    | KeyF7
-    | KeyF8
-    | KeyF9
-    | KeyF10
-    | KeyF11
-    | KeyF12
-    | KeyLeftShift
-    | KeyRightShift
-    | KeyLeftControl
-    | KeyRightControl
-    | KeyUp
-    | KeyDown
-    | KeyLeft
-    | KeyRight
-    | KeyTab
-    | KeyEnter
-    | KeyBackspace
-    | KeyInsert
-    | KeyDelete
-    | KeyPageUp
-    | KeyPageDown
-    | KeyHome
-    | KeyEnd
-    | KeyPad0
-    | KeyPad1
-    | KeyPad2
-    | KeyPad3
-    | KeyPad4
-    | KeyPad5
-    | KeyPad6
-    | KeyPad7
-    | KeyPad8
-    | KeyPad9
-    | KeyPadDivide
-    | KeyPadMultiply
-    | KeyPadSubtract
-    | KeyPadAdd
-    | KeyPadDecimal
-    | KeyPadEqual
-    | KeyPadEnter
-    | MouseLeft
-    | MouseRight
-    | MouseMiddle
-    deriving (Show, Eq, Ord)
-
-data MouseState = MouseState
-    { mousePosition :: Vec2
-    , leftButton :: Bool
-    , middleButton :: Bool
-    , rightButton :: Bool
-    , mouseWheel :: Int
-    } deriving Show
-
-{-# DEPRECATED Key "use Button instead" #-}
--- Deprecated synonym for 'Button'.
-type Key = Button
− Graphics/FreeGame/Internal/Finalizer.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE Rank2Types #-}
-module Graphics.FreeGame.Internal.Finalizer (FinalizerT(..), finalizer, runFinalizerT) where
-
-import Control.Monad.IO.Class
-import Control.Applicative
-
--- | An action with explicit releasing action.
-newtype FinalizerT m a = FinalizerT
-    { unFinalizerT :: forall r. (a -> m r) -> (IO () -> r -> m r) -> m r }
-
--- | Add a finalizer.
-finalizer :: Monad m => IO () -> FinalizerT m ()
-finalizer m = FinalizerT $ \p f -> p () >>= f m
-
-instance Functor (FinalizerT m) where
-    fmap f (FinalizerT g) = FinalizerT $ \p -> g (p . f)
-
-instance Applicative (FinalizerT m) where
-    pure a = FinalizerT $ \p _ -> p a
-    FinalizerT ff <*> FinalizerT fa = FinalizerT $ \p f -> ff (\a -> fa (\b -> p (a b)) f) f
-
-instance Monad (FinalizerT m) where
-    return a = FinalizerT $ \p _ -> p a
-    FinalizerT rf >>= k = FinalizerT $ \p f -> rf (\x -> unFinalizerT (k x) p f) f
-
-instance MonadIO m => MonadIO (FinalizerT m) where
-    liftIO m = FinalizerT $ \r _ -> liftIO m >>= r
-
--- | Run the action and run all associated finalizers.
-runFinalizerT :: MonadIO m => FinalizerT m a -> m a
-runFinalizerT (FinalizerT z) = do
-    (fin, a) <- z (\a -> return (return (), a)) (\m (fs, r) -> return (m >> fs,　r))
-    liftIO fin
-    return a
− Graphics/FreeGame/Simple.hs 
@@ -1,92 +0,0 @@-{-# LANGUAGE RankNTypes, FlexibleContexts #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.FreeGame.Simple
--- Copyright   :  (C) 2013 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
--- Stability   :  provisional
--- Portability :  non-portable
---
--- The essentials of using free-game
-----------------------------------------------------------------------------
-module Graphics.FreeGame.Simple (
-    -- * Basic type
-    Game
-    ,GameAction
-
-    -- * Run the game
-    ,GameParam(..)
-    ,defaultGameParam
-    ,runSimple
-    ,runSimple'
-
-    -- * In the Game monad
-    ,drawPicture
-    ,getButtonState
-    ,getMousePosition
-    ,getMouseWheel
-    ,embedIO
-    ,quitGame
-    ,tick
-    ,untick
-    ,untickInfinite
-    ,untickGame
-
-    -- * About Picture
-    ,Picture(..)
-    ,Bitmap
-    ,loadBitmapFromFile
-    ,loadBitmaps
-    ,loadBitmapsWith
-    ,Vec2(..)
-
-    -- * Drawing texts
-    ,Font
-    ,loadFont
-    ,text
-
-    -- * Utilities
-    ,randomness
-    ,degrees
-
-    -- * Deprecated
-    ,askInput
-    ,getMouseState
-
-    -- * Reexports
-    ,module Graphics.FreeGame.Input
-    ,module Graphics.FreeGame.Data.Color
-    )
-
-where
-
-import Graphics.FreeGame
-import Graphics.FreeGame.Data.Color
-import Graphics.FreeGame.Input
-import Control.Monad
-import Control.Monad.Free
-
--- | Run a 'Game' by the given initial state and updating function.
-runSimple :: GameParam
-    -> world -- ^ An initial world
-    -> (world -> Game world) -- ^ A computation yielding new world
-    -> IO ()
-runSimple param initial m = void $ runGame param $ looping initial where
-    looping world = do
-        world' <- m world
-        tick
-        looping world'
-
--- | In most cases there's no unwrapping (Game a -> GameAction (Game a)).
--- | The use of ('>>=') is more efficient than 'runGame' in such situation.
-runSimple' :: GameParam
-    -> world -- ^ An initial world
-    -> (world -> forall m. MonadFree GameAction m => m world) -- ^ A computation yielding new world
-    -> IO ()
-runSimple' param initial m = void $ runGame' param $ looping initial where
-    looping world = do
-        world' <- m world
-        tick
-        looping world'
− Graphics/FreeGame/Types.hs 
@@ -1,17 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.FreeGame.Types
--- Copyright   :  (C) 2013 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
--- Stability   :  provisional
--- Portability :  non-portable
---
-----------------------------------------------------------------------------
-module Graphics.FreeGame.Types (BoundingBox(..)) where
-import Data.Vect
-data BoundingBox = BoundingBox
-    { topLeft :: Vec2
-    , bottomRight :: Vec2
-    } deriving (Show)
− Graphics/FreeGame/Util.hs 
@@ -1,107 +0,0 @@-{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.FreeGame.Util
--- Copyright   :  (C) 2013 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
-----------------------------------------------------------------------------
-
-module Graphics.FreeGame.Util (
-    untick,
-    untickGame,
-    untickInfinite,
-    randomness,
-    degrees,
-    radians,
-    loadPictureFromFile,
-    loadBitmaps,
-    loadBitmapsWith) where
-import Control.Monad
-import Control.Monad.Free
-import Control.Applicative
-import Data.Char
-import Graphics.FreeGame.Base
-import Graphics.FreeGame.Data.Bitmap
-import System.Random
-import Language.Haskell.TH
-import System.Directory
-import System.FilePath
-import System.IO.Unsafe
-import Data.Void
-
-untickGame :: MonadFree GameAction m => Free GameAction a -> m (Free GameAction a)
-untickGame (Pure a) = return (Pure a)
-untickGame (Free (Tick cont)) = return cont
-untickGame (Free fm) = wrap $ fmap untickGame fm
-{-# DEPRECATED untickGame "use untick or untickInfinite instead" #-}
-
--- | Run a 'Game' as one frame.
-untick :: MonadFree GameAction m => Free GameAction a -> m (Either (Free GameAction 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 :: MonadFree GameAction m => Free GameAction Void -> m (Free GameAction Void)
-untickInfinite = liftM (either id absurd) . untick
-
--- | Get a given range of value.
-randomness :: (Random r, MonadFree GameAction m) => (r, r) -> m r
-randomness r = embedIO $ randomRIO r
-
--- | 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 :: MonadFree GameAction m => FilePath -> m Picture
-loadPictureFromFile = embedIO . fmap Bitmap . loadBitmapFromFile
-
--- | Load and define all pictures in the specified directory.
-loadBitmapsWith :: Name -> FilePath -> Q [Dec]
-loadBitmapsWith getFullPath path = do
-    loc <- (</>path) <$> takeDirectory <$> loc_filename <$> location
-    paths <- runIO $ getFileList loc
-    
-    sequence $ do
-        p <- paths
-        let name = pathToName p
-        [ return $ SigD (mkName name) (ConT ''Bitmap)
-            , funD (mkName name) [clause [] (normalB $ load name $ loc </> p) []]
-            ]
-    where
-        load name fp = do
-            runIO $ putStrLn $ "Defined: " ++ fp ++ " as `" ++ name ++ "'"
-            appE (varE 'unsafePerformIO) $ uInfixE (appE (varE getFullPath) (litE $ StringL fp))
-                (varE '(>>=))
-                (varE 'loadBitmapFromFile)
-
--- | use with getDataFileName
-loadBitmaps :: FilePath -> Q [Dec]
-loadBitmaps = loadBitmapsWith 'canonicalizePath
-
-getFileList :: FilePath -> IO [FilePath]
-getFileList path = do
-    allContents <- filter notHidden `fmap` getDirectoryContents path
-    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 view
@@ -0,0 +1,62 @@+{-|
+Module      :  Graphics.UI.FreeGame
+Copyright   :  (C) 2013 Fumiaki Kinoshita
+License     :  BSD-style (see the file LICENSE)
+Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
+
+free-game is a library that abstracts and purifies GUI applications with simple interfaces.
+-}
+module Graphics.UI.FreeGame
+  ( -- * Examples
+    -- $example
+    -- * 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.Data.Color,
+    module Graphics.UI.FreeGame.GUI,
+    module Graphics.UI.FreeGame.Util,
+    module Graphics.UI.FreeGame.Types
+
+) where
+
+import Graphics.UI.FreeGame.Base
+import Graphics.UI.FreeGame.GUI (GUI, GUIParam(..), Picture)
+import Graphics.UI.FreeGame.Util
+import Graphics.UI.FreeGame.Types
+import Graphics.UI.FreeGame.Data.Bitmap
+import Graphics.UI.FreeGame.Data.Font
+import Graphics.UI.FreeGame.Data.Color
+import qualified Graphics.UI.FreeGame.GUI.GLFW as GLFW
+import Control.Monad.Free.Church
+import Data.Default
+
+-- | 'Game' is a "free" monad which describes GUIs.
+-- This monad is an instance of 'Picture2D' so you can create it using 'fromBitmap' and can be transformed with 'translate', 'scale', 'rotate', 'colored'.
+--
+-- It is also an instance of 'Keyboard' and 'Mouse'.
+--
+-- You have to call 'tick' at the end of the current frame.
+--
+-- The only way to embody 'Game' as real thing is to apply 'runGame'.
+type Game = F GUI
+
+-- | Run a 'Game'.
+runGame :: GUIParam -> Game a -> IO (Maybe a)
+runGame = GLFW.runGame
+
+{- $example
+
+> import Control.Monad
+> import Graphics.UI.FreeGame
+> main = runGame def $ forever tick
+
+shows a window and does nothing.
+
+for more examples, see <https://github.com/fumieval/free-game/tree/master/examples>.
+
+-}
+ Graphics/UI/FreeGame/Base.hs view
@@ -0,0 +1,282 @@+{-# 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 Kinsohita <fumiexcel@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Abstract structures for descripting user interfaces+----------------------------------------------------------------------------++module Graphics.UI.FreeGame.Base (+    -- * Types+    UI(..)++    -- * Basic operations+    ,tick+    ,bracket+    ,quit+    ,embedIO+    ,liftUI+    ,_LiftUI+    -- * Classes+    ,Picture2D(..)+    ,Keyboard(..)+    ,Mouse(..)+    ,FromFinalizer(..)+    ,SpecialKey(..)+) where++import Control.Applicative+import Control.Applicative.Free as Ap+import Control.Monad.IO.Class+import Data.Monoid+import Data.Void+import Graphics.UI.FreeGame.Data.Bitmap+import Graphics.UI.FreeGame.Data.Color+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`++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)+    | 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 Void+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++-- | @'_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 o) = fmap LiftUI (f o)+_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 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 hoistFR #-}++-- | 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 ()+    -- | Counterclockwise, degrees+    rotate :: Float -> p a -> p a+    scale :: V2 Float -> p a -> p a+    translate :: V2 Float -> p a -> p a+    colored :: Color -> 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 (V2 Float)+    mouseWheel :: t Int+    mouseButtonL :: t Bool+    mouseButtonM :: t Bool+    mouseButtonR :: t Bool++class FromFinalizer m where+    fromFinalizer :: FinalizerT IO a -> m a++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; \+    rotate = (t) . rotate; \+    translate = (t) . translate; \+    scale = (t) . scale; \+    colored = (t) . colored }++#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_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 view
@@ -0,0 +1,84 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Graphics.UI.FreeGame.Data.Bitmap
+-- Copyright   :  (C) 2013 Fumiaki Kinoshita
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Fumiaki Kinsohita <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
+
+-- | 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.
+
+-- | @'_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 $ head $ foldAllP 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 :: FilePath -> IO Bitmap
+loadBitmapFromFile path = readImageRGBA path >>= either fail return >>= makeStableBitmap . imgData
+
+-- | 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) (head . computeP . extract (Z :. y :. x :. 0) (Z :. h :. w :. 4)) bmp
+ Graphics/UI/FreeGame/Data/Color.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE Rank2Types #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Graphics.UI.FreeGame.Data.Color
+-- Copyright   :  (C) 2013 Fumiaki Kinoshita
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
+-- Stability   :  provisional
+-- Portability :  non-portable
+--
+-- Colors and its operations
+----------------------------------------------------------------------------
+module Graphics.UI.FreeGame.Data.Color (
+    -- * The type
+    Color(..)
+    -- * Color operations
+    , blend
+    -- * Lenses
+    , _Red, _Green, _Blue, _Alpha, _8Bit
+    -- * Basic colors
+    , white, black, red, green, blue, yellow, cyan, magenta
+    ) where
+
+import Data.String
+import Data.Char
+import Data.Profunctor
+import Data.Word
+
+-- | A color that has red, green, blue, alpha as its component.
+data Color = Color Float Float Float Float deriving (Show, Eq, Ord)
+
+-- | @'_8Bit' :: Iso' 'Float' 'Word8'@
+_8Bit :: forall p f. (Profunctor p, Functor f) => p Word8 (f Word8) -> p Float (f Float)
+_8Bit = dimap (floor.(*255)) (fmap ((/255) . fromIntegral))
+
+-- | @'_Red' :: Lens' 'Color' 'Float'@
+_Red :: Functor f => (Float -> f Float) -> Color -> f Color
+_Red f (Color r g b a) = fmap (\r' -> Color r' g b a) (f r)
+
+-- | @'_Green' :: Lens' 'Color' 'Float'@
+_Green :: Functor f => (Float -> f Float) -> Color -> f Color
+_Green f (Color r g b a) = fmap (\g' -> Color r g' b a) (f g)
+
+-- | @'_Blue' :: Lens' 'Color' 'Float'@
+_Blue :: Functor f => (Float -> f Float) -> Color -> f Color
+_Blue f (Color r g b a) = fmap (\b' -> Color r g b' a) (f b)
+
+-- | @'_Alpha' :: Lens' 'Color' 'Float'@
+_Alpha :: Functor f => (Float -> f Float) -> Color -> f Color
+_Alpha f (Color r g b a) = fmap (\a' -> Color r g b a') (f a)
+
+hf :: Char -> Float
+hf x = fromIntegral (digitToInt x) / 15
+
+hf' :: Char -> Char -> Float
+hf' x y = fromIntegral (digitToInt x * 16 + digitToInt y) / 255
+
+instance IsString Color where
+    fromString xs@[r,g,b,a] | all isHexDigit xs = Color (hf r) (hf g) (hf b) (hf a)
+    fromString xs@[r,g,b] | all isHexDigit xs = Color (hf r) (hf g) (hf b) 1
+    fromString xs@[r1,r0,g1,g0,b1,b0,a1,a0] | all isHexDigit xs = Color (hf' r1 r0) (hf' g1 g0) (hf' b1 b0) (hf' a1 a0)
+    fromString xs@[r1,r0,g1,g0,b1,b0] | all isHexDigit xs = Color (hf' r1 r0) (hf' g1 g0) (hf' b1 b0) 1
+    fromString x = error $ "Invalid color representation: " ++ x
+
+-- | Blend two colors.
+blend :: Float -> Color -> Color -> Color
+blend t (Color r0 g0 b0 a0) (Color r1 g1 b1 a1) = Color
+    (r0 * (1 - t) + r1 * t)
+    (g0 * (1 - t) + g1 * t)
+    (b0 * (1 - t) + b1 * t)
+    (a0 * (1 - t) + a1 * t)
+
+white :: Color
+white = Color 1.0 1.0 1.0 1.0
+
+black :: Color
+black = Color 0.0 0.0 0.0 1.0
+
+red :: Color
+red = Color 1.0 0.0 0.0 1.0
+
+green :: Color
+green = Color 0.0 1.0 0.0 1.0
+
+blue :: Color
+blue = Color 0.0 0.0 1.0 1.0
+
+yellow :: Color
+yellow = Color 1.0 1.0 0.0 1.0
+
+cyan :: Color
+cyan = Color 0.0 1.0 1.0 1.0
+
+magenta :: Color
+magenta = Color 1.0 0.0 1.0 1.0
+ Graphics/UI/FreeGame/Data/Font.hs view
@@ -0,0 +1,159 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Graphics.UI.FreeGame.Data.Font
+-- Copyright   :  (C) 2013 Fumiaki Kinoshita
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
+-- Stability   :  provisional
+-- Portability :  non-portable
+--
+-- Rendering characters
+----------------------------------------------------------------------------
+module Graphics.UI.FreeGame.Data.Font 
+  ( Font
+  , loadFont
+  , Metrics(..)
+  , Graphics.UI.FreeGame.Data.Font.metrics
+  , fontBoundingBox
+  , charToBitmap
+  , RenderedChar(..)
+  , text
+  , renderCharacters
+  ) where
+
+import Control.Applicative
+import Control.Monad
+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 Metrics (BoundingBox Float) (IORef (M.Map (Float, Char) RenderedChar))
+
+-- | Create a 'Font' from the given file.
+loadFont :: FilePath -> IO Font
+loadFont path = alloca $ \p -> do
+    e <- withCString path $ \str -> ft_New_Face freeType str 0 p
+    failFreeType e
+    f <- peek p
+    b <- peek (bbox f)
+    asc <- peek (ascender f)
+    desc <- peek (descender f)
+    u <- fromIntegral <$> peek (units_per_EM f)
+    let m = Metrics (fromIntegral asc/u) (fromIntegral desc/u)
+        box = BoundingBox (fromIntegral (xMin b)/u) (fromIntegral (yMin b)/u)
+                          (fromIntegral (xMax b)/u) (fromIntegral (yMax b)/u)
+    Font f m box <$> newIORef M.empty
+
+-- | Get the font's metrics.
+metrics :: Font -> Metrics
+metrics (Font _ m _ _) = m
+
+fontBoundingBox :: Font -> BoundingBox Float
+fontBoundingBox (Font _ _ b _) = b
+
+-- | Render a text by the specified 'Font'.
+text :: (Monad p, Picture2D p, FromFinalizer p) => Font -> Float -> String -> p ()
+text font siz str = join $ fromFinalizer $ fmap sequence_ (renderCharacters font siz str)
+
+failFreeType :: Monad m => CInt -> m ()
+failFreeType 0 = return ()
+failFreeType e = fail $ "FreeType Error:" Prelude.++ show e
+
+freeType :: FT_Library
+freeType = unsafePerformIO $ alloca $ \p -> do
+    failFreeType =<< ft_Init_FreeType p
+    peek p
+
+data RenderedChar = RenderedChar
+    { charBitmap :: Bitmap
+    , charOffset :: V2 Float
+    ,　charAdvance :: Float
+    }
+
+data Metrics = Metrics
+    { metricsAscent :: Float
+    , metricsDescent :: Float
+    }
+
+-- | The resolution used to render fonts.
+resolutionDPI :: Int
+resolutionDPI = 300
+
+charToBitmap :: Font -> Float -> Char -> FinalizerT IO RenderedChar
+charToBitmap (Font face _ _ refCache) pixel ch = do
+    cache <- liftIO $ readIORef refCache
+    case M.lookup (siz, ch) cache of
+        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
+
+            failFreeType =<< ft_Set_Char_Size face 0 (floor $ siz * 64) dpi dpi
+            
+            ix <- ft_Get_Char_Index face (fromIntegral $ fromEnum ch)
+            failFreeType =<< ft_Load_Glyph face ix ft_LOAD_DEFAULT
+
+            slot <- peek $ glyph face
+            failFreeType =<< 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)
+ 
+renderCharacters :: (Monad p, Picture2D p) => Font -> Float -> String -> FinalizerT IO [p ()]
+renderCharacters font pixel str = render str 0 where
+    render [] _ = return []
+    render (c:cs) pen = do
+        RenderedChar b (V2 x y) adv <- charToBitmap font pixel c
+        let (w,h) = bitmapSize b
+            offset = V2 (pen + x + fromIntegral w / 2) (y + fromIntegral h / 2)
+        (translate offset (fromBitmap b):) <$> render cs (pen + adv)
+ Graphics/UI/FreeGame/GUI.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DeriveFunctor #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Graphics.UI.FreeGame.GUI
+-- Copyright   :  (C) 2013 Fumiaki Kinoshita
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
+-- Stability   :  provisional
+-- Portability :  non-portable
+-- Provides the "free" embodiment.
+----------------------------------------------------------------------------
+module Graphics.UI.FreeGame.GUI (
+    GUI
+    , GUIBase(..)
+    , _Draw
+    , _Input
+    , GUIInput(..)
+    , Picture(..)
+    , GUIParam(..)
+) where
+
+import Graphics.UI.FreeGame.Base
+import Graphics.UI.FreeGame.Data.Color
+import Graphics.UI.FreeGame.Data.Bitmap
+import Graphics.UI.FreeGame.Internal.Finalizer
+import Graphics.UI.FreeGame.Internal.Raindrop
+import Control.Applicative
+import Control.Applicative.Free (Ap)
+import Data.Default
+import Linear hiding (rotate)
+
+-- | A 'Functor' which represents graphical user interfaces.
+type GUI = UI GUIBase
+
+data GUIBase a = Input (Ap GUIInput a) | Draw (Picture a) deriving Functor
+
+_Draw :: Applicative f => (Picture a -> f (Picture a)) -> GUIBase a -> f (GUIBase a)
+_Draw f (Draw o) = fmap Draw (f o)
+_Draw _ x = pure x
+
+_Input :: Applicative f => (Ap GUIInput a -> f (Ap GUIInput a)) -> GUIBase a -> f (GUIBase a)
+_Input f (Input o) = fmap Input (f o)
+_Input _ x = pure x
+
+instance Picture2D GUIBase where
+    fromBitmap = Draw . fromBitmap
+    rotate = over _Draw . rotate
+    scale = over _Draw . scale
+    translate = over _Draw . translate
+    colored = over _Draw . colored
+
+instance Keyboard GUIBase where
+    keyChar = Input . keyChar
+    keySpecial = Input . keySpecial
+
+instance Mouse GUIBase where
+    mousePosition = Input mousePosition
+    mouseWheel = Input mouseWheel
+    mouseButtonL = Input mouseButtonL
+    mouseButtonR = Input mouseButtonR
+    mouseButtonM = Input mouseButtonR
+
+instance FromFinalizer GUIBase where
+    fromFinalizer = Draw . fromFinalizer
+
+data GUIInput a = 
+      ICharKey Char (Bool -> a)
+    | ISpecialKey SpecialKey (Bool -> a)
+    | IMousePosition (V2 Float -> a)
+    | IMouseWheel (Int -> a)
+    | IMouseButtonL (Bool -> a)
+    | IMouseButtonM (Bool -> a)
+    | IMouseButtonR (Bool -> a)
+    deriving Functor
+
+data Picture a
+    = LiftBitmap Bitmap a
+    | PictureWithFinalizer (FinalizerT IO a)
+    | Rotate Float (Picture a)
+    | Scale (V2 Float) (Picture a)
+    | Translate (V2 Float) (Picture a)
+    | Colored Color (Picture a)
+    deriving Functor
+
+instance Picture2D Picture where
+    fromBitmap = flip LiftBitmap ()
+    rotate = Rotate
+    scale = Scale
+    translate = Translate
+    colored = Colored
+
+instance FromFinalizer Picture where
+    fromFinalizer = PictureWithFinalizer
+
+instance Keyboard GUIInput where
+    keyChar x = ICharKey x id
+    keySpecial x = ISpecialKey x id
+
+instance Mouse GUIInput where
+    mousePosition = IMousePosition id
+    mouseWheel = IMouseWheel id
+    mouseButtonL = IMouseButtonL id
+    mouseButtonR = IMouseButtonR id
+    mouseButtonM = IMouseButtonM id
+
+data GUIParam = GUIParam
+    { _framePerSecond :: Int
+    , _windowSize :: V2 Int
+    , _windowTitle :: String
+    , _windowed :: Bool
+    , _cursorVisible :: Bool
+    , _clearColor :: Color
+    , _windowOrigin :: V2 Float
+    } deriving Show
+
+instance Default GUIParam where
+    def = GUIParam
+        { _framePerSecond = 60
+        , _windowSize = V2 640 480
+        , _windowTitle = "free-game"
+        , _windowed = True
+        , _cursorVisible = True
+        , _clearColor = white
+        , _windowOrigin = V2 0 0
+        }
+ Graphics/UI/FreeGame/GUI/GLFW.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE ImplicitParams #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Graphics.UI.FreeGame.GUI.GLFW
+-- Copyright   :  (C) 2013 Fumiaki Kinoshita
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+----------------------------------------------------------------------------
+module Graphics.UI.FreeGame.GUI.GLFW (runGame) where
+import Control.Applicative
+import Control.Applicative.Free as Ap
+import Control.Monad
+import Control.Monad.Free.Church
+import Control.Monad.IO.Class
+import Data.IORef
+import Foreign.ForeignPtr
+import Graphics.UI.FreeGame.Base
+import Graphics.UI.FreeGame.Data.Bitmap
+import Graphics.UI.FreeGame.Data.Color
+import Graphics.UI.FreeGame.Internal.Finalizer
+import Graphics.UI.FreeGame.GUI
+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 Linear
+
+runGame :: GUIParam -> F GUI a -> IO (Maybe a)
+runGame param m = launch param $ \r s -> runF m (return . Just) (runAction param r s)
+
+runAction :: GUIParam
+    -> IORef (IM.IntMap Texture)
+    -> IORef Int
+    -> GUI (FinalizerT IO (Maybe a)) -> FinalizerT IO (Maybe a)
+runAction param refTextures refFrame _f = case _f of
+    LiftUI (Draw pic) -> let ?refTextures = refTextures in join $ runPicture pic
+    EmbedIO m -> join (liftIO m)
+    Bracket m -> liftIO (runFinalizerT $ runF m (return.Just) (runAction param refTextures refFrame)) >>= maybe (return Nothing) id
+    LiftUI (Input i) -> join $ liftIO $ runInput i
+    Quit -> return Nothing
+    Tick cont -> do
+        liftIO $ do
+            GL.matrixMode $= GL.Projection
+            GLFW.swapBuffers
+            performGC
+            t <- GLFW.getTime
+            n <- readIORef refFrame
+            GLFW.sleep $ fromIntegral n / fromIntegral (_framePerSecond param) - t
+            if t > 1
+                then GLFW.resetTime >> writeIORef refFrame 0
+                else writeIORef refFrame (succ n)
+
+        r <- liftIO $ GLFW.windowIsOpen
+        if not r then return Nothing else do
+            liftIO $ do
+                GL.clear [GL.ColorBuffer] 
+                GL.loadIdentity
+                GL.scale (gf 1) (-1) 1
+                let V2 ox oy = _windowOrigin param
+                    V2 ww wh = _windowSize param
+                    windowL = realToFrac ox
+                    windowR = realToFrac ox + fromIntegral ww
+                    windowT = realToFrac oy
+                    windowB = realToFrac oy + fromIntegral wh
+                GL.ortho windowL windowR windowT windowB 0 (-100)
+                GL.matrixMode $= GL.Modelview 0
+            cont
+
+data Texture = Texture GL.TextureObject !Int !Int
+
+bool :: a -> a -> Bool -> a
+bool r _ False = r
+bool _ r True = r
+
+launch :: GUIParam -> (IORef (IM.IntMap Texture) -> IORef Int -> 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 = _windowSize 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.Smooth
+    GL.texture GL.Texture2D $= GL.Enabled
+    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)
+
+    res <- runFinalizerT $ join $ m <$> liftIO (newIORef IM.empty) <*> liftIO (newIORef 0)
+
+    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 Nothing GL.NoProxy 0 GL.RGBA8 siz 0
+        . GL.PixelData GL.RGBA GL.UnsignedInt8888
+    finalizer $ GL.deleteObjectNames [tex]
+    return $ Texture tex width height
+
+runInput :: Ap GUIInput a -> IO a
+runInput (Ap.Pure a) = pure a
+runInput (Ap.Ap v af) = (runInput af <*>) $ case v of
+    ICharKey ch cont -> cont <$> GLFW.keyIsPressed (GLFW.CharKey ch)
+    ISpecialKey x cont -> cont <$> GLFW.keyIsPressed (mapSpecialKey x)
+    IMouseButtonL cont -> cont <$> GLFW.mouseButtonIsPressed GLFW.MouseButton0
+    IMouseButtonR cont -> cont <$> GLFW.mouseButtonIsPressed GLFW.MouseButton1
+    IMouseButtonM cont -> cont <$> GLFW.mouseButtonIsPressed GLFW.MouseButton2
+    IMousePosition cont -> do
+        (x, y) <- GLFW.getMousePosition
+        return $ cont $ V2 (fromIntegral x) (fromIntegral y)
+    IMouseWheel cont -> cont <$> GLFW.getMouseWheel
+
+runPicture :: (?refTextures :: IORef (IM.IntMap Texture)) => Picture a -> FinalizerT IO a
+runPicture (LiftBitmap bmp@(BitmapData _ (Just h)) r) = do
+    m <- liftIO $ readIORef ?refTextures
+    case IM.lookup h m of
+        Just t -> liftIO $ drawTexture t
+        Nothing -> do
+            t <- installTexture bmp
+            liftIO $ writeIORef ?refTextures $ IM.insert h t m
+            liftIO $ drawTexture t
+            finalizer $ modifyIORef ?refTextures $ IM.delete h
+    return r
+runPicture (LiftBitmap bmp@(BitmapData _ Nothing) r) = do
+    liftIO $ runFinalizerT $ installTexture bmp >>= liftIO . drawTexture
+    return r
+runPicture (Rotate theta cont) = preservingMatrix' $ do
+    liftIO $ GL.rotate (gf (-theta)) (GL.Vector3 0 0 1)
+    runPicture cont
+runPicture (Scale (V2 sx sy) cont) = preservingMatrix' $ do
+    liftIO $ GL.scale (gf sx) (gf sy) 1
+    runPicture cont
+runPicture (Translate (V2 tx ty) cont) = preservingMatrix' $ do
+    liftIO $ GL.translate (GL.Vector3 (gf tx) (gf ty) 0)
+    runPicture cont
+runPicture (PictureWithFinalizer m) = m
+runPicture (Colored (Color r g b a) cont) = do
+    oldColor <- liftIO $ get GL.currentColor
+    liftIO $ GL.currentColor $= GL.Color4 (gf r) (gf g) (gf b) (gf a)
+    res <- runPicture cont
+    liftIO $ GL.currentColor $= oldColor
+    return res
+
+preservingMatrix' :: MonadIO m => m a -> m a
+preservingMatrix' m = do
+    liftIO $ glPushMatrix
+    r <- m
+    liftIO $ glPopMatrix
+    return r
+
+gf :: Float -> GL.GLfloat
+{-# INLINE gf #-}
+gf x = unsafeCoerce x
+
+gsizei :: Int -> GL.GLsizei
+{-# INLINE gsizei #-}
+gsizei x = unsafeCoerce x
+
+drawTexture :: Texture -> IO ()
+drawTexture (Texture tex width height) = do
+    let (w, h) = (fromIntegral width / 2, fromIntegral height / 2)
+    GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest)
+    GL.textureBinding GL.Texture2D $= Just tex
+    GL.renderPrimitive GL.Polygon $ zipWithM_
+        (\(pX, pY) (tX, tY) -> do
+            GL.texCoord $ GL.TexCoord2 (gf tX) (gf tY)
+            GL.vertex $ GL.Vertex2 (gf pX) (gf pY))
+        [(-w, -h), (w, -h), (w, h), (-w, h)]
+        [(0,0), (1.0,0), (1.0,1.0), (0,1.0)]
+
+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
+ Graphics/UI/FreeGame/Internal/Finalizer.hs view
@@ -0,0 +1,34 @@+{-# 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/Types.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveFunctor #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Graphics.UI.FreeGame.Types
+-- Copyright   :  (C) 2013 Fumiaki Kinoshita
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
+-- Stability   :  provisional
+-- Portability :  non-portable
+--
+----------------------------------------------------------------------------
+module Graphics.UI.FreeGame.Types (
+    BoundingBox(..),
+    _TopLeft,
+    _TopRight,
+    _BottomLeft,
+    _BottomRight
+    ) where
+
+import Linear.V2
+
+-- | 2D bounding box.
+data BoundingBox a = BoundingBox a a a a deriving (Show, Eq, Ord, Functor, Read)
+
+-- | @'_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 view
@@ -0,0 +1,127 @@+{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Graphics.UI.FreeGame.Util
+-- Copyright   :  (C) 2013 Fumiaki Kinoshita
+-- License     :  BSD-style (see the file LICENSE)
+--
+-- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+----------------------------------------------------------------------------
+
+module Graphics.UI.FreeGame.Util (
+    -- * Combinators
+    notF,
+    (<&&>),
+    (<||>),
+    -- * Controlling
+    untick,
+    untickInfinite,
+    -- * Random
+    randomness,
+    -- * Helper
+    degrees,
+    radians,
+    sinCos,
+    -- * Loading
+    loadPictureFromFile,
+    loadBitmaps,
+    loadBitmapsWith
+    ) where
+import Control.Monad
+import Control.Monad.Free
+import Control.Applicative
+import Data.Char
+import Graphics.UI.FreeGame.Base
+import Graphics.UI.FreeGame.Data.Bitmap
+import System.Random
+import Language.Haskell.TH
+import System.Directory
+import System.FilePath
+import System.IO.Unsafe
+import Data.Void
+import Linear
+
+-- | A lifted 'not'.
+notF :: Functor f => f Bool -> f Bool
+notF = fmap not
+
+-- | A lifted '(&&)'.
+(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool
+(<&&>) = liftA2 (&&)
+
+-- | A lifted '(||)'
+(<||>) :: Applicative f => f Bool -> f Bool -> f Bool
+(<||>) = liftA2 (||)
+
+-- | Create a unit vector from a direction.
+sinCos :: Floating a => a -> V2 a
+sinCos t = V2 (cos t) (sin t)
+
+-- | 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
+
+-- | Load and define all pictures in the specified directory.
+loadBitmapsWith :: Name -> FilePath -> Q [Dec]
+loadBitmapsWith getFullPath path = do
+    loc <- (</>path) <$> takeDirectory <$> loc_filename <$> location
+    paths <- runIO $ getFileList loc
+    
+    sequence $ do
+        p <- paths
+        let name = pathToName p
+        [ return $ SigD (mkName name) (ConT ''Bitmap)
+            , funD (mkName name) [clause [] (normalB $ load name $ loc </> p) []]
+            ]
+    where
+        load name fp = do
+            runIO $ putStrLn $ "Defined: " ++ fp ++ " as `" ++ name ++ "'"
+            appE (varE 'unsafePerformIO) $ uInfixE (appE (varE getFullPath) (litE $ StringL fp))
+                (varE '(>>=))
+                (varE 'loadBitmapFromFile)
+
+-- | use with getDataFileName
+loadBitmaps :: FilePath -> Q [Dec]
+loadBitmaps = loadBitmapsWith 'canonicalizePath
+
+getFileList :: FilePath -> IO [FilePath]
+getFileList path = do
+    allContents <- filter notHidden `fmap` getDirectoryContents path
+    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 = '_'
− examples/VL-PGothic-Regular.ttf

file too large to diff

− examples/bitmap.hs 
@@ -1,21 +0,0 @@-import Graphics.FreeGame.Simple
-import Graphics.FreeGame.Data.Bitmap
-import Control.Monad
-import Data.Array.Repa
-import Data.Word
-
-renderCircle :: Int -> (Word8, Word8, Word8, Word8) -> Bitmap
-renderCircle size (r,g,b,a) = toStableBitmap $ computeS $ fromFunction (Z :. size :. size :. 4) render where
-    center = fromIntegral size / 2
-    render (Z:.y:.x:.0)
-        | s < 0 = a
-        | s >= 1 = 0
-        | otherwise = floor ((1 - s) * 256)
-        where
-            r = sqrt $ (fromIntegral y - center) ^ 2 + (fromIntegral x - center) ^ 2
-            s = r - fromIntegral size / 2
-    render (Z:._:._:.c) = [undefined,b,g,r] !! c
-
-main = runSimple defaultGameParam () $ \_ -> drawPicture $ Translate (Vec2 240 240) circle
-    where
-        circle = Scale (Vec2 0.5 0.5) $ BitmapPicture $ renderCircle 128 (128,216,128,255)
− examples/font.hs 
@@ -1,16 +0,0 @@-import Graphics.FreeGame.Simple
-import Graphics.FreeGame.Data.Color
-import Graphics.FreeGame.Data.Font
-import Control.Monad
-
-main = do
-    font <- loadFont "VL-PGothic-Regular.ttf"
-    print $ fontBoundingBox font
-    runSimple defaultGameParam 0 $ \n -> do
-        drawPicture $ Translate (Vec2 30 120) $ Colored (halfD red) $ text font 14 ("Counter: " ++ show n)
-
-        drawPicture $ Translate (Vec2 30 240) $ Colored (halfD blue) $ text font 20 "日本語も、美しくレンダリング。"
-
-        -- drawPicture $ Translate (Vec2 30 (240 +  * 20)) $ Colored (halfD green) $ text font 20 "___"
-
-        return $! n + 1
− examples/images/logo.png

binary file changed (1893 → absent bytes)

− examples/test.hs 
@@ -1,59 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}
-import Graphics.FreeGame.Simple
-import Control.Applicative
-import Control.Monad
-import Data.Vect
-import Control.Monad.State
-import Data.Void
-import Control.Lens -- using lens (http://hackage.haskell.org/package/lens)
-
-$(loadBitmaps "images")
-
-data Object = Object
-    { _position :: Vec2
-    , _velocity :: Vec2
-    , _pressed :: Bool
-    }
-
-$(makeLenses ''Object)
-
-obj :: StateT Object Game Void
-obj = forever $ do
-    pos@(Vec2 x y) <- use position
-
-    vel@(Vec2 dx dy) <- use velocity
-
-    let dx' | x <= 0 = abs dx
-            | x >= 640 = -(abs dx)
-            | otherwise = dx
-        dy' | y <= 0 = abs dy
-            | y >= 480 = -(abs dy)
-            | otherwise = dy
-
-    position .= pos &+ vel
-    velocity .= Vec2 dx' dy'
-
-    mpos <- getMousePosition
-
-    w <- if norm (mpos &- pos) < 32
-        then do
-            btn <- use pressed
-            btn' <- getButtonState MouseLeft
-            when (not btn && btn') $ velocity <~ (&*4) <$> sinCos <$> randomness (0, 2 * pi)
-            pressed .= btn'
-            return id
-
-        else return $ Colored (transparent 0.7 white)
-
-    drawPicture $ Translate pos $ w (Bitmap _logo_png)
-
-    tick
-
-initial :: Game Void
-initial = do
-    x <- randomness (0,640)
-    y <- randomness (0,480)
-    a <- randomness (0, 2 * pi)
-    evalStateT obj $ Object (Vec2 x y) (sinCos a &* 4) False
-
-main = runSimple defaultGameParam (replicate 100 initial) $ mapM untickInfinite
free-game.cabal view
@@ -1,6 +1,6 @@ name:                free-game
-version:             0.3.2.7
-synopsis:            Create graphical applications for free.
+version:             0.9
+synopsis:            Create graphical applications for free
 description:         Cross-platform GUI library based on free monads
 homepage:            https://github.com/fumieval/free-game
 bug-reports:         https://github.com/fumieval/free-game/issues
@@ -9,48 +9,51 @@ author:              Fumiaki Kinoshita
 maintainer:          Fumiaki Kinoshita <fumiexcel@gmail.com>
 copyright:           Copyright (C) 2012-2013 Fumiaki Kinoshita
-category:            Graphics
+category:            Graphics, Monads
 build-type:          Simple
 stability:           experimental
-cabal-version:       >=1.8
-extra-source-files:
-  examples/*.hs
-  examples/images/*.png
-  examples/VL-PGothic-Regular.ttf
+cabal-version:       >=1.10
 
 source-repository head
   type: git
   location: https://github.com/fumieval/free-game.git
 
 library
-  exposed-modules:     Graphics.FreeGame
-    , Graphics.FreeGame.Simple
-    , Graphics.FreeGame.Util
-    , Graphics.FreeGame.Input
-    , Graphics.FreeGame.Base
-    , Graphics.FreeGame.Types
-    , Graphics.FreeGame.Backends.GLFW
-    , Graphics.FreeGame.Data.Color
-    , Graphics.FreeGame.Data.Bitmap
-    , Graphics.FreeGame.Data.Font
-    , Graphics.FreeGame.Internal.Finalizer
+  default-language:   Haskell2010
+  exposed-modules:
+    Graphics.UI.FreeGame
+    Graphics.UI.FreeGame.Base
+    Graphics.UI.FreeGame.Data.Bitmap
+    Graphics.UI.FreeGame.Data.Color
+    Graphics.UI.FreeGame.Data.Font
+    Graphics.UI.FreeGame.GUI
+    Graphics.UI.FreeGame.GUI.GLFW
+    Graphics.UI.FreeGame.Internal.Finalizer
+    Graphics.UI.FreeGame.Types
+    Graphics.UI.FreeGame.Util
+
   ghc-options: -Wall -fexcess-precision -O2
-  build-depends: base == 4.*
-    , array >= 0.4
-    , containers >= 0.4
-    , directory >= 1.0
-    , filepath >= 1.3
-    , free == 3.*
-    , freetype2 >= 0.1
-    , GLFW-b >= 0.1.0.3
-    , hashable >= 1.2
-    , JuicyPixels-repa >= 0.5.1
-    , mtl >= 2.1
-    , OpenGL == 2.8.*
-    , OpenGLRaw >= 1.3
-    , random == 1.*
-    , repa >= 3.2
-    , transformers >= 0.3
-    , vect >= 0.4.7
-    , void >= 0.5
-    , template-haskell+
+  build-depends:
+    base == 4.*,
+    array >= 0.4,
+    containers >= 0.4,
+    directory >= 1.0,
+    filepath >= 1.3,
+    free == 3.*,
+    repa,
+    freetype2 >= 0.1,
+    GLFW-b >= 0.1.0.3,
+    hashable >= 1.2,
+    mtl >= 2.1,
+    OpenGL == 2.8.*,
+    OpenGLRaw == 1.3.*,
+    profunctors == 3.*,
+    random == 1.*,
+    transformers >= 0.3,
+    void >= 0.5,
+    template-haskell,
+    linear >= 1.1 && < 1.3,
+    vector == 0.10.*,
+    JuicyPixels-repa >= 0.5.1,
+    data-default