diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Fumiaki Kinoshita + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Fumiaki Kinoshita nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/call.cabal b/call.cabal new file mode 100644 --- /dev/null +++ b/call.cabal @@ -0,0 +1,59 @@ +name: call +version: 0.0 +synopsis: The call game engine +description: Call is a minimalistic game engine which supports 2D graphics and sounds. +homepage: https://github.com/fumieval/call +license: BSD3 +license-file: LICENSE +author: Fumiaki Kinoshita +maintainer: Fumiaki Kinoshita +copyright: (c) Fumiaki Kinoshita 2014 +category: Game +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: + Call + Call.Types + Call.TH + Call.System + Call.Picture + Call.Component + Call.Component.Deck + Call.Internal.GLFW + Call.Data.Wave + Call.Data.Font + Call.Data.Bitmap + Call.Util + ghc-options: -Wall -fexcess-precision -O2 -threaded + other-extensions: Rank2Types, DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveDataTypeable, TemplateHaskell, CPP, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeSynonymInstances, ScopedTypeVariables, FlexibleInstances, FlexibleContexts, KindSignatures, TypeFamilies, BangPatterns, ViewPatterns, LambdaCase, DataKinds, GADTs + build-depends: + base >=4.5 && <5, + transformers >=0.4 && <0.5, + control-bool >=0.2 && <0.3, + colors >=0.1 && <0.2, + linear >=1.10 && <1.11, + boundingboxes >=0.2 && <0.3, + template-haskell == 2.*, + directory, + filepath, + mtl >=2.0 && <2.7, + reflection >=1.5 && <1.6, + containers >=0.5 && <0.7, + vector >=0.9 && <0.13, + GLFW-b >=1.3 && <2, + lens >=4.0 && <5, + OpenGL == 2.9.*, + OpenGLRaw >=1.4 && <1.7, + JuicyPixels == 3.*, + JuicyPixels-util <0.3, + WAVE >=0.1 && <0.2, + freetype2 >=0.1 && <0.2, + random ==1.*, + hashable >=1.2 && <1.3, + objective >= 0.2 && <0.3, + bindings-portaudio + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/Call.hs b/src/Call.hs new file mode 100644 --- /dev/null +++ b/src/Call.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE Rank2Types #-} +module Call ( -- * System + Time, + MonadObjective(..), + (.&), + System, + runSystem, + runSystemDefault, + MonadSystem(..), + -- * Component crafting + module Control.Object, + Mouse(..), + Keyboard(..), + Graphic(..), + Audio(..), + -- * Free instances + PullGraphic(..), + PullAudio(..), + KeyEvent(..), + MouseEvent(..), + -- * Concrete types + WindowMode(..), + BoundingBox2, + Box(..), + isInside, + Picture(..), + Bitmap, + readBitmap, + Affine(..), + Picture2D(..), + Source(..), + readWAVE, + Key(..), + charToKey, + -- * IO + liftIO, + loadBitmapsWith, + -- * Reexports + module Control.Monad, + module Control.Applicative, + module Control.Bool, + module Data.Color, + module Data.Color.Names, + module Linear, +) where + +import Call.TH +import Call.Types +import Call.Component +import Call.Data.Bitmap +import Call.Data.Wave +import Call.Picture +import Call.System +import Control.Monad.IO.Class +import Control.Monad +import Control.Applicative +import Control.Bool +import Control.Object +import Control.Monad.Objective.Class +import Data.Color +import Data.Color.Names +import Linear +import Data.BoundingBox + +runSystemDefault :: (forall s. System s a) -> IO (Maybe a) +runSystemDefault = runSystem Windowed (Box (V2 0 0) (V2 640 480)) diff --git a/src/Call/Component.hs b/src/Call/Component.hs new file mode 100644 --- /dev/null +++ b/src/Call/Component.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveFunctor #-} +----------------------------------------------------------------------------- +-- | +-- Module : Call.Component +-- Copyright : (c) Fumiaki Kinoshita 2014 +-- License : BSD3 +-- +-- Maintainer : Fumiaki Kinoshita +-- Stability : experimental +-- Portability : non-portable +-- +----------------------------------------------------------------------------- +module Call.Component where + +import Call.Types +import Linear +import Call.Picture +import Control.Object + +class Mouse f where + cursorEvent :: Vec2 -> f () + scrollEvent :: Vec2 -> f () + mouseButtonEvent :: Int -> Bool -> f () + +class Keyboard f where + keyEvent :: Key -> Bool -> f () + +class Graphic e where + pullGraphic :: Time -> e (Picture ()) + +class Audio e where + pullAudio :: Time -> Int -> e [V2 Float] + +data PullGraphic a = PullGraphic !Time (Picture () -> a) deriving Functor + +instance Graphic PullGraphic where + pullGraphic t = PullGraphic t id + +data PullAudio a = PullAudio !Time !Int ([V2 Float] -> a) deriving Functor + +instance Audio PullAudio where + pullAudio t n = PullAudio t n id + +data KeyEvent a = KeyEvent !Key !Bool a deriving Functor + +instance Keyboard KeyEvent where + keyEvent k b = KeyEvent k b () + +data MouseEvent a = CursorEvent !Vec2 a | ScrollEvent !Vec2 a | MouseButtonEvent !Int !Bool a + +instance Mouse MouseEvent where + cursorEvent v = CursorEvent v () + scrollEvent v = ScrollEvent v () + mouseButtonEvent i b = MouseButtonEvent i b () + +------------------------------------------------------------------ + +instance Mouse e => Mouse (AccessT s e) where + cursorEvent v = LiftAccessT (cursorEvent v) + scrollEvent v = LiftAccessT (scrollEvent v) + mouseButtonEvent i b = LiftAccessT (mouseButtonEvent i b) + +instance Keyboard e => Keyboard (AccessT s e) where + keyEvent k b = LiftAccessT (keyEvent k b) + +instance Graphic e => Graphic (AccessT s e) where + pullGraphic dt = LiftAccessT (pullGraphic dt) + +instance Audio e => Audio (AccessT s e) where + pullAudio dt n = LiftAccessT (pullAudio dt n) diff --git a/src/Call/Component/Deck.hs b/src/Call/Component/Deck.hs new file mode 100644 --- /dev/null +++ b/src/Call/Component/Deck.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Call.Component.Deck +-- Copyright : (c) Fumiaki Kinoshita 2014 +-- License : BSD3 +-- +-- Maintainer : Fumiaki Kinoshita +-- Stability : experimental +-- Portability : non-portable +-- +-- Decks that plays sounds +-- +----------------------------------------------------------------------------- +module Call.Component.Deck (emptyDeck, States, source, pos, pitch, playing, sampleRate) where +import Call.Component +import Control.Lens +import Linear +import Call.Types +import Control.Monad.State.Strict +import Call.Data.Wave +import Control.Object + +data States = States + { _src :: Maybe (Source (V2 Float)) + , _pos :: !Time + , _pitch :: !Double + , _playing :: !Bool + , _sampleRate :: !Double } + +-- +source :: Lens' States (Maybe (Source (V2 Float))) +source f s = f (_src s) <&> \a -> s { _src = a } +pos :: Lens' States Time +pos f s = f (_pos s) <&> \a -> s { _pos = a } +pitch :: Lens' States Time +pitch f s = f (_pitch s) <&> \a -> s { _pitch = a } +playing :: Lens' States Bool +playing f s = f (_playing s) <&> \a -> s { _playing = a } +sampleRate :: Lens' States Double +sampleRate f s = f (_sampleRate s) <&> \a -> s { _sampleRate = a } + +emptyDeck :: Monad m => Object (AccessT States PullAudio) m +emptyDeck = stateful handle $ States Nothing 0 1 False 44100 where -- FIXME: sample rate + +handle :: MonadState States m => PullAudio (m a) -> m a +handle (PullAudio dt0 n cont) = use source >>= \case + Just (Source s) -> do + pl <- use playing + t0 <- use pos + k <- use pitch + let dt = dt0 * k + if pl + then do + r <- use sampleRate + pos += dt + cont $ map s [t0,t0 + dt / fromIntegral n..t0 + dt - 1 / r] + else do + cont $ replicate n zero + Nothing -> cont $ replicate n zero diff --git a/src/Call/Data/Bitmap.hs b/src/Call/Data/Bitmap.hs new file mode 100644 --- /dev/null +++ b/src/Call/Data/Bitmap.hs @@ -0,0 +1,69 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Call.Data.Bitmap +-- Copyright : (c) Fumiaki Kinoshita 2014 +-- License : BSD3 +-- +-- Maintainer : Fumiaki Kinoshita +-- Stability : experimental +-- Portability : non-portable +-- +----------------------------------------------------------------------------- +module Call.Data.Bitmap ( + -- * Basic types and functions + Bitmap(..) + ,bitmapSize + ,liftBitmapIO + -- * Load and Save + ,readBitmap + ,writeBitmap + + -- * Bitmap operations + ,cropBitmap + -- * V2 + ,sizeBitmap + ,clipBitmap + ) where + +import qualified Codec.Picture as C +import qualified Codec.Picture.RGBA8 as C +import Control.Monad.IO.Class +import Data.BoundingBox +import Linear.V2 +import System.Random +import Control.Applicative +import Data.Hashable + +data Bitmap = Bitmap (C.Image C.PixelRGBA8) Int + +-- | Get the size of the 'Bitmap'. +bitmapSize :: Bitmap -> (Int, Int) +bitmapSize (Bitmap (C.Image w h _) _) = (w, h) + +liftBitmapIO :: MonadIO m => C.Image C.PixelRGBA8 -> m Bitmap +liftBitmapIO b = liftIO $ Bitmap b <$> randomIO + +-- | Load an image file. +readBitmap :: MonadIO m => FilePath -> m Bitmap +readBitmap path = liftIO $ Bitmap <$> C.readImageRGBA8 path <*> randomIO + +-- | Save 'Bitmap' into a file. +writeBitmap :: MonadIO m => FilePath -> Bitmap -> m () +writeBitmap path (Bitmap p _) = liftIO $ C.writePng path p + +-- | Extract a 'Bitmap' from the specified range. +cropBitmap :: Bitmap -- ^original bitmap + -> (Int, Int) -- ^width and height + -> (Int, Int) -- ^x and y + -> Bitmap -- ^result +cropBitmap (Bitmap b k) (w, h) (x, y) = Bitmap + (C.trimImage b (w, h) (x, y)) + (hash (w, h, x, y, k)) + +clipBitmap :: Bitmap -> Box V2 Int -> Bitmap +clipBitmap (Bitmap b k) (Box (V2 x0 y0) (V2 x1 y1)) = Bitmap + (C.trimImage b (x1 - x0, y1 - y0) (x0, y0)) + (hash (x0, y0, x1, y1, k)) + +sizeBitmap :: Bitmap -> V2 Int +sizeBitmap (Bitmap (C.Image w h _) _) = V2 w h diff --git a/src/Call/Data/Font.hs b/src/Call/Data/Font.hs new file mode 100644 --- /dev/null +++ b/src/Call/Data/Font.hs @@ -0,0 +1,139 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Call.Data.Font +-- Copyright : (c) Fumiaki Kinoshita 2014 +-- License : BSD3 +-- +-- Maintainer : Fumiaki Kinoshita +-- Stability : experimental +-- Portability : non-portable +-- +-- Font rendering +-- +----------------------------------------------------------------------------- +module Call.Data.Font + ( Font + , readFont + , fontBoundingBox + , metricsAscent + , metricsDescent + , charToBitmap + , RenderedChar(..) + ) where + +import Control.Applicative +import Control.Monad.IO.Class +import Control.Monad +import Data.IORef +import Data.BoundingBox +import qualified Data.Map as M +import qualified Data.Vector.Storable as V +import Linear +import Call.Data.Bitmap +import Graphics.Rendering.FreeType.Internal +import qualified Graphics.Rendering.FreeType.Internal.GlyphSlot as GS +import qualified Graphics.Rendering.FreeType.Internal.Vector as V +import Graphics.Rendering.FreeType.Internal.Bitmap as B +import Graphics.Rendering.FreeType.Internal.PrimitiveTypes as PT +import Graphics.Rendering.FreeType.Internal.Face as F +import Graphics.Rendering.FreeType.Internal.Library as L +import Graphics.Rendering.FreeType.Internal.BBox as BB +import Foreign.Marshal.Alloc +import Foreign.C.Types +import Foreign.C.String +import Foreign.Storable +import Foreign.ForeignPtr +import Foreign.Ptr +import System.IO.Unsafe +import Codec.Picture +import Codec.Picture.RGBA8 + +-- | Font object +data Font = Font FT_Face (Double, Double) (Box V2 Double) (IORef (M.Map (Double, Char) RenderedChar)) + +-- | Create a 'Font' from the given file. +readFont :: MonadIO m => FilePath -> m Font +readFont path = liftIO $ alloca $ \p -> do + runFreeType $ withCString path $ \str -> ft_New_Face freeType str 0 p + f <- peek p + b <- peek (bbox f) + asc <- peek (ascender f) + desc <- peek (descender f) + u <- fromIntegral <$> peek (units_per_EM f) + let box = fmap (/u) $ Box + (V2 (fromIntegral (xMin b)) (fromIntegral (yMin b))) + (V2 (fromIntegral (xMax b)) (fromIntegral (yMax b))) + Font f (fromIntegral asc/u, fromIntegral desc/u) box <$> newIORef M.empty + + +-- | Get the font's metrics. +metricsAscent :: Font -> Double +metricsAscent (Font _ (a, _) _ _) = a + +-- | Get the font's metrics. +metricsDescent :: Font -> Double +metricsDescent (Font _ (_, d) _ _) = d + +-- | Get the font's boundingbox. +fontBoundingBox :: Font -> Box V2 Double +fontBoundingBox (Font _ _ b _) = b + +runFreeType :: IO CInt -> IO () +runFreeType m = do + r <- m + unless (r == 0) $ fail $ "FreeType Error:" Prelude.++ show r + +freeType :: FT_Library +freeType = unsafePerformIO $ alloca $ \p -> do + runFreeType $ ft_Init_FreeType p + peek p + +data RenderedChar = RenderedChar + { charBitmap :: Bitmap + , charOffset :: V2 Double + ,　charAdvance :: Double + } + +-- | The resolution used to render fonts. +resolutionDPI :: Int +resolutionDPI = 300 + +charToBitmap :: MonadIO m => Font -> Double -> Char -> m RenderedChar +charToBitmap (Font face _ _ refCache) pixel ch = liftIO $ do + let siz = pixel * 72 / fromIntegral resolutionDPI + cache <- liftIO $ readIORef refCache + case M.lookup (siz, ch) cache of + Just d -> return d + Nothing -> do + d <- liftIO $ render face siz ch + liftIO $ writeIORef refCache $ M.insert (siz, ch) d cache + return d + +render :: FT_Face -> Double -> Char -> IO RenderedChar +render face siz ch = do + let dpi = fromIntegral resolutionDPI + + runFreeType $ ft_Set_Char_Size face 0 (floor $ siz * 64) dpi dpi + + ix <- ft_Get_Char_Index face (fromIntegral $ fromEnum ch) + runFreeType $ ft_Load_Glyph face ix ft_LOAD_DEFAULT + + slot <- peek $ glyph face + runFreeType $ ft_Render_Glyph slot ft_RENDER_MODE_NORMAL + + bmp <- peek $ GS.bitmap slot + left <- fmap fromIntegral $ peek $ GS.bitmap_left slot + top <- fmap fromIntegral $ peek $ GS.bitmap_top slot + + let h = fromIntegral $ B.rows bmp + w = fromIntegral $ B.width bmp + + fptr <- newForeignPtr_ $ castPtr $ buffer bmp + + adv <- peek $ GS.advance slot + b <- liftBitmapIO $ fromColorAndOpacity (PixelRGB8 255 255 255) + $ Image w h $ V.unsafeFromForeignPtr0 fptr $ h * w + return $ RenderedChar + b + (V2 (left + fromIntegral w / 2) (-top + fromIntegral h / 2)) + (fromIntegral (V.x adv) / 64) diff --git a/src/Call/Data/Wave.hs b/src/Call/Data/Wave.hs new file mode 100644 --- /dev/null +++ b/src/Call/Data/Wave.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Call.Data.Wave +-- Copyright : (c) Fumiaki Kinoshita 2014 +-- License : BSD3 +-- +-- Maintainer : Fumiaki Kinoshita +-- Stability : experimental +-- Portability : non-portable +-- +----------------------------------------------------------------------------- +module Call.Data.Wave ( + Source(..), + Stereo, + readWAVE +) where + +import Data.WAVE +import Linear +import Call.Types +import Control.Monad.IO.Class +import qualified Data.Vector.Unboxed as V + +newtype Source a = Source (Time -> a) + +type Stereo = V2 Float + +readWAVE :: MonadIO m => FilePath -> m (Source Stereo) +readWAVE path = liftIO $ do + WAVE h ss <- getWAVEFile path + + return $ Source $ sample h $ V.fromList (map fr ss) + where + fr [!a, !b] = (realToFrac $ sampleToDouble a, realToFrac $ sampleToDouble b) + fr _ = (0, 0) + sample h v t = maybe zero (uncurry V2) $ v V.!? floor (t * fromIntegral (waveFrameRate h)) + +-- TODO: Lazy processing diff --git a/src/Call/Internal/GLFW.hs b/src/Call/Internal/GLFW.hs new file mode 100644 --- /dev/null +++ b/src/Call/Internal/GLFW.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Call.Internal.GLFW +-- Copyright : (c) Fumiaki Kinoshita 2014 +-- License : BSD3 +-- +-- Maintainer : Fumiaki Kinoshita +-- Stability : experimental +-- Portability : non-portable +-- +----------------------------------------------------------------------------- +module Call.Internal.GLFW where +import Control.Bool +import Control.Applicative +import Control.Monad.IO.Class +import Control.Lens +import Data.Color +import Data.IORef +import Call.Types +import Data.BoundingBox +import Graphics.Rendering.OpenGL.GL.StateVar +import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility +import Linear +import qualified Graphics.Rendering.OpenGL.GL as GL +import qualified Graphics.UI.GLFW as GLFW +import Unsafe.Coerce +import qualified Data.Vector.Storable as V +import qualified Data.Vector.Storable.Mutable as MV +import Codec.Picture +import Codec.Picture.RGBA8 +import qualified GHC.IO.Encoding as Encoding + +data System = System + { refRegion :: IORef BoundingBox2 + , theWindow :: GLFW.Window + } + +type Texture = (GL.TextureObject, Double, Double) + +runVertices :: MonadIO m => [V2 Double] -> m () +runVertices = liftIO . mapM_ (GL.vertex . mkVertex2) +{-# INLINE runVertices #-} + +preservingMatrix' :: MonadIO m => m a -> m a +preservingMatrix' m = do + liftIO glPushMatrix + r <- m + liftIO glPopMatrix + return r +{-# INLINE preservingMatrix' #-} + +drawTexture :: Texture -> IO () +drawTexture (tex, !w, !h) = drawTextureAt tex (V2 (-w) (-h)) (V2 w (-h)) (V2 w h) (V2 (-w) h) +{-# INLINE drawTexture #-} + +drawTextureAt :: GL.TextureObject -> V2 Double -> V2 Double -> V2 Double -> V2 Double -> IO () +drawTextureAt tex a b c d = do + GL.texture GL.Texture2D $= GL.Enabled + GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest) + GL.textureBinding GL.Texture2D $= Just tex + GL.unsafeRenderPrimitive GL.TriangleStrip $ do + GL.texCoord $ GL.TexCoord2 (0 :: GL.GLdouble) 0 + GL.vertex $ mkVertex2 a + GL.texCoord $ GL.TexCoord2 (1 :: GL.GLdouble) 0 + GL.vertex $ mkVertex2 b + GL.texCoord $ GL.TexCoord2 (0 :: GL.GLdouble) 1 + GL.vertex $ mkVertex2 d + GL.texCoord $ GL.TexCoord2 (1 :: GL.GLdouble) 1 + GL.vertex $ mkVertex2 c + GL.texture GL.Texture2D $= GL.Disabled + +mkVertex2 :: V2 Double -> GL.Vertex2 GL.GLdouble +{-# INLINE mkVertex2 #-} +mkVertex2 = unsafeCoerce + +gf :: Float -> GL.GLfloat +{-# INLINE gf #-} +gf = unsafeCoerce + +gd :: Double -> GL.GLdouble +{-# INLINE gd #-} +gd = unsafeCoerce + +gsizei :: Int -> GL.GLsizei +{-# INLINE gsizei #-} +gsizei = unsafeCoerce + +translate :: V2 Double -> IO a -> IO a +translate (V2 tx ty) m = preservingMatrix' $ GL.translate (GL.Vector3 (gd tx) (gd ty) 0) >> m + +rotateD :: Double -> IO a -> IO a +rotateD theta m = preservingMatrix' $ GL.rotate (gd (-theta)) (GL.Vector3 0 0 1) >> m + +scale :: V2 Double -> IO a -> IO a +scale (V2 sx sy) m = preservingMatrix' $ GL.scale (gd sx) (gd sy) 1 >> m + +circle :: Double -> IO () +circle r = do + let s = 2 * pi / 64 + GL.renderPrimitive GL.Polygon $ runVertices [V2 (cos t * r) (sin t * r) | t <- [0,s..2 * pi]] + +circleOutline :: Double -> IO () +circleOutline r = do + let s = 2 * pi / 64 + GL.renderPrimitive GL.LineLoop $ runVertices [V2 (cos t * r) (sin t * r) | t <- [0,s..2 * pi]] + +color :: Color -> IO a -> IO a +color col m = do + oldColor <- liftIO $ get GL.currentColor + liftIO $ GL.currentColor $= unsafeCoerce col + res <- m + liftIO $ GL.currentColor $= oldColor + return res + +polygon :: [V2 Double] -> IO () +polygon path = GL.renderPrimitive GL.Polygon $ runVertices path + +polygonOutline :: [V2 Double] -> IO () +polygonOutline path = GL.renderPrimitive GL.LineLoop $ runVertices path + +line :: [V2 Double] -> IO () +line path = GL.renderPrimitive GL.LineStrip $ runVertices path + +thickness :: Float -> IO a -> IO a +thickness t m = do + oldWidth <- liftIO $ get GL.lineWidth + liftIO $ GL.lineWidth $= gf t + res <- m + liftIO $ GL.lineWidth $= oldWidth + return res + +installTexture :: Image PixelRGBA8 -> IO Texture +installTexture (Image w h v) = do + [tex] <- GL.genObjectNames 1 + GL.textureBinding GL.Texture2D GL.$= Just tex + let siz = GL.TextureSize2D (gsizei w) (gsizei h) + V.unsafeWith v + $ GL.texImage2D GL.Texture2D GL.NoProxy 0 GL.RGBA8 siz 0 + . GL.PixelData GL.ABGR GL.UnsignedInt8888 + return (tex, fromIntegral w / 2, fromIntegral h / 2) + +releaseTexture :: Texture -> IO () +releaseTexture (tex, _, _) = GL.deleteObjectNames [tex] + +beginFrame :: System -> IO () +beginFrame sys = do + Box (V2 wl wt) (V2 wr wb) <- fmap realToFrac <$> readIORef (refRegion sys) + GL.viewport $= (GL.Position 0 0, GL.Size (floor $ wr - wl) (floor $ wb - wt)) + GL.matrixMode $= GL.Projection + GL.loadIdentity + GL.ortho wl wr wb wt 0 (-100) + GL.matrixMode $= GL.Modelview 0 + GL.clear [GL.ColorBuffer] + +endFrame :: System -> IO Bool +endFrame sys = do + GLFW.swapBuffers $ theWindow sys + GLFW.pollEvents + GLFW.windowShouldClose (theWindow sys) + +beginGLFW :: WindowMode -> BoundingBox2 -> IO System +beginGLFW mode bbox@(Box (V2 x0 y0) (V2 x1 y1)) = do + Encoding.setForeignEncoding Encoding.utf8 + let title = "call" + ww = floor $ x1 - x0 + wh = floor $ y1 - y0 + () <- unlessM GLFW.init (fail "Failed to initialize") + + mon <- case mode of + FullScreen -> GLFW.getPrimaryMonitor + _ -> return Nothing + + GLFW.windowHint $ GLFW.WindowHint'Resizable $ mode == Resizable + win <- GLFW.createWindow ww wh title mon Nothing >>= maybe (fail "Failed to create a window") return + GLFW.makeContextCurrent (Just win) + GL.lineSmooth $= GL.Enabled + GL.blend $= GL.Enabled + GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha) + -- GL.shadeModel $= GL.Flat + GL.textureFunction $= GL.Combine + + GLFW.swapInterval 1 + GL.clearColor $= GL.Color4 1 1 1 1 + + rbox <- newIORef bbox + + GLFW.setFramebufferSizeCallback win $ Just $ \_ w h -> do + modifyIORef rbox $ size zero .~ fmap fromIntegral (V2 w h) + + return $ System rbox win + +endGLFW :: System -> IO () +endGLFW sys = do + GLFW.destroyWindow (theWindow sys) + GLFW.terminate + +screenshotFlipped :: System -> IO (Image PixelRGBA8) +screenshotFlipped sys = do + V2 w h <- fmap floor <$> view (size zero) <$> readIORef (refRegion sys) + mv <- MV.unsafeNew (w * h * 4) + GL.readBuffer $= GL.FrontBuffers + MV.unsafeWith mv + $ \ptr -> GL.readPixels (GL.Position 0 0) (GL.Size (gsizei w) (gsizei h)) + (GL.PixelData GL.RGBA GL.UnsignedByte ptr) + + Image w h <$> V.unsafeFreeze mv + +screenshot :: System -> IO (Image PixelRGBA8) +screenshot sys = flipVertically <$> screenshotFlipped sys + +blendMode2BlendingFactors :: BlendMode -> (GL.BlendingFactor, GL.BlendingFactor) +blendMode2BlendingFactors Normal = (GL.SrcAlpha, GL.OneMinusSrcAlpha) +blendMode2BlendingFactors Inverse = (GL.OneMinusDstColor, GL.Zero) +blendMode2BlendingFactors Add = (GL.SrcAlpha, GL.One) +blendMode2BlendingFactors Multiply = (GL.Zero, GL.SrcColor) +blendMode2BlendingFactors Screen = (GL.One, GL.OneMinusSrcColor) + +blendMode :: BlendMode -> IO a -> IO a +blendMode mode m = do + oldFunc <- get GL.blendFunc + GL.blendFunc $= blendMode2BlendingFactors mode + a <- m + GL.blendFunc $= oldFunc + return a diff --git a/src/Call/Picture.hs b/src/Call/Picture.hs new file mode 100644 --- /dev/null +++ b/src/Call/Picture.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE BangPatterns, DeriveFunctor, Rank2Types #-} +----------------------------------------------------------------------------- +-- | +-- Module : Call.Picture +-- Copyright : (c) Fumiaki Kinoshita 2014 +-- License : BSD3 +-- +-- Maintainer : Fumiaki Kinoshita +-- Stability : experimental +-- Portability : non-portable +-- +----------------------------------------------------------------------------- +module Call.Picture where +import Call.Types +import Call.Data.Bitmap +import Data.Color +import Control.Applicative + +infixr 5 `translate` +infixr 5 `rotateR` +infixr 5 `rotateD` +infixr 5 `scale` +infixr 5 `color` +infixr 5 `thickness` +infixr 5 `blendMode` + +class Functor p => Affine p where + -- | (radians) + rotateR :: Double -> p a -> p a + -- | (degrees) + rotateD :: Double -> p a -> p a + scale :: Vec2 -> p a -> p a + translate :: Vec2 -> p a -> p a + + rotateR = rotateD . (* 180) . (/ pi) + rotateD = rotateR . (/ 180) . (* pi) + +-- | The class of types that can be regarded as a kind of picture. +class Affine p => Picture2D p where + -- | Construct a 'Picture2D' from a 'Bitmap'. + bitmap :: Bitmap -> p () + -- | Same as 'bitmap', but it does not create a cache. + bitmapOnce :: Bitmap -> p () + line :: [Vec2] -> p () + polygon :: [Vec2] -> p () + polygonOutline :: [Vec2] -> p () + circle :: Double -> p () + circleOutline :: Double -> p () + thickness :: Float -> p a -> p a + color :: Color -> p a -> p a + blendMode :: BlendMode -> p a -> p a + +newtype Picture a = Picture { runPicture :: forall m. (Applicative m, Monad m, Picture2D m) => m a } + +instance Functor Picture where + fmap f (Picture m) = Picture (fmap f m) + +instance Applicative Picture where + pure a = Picture (pure a) + Picture a <*> Picture b = Picture (a <*> b) + +instance Monad Picture where + return a = Picture (return a) + Picture m >>= k = Picture (m >>= runPicture . k) + +instance Affine Picture where + rotateR t (Picture m) = Picture (rotateR t m) + rotateD t (Picture m) = Picture (rotateD t m) + scale v (Picture m) = Picture (scale v m) + translate v (Picture m) = Picture (translate v m) + +instance Picture2D Picture where + bitmap b = Picture (bitmap b) + bitmapOnce b = Picture (bitmapOnce b) + line vs = Picture (line vs) + polygon vs = Picture (polygon vs) + polygonOutline vs = Picture (polygonOutline vs) + circle r = Picture (circle r) + circleOutline r = Picture (circleOutline r) + thickness t (Picture m) = Picture (thickness t m) + color c (Picture m) = Picture (color c m) + blendMode b (Picture m) = Picture (blendMode b m) diff --git a/src/Call/System.hs b/src/Call/System.hs new file mode 100644 --- /dev/null +++ b/src/Call/System.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Call.System +-- Copyright : (c) Fumiaki Kinoshita 2014 +-- License : BSD3 +-- +-- Maintainer : Fumiaki Kinoshita +-- Stability : experimental +-- Portability : non-portable +-- +----------------------------------------------------------------------------- +module Call.System (System, runSystem, MonadSystem(..), forkSystem) where + +import Call.Component +import Call.Data.Bitmap +import Call.Picture +import Call.Types +import Control.Applicative +import Control.Concurrent +import Control.Exception +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Object +import Control.Monad.Objective +import Data.IORef +import Data.Reflection +import Linear +import qualified Call.Internal.GLFW as G +import qualified Data.IntMap.Strict as IM +import qualified Graphics.UI.GLFW as GLFW +import qualified Call.Internal.PortAudio as PA +import Unsafe.Coerce + +class (MonadIO m, MonadObjective m) => MonadSystem m where + linkMouse :: Mouse e => Address e m -> m () + linkKeyboard :: Keyboard e => Address e m -> m () + linkGraphic :: Graphic e => Address e m -> m () + linkAudio :: Audio e => Address e m -> m () + unlinkMouse :: Address e m -> m () + unlinkKeyboard :: Address e m -> m () + unlinkGraphic :: Address e m -> m () + unlinkAudio :: Address e m -> m () + stand :: m () + wait :: Double -> m () + +newtype System s a = System (ReaderT (Foundation s) IO a) deriving (Functor, Applicative, Monad) + +unSystem :: Foundation s -> System s a -> IO a +unSystem f m = unsafeCoerce m f + +mkSystem :: (Foundation s -> IO a) -> System s a +mkSystem = unsafeCoerce + +forkSystem :: System s () -> System s ThreadId +forkSystem m = mkSystem $ \fo -> forkIO (unSystem fo m) + +runSystem :: WindowMode -> BoundingBox2 -> (forall s. System s a) -> IO (Maybe a) +runSystem mode box m = do + sys <- G.beginGLFW mode box + f <- Foundation + <$> newMVar 0 + <*> pure 44100 -- FIX THIS + <*> newIORef IM.empty + <*> newIORef IM.empty + <*> newIORef IM.empty + <*> newIORef IM.empty + <*> newMVar 0 + <*> pure sys + <*> newIORef 60 + <*> newIORef IM.empty + <*> newEmptyMVar + let win = G.theWindow sys + GLFW.setKeyCallback win $ Just $ keyCallback f + GLFW.setMouseButtonCallback win $ Just $ mouseButtonCallback f + GLFW.setCursorPosCallback win $ Just $ cursorPosCallback f + GLFW.setScrollCallback win $ Just $ scrollCallback f + ref <- newEmptyMVar + _ <- flip forkFinally (either throwIO (putMVar ref)) $ unSystem f m + PA.with 44100 512 (audioProcess f) $ liftIO $ do + GLFW.setTime 0 + runGraphic f 0 + G.endGLFW sys + tryTakeMVar ref + +data Member c s = forall e. c e => Member (MVar (Object e (System s))) + +data Foundation s = Foundation + { newObjectId :: MVar Int + , sampleRate :: Double + , coreGraphic :: IORef (IM.IntMap (Member Graphic s)) + , coreAudio :: IORef (IM.IntMap (Member Audio s)) + , coreKeyboard :: IORef (IM.IntMap (Member Keyboard s)) + , coreMouse :: IORef (IM.IntMap (Member Mouse s)) + , theTime :: MVar Double + , theSystem :: G.System + , targetFPS :: IORef Double + , textures :: IORef (IM.IntMap G.Texture) + , theEnd :: MVar () + } + +instance MonadIO (System s) where + liftIO m = mkSystem $ const m + {-# INLINE liftIO #-} + +instance MonadObjective (System s) where + type Residence (System s) = System s + data Address e (System s) = Control　Int (MVar (Object e (System s))) + Control _ m .- e = mkSystem $ \fo -> push fo m e + new c = mkSystem $ \fo -> do + n <- takeMVar $ newObjectId fo + mc <- newMVar c + putMVar (newObjectId fo) (n + 1) + return (Control n mc) + +instance MonadSystem (System s) where + linkGraphic (Control i mc) = mkSystem $ \fo -> modifyIORef (coreGraphic fo) $ IM.insert i (Member mc) + linkAudio (Control i mc) = mkSystem $ \fo -> modifyIORef (coreAudio fo) $ IM.insert i (Member mc) + linkKeyboard (Control i mc) = mkSystem $ \fo -> modifyIORef (coreKeyboard fo) $ IM.insert i (Member mc) + linkMouse (Control i mc) = mkSystem $ \fo -> modifyIORef (coreMouse fo) $ IM.insert i (Member mc) + unlinkGraphic (Control i _) = mkSystem $ \fo -> modifyIORef (coreGraphic fo) $ IM.delete i + unlinkAudio (Control i _) = mkSystem $ \fo -> modifyIORef (coreAudio fo) $ IM.delete i + unlinkMouse (Control i _) = mkSystem $ \fo -> modifyIORef (coreMouse fo) $ IM.delete i + unlinkKeyboard (Control i _) = mkSystem $ \fo -> modifyIORef (coreKeyboard fo) $ IM.delete i + + wait dt = mkSystem $ \fo -> do + t0 <- takeMVar (theTime fo) + Just t <- GLFW.getTime + threadDelay $ floor $ (t0 - t + dt) * 1000 * 1000 + putMVar (theTime fo) $ t0 + dt + stand = mkSystem $ \fo -> takeMVar (theEnd fo) + +runGraphic :: Foundation s -> Double -> IO () +runGraphic fo t0 = do + fps <- readIORef (targetFPS fo) + let t1 = t0 + 1/fps + G.beginFrame (theSystem fo) + ms <- readIORef (coreGraphic fo) + pics <- forM (IM.elems ms) $ \(Member m) -> push fo m $ pullGraphic (1/fps) -- is it appropriate? + give (TextureStorage (textures fo)) $ mapM_ runPicture pics + b <- G.endFrame (theSystem fo) + + Just t' <- GLFW.getTime + threadDelay $ floor $ (t1 - t') * 1000 * 1000 + + tryTakeMVar (theEnd fo) >>= \case + Just _ -> return () + _ | b -> putMVar (theEnd fo) () + | otherwise -> runGraphic fo t1 + +audioProcess :: Foundation s -> Int -> IO [V2 Float] +audioProcess fo n = do + let dt = fromIntegral n / sampleRate fo + ms <- readIORef (coreAudio fo) + ws <- forM (IM.elems ms) $ \(Member m) -> push fo m $ pullAudio dt n + return $ foldr (zipWith (+)) (replicate n zero) ws + +push :: Foundation s -> MVar (Object e (System s)) -> e a -> IO a +push fo mc e = do + c0 <- takeMVar mc + (a, c) <- unSystem fo $ runObject c0 e + putMVar mc c + return a + +keyCallback :: Foundation s -> GLFW.KeyCallback +keyCallback fo _ k _ st _ = do + ms <- readIORef (coreKeyboard fo) + forM_ (IM.elems ms) $ \(Member m) -> push fo m + $ keyEvent (toEnum . fromEnum $ k :: Key) (GLFW.KeyState'Released /= st) + +mouseButtonCallback :: Foundation s -> GLFW.MouseButtonCallback +mouseButtonCallback fo _ btn st _ = do + ms <- readIORef (coreMouse fo) + forM_ (IM.elems ms) $ \(Member m) -> push fo m + $ mouseButtonEvent (fromEnum btn) (GLFW.MouseButtonState'Released /= st) + +cursorPosCallback :: Foundation s -> GLFW.CursorPosCallback +cursorPosCallback fo _ x y = do + ms <- readIORef (coreMouse fo) + forM_ (IM.elems ms) $ \(Member m) -> push fo m $ cursorEvent (V2 x y) + +scrollCallback :: Foundation s -> GLFW.ScrollCallback +scrollCallback fo _ x y = do + ms <- readIORef (coreMouse fo) + forM_ (IM.elems ms) $ \(Member m) -> push fo m $ scrollEvent (V2 x y) + +newtype TextureStorage = TextureStorage { getTextureStorage :: IORef (IM.IntMap G.Texture) } + +instance Affine IO where + translate = G.translate + rotateD = G.rotateD + rotateR t = let t' = t / pi * 180 in G.rotateD t' + scale = G.scale + +instance (Given TextureStorage) => Picture2D IO where + bitmap (Bitmap bmp h) = do + m <- readIORef (getTextureStorage given) + case IM.lookup h m of + Just t -> G.drawTexture t + Nothing -> do + t <- G.installTexture bmp + writeIORef (getTextureStorage given) $ IM.insert h t m + G.drawTexture t + bitmapOnce (Bitmap bmp _) = do + t <- G.installTexture bmp + G.drawTexture t + G.releaseTexture t + + circle = G.circle + circleOutline = G.circleOutline + polygon = G.polygon + polygonOutline = G.polygonOutline + line = G.line + thickness = G.thickness + color = G.color + blendMode = G.blendMode diff --git a/src/Call/TH.hs b/src/Call/TH.hs new file mode 100644 --- /dev/null +++ b/src/Call/TH.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TemplateHaskell, CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Call.TH +-- Copyright : (c) Fumiaki Kinoshita 2014 +-- License : BSD3 +-- +-- Maintainer : Fumiaki Kinoshita +-- Stability : experimental +-- Portability : non-portable +-- +-- Utilities that use Template Haskell +-- +----------------------------------------------------------------------------- +module Call.TH ( + loadBitmapsWith + ) where + +import Control.Applicative +import Control.Monad +import Data.Char +import Call.Data.Bitmap +import Language.Haskell.TH +import System.Directory +import System.FilePath +import System.IO.Unsafe + +-- | The type of the given 'ExpQ' must be @FilePath -> IO FilePath@ +-- FIXME: This may cause name duplication if there are multiple non-alphanumeric file names. +loadBitmapsWith :: ExpQ -> FilePath -> Q [Dec] +loadBitmapsWith getFullPath path = do + loc <- (path) <$> takeDirectory <$> loc_filename <$> location + paths <- runIO $ getFileList loc + + sequence $ do + p <- paths + let name = pathToName p + [ return $ SigD (mkName name) (ConT ''Bitmap) + , funD (mkName name) [clause [] (normalB $ load name $ loc p) []] + ] + where + load name fp = do + runIO $ putStrLn $ "Defined: " ++ fp ++ " as `" ++ name ++ "'" + + appE (varE 'unsafePerformIO) $ uInfixE (appE getFullPath $ litE $ StringL fp) + (varE '(>>=)) + (varE 'readBitmap) + +-- | Load and define all pictures in the specified directory. +-- On base >= 4.6, file paths to actually load will be respect to the directory of the executable. Otherwise it will be based on the current directory. + + +getFileList :: FilePath -> IO [FilePath] +getFileList path = do + allContents <- filter notHidden `fmap` getDirectoryContents path + + files <- filterM (doesFileExist . (path)) allContents + dirs <- filterM (doesDirectoryExist . (path)) allContents + fmap ((files++).concat) $ forM dirs $ \i -> map (i) `fmap` getFileList (pathi) + where + notHidden ('.':_) = False + notHidden _ = True + +pathToName :: FilePath -> String +pathToName = ('_':) . map p where + p c | isAlphaNum c = c + | otherwise = '_' diff --git a/src/Call/Types.hs b/src/Call/Types.hs new file mode 100644 --- /dev/null +++ b/src/Call/Types.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Call.Types +-- Copyright : (c) Fumiaki Kinoshita 2014 +-- License : BSD3 +-- +-- Maintainer : Fumiaki Kinoshita +-- Stability : experimental +-- Portability : non-portable +-- +----------------------------------------------------------------------------- +module Call.Types ( + Time + , Vec2 + , WindowMode(..) + , BoundingBox2 + , Key(..) + , charToKey + , BlendMode(..) + ) where + +import Linear +import Data.Typeable +import Data.BoundingBox +import Data.Char + +type Time = Double + +data WindowMode = Windowed | Resizable | FullScreen deriving (Show, Eq, Ord, Read) + +type Vec2 = V2 Double + +type BoundingBox2 = Box V2 Double + +data Key = + KeyUnknown + | KeySpace + | KeyApostrophe + | KeyComma + | KeyMinus + | KeyPeriod + | KeySlash + | Key0 + | Key1 + | Key2 + | Key3 + | Key4 + | Key5 + | Key6 + | Key7 + | Key8 + | Key9 + | KeySemicolon + | KeyEqual + | KeyA + | KeyB + | KeyC + | KeyD + | KeyE + | KeyF + | KeyG + | KeyH + | KeyI + | KeyJ + | KeyK + | KeyL + | KeyM + | KeyN + | KeyO + | KeyP + | KeyQ + | KeyR + | KeyS + | KeyT + | KeyU + | KeyV + | KeyW + | KeyX + | KeyY + | KeyZ + | KeyLeftBracket + | KeyBackslash + | KeyRightBracket + | KeyGraveAccent + | KeyWorld1 + | KeyWorld2 + | KeyEscape + | KeyEnter + | KeyTab + | KeyBackspace + | KeyInsert + | KeyDelete + | KeyRight + | KeyLeft + | KeyDown + | KeyUp + | KeyPageUp + | KeyPageDown + | KeyHome + | KeyEnd + | KeyCapsLock + | KeyScrollLock + | KeyNumLock + | KeyPrintScreen + | KeyPause + | KeyF1 + | KeyF2 + | KeyF3 + | KeyF4 + | KeyF5 + | KeyF6 + | KeyF7 + | KeyF8 + | KeyF9 + | KeyF10 + | KeyF11 + | KeyF12 + | KeyF13 + | KeyF14 + | KeyF15 + | KeyF16 + | KeyF17 + | KeyF18 + | KeyF19 + | KeyF20 + | KeyF21 + | KeyF22 + | KeyF23 + | KeyF24 + | KeyF25 + | KeyPad0 + | KeyPad1 + | KeyPad2 + | KeyPad3 + | KeyPad4 + | KeyPad5 + | KeyPad6 + | KeyPad7 + | KeyPad8 + | KeyPad9 + | KeyPadDecimal + | KeyPadDivide + | KeyPadMultiply + | KeyPadSubtract + | KeyPadAdd + | KeyPadEnter + | KeyPadEqual + | KeyLeftShift + | KeyLeftControl + | KeyLeftAlt + | KeyLeftSuper + | KeyRightShift + | KeyRightControl + | KeyRightAlt + | KeyRightSuper + | KeyMenu + deriving (Enum, Eq, Ord, Read, Show, Typeable, Bounded) + +charToKey :: Char -> Key +charToKey ch + | isAlpha ch = toEnum $ fromEnum KeyA + fromEnum ch - fromEnum 'A' + | isDigit ch = toEnum $ fromEnum Key0 + fromEnum ch - fromEnum '0' +charToKey '-' = KeyMinus +charToKey ',' = KeyComma +charToKey '.' = KeyPeriod +charToKey '/' = KeySlash +charToKey ' ' = KeySpace +charToKey '\'' = KeyApostrophe +charToKey '\\' = KeyBackslash +charToKey '=' = KeyEqual +charToKey ';' = KeySemicolon +charToKey '[' = KeyLeftBracket +charToKey ']' = KeyRightBracket +charToKey '`' = KeyGraveAccent +charToKey '\n' = KeyEnter +charToKey '\r' = KeyEnter +charToKey '\t' = KeyTab +charToKey _ = KeyUnknown + +data BlendMode = Normal + | Inverse + | Add + | Multiply + | Screen + deriving (Enum, Eq, Ord, Read, Show, Typeable) diff --git a/src/Call/Util.hs b/src/Call/Util.hs new file mode 100644 --- /dev/null +++ b/src/Call/Util.hs @@ -0,0 +1,28 @@ +module Call.Util where +import Control.Monad.Objective.Class +import Control.Object +import Call.Component +import Call.Component.Deck +import Call.System +import Call.Types +import Call.Data.Wave +import Call.Picture +import Control.Lens + +animate :: (Time -> System s (Picture ())) -> System s (Address PullGraphic (System s)) +animate f = do + p <- new (go 0) + linkGraphic p + return p + where + go t = Object $ \(PullGraphic dt cont) -> f t >>= \p -> return (cont p, go (t + dt)) + +withSound :: Source Stereo -> System s a -> System s a +withSound src m = do + deck <- new emptyDeck + deck .& source ?= src + deck .& playing .= True + linkAudio deck + r <- m + unlinkAudio deck + return r