packages feed

free-game 0.9 → 0.9.1

raw patch · 9 files changed

+183/−56 lines, 9 files

Files

Graphics/UI/FreeGame.hs view
@@ -17,11 +17,12 @@     module Graphics.UI.FreeGame.Base,
     module Graphics.UI.FreeGame.Data.Bitmap,
     module Graphics.UI.FreeGame.Data.Font,
+    module Graphics.UI.FreeGame.Data.Text,
     module Graphics.UI.FreeGame.Data.Color,
     module Graphics.UI.FreeGame.GUI,
     module Graphics.UI.FreeGame.Util,
-    module Graphics.UI.FreeGame.Types
-
+    module Graphics.UI.FreeGame.Types,
+    module Linear
 ) where
 
 import Graphics.UI.FreeGame.Base
@@ -30,10 +31,12 @@ import Graphics.UI.FreeGame.Types
 import Graphics.UI.FreeGame.Data.Bitmap
 import Graphics.UI.FreeGame.Data.Font
+import Graphics.UI.FreeGame.Data.Text
 import Graphics.UI.FreeGame.Data.Color
 import qualified Graphics.UI.FreeGame.GUI.GLFW as GLFW
 import Control.Monad.Free.Church
 import Data.Default
+import Linear hiding (rotate)
 
 -- | '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'.
