free-game 0.9.3.5 → 0.9.4
raw patch · 9 files changed
+489/−588 lines, 9 filesdep +reflection
Dependencies added: reflection
Files
- Graphics/UI/FreeGame.hs +1/−1
- Graphics/UI/FreeGame/Base.hs +353/−372
- Graphics/UI/FreeGame/Data/Wave.hs +0/−26
- Graphics/UI/FreeGame/GUI.hs +35/−91
- Graphics/UI/FreeGame/GUI/GLFW.hs +88/−85
- Graphics/UI/FreeGame/Internal/Raindrop.hs +5/−1
- Graphics/UI/FreeGame/Types.hs +2/−1
- Graphics/UI/FreeGame/Util.hs +0/−6
- free-game.cabal +5/−5
Graphics/UI/FreeGame.hs view
@@ -4,7 +4,7 @@ License : BSD-style (see the file LICENSE) Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com> -free-game is a library that abstracts and purifies GUI applications with simple interfaces. +This module just re-exports other submodules. -} module Graphics.UI.FreeGame ( -- * Examples
Graphics/UI/FreeGame/Base.hs view
@@ -1,373 +1,354 @@-{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.UI.FreeGame.Base --- Copyright : (C) 2012-2013 Fumiaki Kinoshita --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com> --- Stability : experimental --- Portability : non-portable --- ----------------------------------------------------------------------------- - -module Graphics.UI.FreeGame.Base ( - -- * Types - UI(..) - - -- * Basic operations - ,tick - ,bracket - ,_Bracket - ,quit - ,embedIO - ,_EmbedIO - ,liftUI - ,_LiftUI - -- * Classes - ,Picture2D(..) - ,rotate - ,Figure2D(..) - ,Keyboard(..) - ,Mouse(..) - ,FromFinalizer(..) - ,SpecialKey(..) -) where - -import Control.Applicative -import Control.Applicative.Free as Ap -import Control.Monad.IO.Class -import Data.Monoid -import Data.Color -import Graphics.UI.FreeGame.Data.Bitmap -import Graphics.UI.FreeGame.Data.Wave -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 a -quit = wrap Quit - --- | Lift 'UI''s base functor. -liftUI :: (Functor n, MonadFree (UI n) m) => n a -> m a -liftUI = wrap . LiftUI . fmap return - --- | Lift an arbitrary 'IO' action. -embedIO :: (MonadFree (UI n) m) => IO a -> m a -embedIO = wrap . EmbedIO . fmap return - --- | @'_EmbedIO' :: Traversal' ('UI' m a) (IO a)@ -_EmbedIO :: Applicative f => (IO a -> f (IO a)) -> UI m a -> f (UI m a) -_EmbedIO f (EmbedIO m) = fmap EmbedIO (f m) -_EmbedIO _ x = pure x - --- | @'_Bracket' :: Traversal' ('UI' m a) (F (UI m) a)@ -_Bracket :: Applicative f => (F (UI m) a -> f (F (UI m) a)) -> UI m a -> f (UI m a) -_Bracket f (Bracket m) = fmap Bracket (f m) -_Bracket _ x = pure x - --- | @'_LiftUI' :: Traversal' ('UI' m a) (m a)@ -_LiftUI :: Applicative f => (m a -> f (m a)) -> UI m a -> f (UI m a) -_LiftUI f (LiftUI m) = fmap LiftUI (f m) -_LiftUI _ x = pure x - -hoistFreeR :: (Functor f, MonadFree g m) => (f (m a) -> g (m a)) -> Free.Free f a -> m a -hoistFreeR _ (Free.Pure a) = return a -hoistFreeR t (Free.Free f) = wrap . t $ fmap (hoistFreeR t) f -{-# INLINE[~4] hoistFreeR #-} - -hoistFR :: MonadFree g m => (f (m a) -> g (m a)) -> F f a -> m a -hoistFR t (F m) = m return (wrap . t) -{-# INLINE[~4] hoistFR #-} - -{-# RULES -"hoistFreeR/hoistFreeR"[5] forall f g m. hoistFreeR f (hoistFreeR g m) = hoistFreeR (f . g) m -"hoistFR/hoistFR"[5] forall f g m. hoistFR f (hoistFR g m) = hoistFR (f . g) m - #-} - --- | The class of types that can be regarded as a kind of picture. -class Picture2D p where - -- | Construct a 'Picture2D' from a 'Bitmap'. - fromBitmap :: Bitmap -> p () - -- | (radians) - rotateR :: Float -> p a -> p a - -- | (degrees) - rotateD :: Float -> p a -> p a - scale :: V2 Float -> p a -> p a - translate :: V2 Float -> p a -> p a - colored :: Color -> p a -> p a - - rotateR = rotateD . (* 180) . (/ pi) - rotateD = rotateR . (/ 180) . (* pi) - --- | Deprecated synonym for 'rotateD'. -rotate :: Picture2D p => Float -> p a -> p a -rotate = rotateD - -{-# DEPRECATED rotate "Use rotateD instead" #-} - -class Picture2D p => Figure2D p where - line :: [V2 Float] -> p () - polygon :: [V2 Float] -> p () - polygonOutline :: [V2 Float] -> p () - circle :: Float -> p () - 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 - 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 - -instance FromFinalizer (FinalizerT IO) where - fromFinalizer = id - -data SpecialKey = KeySpace - | KeyEsc - | KeyLeftShift - | KeyRightShift - | KeyLeftControl - | KeyRightControl - | KeyUp - | KeyDown - | KeyLeft - | KeyRight - | KeyTab - | KeyEnter - | KeyBackspace - | KeyInsert - | KeyDelete - | KeyPageUp - | KeyPageDown - | KeyHome - | KeyEnd - | KeyF1 - | KeyF2 - | KeyF3 - | KeyF4 - | KeyF5 - | KeyF6 - | KeyF7 - | KeyF8 - | KeyF9 - | KeyF10 - | KeyF11 - | KeyF12 - | KeyPad0 - | KeyPad1 - | KeyPad2 - | KeyPad3 - | KeyPad4 - | KeyPad5 - | KeyPad6 - | KeyPad7 - | KeyPad8 - | KeyPad9 - | KeyPadDivide - | KeyPadMultiply - | KeyPadSubtract - | KeyPadAdd - | KeyPadDecimal - | KeyPadEqual - | KeyPadEnter - deriving (Show, Eq, Ord, Enum) - -#define _COMMA_ , - -#define MK_PICTURE_2D(cxt, ty, l, t) instance (Picture2D m cxt) => Picture2D (ty) where { \ - fromBitmap = (l) . fromBitmap; \ - rotateD = (t) . rotateD; \ - rotateR = (t) . rotateR; \ - translate = (t) . translate; \ - scale = (t) . scale; \ - colored = (t) . colored } - -#define MK_FIGURE_2D(cxt, ty, l, t) instance (Figure2D m cxt) => Figure2D (ty) where { \ - line = (l) . line; \ - polygon = (l) . polygon; \ - polygonOutline = (l) . polygonOutline; \ - circle = (l) . circle; \ - circleOutline = (l) . circleOutline; \ - thickness = (t) . thickness } - -#define MK_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 } - -#define MK_MOUSE(cxt, ty, l) instance (Mouse m cxt) => Mouse (ty) where { \ - mousePosition = (l) mousePosition; \ - mouseWheel = (l) mouseWheel; \ - mouseButtonL = (l) mouseButtonL; \ - mouseButtonR = (l) mouseButtonR; \ - mouseButtonM = (l) mouseButtonM } - -#define MK_FROM_FINALIZER(cxt, ty, l) instance (FromFinalizer m cxt) => FromFinalizer (ty) where { \ - fromFinalizer = (l) . fromFinalizer } - -MK_PICTURE_2D(_COMMA_ Functor m, F m, liftF, hoistFR) -MK_PICTURE_2D( , UI m, LiftUI, over _LiftUI) -MK_PICTURE_2D(_COMMA_ Functor m, Free.Free m, Free.liftF, hoistFreeR) -MK_PICTURE_2D(_COMMA_ Monad m, ReaderT r m, lift, mapReaderT) -MK_PICTURE_2D(_COMMA_ Monad m, Lazy.StateT s m, lift, Lazy.mapStateT) -MK_PICTURE_2D(_COMMA_ Monad m, Strict.StateT s m, lift, Strict.mapStateT) -MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift, Lazy.mapWriterT) -MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift, Strict.mapWriterT) -MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift, Lazy.mapRWST) -MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift, Strict.mapRWST) -MK_PICTURE_2D(_COMMA_ Monad m, IdentityT m, lift, mapIdentityT) -MK_PICTURE_2D(_COMMA_ Monad m, MaybeT m, lift, mapMaybeT) -MK_PICTURE_2D(_COMMA_ Monad m, ListT m, lift, mapListT) -MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift, mapErrorT) -MK_PICTURE_2D(_COMMA_ Monad m, ContT r m, lift, mapContT) - -MK_FIGURE_2D(_COMMA_ Functor m, F m, liftF, hoistFR) -MK_FIGURE_2D( , UI m, LiftUI, over _LiftUI) -MK_FIGURE_2D(_COMMA_ Functor m, Free.Free m, Free.liftF, hoistFreeR) -MK_FIGURE_2D(_COMMA_ Monad m, ReaderT r m, lift, mapReaderT) -MK_FIGURE_2D(_COMMA_ Monad m, Lazy.StateT s m, lift, Lazy.mapStateT) -MK_FIGURE_2D(_COMMA_ Monad m, Strict.StateT s m, lift, Strict.mapStateT) -MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift, Lazy.mapWriterT) -MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift, Strict.mapWriterT) -MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift, Lazy.mapRWST) -MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift, Strict.mapRWST) -MK_FIGURE_2D(_COMMA_ Monad m, IdentityT m, lift, mapIdentityT) -MK_FIGURE_2D(_COMMA_ Monad m, MaybeT m, lift, mapMaybeT) -MK_FIGURE_2D(_COMMA_ Monad m, ListT m, lift, mapListT) -MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift, mapErrorT) -MK_FIGURE_2D(_COMMA_ Monad m, ContT r m, lift, mapContT) - -MK_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) -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) +{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.UI.FreeGame.Base+-- Copyright : (C) 2012-2013 Fumiaki Kinoshita+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>+-- Stability : experimental+-- Portability : non-portable+--+----------------------------------------------------------------------------++module Graphics.UI.FreeGame.Base (+ -- * Types+ UI(..)+ ,Vec2+ -- * Basic operations+ ,tick+ ,bracket+ ,_Bracket+ ,quit+ ,embedIO+ ,_EmbedIO+ ,liftUI+ ,_LiftUI+ ,getFPS++ -- * Classes+ ,Picture2D(..)+ ,rotate+ ,Figure2D(..)+ ,Keyboard(..)+ ,Mouse(..)+ ,FromFinalizer(..)+ ,SpecialKey(..)+) where++import Control.Applicative+import Control.Applicative.Free as Ap+import Control.Monad.IO.Class+import Data.Monoid+import Data.Color+import Graphics.UI.FreeGame.Data.Bitmap+import Graphics.UI.FreeGame.Internal.Finalizer+import Graphics.UI.FreeGame.Internal.Raindrop+import Linear hiding (rotate)++import Control.Monad.Free.Class+import Control.Monad.Free.Church+import qualified Control.Monad.Free as Free++import Control.Monad.Trans+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.List+import Control.Monad.Trans.Error+import Control.Monad.Trans.Identity+import qualified Control.Monad.State.Lazy as Lazy+import qualified Control.Monad.State.Strict as Strict+import qualified Control.Monad.Writer.Lazy as Lazy+import qualified Control.Monad.Writer.Strict as Strict+import qualified Control.Monad.Trans.RWS.Strict as Strict+import qualified Control.Monad.Trans.RWS.Lazy as Lazy++infixr 5 `translate`+infixr 5 `rotate`+infixr 5 `scale`+infixr 5 `colored`++type Vec2 = V2 Float++instance (Functor m) => MonadIO (F (UI m)) where+ liftIO = embedIO++instance (Functor m) => MonadIO (Free.Free (UI m)) where+ liftIO = embedIO++-- | A functor enriches given functor with control structure.+data UI m a+ = Tick a+ | EmbedIO (IO a)+ | LiftUI (m a)+ | Bracket (F (UI m) a)+ | GetFPS (Int -> a)+ | Quit+ deriving Functor++-- | Finalize the current frame and refresh the screen.+tick :: MonadFree (UI n) m => m ()+tick = wrap $ Tick (return ())++-- | Run a Game monad in a Game monad. Resources (e.g. pictures) will be released when inner computation is done.+bracket :: MonadFree (UI n) m => F (UI n) a -> m a+bracket = wrap . Bracket . fmap return++-- | Break the entire computation.+quit :: MonadFree (UI n) m => m a+quit = wrap Quit++-- | Lift 'UI''s base functor.+liftUI :: (Functor n, MonadFree (UI n) m) => n a -> m a+liftUI = wrap . LiftUI . fmap return++-- | Lift an arbitrary 'IO' action.+embedIO :: (MonadFree (UI n) m) => IO a -> m a+embedIO = wrap . EmbedIO . fmap return++getFPS :: MonadFree (UI n) m => m Int+getFPS = wrap $ GetFPS return++-- | @'_EmbedIO' :: Traversal' ('UI' m a) (IO a)@+_EmbedIO :: Applicative f => (IO a -> f (IO a)) -> UI m a -> f (UI m a)+_EmbedIO f (EmbedIO m) = fmap EmbedIO (f m)+_EmbedIO _ x = pure x++-- | @'_Bracket' :: Traversal' ('UI' m a) (F (UI m) a)@+_Bracket :: Applicative f => (F (UI m) a -> f (F (UI m) a)) -> UI m a -> f (UI m a)+_Bracket f (Bracket m) = fmap Bracket (f m)+_Bracket _ x = pure x++-- | @'_LiftUI' :: Traversal' ('UI' m a) (m a)@+_LiftUI :: Applicative f => (m a -> f (m a)) -> UI m a -> f (UI m a)+_LiftUI f (LiftUI m) = fmap LiftUI (f m)+_LiftUI _ x = pure x++hoistFreeR :: (Functor f, MonadFree g m) => (f (m a) -> g (m a)) -> Free.Free f a -> m a+hoistFreeR _ (Free.Pure a) = return a+hoistFreeR t (Free.Free f) = wrap . t $ fmap (hoistFreeR t) f+{-# INLINE[~4] hoistFreeR #-}++hoistFR :: MonadFree g m => (f (m a) -> g (m a)) -> F f a -> m a+hoistFR t (F m) = m return (wrap . t)+{-# INLINE[~4] hoistFR #-}++{-# RULES+"hoistFreeR/hoistFreeR"[5] forall f g m. hoistFreeR f (hoistFreeR g m) = hoistFreeR (f . g) m+"hoistFR/hoistFR"[5] forall f g m. hoistFR f (hoistFR g m) = hoistFR (f . g) m+ #-}++-- | The class of types that can be regarded as a kind of picture.+class Picture2D p where+ -- | Construct a 'Picture2D' from a 'Bitmap'.+ fromBitmap :: Bitmap -> p ()+ -- | (radians)+ rotateR :: Float -> p a -> p a+ -- | (degrees)+ rotateD :: Float -> p a -> p a+ scale :: Vec2 -> p a -> p a+ translate :: Vec2 -> p a -> p a+ colored :: Color -> p a -> p a++ rotateR = rotateD . (* 180) . (/ pi)+ rotateD = rotateR . (/ 180) . (* pi)++-- | Deprecated synonym for 'rotateD'.+rotate :: Picture2D p => Float -> p a -> p a+rotate = rotateD++{-# DEPRECATED rotate "Use rotateD instead" #-} ++class Picture2D p => Figure2D p where+ line :: [Vec2] -> p ()+ polygon :: [Vec2] -> p ()+ polygonOutline :: [Vec2] -> p ()+ circle :: Float -> p ()+ circleOutline :: Float -> p ()+ thickness :: Float -> p a -> p a++-- | The class of types that can handle inputs of the keyboard.+class Keyboard t where+ keyChar :: Char -> t Bool+ keySpecial :: SpecialKey -> t Bool++-- | The class of types that can handle inputs of the mouse.+class Mouse t where+ mousePosition :: t Vec2+ mouseWheel :: t Int+ mouseButtonL :: t Bool+ mouseButtonM :: t Bool+ mouseButtonR :: t Bool++class FromFinalizer m where+ fromFinalizer :: FinalizerT IO a -> m a++instance FromFinalizer (FinalizerT IO) where+ fromFinalizer = id++data SpecialKey = KeySpace+ | KeyEsc+ | KeyLeftShift+ | KeyRightShift+ | KeyLeftControl+ | KeyRightControl+ | KeyUp+ | KeyDown+ | KeyLeft+ | KeyRight+ | KeyTab+ | KeyEnter+ | KeyBackspace+ | KeyInsert+ | KeyDelete+ | KeyPageUp+ | KeyPageDown+ | KeyHome+ | KeyEnd+ | KeyF1+ | KeyF2+ | KeyF3+ | KeyF4+ | KeyF5+ | KeyF6+ | KeyF7+ | KeyF8+ | KeyF9+ | KeyF10+ | KeyF11+ | KeyF12+ | KeyPad0+ | KeyPad1+ | KeyPad2+ | KeyPad3+ | KeyPad4+ | KeyPad5+ | KeyPad6+ | KeyPad7+ | KeyPad8+ | KeyPad9+ | KeyPadDivide+ | KeyPadMultiply+ | KeyPadSubtract+ | KeyPadAdd+ | KeyPadDecimal+ | KeyPadEqual+ | KeyPadEnter+ deriving (Show, Eq, Ord, Enum)++#define _COMMA_ ,++#define MK_PICTURE_2D(cxt, ty, l, t) instance (Picture2D m cxt) => Picture2D (ty) where { \+ fromBitmap = (l) . fromBitmap; \+ rotateD = (t) . rotateD; \+ rotateR = (t) . rotateR; \+ translate = (t) . translate; \+ scale = (t) . scale; \+ colored = (t) . colored }++#define MK_FIGURE_2D(cxt, ty, l, t) instance (Figure2D m cxt) => Figure2D (ty) where { \+ line = (l) . line; \+ polygon = (l) . polygon; \+ polygonOutline = (l) . polygonOutline; \+ circle = (l) . circle; \+ circleOutline = (l) . circleOutline; \+ thickness = (t) . thickness }++#define MK_KEYBOARD(cxt, ty, l) instance (Keyboard m cxt) => Keyboard (ty) where { \+ keyChar = (l) . keyChar; \+ keySpecial = (l) . keySpecial }++#define MK_MOUSE(cxt, ty, l) instance (Mouse m cxt) => Mouse (ty) where { \+ mousePosition = (l) mousePosition; \+ mouseWheel = (l) mouseWheel; \+ mouseButtonL = (l) mouseButtonL; \+ mouseButtonR = (l) mouseButtonR; \+ mouseButtonM = (l) mouseButtonM }++#define MK_FROM_FINALIZER(cxt, ty, l) instance (FromFinalizer m cxt) => FromFinalizer (ty) where { \+ fromFinalizer = (l) . fromFinalizer }++MK_PICTURE_2D(_COMMA_ Functor m, F m, liftF, hoistFR)+MK_PICTURE_2D( , UI m, LiftUI, over _LiftUI)+MK_PICTURE_2D(_COMMA_ Functor m, Free.Free m, Free.liftF, hoistFreeR)+MK_PICTURE_2D(_COMMA_ Monad m, ReaderT r m, lift, mapReaderT)+MK_PICTURE_2D(_COMMA_ Monad m, Lazy.StateT s m, lift, Lazy.mapStateT)+MK_PICTURE_2D(_COMMA_ Monad m, Strict.StateT s m, lift, Strict.mapStateT)+MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift, Lazy.mapWriterT)+MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift, Strict.mapWriterT)+MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift, Lazy.mapRWST)+MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift, Strict.mapRWST)+MK_PICTURE_2D(_COMMA_ Monad m, IdentityT m, lift, mapIdentityT)+MK_PICTURE_2D(_COMMA_ Monad m, MaybeT m, lift, mapMaybeT)+MK_PICTURE_2D(_COMMA_ Monad m, ListT m, lift, mapListT)+MK_PICTURE_2D(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift, mapErrorT)+MK_PICTURE_2D(_COMMA_ Monad m, ContT r m, lift, mapContT)++MK_FIGURE_2D(_COMMA_ Functor m, F m, liftF, hoistFR)+MK_FIGURE_2D( , UI m, LiftUI, over _LiftUI)+MK_FIGURE_2D(_COMMA_ Functor m, Free.Free m, Free.liftF, hoistFreeR)+MK_FIGURE_2D(_COMMA_ Monad m, ReaderT r m, lift, mapReaderT)+MK_FIGURE_2D(_COMMA_ Monad m, Lazy.StateT s m, lift, Lazy.mapStateT)+MK_FIGURE_2D(_COMMA_ Monad m, Strict.StateT s m, lift, Strict.mapStateT)+MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift, Lazy.mapWriterT)+MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift, Strict.mapWriterT)+MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift, Lazy.mapRWST)+MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift, Strict.mapRWST)+MK_FIGURE_2D(_COMMA_ Monad m, IdentityT m, lift, mapIdentityT)+MK_FIGURE_2D(_COMMA_ Monad m, MaybeT m, lift, mapMaybeT)+MK_FIGURE_2D(_COMMA_ Monad m, ListT m, lift, mapListT)+MK_FIGURE_2D(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift, mapErrorT)+MK_FIGURE_2D(_COMMA_ Monad m, ContT r m, lift, mapContT)++MK_KEYBOARD(, Ap m, liftAp)+MK_KEYBOARD(, UI m, LiftUI)+MK_KEYBOARD(_COMMA_ Functor m, F m, liftF)+MK_KEYBOARD(_COMMA_ Functor m, Free.Free m, Free.liftF)+MK_KEYBOARD(_COMMA_ Monad m, ReaderT s m, lift)+MK_KEYBOARD(_COMMA_ Monad m, Lazy.StateT s m, lift)+MK_KEYBOARD(_COMMA_ Monad m, Strict.StateT s m, lift)+MK_KEYBOARD(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift)+MK_KEYBOARD(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift)+MK_KEYBOARD(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift)+MK_KEYBOARD(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift)+MK_KEYBOARD(_COMMA_ Monad m, IdentityT m, lift)+MK_KEYBOARD(_COMMA_ Monad m, MaybeT m, lift)+MK_KEYBOARD(_COMMA_ Monad m, ListT m, lift)+MK_KEYBOARD(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift)+MK_KEYBOARD(_COMMA_ Monad m, ContT r m, lift)++MK_MOUSE(, Ap m, liftAp)+MK_MOUSE(, UI m, LiftUI)+MK_MOUSE(_COMMA_ Functor m, F m, liftF)+MK_MOUSE(_COMMA_ Functor m, Free.Free m, Free.liftF)+MK_MOUSE(_COMMA_ Monad m, ReaderT r m, lift)+MK_MOUSE(_COMMA_ Monad m, Lazy.StateT s m, lift)+MK_MOUSE(_COMMA_ Monad m, Strict.StateT s m, lift)+MK_MOUSE(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift)+MK_MOUSE(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift)+MK_MOUSE(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift)+MK_MOUSE(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift)+MK_MOUSE(_COMMA_ Monad m, IdentityT m, lift)+MK_MOUSE(_COMMA_ Monad m, MaybeT m, lift)+MK_MOUSE(_COMMA_ Monad m, ListT m, lift)+MK_MOUSE(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift)+MK_MOUSE(_COMMA_ Monad m, ContT r m, lift)++MK_FROM_FINALIZER(, UI m, LiftUI)+MK_FROM_FINALIZER(_COMMA_ Functor m, F m, liftF)+MK_FROM_FINALIZER(_COMMA_ Functor m, Free.Free m, Free.liftF)+MK_FROM_FINALIZER(_COMMA_ Monad m, Lazy.StateT s m, lift)+MK_FROM_FINALIZER(_COMMA_ Monad m, Strict.StateT s m, lift)+MK_FROM_FINALIZER(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.WriterT w m, lift)+MK_FROM_FINALIZER(_COMMA_ Monad m _COMMA_ Monoid w, Strict.WriterT w m, lift)+MK_FROM_FINALIZER(_COMMA_ Monad m _COMMA_ Monoid w, Lazy.RWST r w s m, lift)+MK_FROM_FINALIZER(_COMMA_ Monad m _COMMA_ Monoid w, Strict.RWST r w s m, lift)+MK_FROM_FINALIZER(_COMMA_ Monad m, IdentityT m, lift)+MK_FROM_FINALIZER(_COMMA_ Monad m, MaybeT m, lift)+MK_FROM_FINALIZER(_COMMA_ Monad m, ListT m, lift)+MK_FROM_FINALIZER(_COMMA_ Monad m _COMMA_ Error e, ErrorT e m, lift) MK_FROM_FINALIZER(_COMMA_ Monad m, ContT r m, lift)
− Graphics/UI/FreeGame/Data/Wave.hs
@@ -1,26 +0,0 @@-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.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor, BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.UI.FreeGame.GUI @@ -13,103 +13,49 @@ module Graphics.UI.FreeGame.GUI ( GUI , GUIBase(..) - , _Draw - , _Input - , GUIInput(..) - , Picture(..) , GUIParam(..) ) where import Graphics.UI.FreeGame.Base import Graphics.UI.FreeGame.Data.Bitmap import Graphics.UI.FreeGame.Internal.Finalizer -import Graphics.UI.FreeGame.Internal.Raindrop -import Control.Applicative +import Graphics.UI.FreeGame.Types import Data.Default import Data.Color -import Linear hiding (rotate) -- | A 'Functor' which represents graphical user interfaces. type GUI = UI GUIBase -- | The base of 'GUI'. -data GUIBase a = Input (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 => (GUIInput a -> f (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 - rotateD = over _Draw . rotateD - scale = over _Draw . scale - 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 - -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 - --- | A free structure that represents inputs. -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 - --- | A free structure that represents pictures. -data Picture a - = LiftBitmap Bitmap a - | PictureWithFinalizer (FinalizerT IO a) - | RotateD Float (Picture a) - | 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 +data GUIBase a = FromBitmap Bitmap a + | FromFinalizer (FinalizerT IO a) + | RotateD Float (GUIBase a) + | Scale Vec2 (GUIBase a) + | Translate Vec2 (GUIBase a) + | Colored Color (GUIBase a) + | Line [Vec2] a + | Polygon [Vec2] a + | PolygonOutline [Vec2] a | Circle Float a | CircleOutline Float a - | Thickness Float (Picture a) + | Thickness Float (GUIBase a) + | KeyChar Char (Bool -> a) + | KeySpecial SpecialKey (Bool -> a) + | MousePosition (Vec2 -> a) + | MouseWheel (Int -> a) + | MouseButtonL (Bool -> a) + | MouseButtonM (Bool -> a) + | MouseButtonR (Bool -> a) deriving Functor -instance Picture2D Picture where - fromBitmap = flip LiftBitmap () +instance Picture2D GUIBase where + fromBitmap b = FromBitmap b () rotateD = RotateD scale = Scale translate = Translate colored = Colored -instance Figure2D Picture where +instance Figure2D GUIBase where line = flip Line () polygon = flip Polygon () polygonOutline = flip PolygonOutline () @@ -117,38 +63,36 @@ circleOutline = flip CircleOutline () thickness = Thickness -instance FromFinalizer Picture where - fromFinalizer = PictureWithFinalizer +instance Keyboard GUIBase where + keyChar x = KeyChar x id + keySpecial x = KeySpecial x id -instance Keyboard GUIInput where - keyChar x = ICharKey x id - keySpecial x = ISpecialKey x id +instance Mouse GUIBase where + mousePosition = MousePosition id + mouseWheel = MouseWheel id + mouseButtonL = MouseButtonL id + mouseButtonR = MouseButtonR id + mouseButtonM = MouseButtonM id -instance Mouse GUIInput where - mousePosition = IMousePosition id - mouseWheel = IMouseWheel id - mouseButtonL = IMouseButtonL id - mouseButtonR = IMouseButtonR id - mouseButtonM = IMouseButtonM id +instance FromFinalizer GUIBase where + fromFinalizer = FromFinalizer -- | Parameters of the application. data GUIParam = GUIParam { _framePerSecond :: Int - , _windowSize :: V2 Int + , _windowRegion :: BoundingBox Float , _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 = Color 1 1 1 1 - , _windowOrigin = V2 0 0 + , _windowRegion = BoundingBox 0 0 640 480 }
Graphics/UI/FreeGame/GUI/GLFW.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE FlexibleContexts, Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.UI.FreeGame.GUI.GLFW @@ -21,7 +21,9 @@ import Graphics.UI.FreeGame.Base import Graphics.UI.FreeGame.Data.Bitmap import Graphics.UI.FreeGame.Internal.Finalizer +import Graphics.UI.FreeGame.Internal.Raindrop import Graphics.UI.FreeGame.GUI +import Graphics.UI.FreeGame.Types import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility import qualified Data.Array.Repa.Repr.ForeignPtr as RF import qualified Graphics.UI.GLFW as GLFW @@ -30,61 +32,56 @@ import qualified Graphics.Rendering.OpenGL.GL as GL import System.Mem import Unsafe.Coerce +import Control.Bool import Linear +import Data.Reflection runGame :: GUIParam -> F GUI a -> IO (Maybe a) -runGame param m = launch param $ \r s -> runF m (return . Just) (runAction param r s) +runGame param m = launch param $ runF m (return . Just) runAction -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 1 pic - EmbedIO m -> join (liftIO m) - Bracket m -> liftIO (runFinalizerT $ runF m (return.Just) (runAction param refTextures refFrame)) +data System = System + { refTextures :: IORef (IM.IntMap Texture) + , refFrame :: IORef Int + , refFPS :: IORef Int + , theParameter :: GUIParam + } + +runAction :: Given System => GUI (FinalizerT IO (Maybe a)) -> FinalizerT IO (Maybe a) +runAction (LiftUI f) = join $ runUI id f +runAction (EmbedIO m) = join (liftIO m) +runAction (Bracket m) = liftIO $ runFinalizerT $ runF m (return.Just) runAction >>= maybe (return Nothing) id - 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) +runAction Quit = return Nothing +runAction (Tick cont) = do + liftIO $ do + GL.matrixMode $= GL.Projection + GLFW.swapBuffers + performGC + t <- GLFW.getTime + n <- readIORef (refFrame given) + GLFW.sleep $ fromIntegral n / fromIntegral (_framePerSecond $ theParameter given) - t + if t >= 1 + then GLFW.resetTime >> writeIORef (refFrame given) 0 >> writeIORef (refFPS given) n + else writeIORef (refFrame given) (succ n) - r <- liftIO $ GLFW.windowIsOpen - if not r then return Nothing else do - liftIO $ do - GL.clear [GL.ColorBuffer] - GL.loadIdentity - 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 + r <- liftIO $ GLFW.windowIsOpen + if not r then return Nothing else do + liftIO $ do + GL.clear [GL.ColorBuffer] + GL.loadIdentity + let BoundingBox wl wt wr wb = fmap realToFrac $ _windowRegion $ theParameter given + GL.ortho wl wr wb wt 0 (-100) + GL.matrixMode $= GL.Modelview 0 + cont +runAction (GetFPS cont) = liftIO (readIORef (refFPS given)) >>= cont type Texture = (GL.TextureObject, Int, Int) -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 :: GUIParam -> (Given System => FinalizerT IO (Maybe a)) -> IO (Maybe a) launch param m = do GLFW.initialize >>= bool (fail "Failed to initialize") (return ()) pf <- GLFW.openGLProfile - let V2 ww wh = _windowSize param + let V2 ww wh = fmap floor (view _BottomRight (_windowRegion param) - view _TopLeft (_windowRegion param)) (>>=bool (fail "Failed to initialize") (return ())) $ GLFW.openWindow $ GLFW.defaultDisplayOptions { GLFW.displayOptions_width = ww ,GLFW.displayOptions_height = wh @@ -97,12 +94,13 @@ GL.lineSmooth $= GL.Enabled GL.blend $= GL.Enabled GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha) - GL.shadeModel $= GL.Smooth + GL.shadeModel $= GL.Flat GL.textureFunction $= GL.Combine let Color r g b a = _clearColor param in GL.clearColor $= GL.Color4 (gf r) (gf g) (gf b) (gf a) - res <- runFinalizerT $ join $ m <$> liftIO (newIORef IM.empty) <*> liftIO (newIORef 0) + sys <- System <$> newIORef IM.empty <*> newIORef 0 <*> newIORef 0 <*> pure param + res <- runFinalizerT $ give sys m GLFW.closeWindow GLFW.terminate @@ -120,70 +118,75 @@ finalizer $ GL.deleteObjectNames [tex] return (tex, width, height) -runInput :: GUIInput a -> IO a -runInput (ICharKey ch cont) = cont <$> GLFW.keyIsPressed (GLFW.CharKey ch) -runInput (ISpecialKey x cont) = cont <$> GLFW.keyIsPressed (mapSpecialKey x) -runInput (IMouseButtonL cont) = cont <$> GLFW.mouseButtonIsPressed GLFW.MouseButton0 -runInput (IMouseButtonR cont) = cont <$> GLFW.mouseButtonIsPressed GLFW.MouseButton1 -runInput (IMouseButtonM cont) = cont <$> GLFW.mouseButtonIsPressed GLFW.MouseButton2 -runInput (IMousePosition cont) = do - (x, y) <- GLFW.getMousePosition - return $ cont $ V2 (fromIntegral x) (fromIntegral y) -runInput (IMouseWheel cont) = cont <$> GLFW.getMouseWheel +rot2 :: Floating a => a -> V2 a -> V2 a +rot2 a (V2 x y) = V2 (p * x + q * y) (-q * x + p * y) where + d = a * (pi / 180) + p = cos d + q = sin d -runPicture :: (?refTextures :: IORef (IM.IntMap Texture)) => Float -> Picture a -> FinalizerT IO a -runPicture _ (LiftBitmap bmp@(BitmapData _ (Just h)) r) = do - m <- liftIO $ readIORef ?refTextures +runUI :: Given System => (V2 Float -> V2 Float) -> GUIBase a -> FinalizerT IO a +runUI _ (FromBitmap bmp@(BitmapData _ (Just h)) r) = do + m <- liftIO $ readIORef $ refTextures given case IM.lookup h m of Just t -> liftIO $ drawTexture t Nothing -> do t <- installTexture bmp - liftIO $ writeIORef ?refTextures $ IM.insert h t m + liftIO $ writeIORef (refTextures given) $ IM.insert h t m liftIO $ drawTexture t - finalizer $ modifyIORef ?refTextures $ IM.delete h + finalizer $ modifyIORef (refTextures given) $ IM.delete h return r -runPicture _ (LiftBitmap bmp@(BitmapData _ Nothing) r) = do +runUI _ (FromBitmap bmp@(BitmapData _ Nothing) r) = do liftIO $ runFinalizerT $ installTexture bmp >>= liftIO . drawTexture return r -runPicture sc (Translate (V2 tx ty) cont) = preservingMatrix' $ do +runUI f (Translate t@(V2 tx ty) inner) = preservingMatrix' $ do liftIO $ GL.translate (GL.Vector3 (gf tx) (gf ty) 0) - runPicture sc cont -runPicture sc (RotateD theta cont) = preservingMatrix' $ do + runUI (subtract t . f) inner +runUI f (RotateD theta inner) = preservingMatrix' $ do liftIO $ GL.rotate (gf (-theta)) (GL.Vector3 0 0 1) - runPicture sc cont -runPicture sc (Scale (V2 sx sy) cont) = preservingMatrix' $ do + runUI (rot2 (-theta) . f) inner +runUI f (Scale s@(V2 sx sy) inner) = preservingMatrix' $ do liftIO $ GL.scale (gf sx) (gf sy) 1 - runPicture (sc * max sx sy) cont -runPicture _ (PictureWithFinalizer m) = m -runPicture sc (Colored col cont) = do + runUI ((/s) . f) inner +runUI _ (FromFinalizer m) = m +runUI f (Colored col inner) = do oldColor <- liftIO $ get GL.currentColor liftIO $ GL.currentColor $= unsafeCoerce col - res <- runPicture sc cont + res <- runUI f inner liftIO $ GL.currentColor $= oldColor return res -runPicture _ (Line path a) = do +runUI _ (Line path r) = do liftIO $ GL.renderPrimitive GL.LineStrip $ runVertices path - return a -runPicture _ (Polygon path a) = do + return r +runUI _ (Polygon path r) = do liftIO $ GL.renderPrimitive GL.Polygon $ runVertices path - return a -runPicture _ (PolygonOutline path a) = do + return r +runUI _ (PolygonOutline path r) = do liftIO $ GL.renderPrimitive GL.LineLoop $ runVertices path - return a -runPicture sc (Circle r a) = do - let s = 2 * pi / 64 * sc + return r +runUI _ (Circle r cont) = do + let s = 2 * pi / r liftIO $ GL.renderPrimitive GL.Polygon $ runVertices [V2 (cos t * r) (sin t * r) | t <- [0,s..2 * pi]] - return a -runPicture sc (CircleOutline r a) = do - let s = 2 * pi / 64 * sc + return cont +runUI _ (CircleOutline r cont) = do + let s = 2 * pi / r liftIO $ GL.renderPrimitive GL.LineLoop $ runVertices [V2 (cos t * r) (sin t * r) | t <- [0,s..2 * pi]] - return a -runPicture sc (Thickness t cont) = do + return cont +runUI f (Thickness t inner) = do oldWidth <- liftIO $ get GL.lineWidth liftIO $ GL.lineWidth $= gf t - res <- runPicture sc cont + res <- runUI f inner liftIO $ GL.lineWidth $= oldWidth return res +runUI _ (KeyChar ch cont) = cont <$> liftIO (GLFW.keyIsPressed (GLFW.CharKey ch)) +runUI _ (KeySpecial x cont) = cont <$> liftIO (GLFW.keyIsPressed (mapSpecialKey x)) +runUI _ (MouseButtonL cont) = cont <$> liftIO (GLFW.mouseButtonIsPressed GLFW.MouseButton0) +runUI _ (MouseButtonR cont) = cont <$> liftIO (GLFW.mouseButtonIsPressed GLFW.MouseButton1) +runUI _ (MouseButtonM cont) = cont <$> liftIO (GLFW.mouseButtonIsPressed GLFW.MouseButton2) +runUI f (MousePosition cont) = do + (x, y) <- liftIO GLFW.getMousePosition + let pos = f $ V2 (fromIntegral x) (fromIntegral y) + return $ cont pos +runUI _ (MouseWheel cont) = cont <$> liftIO GLFW.getMouseWheel runVertices :: MonadIO m => [V2 Float] -> m () runVertices = liftIO . mapM_ (GL.vertex . mkVertex2)
Graphics/UI/FreeGame/Internal/Raindrop.hs view
@@ -10,7 +10,7 @@ -- -- A portable implementation of lens(<http://hackage.haskell.org/package/lens>) -----------------------------------------------------------------------------module Graphics.UI.FreeGame.Internal.Raindrop (view, over) where+module Graphics.UI.FreeGame.Internal.Raindrop (view, over, biover) where import Data.Functor.Identity import Control.Monad.Reader@@ -30,3 +30,7 @@ over :: ((a -> Identity b) -> (s -> Identity t)) -> (a -> b) -> s -> t over l f = runIdentity #. l (Identity #. f) {-# INLINE over #-}++biover :: ((a -> Identity b) -> (c -> Identity d) -> (s -> Identity t)) -> (a -> b) -> (c -> d) -> s -> t+biover l f g = runIdentity #. l (Identity #. f) (Identity #. g)+{-# INLINE biover #-}
Graphics/UI/FreeGame/Types.hs view
@@ -21,7 +21,7 @@ import Linear.V2 --- | 2D bounding box +-- | 2D bounding box (x0, y0, x1, y1) data BoundingBox a = BoundingBox a a a a deriving (Show, Eq, Ord, Functor, Read) -- | Determine whether the given point is in the 'BoundingBox'. @@ -43,3 +43,4 @@ -- | @'_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
@@ -23,7 +23,6 @@ radians, unitV2, angleV2, - sinCos, -- * Loading loadPictureFromFile, loadBitmaps, @@ -55,11 +54,6 @@ -- | An angle of given vector. angleV2 :: RealFloat a => V2 a -> a angleV2 (V2 a b) = atan2 b a - --- | Deprecated synonym for 'unitV2'. -sinCos :: Floating a => a -> V2 a -sinCos = unitV2 -{-# DEPRECATED sinCos "Use unitV2 instead" #-} -- | 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)
free-game.cabal view
@@ -1,8 +1,8 @@ name: free-game -version: 0.9.3.5 -synopsis: Create graphical applications for free -description: Cross-platform GUI library based on free monads -homepage: https://github.com/fumieval/free-game +version: 0.9.4 +synopsis: Cross-platform GUI library based on free monads +description: free-game is a library that abstracts graphical applications with simple interfaces. Twitter: #hs_free_game +homepage: https://github.com/fumieval/free-game/tree/maintainance0.9 bug-reports: https://github.com/fumieval/free-game/issues license: BSD3 license-file: LICENSE @@ -24,7 +24,6 @@ Graphics.UI.FreeGame Graphics.UI.FreeGame.Base Graphics.UI.FreeGame.Data.Bitmap - Graphics.UI.FreeGame.Data.Wave Graphics.UI.FreeGame.Data.Font Graphics.UI.FreeGame.Text Graphics.UI.FreeGame.GUI @@ -58,5 +57,6 @@ vector == 0.10.*, JuicyPixels-repa >= 0.5.1, data-default, + reflection == 1.*, colors == 0.1.*, control-bool