free-game 0.3.0.2 → 0.3.1.0

raw patch · 14 files changed

+530/−177 lines, 14 filesdep +freetype2dep +hashabledep −stb-truetypePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: freetype2, hashable

Dependencies removed: stb-truetype

API changes (from Hackage documentation)

Files

• Graphics/FreeGame.hs +7/−23
• Graphics/FreeGame/Backends/GLFW.hs +53/−25
• Graphics/FreeGame/Base.hs +38/−22
• Graphics/FreeGame/Bitmap.hs +0/−66
• Graphics/FreeGame/Data/Bitmap.hs +84/−0
• Graphics/FreeGame/Data/Color.hs +59/−0
• Graphics/FreeGame/Data/Font.hs +135/−0
• Graphics/FreeGame/Simple.hs +64/−0
• Graphics/FreeGame/Util.hs +3/−17
• examples/VL-PGothic-Regular.ttf too large to diff
• examples/bitmap.hs +21/−0
• examples/font.hs +15/−0
• examples/test.hs +41/−20
• free-game.cabal +10/−4

@@ -4,37 +4,26 @@ License     :  BSD-style (see the file LICENSE)
 Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
 
-free-game is a library that abstracts and purifies GUI applications.
-
-Small instruction:
-
-    * load images by 'loadPictureFromFile'.
-
-    * describe an application using 'drawPicture', 'askInput', 'tick', and so on, in Game monad.
-
-    * apply 'runGame defaultGameParam' to run.
-
-    * That's all!
+free-game is a library that abstracts and purifies GUI applications with simple interfaces.
 -}
 module Graphics.FreeGame
   ( -- * Examples
     -- $example
 
-    -- * Note
-    -- $note
-
     -- * Reexports
     module Graphics.FreeGame.Base,
-    module Graphics.FreeGame.Bitmap,
+    module Graphics.FreeGame.Data.Bitmap,
+    module Graphics.FreeGame.Data.Font,
     module Graphics.FreeGame.Input,
     module Graphics.FreeGame.Util,
     runGame
 ) where
 
 import Graphics.FreeGame.Base
-import Graphics.FreeGame.Bitmap
 import Graphics.FreeGame.Input
 import Graphics.FreeGame.Util
+import Graphics.FreeGame.Data.Bitmap
+import Graphics.FreeGame.Data.Font
 import qualified Graphics.FreeGame.Backends.GLFW as GLFW
 
 -- | Run a 'Game' computation.
@@ -43,16 +32,11 @@ 
 {- $example
 
-> main = runGame defaultGameParam $ forever tick
+> 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>.
-
--}
-
-{- $note
-
-* There are experimental implementation of text rendering('withRenderString'), but it often yields strange pictures.
 
 -}

@@ -3,9 +3,11 @@ import Graphics.UI.GLFW as GLFW
 import qualified Graphics.Rendering.OpenGL.GL as GL
 import Graphics.FreeGame.Base
-import Graphics.FreeGame.Bitmap
+import Graphics.FreeGame.Data.Bitmap
+import Graphics.FreeGame.Data.Color
 import qualified Graphics.FreeGame.Input as I
 import Codec.Picture.Repa
+import Control.Applicative
 import Control.Monad.Free
 import Control.Monad
 import System.Random
@@ -27,25 +29,25 @@     [tex] <- GL.genObjectNames 1
     GL.textureBinding GL.Texture2D GL.$= Just tex
 
-    fptr <- liftM RF.toForeignPtr $ computeP $ bitmapData bmp
+    let ar = bitmapData bmp
     let (width, height) = bitmapSize bmp
-    withForeignPtr fptr
+    withForeignPtr (RF.toForeignPtr ar)
         $ GL.texImage2D Nothing GL.NoProxy 0 GL.RGBA8 (GL.TextureSize2D (gsizei width) (gsizei height)) 0
         . GL.PixelData GL.RGBA GL.UnsignedInt8888
-
     return $ Texture tex width height
 