Graphics/UI/FreeGame/Base.hs view
@@ -28,6 +28,7 @@     ,_LiftUI     -- * Classes     ,Picture2D(..)+    ,Figure2D(..)     ,Keyboard(..)     ,Mouse(..)     ,FromFinalizer(..)@@ -127,6 +128,14 @@     translate :: V2 Float -> p a -> p a     colored :: Color -> p a -> p a +class Picture2D p => Figure2D p where+    line :: [V2 Float] -> p ()+    polygon :: [V2 Float] -> p ()+    polygonOutline :: [V2 Float] -> p ()+    circle :: Float -> p ()+    circleOutline :: Float -> p ()+    thickness :: Float -> p a -> p a+ -- | The class of types that can handle inputs of the keyboard. class Keyboard t where     keyChar :: Char -> t Bool@@ -202,6 +211,14 @@     scale = (t) . scale; \     colored = (t) . colored } +#define MK_FIGURE_2D(cxt, ty, l, t) instance (Figure2D m cxt) => Figure2D (ty) where { \+    line = (l) . line; \+    polygon = (l) . polygon; \+    polygonOutline = (l) . polygonOutline; \+    circle = (l) . circle; \+    circleOutline = (l) . circleOutline; \+    thickness = (t) . thickness }+ #define MK_KEYBOARD(cxt, ty, l) instance (Keyboard m cxt) => Keyboard (ty) where { \     keyChar = (l) . keyChar; \     keySpecial = (l) . keySpecial }@@ -231,6 +248,22 @@ MK_PICTURE_2D(_COMMA_ Monad m, ListT m, lift, mapListT) MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift, mapErrorT) MK_PICTURE_2D(_COMMA_ Monad m, ContT r m, lift, mapContT)++MK_FIGURE_2D(_COMMA_ Functor m, F m, liftF, hoistFR)+MK_FIGURE_2D( , UI m, LiftUI, over _LiftUI)+MK_FIGURE_2D(_COMMA_ Functor m, Free.Free m, Free.liftF, hoistFreeR)+MK_FIGURE_2D(_COMMA_ Monad m, ReaderT r m, lift, mapReaderT)+MK_FIGURE_2D(_COMMA_ Monad m, Lazy.StateT s m, lift, Lazy.mapStateT)+MK_FIGURE_2D(_COMMA_ Monad m, Strict.StateT s m, lift, Strict.mapStateT)+MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift, Lazy.mapWriterT)+MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift, Strict.mapWriterT)+MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift, Lazy.mapRWST)+MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift, Strict.mapRWST)+MK_FIGURE_2D(_COMMA_ Monad m, IdentityT m, lift, mapIdentityT)+MK_FIGURE_2D(_COMMA_ Monad m, MaybeT m, lift, mapMaybeT)+MK_FIGURE_2D(_COMMA_ Monad m, ListT m, lift, mapListT)+MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift, mapErrorT)+MK_FIGURE_2D(_COMMA_ Monad m, ContT r m, lift, mapContT)  MK_KEYBOARD(, Ap m, liftAp) MK_KEYBOARD(, UI m, LiftUI)
Graphics/UI/FreeGame/Data/Font.hs view
@@ -13,17 +13,14 @@ module Graphics.UI.FreeGame.Data.Font 
   ( Font
   , loadFont
-  , Metrics(..)
-  , Graphics.UI.FreeGame.Data.Font.metrics
   , fontBoundingBox
+  , metricsAscent
+  , metricsDescent
   , 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
@@ -31,7 +28,6 @@ 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
@@ -51,41 +47,41 @@ import Unsafe.Coerce
 
 -- | Font object
-data Font = Font FT_Face Metrics (BoundingBox Float) (IORef (M.Map (Float, Char) RenderedChar))
+data Font = Font FT_Face (Float, Float) (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
+    runFreeType $ withCString path $ \str -> ft_New_Face freeType str 0 p
     f <- peek p
     b <- peek (bbox f)
     asc <- peek (ascender f)
     desc <- peek (descender f)
     u <- fromIntegral <$> peek (units_per_EM f)
-    let m = Metrics (fromIntegral asc/u) (fromIntegral desc/u)
-        box = BoundingBox (fromIntegral (xMin b)/u) (fromIntegral (yMin b)/u)
+    let 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
+    Font f (fromIntegral asc/u, fromIntegral desc/u) box <$> newIORef M.empty
 
 -- | Get the font's metrics.
-metrics :: Font -> Metrics
-metrics (Font _ m _ _) = m
+metricsAscent :: Font -> Float
+metricsAscent (Font _ (a, _) _ _) = a
 
+metricsDescent :: Font -> Float
+metricsDescent (Font _ (_, d) _ _) = d
+
 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
+runFreeType :: IO CInt -> IO ()
+runFreeType m = do
+    r <- m
+    case r of
+        0 -> return ()
+        e -> fail $ "FreeType Error:" Prelude.++ show e
 
 freeType :: FT_Library
 freeType = unsafePerformIO $ alloca $ \p -> do
-    failFreeType =<< ft_Init_FreeType p
+    runFreeType $ ft_Init_FreeType p
     peek p
 
 data RenderedChar = RenderedChar
@@ -94,11 +90,6 @@     ,　charAdvance :: Float
     }
 
-data Metrics = Metrics
-    { metricsAscent :: Float
-    , metricsDescent :: Float
-    }
-
 -- | The resolution used to render fonts.
 resolutionDPI :: Int
 resolutionDPI = 300
@@ -118,13 +109,13 @@         render = do
             let dpi = fromIntegral resolutionDPI
 
-            failFreeType =<< ft_Set_Char_Size face 0 (floor $ siz * 64) dpi dpi
+            runFreeType $ 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
+            runFreeType $ ft_Load_Glyph face ix ft_LOAD_DEFAULT
 
             slot <- peek $ glyph face
-            failFreeType =<< ft_Render_Glyph slot ft_RENDER_MODE_NORMAL
+            runFreeType $ ft_Render_Glyph slot ft_RENDER_MODE_NORMAL
 
             bmp <- peek $ GS.bitmap slot
             left <- fmap fromIntegral $ peek $ GS.bitmap_left slot
@@ -148,12 +139,3 @@             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/Data/Text.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveFunctor #-}
+module Graphics.UI.FreeGame.Data.Text (TextF(..), TextT, runTextT) where
+
+import Data.String
+import Graphics.UI.FreeGame.Base
+import Graphics.UI.FreeGame.Types
+import Graphics.UI.FreeGame.Internal.Raindrop
+import Graphics.UI.FreeGame.Data.Font
+import Graphics.UI.FreeGame.Data.Bitmap
+import Control.Monad.Trans.Free
+import Control.Monad.State
+import Linear
+
+data TextF a = TypeChar Char a deriving Functor
+
+type TextT = FreeT TextF
+
+instance Monad m => IsString (TextT m ()) where
+    fromString str = mapM_ (\c -> liftF (TypeChar c ())) str
+
+runTextT :: (FromFinalizer m, Monad m, Picture2D m) => Maybe (BoundingBox Float) -> Font -> Float -> TextT m a -> m a
+runTextT bbox font size = flip evalStateT (V2 x0 y0) . go where
+    go m = lift (runFreeT m) >>= \r -> case r of
+        Pure a -> return a
+        Free (TypeChar '\n' cont) -> do
+            modify $ over _x (const x0) . over _y (+advV)
+            go cont
+        Free (TypeChar ch cont) -> do
+            RenderedChar bmp (V2 x y) adv <- fromFinalizer $ charToBitmap font size ch
+            pen <- get
+            let (w,h) = bitmapSize bmp
+                offset = pen ^+^ V2 (x + fromIntegral w / 2) (y + fromIntegral h / 2)
+            translate offset $ fromBitmap bmp
+            let pen' = over _x (+adv) pen
+            put $ if cond pen'
+                then pen'
+                else V2 x0 (view _y pen + advV)
+            go cont
+    advV = size * (metricsAscent font - metricsDescent font) * 1.1
+    (V2 x0 y0, cond) = maybe (zero, const True) (\b -> (view _TopLeft b, flip inBoundingBox b)) bbox
Graphics/UI/FreeGame/GUI.hs view
@@ -35,10 +35,12 @@ 
 data GUIBase a = Input (Ap GUIInput a) | Draw (Picture a) deriving Functor
 
+-- | _Draw :: Traversal' (GUIBase a) (Picture a)
 _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 :: Traversal' (GUIBase a) (Ap GUIInput a)
 _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
@@ -50,6 +52,14 @@     translate = over _Draw . translate
     colored = over _Draw . colored
 
+instance Figure2D GUIBase where
+    line = Draw . line
+    polygon = Draw . polygon
+    polygonOutline = Draw . polygonOutline
+    circle = Draw . circle
+    circleOutline = Draw . circleOutline
+    thickness = over _Draw . thickness
+
 instance Keyboard GUIBase where
     keyChar = Input . keyChar
     keySpecial = Input . keySpecial
@@ -81,6 +91,13 @@     | Scale (V2 Float) (Picture a)
     | Translate (V2 Float) (Picture a)
     | Colored Color (Picture a)
+
+    | Line [V2 Float] a
+    | Polygon [V2 Float] a
+    | PolygonOutline [V2 Float] a
+    | Circle Float a
+    | CircleOutline Float a
+    | Thickness Float (Picture a)
     deriving Functor
 
 instance Picture2D Picture where
@@ -89,6 +106,14 @@     scale = Scale
     translate = Translate
     colored = Colored
+
+instance Figure2D Picture where
+    line = flip Line ()
+    polygon = flip Polygon ()
+    polygonOutline = flip PolygonOutline ()
+    circle = flip Circle ()
+    circleOutline = flip CircleOutline ()
+    thickness = Thickness
 
 instance FromFinalizer Picture where
     fromFinalizer = PictureWithFinalizer
Graphics/UI/FreeGame/GUI/GLFW.hs view
@@ -41,7 +41,7 @@     -> 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
+    LiftUI (Draw pic) -> let ?refTextures = refTextures in join $ runPicture 1 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
@@ -98,7 +98,6 @@     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)
@@ -134,8 +133,8 @@         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
+runPicture :: (?refTextures :: IORef (IM.IntMap Texture)) => Float -> 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
@@ -145,26 +144,52 @@             liftIO $ drawTexture t
             finalizer $ modifyIORef ?refTextures $ IM.delete h
     return r
