call (empty) → 0.0

raw patch · 15 files changed

+1361/−0 lines, 15 filesdep +GLFW-bdep +JuicyPixelsdep +JuicyPixels-utilsetup-changed

Dependencies added: GLFW-b, JuicyPixels, JuicyPixels-util, OpenGL, OpenGLRaw, WAVE, base, bindings-portaudio, boundingboxes, colors, containers, control-bool, directory, filepath, freetype2, hashable, lens, linear, mtl, objective, random, reflection, template-haskell, transformers, vector

Files

LICENSE +30/−0
Setup.hs +2/−0
call.cabal +59/−0
src/Call.hs +66/−0
src/Call/Component.hs +70/−0
src/Call/Component/Deck.hs +65/−0
src/Call/Data/Bitmap.hs +69/−0
src/Call/Data/Font.hs +139/−0
src/Call/Data/Wave.hs +39/−0
src/Call/Internal/GLFW.hs +225/−0
src/Call/Picture.hs +82/−0
src/Call/System.hs +234/−0
src/Call/TH.hs +67/−0
src/Call/Types.hs +186/−0
src/Call/Util.hs +28/−0

+ LICENSE view

@@ -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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ call.cabal view

@@ -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 <fumiexcel@gmail.com>
+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

+ src/Call.hs view

@@ -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))

+ src/Call/Component.hs view

@@ -0,0 +1,70 @@+{-# LANGUAGE DeriveFunctor #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Component
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- 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)

+ src/Call/Component/Deck.hs view

@@ -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 <fumiexcel@gmail.com>
+-- 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

+ src/Call/Data/Bitmap.hs view

@@ -0,0 +1,69 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Data.Bitmap
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- 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

+ src/Call/Data/Font.hs view

@@ -0,0 +1,139 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Data.Font
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- 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)

+ src/Call/Data/Wave.hs view

@@ -0,0 +1,39 @@+{-# LANGUAGE BangPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Data.Wave
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- 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

+ src/Call/Internal/GLFW.hs view

@@ -0,0 +1,225 @@+{-# LANGUAGE BangPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Internal.GLFW
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- 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

+ src/Call/Picture.hs view

@@ -0,0 +1,82 @@+{-# LANGUAGE BangPatterns, DeriveFunctor, Rank2Types #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Picture
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- 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)

+ src/Call/System.hs view

@@ -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 <fumiexcel@gmail.com>
+-- 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

+ src/Call/TH.hs view

@@ -0,0 +1,67 @@+{-# LANGUAGE TemplateHaskell, CPP #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.TH
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- 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 (path</>i)
+    where
+        notHidden ('.':_) = False
+        notHidden _ = True
+
+pathToName :: FilePath -> String
+pathToName = ('_':) . map p where
+    p c | isAlphaNum c = c
+        | otherwise = '_'

+ src/Call/Types.hs view

@@ -0,0 +1,186 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveDataTypeable #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Types
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- 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)

+ src/Call/Util.hs view

@@ -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