packages feed

free-game 0.9.1 → 0.9.2

raw patch · 8 files changed

+119/−49 lines, 8 files

Files

Graphics/UI/FreeGame.hs view
@@ -17,10 +17,10 @@     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.Text,
     module Graphics.UI.FreeGame.Types,
     module Linear
 ) where
@@ -29,9 +29,9 @@ import Graphics.UI.FreeGame.GUI (GUI, GUIParam(..), Picture)
 import Graphics.UI.FreeGame.Util
 import Graphics.UI.FreeGame.Types
+import Graphics.UI.FreeGame.Text
 import Graphics.UI.FreeGame.Data.Bitmap
 import Graphics.UI.FreeGame.Data.Font
-import 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
Graphics/UI/FreeGame/Base.hs view
@@ -22,8 +22,10 @@     -- * Basic operations     ,tick     ,bracket+    ,_Bracket     ,quit     ,embedIO+    ,_EmbedIO     ,liftUI     ,_LiftUI     -- * Classes@@ -39,8 +41,8 @@ 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.Wave import Graphics.UI.FreeGame.Data.Color import Graphics.UI.FreeGame.Internal.Finalizer import Graphics.UI.FreeGame.Internal.Raindrop@@ -93,7 +95,7 @@ bracket = wrap . Bracket . fmap return  -- | Break the entire computation.-quit :: MonadFree (UI n) m => m Void+quit :: MonadFree (UI n) m => m a quit = wrap Quit  -- | Lift 'UI''s base functor.@@ -104,9 +106,19 @@ embedIO :: (MonadFree (UI n) m) => IO a -> m a embedIO = wrap . EmbedIO . fmap return +-- | @'_EmbedIO' :: Traversal' ('UI' m a) (IO a)@+_EmbedIO :: Applicative f => (IO a -> f (IO a)) -> UI m a -> f (UI m a)+_EmbedIO f (EmbedIO m) = fmap EmbedIO (f m)+_EmbedIO _ x = pure x++-- | @'_Bracket' :: Traversal' ('UI' m a) (F (UI m) a)@+_Bracket :: Applicative f => (F (UI m) a -> f (F (UI m) a)) -> UI m a -> f (UI m a)+_Bracket f (Bracket m) = fmap Bracket (f m)+_Bracket _ x = pure x+ -- | @'_LiftUI' :: Traversal' ('UI' m a) (m a)@ _LiftUI :: Applicative f => (m a -> f (m a)) -> UI m a -> f (UI m a)-_LiftUI f (LiftUI o) = fmap LiftUI (f o)+_LiftUI f (LiftUI m) = fmap LiftUI (f m) _LiftUI _ x = pure x  hoistFreeR :: (Functor f, MonadFree g m) => (f (m a) -> g (m a)) -> Free.Free f a -> m a@@ -136,6 +148,11 @@     circleOutline :: Float -> p ()     thickness :: Float -> p a -> p a +class Sound p where+    fromWave :: Wave -> p ()+    volume :: Float -> p a -> p a+    pan :: Float -> p a -> p a+ -- | The class of types that can handle inputs of the keyboard. class Keyboard t where     keyChar :: Char -> t Bool@@ -219,6 +236,11 @@     circleOutline = (l) . circleOutline; \     thickness = (t) . thickness } +#define MK_SOUND(cxt, ty, l, t) instance (Sound m cxt) => Sound (ty) where { \+    fromWave = (l) . fromWave; \+    volume = (t) . volume; \+    pan = (t) . pan }+ #define MK_KEYBOARD(cxt, ty, l) instance (Keyboard m cxt) => Keyboard (ty) where { \     keyChar = (l) . keyChar; \     keySpecial = (l) . keySpecial }@@ -264,6 +286,22 @@ 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_SOUND(_COMMA_ Functor m, F m, liftF, hoistFR)+MK_SOUND( , UI m, LiftUI, over _LiftUI)+MK_SOUND(_COMMA_ Functor m, Free.Free m, Free.liftF, hoistFreeR)+MK_SOUND(_COMMA_ Monad m, ReaderT r m, lift, mapReaderT)+MK_SOUND(_COMMA_ Monad m, Lazy.StateT s m, lift, Lazy.mapStateT)+MK_SOUND(_COMMA_ Monad m, Strict.StateT s m, lift, Strict.mapStateT)+MK_SOUND(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift, Lazy.mapWriterT)+MK_SOUND(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift, Strict.mapWriterT)+MK_SOUND(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift, Lazy.mapRWST)+MK_SOUND(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift, Strict.mapRWST)+MK_SOUND(_COMMA_ Monad m, IdentityT m, lift, mapIdentityT)+MK_SOUND(_COMMA_ Monad m, MaybeT m, lift, mapMaybeT)+MK_SOUND(_COMMA_ Monad m, ListT m, lift, mapListT)+MK_SOUND(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift, mapErrorT)+MK_SOUND(_COMMA_ Monad m, ContT r m, lift, mapContT)  MK_KEYBOARD(, Ap m, liftAp) MK_KEYBOARD(, UI m, LiftUI)
Graphics/UI/FreeGame/Data/Bitmap.hs view
@@ -39,6 +39,7 @@ import Data.Word
 import System.Random
 import Data.Hashable