-drawPic :: (?refTextures :: IORef (IM.IntMap Texture)) => Picture -> IO ()
-drawPic (Image u) = do
-    Texture tex width height <- liftM (IM.! hashUnique u) $ readIORef ?refTextures
+freeTexture :: Texture -> IO ()
+freeTexture (Texture tex width height) = GL.deleteObjectNames [tex]
+
+drawTexture :: Texture -> IO ()
+drawTexture (Texture tex width height) = do
     let (w, h) = (fromIntegral width / 2, fromIntegral height / 2)
-    GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Repeat)
-    GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Repeat)
+    GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Clamp)
+    GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Clamp)
     GL.textureFilter   GL.Texture2D      $= ((GL.Nearest, Nothing), GL.Nearest)
     GL.texture GL.Texture2D $= GL.Enabled
     GL.textureFunction      $= GL.Combine    
     GL.textureBinding GL.Texture2D $= Just tex
-    GL.currentColor $= GL.Color4 1.0 1.0 1.0 1.0
     GL.renderPrimitive GL.Polygon $ zipWithM_
         (\(pX, pY) (tX, tY) -> do
             GL.texCoord $ GL.TexCoord2 (gf tX) (gf tY)
@@ -54,11 +56,40 @@         [(0,0), (1.0,0), (1.0,1.0), (0,1.0)]
     GL.texture GL.Texture2D GL.$= GL.Disabled
 
+drawPic :: (?refTextures :: IORef (IM.IntMap Texture)) => Picture -> IO [Int]
+drawPic (BitmapPicture bmp) = case bitmapHash bmp of
+    Nothing -> do
+        t <- installTexture bmp
+        drawTexture t
+        freeTexture t
+        return []
+    Just h -> do
+        m <- readIORef ?refTextures
+        case IM.lookup h m of
+            Just t -> [] <$ drawTexture t
+            Nothing -> do
+                t <- installTexture bmp
+                writeIORef ?refTextures $ IM.insert h t m
+                drawTexture t
+                return [h]
+
 drawPic (Rotate theta p) = GL.preservingMatrix $ GL.rotate (gf (-theta)) (GL.Vector3 0 0 1) >> drawPic p
+
 drawPic (Scale (Vec2 sx sy) p) = GL.preservingMatrix $ GL.scale (gf sx) (gf sy) 1 >> drawPic p
+
 drawPic (Translate (Vec2 tx ty) p) = GL.preservingMatrix $ GL.translate (GL.Vector3 (gf tx) (gf ty) 0) >> drawPic p
-drawPic (Pictures ps) = mapM_ drawPic ps
 
+drawPic (Pictures ps) = concat <$> mapM drawPic ps
+
+drawPic (Colored (Color r g b a) pic) = do
+    oldColor <- get GL.currentColor
+    GL.currentColor  $= GL.Color4 (gf r) (gf g) (gf b) (gf a)
+    r <- drawPic pic
+    GL.currentColor $= oldColor
+    return r
+
+drawPic (IOPicture m) = m >>= drawPic
+
 -- | Run 'Game' using OpenGL and GLFW.
 runGame :: GameParam -> Game a -> IO (Maybe a)
 runGame param game = do
@@ -100,6 +131,16 @@         modifyIORef ?refTextures $ flip (foldr IM.delete) is
         return (Just x)
     run is (Free f) = case f of
+        DrawPicture pic cont -> do
+            ls <- GL.preservingMatrix $ do
+                GL.loadIdentity
+                GL.scale (gf 1) (-1) 1
+                GL.ortho 0 (fromIntegral ?windowWidth) 0 (fromIntegral ?windowHeight) 0 (-100)
+                GL.matrixMode   $= GL.Modelview 0
+                ls <- drawPic pic
+                GL.matrixMode   $= GL.Projection
+                return ls
+            flip run cont $! ls Prelude.++ is -- Strict!!!
         EmbedIO m -> m >>= run is
         Bracket m -> run [] m >>= maybe (return Nothing) (run is)
         Tick cont -> do
@@ -123,20 +164,7 @@             b2 <- mouseButtonIsPressed MouseButton1
             w <- getMouseWheel
             run is $ fcont $ I.MouseState (Vec2 (fromIntegral x) (fromIntegral y)) b0 b2 b1 w
-        DrawPicture pic cont -> do
-            GL.preservingMatrix $ do
-                GL.loadIdentity
-                GL.scale (gf 1) (-1) 1
-                GL.ortho 0 (fromIntegral ?windowWidth) 0 (fromIntegral ?windowHeight) 0 (-100)
-                GL.matrixMode   $= GL.Modelview 0
-                drawPic pic
-                GL.matrixMode   $= GL.Projection
-            run is cont
-        LoadPicture bmp fcont -> do
-            tex <- installTexture bmp
-            u <- newUnique
-            modifyIORef ?refTextures $ IM.insert (hashUnique u) tex
-            run (hashUnique u:is) $ fcont (Image u)
+        QuitGame -> return Nothing
 
     mapKey k = case k of
         I.KeyChar c -> CharKey c

@@ -21,12 +21,13 @@     ,tick
     ,embedIO
     ,bracket
+    ,quitGame
 
     -- * Pictures
+    ,Vec2(..)
     ,Picture(..)
     ,transPicture
     ,drawPicture
-    ,loadPicture
     
     -- * Inputs
     ,askInput
@@ -36,37 +37,43 @@     ,GameParam(..)
     ,defaultGameParam
 
+    -- * Deprecated
+    ,loadPicture
 ) where
 
 import Control.Monad.Free
 import Control.Monad