-runPicture (LiftBitmap bmp@(BitmapData _ Nothing) r) = do
+runPicture _ (LiftBitmap bmp@(BitmapData _ Nothing) r) = do
     liftIO $ runFinalizerT $ installTexture bmp >>= liftIO . drawTexture
     return r
-runPicture (Rotate theta cont) = preservingMatrix' $ do
+runPicture sc (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
+    runPicture sc cont
+runPicture sc (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
+    runPicture (sc * max sx sy) cont
+runPicture sc (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
+    runPicture sc cont
+runPicture _ (PictureWithFinalizer m) = m
+runPicture sc (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
+    res <- runPicture sc cont
     liftIO $ GL.currentColor $= oldColor
     return res
+runPicture _ (Line path a) = do
+    liftIO $ GL.renderPrimitive GL.LineStrip $ runVertices path
+    return a
+runPicture _ (Polygon path a) = do
+    liftIO $ GL.renderPrimitive GL.Polygon $ runVertices path
+    return a
+runPicture _ (PolygonOutline path a) = do
+    liftIO $ GL.renderPrimitive GL.LineLoop $ runVertices path
+    return a
+runPicture sc (Circle r a) = do
+    let s = 2 * pi / 64 * sc
+    liftIO $ GL.renderPrimitive GL.Polygon $ runVertices [V2 (cos t * r) (sin t * r) | t <- [0,s..2 * pi]]
+    return a
+runPicture sc (CircleOutline r a) = do
+    let s = 2 * pi / 64 * sc
+    liftIO $ GL.renderPrimitive GL.LineLoop $ runVertices [V2 (cos t * r) (sin t * r) | t <- [0,s..2 * pi]]
+    return a
+runPicture sc (Thickness t cont) = do
+    oldWidth <- liftIO $ get GL.lineWidth
+    liftIO $ GL.lineWidth $= gf t
+    res <- runPicture sc cont
+    liftIO $ GL.lineWidth $= oldWidth
+    return res
 
+runVertices :: MonadIO m => [V2 Float] -> m ()
+runVertices = mapM_ (\(V2 x y) -> liftIO $ GL.vertex $ GL.Vertex2 (gf x) (gf y))
+
 preservingMatrix' :: MonadIO m => m a -> m a
 preservingMatrix' m = do
     liftIO $ glPushMatrix
@@ -183,6 +208,7 @@ drawTexture :: Texture -> IO ()
 drawTexture (Texture tex width height) = do
     let (w, h) = (fromIntegral width / 2, fromIntegral height / 2)
+    GL.texture GL.Texture2D $= GL.Enabled
     GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest)
     GL.textureBinding GL.Texture2D $= Just tex
     GL.renderPrimitive GL.Polygon $ zipWithM_
@@ -191,6 +217,7 @@             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)]
+    GL.texture GL.Texture2D $= GL.Disabled
 
 mapSpecialKey :: SpecialKey -> GLFW.Key
 mapSpecialKey KeySpace = GLFW.KeySpace
+ Graphics/UI/FreeGame/Internal/Raindrop.hs view
@@ -0,0 +1,11 @@+module Graphics.UI.FreeGame.Internal.Raindrop (view, over) where++import Data.Functor.Identity+import Control.Monad.Reader+import Control.Applicative++view :: MonadReader s m => ((a -> Const a b) -> (s -> Const a t)) -> m a+view f = ask >>= return . getConst . f Const++over :: ((a -> Identity b) -> (s -> Identity t)) -> (a -> b) -> s -> t+over l f = runIdentity . l (Identity . f)
Graphics/UI/FreeGame/Types.hs view
@@ -12,6 +12,7 @@ ----------------------------------------------------------------------------
 module Graphics.UI.FreeGame.Types (
     BoundingBox(..),
+    inBoundingBox,
     _TopLeft,
     _TopRight,
     _BottomLeft,
@@ -22,6 +23,9 @@ 
 -- | 2D bounding box.
 data BoundingBox a = BoundingBox a a a a deriving (Show, Eq, Ord, Functor, Read)
+
+inBoundingBox :: Ord a => V2 a -> BoundingBox a -> Bool
+inBoundingBox (V2 x y) (BoundingBox x0 y0 x1 y1) = x0 <= x && x <= x1 && y0 <= y && y <= y1
 
 -- | @'_TopLeft' :: Lens' ('BoundingBox' a) ('V2' a)@
 _TopLeft :: Functor f => (V2 a -> f (V2 a)) -> (BoundingBox a -> f (BoundingBox a))
free-game.cabal view
@@ -1,5 +1,5 @@ name:                free-game
-version:             0.9
+version:             0.9.1
 synopsis:            Create graphical applications for free
 description:         Cross-platform GUI library based on free monads
 homepage:            https://github.com/fumieval/free-game
@@ -26,9 +26,11 @@     Graphics.UI.FreeGame.Data.Bitmap
     Graphics.UI.FreeGame.Data.Color
     Graphics.UI.FreeGame.Data.Font
+    Graphics.UI.FreeGame.Data.Text
     Graphics.UI.FreeGame.GUI
     Graphics.UI.FreeGame.GUI.GLFW
     Graphics.UI.FreeGame.Internal.Finalizer
+    Graphics.UI.FreeGame.Internal.Raindrop
     Graphics.UI.FreeGame.Types
     Graphics.UI.FreeGame.Util