+import Control.Monad.IO.Class
 
 -- | Concrete bitmap data. Internal representation is stored as y * x * RGBA.
 data Bitmap = BitmapData (R.Array RF.F DIM3 Word8) (Maybe Int) -- ^ This value is used to ensure that two bitmaps are equivalent.
@@ -70,7 +71,7 @@ 
 -- | Create a 'Bitmap' from the given file.
 loadBitmapFromFile :: FilePath -> IO Bitmap
-loadBitmapFromFile path = readImageRGBA path >>= either fail return >>= makeStableBitmap . imgData
+loadBitmapFromFile path = liftIO $ 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
− Graphics/UI/FreeGame/Data/Text.hs 
@@ -1,40 +0,0 @@-{-# 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/Data/Wave.hs view
@@ -0,0 +1,26 @@+module Graphics.UI.FreeGame.Data.Wave (
+    Wave(..)
+    , _WaveData
+    , _WaveHash
+    , toWave
+    , makeWave
+) where
+
+import Data.Hashable
+import System.Random
+
+data Wave = WaveData [(Float, Float)] Int
+
+-- | @'_WaveData' :: Lens' 'Wave' [(Float, Float)]@
+_WaveData :: Functor f => ([(Float, Float)] -> f [(Float, Float)]) -> Wave -> f Wave
+_WaveData f (WaveData a h) = fmap (\a' -> WaveData a' h) (f a)
+
+-- | @'_WaveHash' :: Lens' 'Wave' ('Int')@
+_WaveHash :: Functor f => (Int -> f Int) -> Wave -> f Wave
+_WaveHash f (WaveData a h) = fmap (\h' -> WaveData a h') (f h)
+
+toWave :: [(Float, Float)] -> Wave
+toWave w = WaveData w (hash w)
+
+makeWave :: [(Float, Float)] -> IO Wave
+makeWave w = fmap (WaveData w) randomIO
Graphics/UI/FreeGame/GUI/GLFW.hs view
@@ -43,7 +43,8 @@ runAction param refTextures refFrame _f = case _f of
     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
+    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
+ Graphics/UI/FreeGame/Text.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveFunctor #-}
+module Graphics.UI.FreeGame.Text (TextF(..), TextT, runTextT, text) where
+
+import Data.String
+import Graphics.UI.FreeGame.Base
+import Graphics.UI.FreeGame.Types
+import Graphics.UI.FreeGame.Internal.Raindrop
+import Graphics.UI.FreeGame.Data.Font
+import Graphics.UI.FreeGame.Data.Bitmap
+import Control.Monad.Trans.Free
+import Control.Monad.State
+import Linear
+
+data TextF a = TypeChar Char a deriving Functor
+
+type TextT = FreeT TextF
+
+instance Monad m => IsString (TextT m ()) where
+    fromString str = mapM_ (\c -> liftF (TypeChar c ())) str
+
+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
+
+text :: (FromFinalizer m, Monad m, Picture2D m) => Font -> Float -> String -> m ()
+text font size str = runTextT Nothing font size (fromString str)
free-game.cabal view
@@ -1,5 +1,5 @@ name:                free-game
-version:             0.9.1
+version:             0.9.2
 synopsis:            Create graphical applications for free
 description:         Cross-platform GUI library based on free monads
 homepage:            https://github.com/fumieval/free-game
@@ -24,9 +24,10 @@     Graphics.UI.FreeGame
     Graphics.UI.FreeGame.Base
     Graphics.UI.FreeGame.Data.Bitmap
+    Graphics.UI.FreeGame.Data.Wave
     Graphics.UI.FreeGame.Data.Color
     Graphics.UI.FreeGame.Data.Font
-    Graphics.UI.FreeGame.Data.Text
+    Graphics.UI.FreeGame.Text
     Graphics.UI.FreeGame.GUI
     Graphics.UI.FreeGame.GUI.GLFW
     Graphics.UI.FreeGame.Internal.Finalizer