-import Graphics.FreeGame.Bitmap
+import Graphics.FreeGame.Data.Color
+import Graphics.FreeGame.Data.Bitmap
 import Graphics.FreeGame.Input
-import Data.Unique
 import Data.Vect
 
+infixr 5 `Translate`
+infixr 5 `Rotate`
+infixr 5 `Scale`
+infixr 5 `Colored`
+
+-- | 'Game' is a 'Monad' that abstracts user interfaces.
 type Game = Free GameAction
 
 -- | A base for 'Game' monad.
-data GameAction cont
-    = Tick cont
-    | EmbedIO (IO cont)
-    | Bracket (Game cont)
-
-    | DrawPicture Picture cont
-    | LoadPicture Bitmap (Picture -> cont) 
-
-    | AskInput Key (Bool -> cont)
-    | GetMouseState (MouseState -> cont)
+data GameAction a
+    = Tick a
+    | EmbedIO (IO a)
+    | Bracket (Game a)
+    | DrawPicture Picture a
+    | AskInput Key (Bool -> a)
+    | GetMouseState (MouseState -> a)
+    | QuitGame
 
 instance Functor GameAction where
     fmap f (DrawPicture a cont) = DrawPicture a (f cont)
-    fmap f (LoadPicture a cont) = LoadPicture a (f . cont)
     fmap f (AskInput a cont)    = AskInput a (f . cont)
     fmap f (GetMouseState cont) = GetMouseState (f . cont)
     fmap f (EmbedIO m) = EmbedIO (fmap f m)
     fmap f (Bracket m) = Bracket (fmap f m)
     fmap f (Tick cont) = Tick (f cont)
+    fmap _ QuitGame = QuitGame
 
 -- | Finalize the current frame and refresh the screen.
 tick :: MonadFree GameAction m => m ()
@@ -80,14 +87,14 @@ bracket :: MonadFree GameAction m => Game a -> m a
 bracket m = wrap $ Bracket $ liftM return m
 
+-- | Break the current computation.
+quitGame :: MonadFree GameAction m => m a
+quitGame = wrap QuitGame
+
 -- | Draw a 'Picture'.
 drawPicture :: MonadFree GameAction m => Picture -> m ()
 drawPicture pic = wrap $ DrawPicture pic (return ())
 
--- | Create a 'Picture' from 'Bitmap'.
-loadPicture :: MonadFree GameAction m => Bitmap -> m Picture
-loadPicture img = wrap $ LoadPicture img return
-
 -- | Is the specified 'Key' is pressed?
 askInput :: MonadFree GameAction m => Key -> m Bool
 askInput key = wrap $ AskInput key return
@@ -103,16 +110,20 @@ 
 -- | A 2D Picture.
 data Picture
-    -- | An abstract primitive image.
-    = Image Unique
-    -- | Combined picture from some pictures.
+    -- | A 'Bitmap' as a 'Picture'.
+    = BitmapPicture Bitmap
+    -- | A picture consist of some 'Picture's.
     | Pictures [Picture]
