diff --git a/Graphics/UI/FreeGame.hs b/Graphics/UI/FreeGame.hs --- a/Graphics/UI/FreeGame.hs +++ b/Graphics/UI/FreeGame.hs @@ -4,7 +4,7 @@ License : BSD-style (see the file LICENSE) Maintainer : Fumiaki Kinoshita -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 diff --git a/Graphics/UI/FreeGame/Base.hs b/Graphics/UI/FreeGame/Base.hs --- a/Graphics/UI/FreeGame/Base.hs +++ b/Graphics/UI/FreeGame/Base.hs @@ -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 --- 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 +-- 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) diff --git a/Graphics/UI/FreeGame/Data/Wave.hs b/Graphics/UI/FreeGame/Data/Wave.hs deleted file mode 100644 --- a/Graphics/UI/FreeGame/Data/Wave.hs +++ /dev/null @@ -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 diff --git a/Graphics/UI/FreeGame/GUI.hs b/Graphics/UI/FreeGame/GUI.hs --- a/Graphics/UI/FreeGame/GUI.hs +++ b/Graphics/UI/FreeGame/GUI.hs @@ -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 } diff --git a/Graphics/UI/FreeGame/GUI/GLFW.hs b/Graphics/UI/FreeGame/GUI/GLFW.hs --- a/Graphics/UI/FreeGame/GUI/GLFW.hs +++ b/Graphics/UI/FreeGame/GUI/GLFW.hs @@ -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) diff --git a/Graphics/UI/FreeGame/Internal/Raindrop.hs b/Graphics/UI/FreeGame/Internal/Raindrop.hs --- a/Graphics/UI/FreeGame/Internal/Raindrop.hs +++ b/Graphics/UI/FreeGame/Internal/Raindrop.hs @@ -10,7 +10,7 @@ -- -- A portable implementation of 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 #-} diff --git a/Graphics/UI/FreeGame/Types.hs b/Graphics/UI/FreeGame/Types.hs --- a/Graphics/UI/FreeGame/Types.hs +++ b/Graphics/UI/FreeGame/Types.hs @@ -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)) + diff --git a/Graphics/UI/FreeGame/Util.hs b/Graphics/UI/FreeGame/Util.hs --- a/Graphics/UI/FreeGame/Util.hs +++ b/Graphics/UI/FreeGame/Util.hs @@ -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) diff --git a/free-game.cabal b/free-game.cabal --- a/free-game.cabal +++ b/free-game.cabal @@ -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