+    -- | A picture that may have side effects.
+    | IOPicture (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
 
 -- | Parameters of the application.
 data GameParam = GameParam {
@@ -124,4 +135,9 @@ 
 -- | 640*480(windowed), 60fps
 defaultGameParam :: GameParam
-defaultGameParam = GameParam 60 (640,480) "free-game" True+defaultGameParam = GameParam 60 (640,480) "free-game" True
+
+{-# DEPRECATED loadPicture "No longer needed; use BitmapPicture instead" #-}
+-- | Create a 'Picture' from 'Bitmap'.
+loadPicture :: MonadFree GameAction m => Bitmap -> m Picture
+loadPicture = return . BitmapPicture

@@ -1,66 +0,0 @@------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.FreeGame.Bitmap
--- Copyright   :  (C) 2012 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinsohita <fumiexcel@gmail.com>
--- Stability   :  provisional
--- Portability :  non-portable
---
--- Manipulating bitmaps
-----------------------------------------------------------------------------
-
-module Graphics.FreeGame.Bitmap (Bitmap, bitmapData, bitmapSize, loadBitmapFromFile, cropBitmap, Font, loadFont, charToBitmap) where
-
-import Control.Applicative
-import Codec.Picture.Repa
-import Data.Array.Repa as R
-import Data.Word
-import Data.Array.IArray as A
-import qualified Graphics.Rendering.TrueType.STB as TT
-
--- | Concrete bitmap data
-newtype Bitmap = Bitmap {
-    bitmapData :: R.Array D DIM3 Word8 -- ^ Bare the 'Bitmap''s internal representation (y * x * ARGB)
-    }
-
--- | 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 = Bitmap <$> delay <$> imgData <$> either error id <$> readImageRGBA path
-
--- | Extract a 'Bitmap' from the specified range.
-cropBitmap :: Bitmap -- ^original bitmap
-    -> (Int, Int) -- ^width and height
-    -> (Int, Int) -- ^x and y
-    -> Bitmap -- ^result
-cropBitmap (Bitmap img) (w, h) (x, y) = Bitmap $ extract (Z :. y :. x :. 0) (Z :. h :. w :. 4) img
-
--- | Font object
-newtype Font = Font TT.BitmapCache
-
--- | Create a 'Font' from the given file.
-loadFont :: FilePath -> Float -> IO Font
-loadFont path size = do
-    tt <- TT.loadTTF path
-    o <- head <$> TT.enumerateFonts tt
-    font <- TT.initFont tt o
-    Just g <- TT.findGlyph font '|'
-    TT.BBox (x0,y0) (x1,y1) <- TT.getGlyphBoundingBox font g
-    let s = size/fromIntegral (x1-x0)
-    Font <$> TT.newBitmapCache font False (s, s)
-
--- | Render 'Bitmap' of the character by specified 'Font' and color(RGB).
-charToBitmap :: Font -> (Word8, Word8, Word8) -> Char -> IO (Maybe (Bitmap, Float, Float, Float))
-charToBitmap (Font cache) (red,green,blue) ch = do
-    r <- TT.getCachedBitmap cache ch
-    case r of
-        Just (TT.CBM bmp@(TT.Bitmap (w,h) _) (ox,oy) (TT.HMetrics adv _)) -> do
-            ar <- TT.bitmapArray bmp
-            let pixel (Z:.y:.x:.c) = [ar A.! (y, x), red, green, blue] !! c
-            return $ Just (Bitmap $ fromFunction (Z :. h :. w :. 4) pixel, fromIntegral ox / 2, fromIntegral oy / 2, adv)
-        Nothing -> return Nothing

@@ -0,0 +1,84 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Graphics.FreeGame.Data.Bitmap
+-- Copyright   :  (C) 2012 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 >>= makeStableBitmap . imgData . either error id
+
+-- | 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

@@ -0,0 +1,59 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Graphics.FreeGame.Data.Color
+-- Copyright   :  (C) 2012 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 (Color(..), fromRGBA, colorAsWord8, transparent, white, black, red, green, blue, yellow, cyan, magenta, intermediate, halfD, halfB) where
+
+import Data.Word
+
+data Color = Color Float Float Float Float deriving (Show, Eq, Ord)
+
+fromRGBA :: Float -> Float -> Float -> Float -> Color
+fromRGBA = Color
+
+colorAsWord8 :: Color -> (Word8, Word8, Word8, Word8)
+colorAsWord8 (Color r g b a) = (floor $ r * 255, floor $ g * 255, floor $ b * 255, floor $ a * 255)
+
+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)
+
+transparent :: Float -> Color -> Color
+transparent f (Color r g b a) = Color r g b (f * a)
+
+halfD :: Color -> Color
+halfD = intermediate black
+
+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

@@ -0,0 +1,135 @@+{-# LANGUAGE ScopedTypeVariables #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Graphics.FreeGame.Data.Font
+-- Copyright   :  (C) 2012 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, text, withRenderString, withRenderCharacters ) where
+
+import Control.Applicative
+import Data.Array.Repa as R
+import Data.Array.Repa.Eval
+import qualified Data.Array.Repa.Repr.ForeignPtr as RF
+import Data.Vect
+import Data.IORef
+import qualified Data.Map as M
+import Data.Word
+import Graphics.FreeGame.Base
+import Graphics.FreeGame.Data.Color
+import Graphics.FreeGame.Data.Bitmap
+import Graphics.Rendering.FreeType.Internal
+import Graphics.Rendering.FreeType.Internal.GlyphSlot as GS
+import 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 Foreign.Marshal.Alloc
+import Foreign.C.String
+import Foreign.Storable
+import System.IO.Unsafe
+import Unsafe.Coerce
+import Paths_free_game
+
+-- | Font object
+data Font = Font FT_Face (IORef (M.Map (Float, Color, 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
+    Font <$> peek p <*> newIORef M.empty
+
+-- | Render a text by the specified 'Font' and 'Color' and size.
+text :: Font -> Float -> Color -> String -> Picture
+text font size color str = IOPicture $ Pictures <$> renderCharacters font size color str
+
+-- | Render the string by the given font and color, and pass it to the 'Game' action. 
+withRenderCharacters :: Font -> Float -> Color -> String -> ([Picture] -> Game a) -> Game a
+withRenderCharacters font size color str action = bracket
+    $ embedIO (renderCharacters font size color str) >>= action
+
+-- | Render the string by the given font and color, and pass it to the 'Game' action. 
+withRenderString :: Font -> Float -> Color -> String -> (Picture -> Game a) -> Game a
+withRenderString font size color str action = withRenderCharacters font size color str (action . Pictures)
+
+failFreeType 0 = return ()
+failFreeType e = fail $ "FreeType Error:" Prelude.++ show e
+
+freeType :: FT_Library
+freeType = unsafePerformIO $ alloca $ \p -> do
+    e <- ft_Init_FreeType p
+    failFreeType e
+    peek p
+
+data RenderedChar = RenderedChar
+    {
+        charBitmap :: Bitmap
+        ,charOffset :: Vec2
+        ,charAdvance :: Float
+    }
+
+charToBitmap :: Font -> Float -> Color -> Char -> IO RenderedChar
+charToBitmap (Font face refCache) size col@(Color r g b a) ch = do
+    cache <- readIORef refCache
+    case M.lookup (size, col, ch) cache of
+        Nothing -> do
+            d <- render
+            writeIORef refCache $ M.insert (size, col, ch) d cache
+            return d
+        Just d -> return d
+
+    where
+        render = do
+            ft_Set_Char_Size face 0 (floor $ size * 64) 300 300
+            ix <- ft_Get_Char_Index face (fromIntegral $ fromEnum ch)
+            ft_Load_Glyph face ix ft_LOAD_DEFAULT
+
+            slot <- peek $ glyph face
+            e <- ft_Render_Glyph slot ft_RENDER_MODE_NORMAL
+            failFreeType e
+
+            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 $ advance slot
+
+            ar :: R.Array U DIM2 Word8 <- unsafeFreezeMVec (Z:.h:.w) mv
+
+            let pixel (crd:.0) = floor $ fromIntegral (R.index ar crd) * a
+                pixel (crd:.1) = floor $ b * 255
+                pixel (crd:.2) = floor $ g * 255
+                pixel (crd:.3) = floor $ r * 255
+
+            result <- computeP (fromFunction (Z:.h:.w:.4) pixel) >>= makeStableBitmap
+            
+            return $ RenderedChar result (Vec2 left (-top)) (fromIntegral (V.x adv) / 64)
+
+renderCharacters :: Font -> Float -> Color -> String -> IO [Picture]
+renderCharacters font size color str = render str 0
+    where
+        render [] _ = return []
+        render (c:cs) pen = do
+            RenderedChar b (Vec2 x y) adv <- charToBitmap font size color c
+            let (w,h) = bitmapSize b
+                offset = Vec2 (pen + x + fromIntegral w / 2) (y + fromIntegral h / 2)
+            (Translate offset (BitmapPicture b):)
+                <$> render cs (pen + adv)

@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Graphics.FreeGame.Simple
+-- Copyright   :  (C) 2012 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
+
+    -- * Run the game
+    ,defaultGameParam
+    ,runSimple
+
+    -- * In the Game monad
+    ,drawPicture
+    ,askInput
+    ,getMouseState
+    ,embedIO
+    ,quitGame
+    ,tick
+    ,untickGame
+
+    -- * About Picture
+    ,Picture(..)
+    ,loadBitmapFromFile
+    ,Vec2(..)
+
+    -- * Drawing texts
+    ,loadFont
+    ,text
+
+    -- * Utilities
+    ,randomness
+
+    -- * Reexports
+    ,module Graphics.FreeGame.Input
+    ,module Graphics.FreeGame.Data.Color
+    )
+
+where
+
+import Graphics.FreeGame
+import Graphics.FreeGame.Data.Color
+import Graphics.FreeGame.Data.Font
+import Graphics.FreeGame.Input
+import Control.Monad
+
+-- | 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'

@@ -11,16 +11,12 @@ --
 ----------------------------------------------------------------------------
 
-module Graphics.FreeGame.Util (untickGame, randomness, degrees, radians, withRenderString, loadPictureFromFile) where
-import Control.Applicative
-import Control.Monad
+module Graphics.FreeGame.Util (untickGame, randomness, degrees, radians, loadPictureFromFile) where
 import Control.Monad.Free
 import qualified Control.Monad.Trans.Free as T
 import Graphics.FreeGame.Base
-import Graphics.FreeGame.Bitmap
+import Graphics.FreeGame.Data.Bitmap
 import System.Random
-import Data.Vect
-import Data.Word
 
 -- | Run a 'Game' as one frame.
 untickGame :: Game a -> Game (Game a)
@@ -42,16 +38,6 @@ {-# INLINE radians #-}
 radians x = x / 180 * pi
 
--- | Render the string by the given font and color, and pass it to the 'Game' computation. 
-withRenderString :: Font -> (Word8, Word8, Word8) -> String -> (Picture -> Game a) -> Game a
-withRenderString font color str action = bracket $ render str 0 >>= action . Pictures
-    where
-        render [] _ = return []
-        render (c:cs) x = do
-            Just (b, o, h, w) <- embedIO $ charToBitmap font color c
-            (:) <$> Translate (Vec2 (x + w + o) h) <$> loadPicture b
-                <*> render cs (x + w)
-
 -- | Create a 'Picture' from the given file.
 loadPictureFromFile :: FilePath -> Game Picture
-loadPictureFromFile = embedIO . loadBitmapFromFile >=> loadPicture+loadPictureFromFile = embedIO . fmap BitmapPicture . loadBitmapFromFile

file too large to diff

@@ -0,0 +1,21 @@+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)

@@ -0,0 +1,15 @@+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"
+    runSimple defaultGameParam 0 $ \n -> do
+        drawPicture $ Translate (Vec2 30 120) $ text font 7 (halfD red) ("Counter: " ++ show n)
+
+        drawPicture $ Translate (Vec2 30 240) $ text font 9 (halfD blue) "日本語も、美しくレンダリング。"
+
+        withRenderString font 12 yellow "★☆★☆★☆★☆" $ drawPicture . Translate (Vec2 30 360)
+
+        return $! n + 1

@@ -1,14 +1,27 @@-{-# LANGUAGE ImplicitParams #-}
-import Graphics.FreeGame
+{-# LANGUAGE ImplicitParams, TemplateHaskell #-}
+import Graphics.FreeGame.Simple
 import Control.Applicative
 import Control.Monad
 import Data.Vect
+import Control.Monad.State
 
-act :: (?pic :: Picture) => Vec2 -> Vec2 -> Float -> Bool -> Game ()
-act pos@(Vec2 x y) vel@(Vec2 dx dy) angle btn = do
+import Control.Lens -- using lens (http://hackage.haskell.org/package/lens)
 
-    drawPicture $ Translate pos $ Rotate angle ?pic
-    
+data Object = Object
+    {
+        _position :: Vec2
+        , _velocity :: Vec2
+        , _pressed :: Bool
+    }
+
+$(makeLenses ''Object)
+
+obj :: (?pic :: Picture) => StateT Object Game ()
+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
@@ -16,26 +29,34 @@             | y >= 480 = -(abs dy)
             | otherwise = dy
 
+    position .= pos &+ vel
+    velocity .= Vec2 dx' dy'
+
     mouse <- getMouseState
-    vel' <- if not btn && leftButton mouse && norm (mousePosition mouse &- pos) < 32
-        then (&*3) <$> sinCos <$> randomness (0, 2 * pi)
-        else return (Vec2 dx' dy')
+
+    if norm (mousePosition mouse &- pos) < 32
+        then do
+            drawPicture $ Translate pos ?pic
+            btn <- use pressed
+            when (not btn && leftButton mouse) $ do
+                vel' <- (&*4) <$> sinCos <$> randomness (0, 2 * pi)
+                velocity .= vel'
+
+            pressed .= leftButton mouse
+
+        else drawPicture $ Translate pos $ Colored (transparent 0.7 white) ?pic
+
     tick
-    act (pos &+ vel) vel' (angle + 1) (leftButton mouse)
 
 initial :: (?pic :: Picture) => Game ()
 initial = do
     x <- randomness (0,640)
     y <- randomness (0,480)
     a <- randomness (0, 2 * pi)
-    act (Vec2 x y) (sinCos a &* 4) 0 False
+    evalStateT obj $ Object (Vec2 x y) (sinCos a &* 4) False
 
-main = runGame defaultGameParam $ do
-    pic <- loadPictureFromFile "logo.png"
-    let ?pic = pic
-    run (replicate 24 initial)
-    where
-        run ms = do
-            ms' <- mapM untickGame ms
-            tick
-            run ms'+main = do
+    bmp <- loadBitmapFromFile "logo.png"
+    let ?pic = BitmapPicture bmp
+
+    runSimple defaultGameParam (replicate 10 initial) $ mapM untickGame

@@ -1,5 +1,5 @@ name:                free-game
-version:             0.3.0.2
+version:             0.3.1.0
 synopsis:            Create graphical applications for free.
 description:         Cross-platform GUI library based on free monads.
 homepage:            https://github.com/fumieval/free-game
@@ -16,6 +16,9 @@ extra-source-files:
   examples/test.hs
   examples/logo.png
+  examples/font.hs
+  examples/bitmap.hs
+  examples/VL-PGothic-Regular.ttf
 
 source-repository head
   type: git
@@ -23,13 +26,15 @@ 
 library
   exposed-modules:     Graphics.FreeGame
+    , Graphics.FreeGame.Simple
     , Graphics.FreeGame.Util
     , Graphics.FreeGame.Input
-    , Graphics.FreeGame.Bitmap
     , Graphics.FreeGame.Base
     , Graphics.FreeGame.Backends.GLFW
+    , Graphics.FreeGame.Data.Color
+    , Graphics.FreeGame.Data.Bitmap
+    , Graphics.FreeGame.Data.Font
   ghc-options:         -fexcess-precision
-  -- other-modules:       
   build-depends: base == 4.*
     , mtl >= 2.1
     , containers >= 0.4
@@ -40,7 +45,8 @@     , vect >= 0.4.6
     , array >= 0.3
     , filepath >= 1.3
-    , stb-truetype >= 0.1
+    , freetype2 >= 0.1
+    , hashable >= 1.0
     , OpenGL >= 2.5
     , GLFW-b >= 0.1
     , StateVar