call 0.0.1 → 0.1

raw patch · 21 files changed

+1147/−751 lines, 21 filesdep +calldep +clean-unionsdep +distributivedep ~JuicyPixels-utildep ~basedep ~boundingboxesnew-component:exe:hello-world

Dependencies added: call, clean-unions, distributive, elevator, text

Dependency ranges changed: JuicyPixels-util, base, boundingboxes, colors, control-bool, lens, linear, objective, reflection

Files

• call.cabal +48/−23
• data/VL-PGothic-Regular.ttf too large to diff
• examples/hello-world.hs +36/−0
• shaders/fragment.glsl +25/−0
• shaders/vertex.glsl +26/−0
• src/Call.hs +13/−43
• src/Call/Component.hs +0/−70
• src/Call/Component/Deck.hs +0/−65
• src/Call/Data/Bitmap.hs +75/−44
• src/Call/Data/Font.hs +45/−60
• src/Call/Data/Wave.hs +14/−8
• src/Call/Internal/GLFW.hs +133/−145
• src/Call/Internal/PortAudio.hs +31/−27
• src/Call/Picture.hs +0/−85
• src/Call/Sight.hs +183/−0
• src/Call/System.hs +343/−148
• src/Call/TH.hs +3/−3
• src/Call/Types.hs +54/−7
• src/Call/Util.hs +16/−23
• src/Call/Util/Deck.hs +53/−0
• src/Call/Util/Sampler.hs +49/−0

@@ -1,7 +1,7 @@ name:                call
-version:             0.0.1
+version:             0.1
 synopsis:            The call game engine
-description:         Call is a minimalistic game engine which supports 2D graphics and sounds.
+description:         Call is a minimalistic game engine that supports 2D/3D graphics and sounds.
 homepage:            https://github.com/fumieval/call
 license:             BSD3
 license-file:        LICENSE
@@ -10,51 +10,76 @@ copyright:           (c) Fumiaki Kinoshita 2014
 category:            Game
 build-type:          Simple
--- extra-source-files:  
+data-files:
+  shaders/*.glsl
+  data/*.ttf
 cabal-version:       >=1.10
 
+flag BuildHelloWorld
+    default: False
+
+source-repository head
+  type: git
+  location: https://github.com/fumieval/call.git
+
 library
   exposed-modules:
     Call
     Call.Types
     Call.TH
     Call.System
-    Call.Picture
-    Call.Component
-    Call.Component.Deck
+    Call.Sight
     Call.Internal.GLFW
     Call.Internal.PortAudio
     Call.Data.Wave
     Call.Data.Font
     Call.Data.Bitmap
     Call.Util
+    Call.Util.Deck
+    Call.Util.Sampler
+  other-modules:
+    Paths_call
   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.3 && <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.*,
+    bindings-portaudio,
+    boundingboxes >=0.2 && <0.4,
+    clean-unions >= 0.1 && <0.3,
+    colors >=0.2 && <0.3,
+    containers >=0.5 && <0.7,
+    control-bool >=0.2 && <0.4,
     directory,
+    distributive == 0.4.*,
+    elevator,
     filepath,
-    mtl >=2.0 && <2.7,
-    reflection >=1.5 && <1.6,
-    containers >=0.5 && <0.7,
-    vector >=0.9 && <0.13,
+    freetype2 >=0.1 && <0.2,
     GLFW-b >=1.3 && <2,
+    hashable >=1.2 && <1.3,
+    JuicyPixels == 3.*,
+    JuicyPixels-util >= 0.2 && <0.4,
     lens >=4.0 && <5,
+    linear >=1.13 && <2,
+    mtl >=2.0 && <2.7,
+    objective >= 0.5 && <0.7,
     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
+    reflection >=1.4 && <1.7,
+    template-haskell == 2.*,
+    text >= 1.0 && <1.5,
+    transformers >=0.3 && <0.5,
+    vector >=0.9 && <0.13,
+    WAVE >=0.1 && <0.2
   hs-source-dirs:      src
+  default-language:    Haskell2010
+
+executable hello-world
+  ghc-options: -threaded
+  main-is: examples/hello-world.hs
+  if flag(BuildHelloWorld)
+    buildable: True
+  else
+    buildable: False
+  build-depends: base == 4.*, call <= 0.1, lens == 4.*
   default-language:    Haskell2010

file too large to diff

@@ -0,0 +1,36 @@+{-# LANGUAGE Rank2Types, LambdaCase, FlexibleContexts #-}
+-- $ ghc -threaded hello-world.hs
+import Call
+import Call.Util.Deck
+import Control.Lens
+import Control.Monad.State.Strict
+
+-- calculates the root-mean-square value of the playing sound
+currentRMS :: MonadState Deck m => Int -> m (V2 Float)
+currentRMS n = do
+  Source s <- use source
+  t <- use pos
+  let t0 = t - fromIntegral (n-1)/44100
+  return $ fmap realToFrac
+    $ fmap (/fromIntegral n)
+    $ sum $ map (fmap (^(2::Int)) . s) [t0, t0 + 1 / 44100..t]
+
+main = runSystemDefault $ do
+  setTitle "Hello, world!"
+  src <- readWAVE "examples/hello-world.wav"
+  deck <- new $ variable $ Call.Util.Deck.empty & source .~ sampleSource src
+  linkAudio $ ((deck .-) .) . playback
+  linkPicture $ \_ -> do
+    let s x = (10 + max (log (realToFrac x) / log 10) (-10)) / 10
+    V2 a b <- fmap (fmap s) $ deck .- currentRMS 1024
+    return $ translate (V2 0 240) $ mconcat
+      [color black $ polygonOutline [V2 0 0, V2 40 0, V2 40 (-240), V2 0 (-240)]
+      ,color red $ mconcat [polygonOutline [V2 0 0, V2 16 0, V2 16 (-a * 240), V2 0 (-a * 240)]
+        , polygonOutline [V2 24 0, V2 40 0, V2 40 (-b * 240), V2 24 (-b * 240)]]
+        ]
+  linkKeyboard $ \case
+    Down KeySpace -> deck .- pos .= 0
+    _ -> return ()
+  deck .- playing .= True
+  stand
+ 

@@ -0,0 +1,25 @@+#version 330
+in vec2 UV;
+in vec2 envUV;
+out vec4 fragColor;
+uniform vec4 color;
+uniform bool useTexture;
+uniform int useEnv;
+uniform sampler2D tex;
+uniform sampler2D env;
+
+void main(void){
+  if(useTexture){
+    fragColor = texture( tex, UV ).rgba * color;
+  }else{
+    fragColor = color;
+  }
+  if (useEnv == 1)
+  {
+    fragColor += texture( env, envUV ).rgba;
+  }
+  else if (useEnv == 2)
+  {
+    fragColor *= texture( env, envUV ).rgba;
+  }
+}

@@ -0,0 +1,26 @@+#version 330
+uniform mat4 projection;
+uniform mat4 matrices[13];
+uniform int level;
+uniform int useEnv;
+out vec2 UV;
+out vec2 envUV;
+in vec3 in_Position;
+in vec2 in_UV;
+in vec3 in_Normal;
+
+void main(void) {
+  mat4 model = mat4(1.0);
+  for(int i=0; i < level; i++)
+  {
+    model *= matrices[i];
+  }
+  gl_Position = projection * model * vec4(in_Position, 1.0);
+  UV = in_UV;
+  if(useEnv != 0)
+  {
+    vec3 r = reflect( normalize(vec3(model * vec4(in_Position, 1.0))), in_Normal );
+    float m = 2.0 * sqrt( r.x*r.x + r.y*r.y + (r.z+1.0)*(r.z+1.0) );
+    envUV = r.xy / m + 0.5;
+  }
+}

@@ -1,62 +1,31 @@ {-# 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
-    Vec2,
-    WindowMode(..),
-    BoundingBox2,
-    Box(..),
-    isInside,
-    Picture(..),
-    Affine(..),
-    Picture2D(..),
-    opacity,
-    BlendMode(..),
-    Key(..),
-    charToKey,
-    -- * Bitmap
-    Bitmap,
-    readBitmap,
-    clipBitmap,
-    loadBitmapsWith,
-    -- * Sound
-    Source(..),
-    readWAVE,
-    -- * IO
-    liftIO,
+    module Call.Sight,
+    module Call.Util,
+    module Call.System,
+    module Call.Types,
+    module Call.TH,
+    module Call.Data.Wave,
     -- * Reexports
     module Control.Monad,
     module Control.Applicative,
     module Control.Bool,
+    module Data.Monoid,
     module Data.Color,
     module Data.Color.Names,
     module Linear,
+    module Control.Object,
+    module Control.Monad.Objective.Class,
+    module Control.Monad.IO.Class
 ) where
 
 import Call.TH
 import Call.Types
-import Call.Component
-import Call.Data.Bitmap
 import Call.Data.Wave
-import Call.Picture
+import Call.Sight
 import Call.System
+import Call.Util
 import Control.Monad.IO.Class
 import Control.Monad
 import Control.Applicative
@@ -65,6 +34,7 @@ import Control.Monad.Objective.Class
 import Data.Color
 import Data.Color.Names
+import Data.Monoid
 import Linear
 import Data.BoundingBox
 

@@ -1,70 +0,0 @@-{-# 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)

@@ -1,65 +0,0 @@-{-# 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

@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Call.Data.Bitmap
@@ -10,60 +11,90 @@ --
 -----------------------------------------------------------------------------
 module Call.Data.Bitmap (
-    -- * Basic types and functions
-    Bitmap(..)
-    ,bitmapSize
-    ,liftBitmapIO
-    -- * Load and Save
-    ,readBitmap
-    ,writeBitmap
-
-    -- * Bitmap operations
-    ,cropBitmap
-    -- * V2
-    ,sizeBitmap
-    ,clipBitmap
-    ) where
-
+  Bitmap(Blank, Bitmap)
+  ,image
+  ,offset
+  ,hash
+  ,liftImage
+  ,liftImage'
+  ,size
+  ,clip
+  ,bbox
+  ,readFile
+  ,writeFile
+  ) where
+import Prelude hiding (readFile, writeFile)
 import qualified Codec.Picture as C
+import qualified Codec.Picture.Types as C
 import qualified Codec.Picture.RGBA8 as C
 import Control.Monad.IO.Class
-import Data.BoundingBox
-import Linear.V2
+import qualified Data.BoundingBox as B
+import Linear
 import System.Random
 import Control.Applicative
-import Data.Hashable
+import qualified Data.Hashable as H
+import qualified Data.Vector.Storable as V
+import Data.Monoid
+import Control.Lens
+import Control.Monad.ST
 
-data Bitmap = Bitmap { bitmapImage :: C.Image C.PixelRGBA8, bitmapHash :: Int }
+data Bitmap = Blank | Bitmap { _image :: C.Image C.PixelRGBA8, _offset :: V2 Int, _hash :: Int }
 
--- | Get the size of the 'Bitmap'.
-bitmapSize :: Bitmap -> (Int, Int)
-bitmapSize (Bitmap (C.Image w h _) _) = (w, h)
+image :: Traversal' Bitmap (C.Image C.PixelRGBA8)
+image _ Blank = pure Blank
+image f (Bitmap i o h) = f i <&> \i' -> Bitmap i' o h
 
-liftBitmapIO :: MonadIO m => C.Image C.PixelRGBA8 -> m Bitmap
-liftBitmapIO b = liftIO $ Bitmap b <$> randomIO
+offset :: Traversal' Bitmap (V2 Int)
+offset _ Blank = pure Blank
+offset f (Bitmap i o h) = f o <&> \o' -> Bitmap i o' h
 
--- | Load an image file.
-readBitmap :: MonadIO m => FilePath -> m Bitmap
-readBitmap path = liftIO $ Bitmap <$> C.readImageRGBA8 path <*> randomIO
+hash :: Traversal' Bitmap Int
+hash _ Blank = pure Blank
+hash f (Bitmap i o h) = f h <&> \h' -> Bitmap i o h'
 
--- | Save 'Bitmap' into a file.
-writeBitmap :: MonadIO m => FilePath -> Bitmap -> m ()
-writeBitmap path (Bitmap p _) = liftIO $ C.writePng path p
+-- | `mappend` stitches the right operand to the left
+instance Monoid Bitmap where
+  mempty = Blank
+  mappend base@(Bitmap b (V2 x0 y0) h0) lay@(Bitmap l (V2 x1 y1) h1) = runST $ do
+    let box = B.union (bbox base) (bbox lay)
+    let V2 w h = box ^. B.size 0
+    img <- C.createMutableImage w h (C.PixelRGBA8 0 0 0 0) >>= C.unsafeFreezeImage
+    let ox = max 0 (x0 - x1)
+    let oy = max 0 (y0 - y1)
+    return $ Bitmap
+      (C.patchImage (C.patchImage img (ox, oy) b) (max 0 (x1 - x0), max 0 (y1 - y0)) l)
+      (V2 (x0 + ox) (y0 + oy))
+      (H.hash (h0, h1))
+  mappend Blank b = b
+  mappend b Blank = b
 
--- | 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))
+clip :: Bitmap -> B.Box V2 Int -> Bitmap
+clip (Bitmap b (V2 ox oy) k) (B.Box (V2 x0 y0) (V2 x1 y1)) = Bitmap
+  (C.trimImage b (x1 - x0, y1 - y0) (x0 - ox, y0 - oy))
+  (V2 ox oy)
+  (H.hash (x0, y0, x1, y1, 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))
+clip Blank _ = Blank
 
-sizeBitmap :: Bitmap -> V2 Int
-sizeBitmap (Bitmap (C.Image w h _) _) = V2 w h+bbox :: Bitmap -> B.Box V2 Int
+bbox (Bitmap (C.Image w h _) (V2 x y) _) = B.Box (V2 x y) (V2 (x+w) (y+h))
+bbox Blank = B.Box zero zero
+
+size :: Bitmap -> V2 Int
+size (Bitmap (C.Image w h _) _ _) = V2 w h
+size Blank = zero
+
+liftImage :: C.Image C.PixelRGBA8 -> Bitmap
+liftImage b@(C.Image _ _ r) = Bitmap b zero (V.foldl H.hashWithSalt 0 r)
+
+liftImage' :: MonadIO m => C.Image C.PixelRGBA8 -> m Bitmap
+liftImage' b = liftIO $ Bitmap b zero <$> randomIO
+
+-- | Load an image file.
+readFile :: MonadIO m => FilePath -> m Bitmap
+readFile path = liftIO $ Bitmap <$> C.readImageRGBA8 path <*> pure zero <*> randomIO
+
+-- | Save 'Bitmap' into a file.
+writeFile :: MonadIO m => FilePath -> Bitmap -> m ()
+writeFile path (Bitmap p _ _) = liftIO $ C.writePng path p
+writeFile _ Blank = fail "Blank bitmap"

@@ -14,19 +14,17 @@ module Call.Data.Font 
   ( Font
   , readFont
+  , defaultFont
   , fontBoundingBox
   , metricsAscent
   , metricsDescent
-  , charToBitmap
-  , RenderedChar(..)
+  , renderChar
   ) 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
@@ -47,36 +45,41 @@ import System.IO.Unsafe
 import Codec.Picture
 import Codec.Picture.RGBA8
+import Paths_call
 
 -- | Font object
-data Font = Font FT_Face (Double, Double) (Box V2 Double) (IORef (M.Map (Double, Char) RenderedChar))
+data Font = Font FT_Face (Float, Float) (Box V2 Float)
 
+defaultFont :: Font
+defaultFont = unsafePerformIO $ do
+  path <- getDataFileName "data/VL-PGothic-Regular.ttf"
+  readFont path
+
 -- | 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)
+    b <- peek (F.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
-
+    let box = fmap ((/u).fromIntegral) $ Box
+            (V2 (xMin b) (yMin b))
+            (V2 (xMax b) (yMax b))
+    return $ Font f (fromIntegral asc/u, fromIntegral desc/u) box
 
 -- | Get the font's metrics.
-metricsAscent :: Font -> Double
-metricsAscent (Font _ (a, _) _ _) = a
+metricsAscent :: Font -> Float
+metricsAscent (Font _ (a, _) _) = a
 
 -- | Get the font's metrics.
-metricsDescent :: Font -> Double
-metricsDescent (Font _ (_, d) _ _) = d
+metricsDescent :: Font -> Float
+metricsDescent (Font _ (_, d) _) = d
 
--- | Get the font's boundingbox.
-fontBoundingBox :: Font -> Box V2 Double
-fontBoundingBox (Font _ _ b _) = b
+-- | Get the font's bounding box.
+fontBoundingBox :: Font -> Box V2 Float
+fontBoundingBox (Font _ _ b) = b
 
 runFreeType :: IO CInt -> IO ()
 runFreeType m = do
@@ -85,55 +88,37 @@ 
 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
-    }
+  runFreeType $ ft_Init_FreeType p
+  peek p
 
 -- | 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
+renderChar :: Font -> Float -> Char -> IO (Bitmap, V2 Float, V2 Float)
+renderChar (Font 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
+  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
+  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
+  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
+  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)
+  adv <- peek $ GS.advance slot
+  b <- liftImage' $ fromColorAndOpacity (PixelRGB8 255 255 255)
+      $ Image w h $ V.unsafeFromForeignPtr0 fptr $ h * w
+  return (b
+    , V2 (left + fromIntegral w / 2) (-top + fromIntegral h / 2)
+    , V2 (fromIntegral (V.x adv) / 64) 0)

@@ -12,6 +12,7 @@ -----------------------------------------------------------------------------
 module Call.Data.Wave (
   Source(..),
+  Sample(..),
   Stereo,
   readWAVE
 ) where
@@ -21,19 +22,24 @@ import Call.Types
 import Control.Monad.IO.Class
 import qualified Data.Vector.Unboxed as V
+import GHC.Float
 
 newtype Source a = Source (Time -> a)
 
-type Stereo = V2 Float
-
-readWAVE :: MonadIO m => FilePath -> m (Source Stereo)
+readWAVE :: MonadIO m => FilePath -> m (Sample Stereo)
 readWAVE path = liftIO $ do
   WAVE h ss <- getWAVEFile path
-  
-  return $ Source $ sample h $ V.fromList (map fr ss)
+  let vec = V.fromList (map fr ss)
+      rate = fromIntegral (waveFrameRate h)
+      !dur = fromIntegral (V.length vec) / rate
+      sample t
+        | t < 0 || t >= dur = zero
+        | otherwise = vec V.! floor (t * rate)
+  return $ Sample dur (Source sample)
   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))
+    fr [a, b] = V2 (double2Float $ sampleToDouble a) (double2Float $ sampleToDouble b)
+    fr _ = zero
+
+data Sample a = Sample { sampleLength :: Time ,sampleSource :: Source a} 
 
 -- TODO: Lazy processing

@@ -13,15 +13,14 @@ 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 Control.Monad
 import Graphics.Rendering.OpenGL.GL.StateVar
-import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility
 import Linear
+import qualified Graphics.Rendering.OpenGL.Raw as GL
 import qualified Graphics.Rendering.OpenGL.GL as GL
 import qualified Graphics.UI.GLFW as GLFW
 import Unsafe.Coerce
@@ -30,181 +29,170 @@ import Codec.Picture
 import Codec.Picture.RGBA8
 import qualified GHC.IO.Encoding as Encoding
-
+import qualified Data.Text.IO as Text
+import qualified Data.Text.Encoding as Text
+import Foreign.C (CFloat)
+import Foreign (nullPtr, plusPtr, sizeOf)
+import Paths_call
 data System = System
-    { refRegion :: IORef BoundingBox2
-    , theWindow :: GLFW.Window
-    }
+  { refRegion :: IORef (Box V2 Float)
+  , theWindow :: GLFW.Window
+  , theProgram :: GL.Program
+  }
 
 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
+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)
 
-scale :: V2 Double -> IO a -> IO a
-scale (V2 sx sy) m = preservingMatrix' $ GL.scale (gd sx) (gd sy) 1 >> m
+releaseTexture :: Texture -> IO ()
+releaseTexture (tex, _, _) = GL.deleteObjectNames [tex]
 
-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]]
+beginFrame :: System -> IO ()
+beginFrame _ = do
+  GL.clear [GL.ColorBuffer, GL.DepthBuffer]
 
-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]]
+endFrame :: System -> IO Bool
+endFrame sys = do
+  GLFW.swapBuffers $ theWindow sys
+  GLFW.pollEvents
+  GLFW.windowShouldClose (theWindow sys)
 
-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
+beginGLFW :: WindowMode -> Box V2 Float -> 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")
 
-polygon :: [V2 Double] -> IO ()
-polygon path = GL.renderPrimitive GL.Polygon $ runVertices path
+  mon <- case mode of
+    FullScreen -> GLFW.getPrimaryMonitor
+    _ -> return Nothing
 
-polygonOutline :: [V2 Double] -> IO ()
-polygonOutline path = GL.renderPrimitive GL.LineLoop $ runVertices path
+  -- GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
+  -- GLFW.windowHint $ GLFW.WindowHint'OpenGLForwardCompat True
+  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)
+  prog <- initializeGL
 
-line :: [V2 Double] -> IO ()
-line path = GL.renderPrimitive GL.LineStrip $ runVertices path
+  GLFW.swapInterval 1
+  -- GL.clearColor $= GL.Color4 1 1 1 1
+  
+  rbox <- newIORef bbox
 
-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
+  GLFW.setFramebufferSizeCallback win $ Just $ \_ w h -> do
+      modifyIORef rbox $ size zero .~ fmap fromIntegral (V2 w h)
 
-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)
+  return $ System rbox win prog
 
-releaseTexture :: Texture -> IO ()
-releaseTexture (tex, _, _) = GL.deleteObjectNames [tex]
+compileShader :: FilePath -> GL.Shader -> IO ()
+compileShader path shader = do
+  src <- getDataFileName path >>= Text.readFile
+  GL.shaderSourceBS shader $= Text.encodeUtf8 src
+  GL.compileShader shader
+  GL.get (GL.shaderInfoLog shader) >>= putStrLn
 
-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]
+initializeGL :: IO GL.Program
+initializeGL = do
+  let vertexAttribute = GL.AttribLocation 0
+  let uvAttribute = GL.AttribLocation 1
+  let normalAttribute = GL.AttribLocation 2
+  
+  cubeVao <- GL.genObjectName
+  cubeVbo <- GL.genObjectName
 
-endFrame :: System -> IO Bool
-endFrame sys = do
-    GLFW.swapBuffers $ theWindow sys
-    GLFW.pollEvents
-    GLFW.windowShouldClose (theWindow sys)
+  GL.bindVertexArrayObject $= Just cubeVao
+  GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo
 
-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")
+  let stride = fromIntegral $ sizeOf (undefined :: Vertex)
 
-    mon <- case mode of
-        FullScreen -> GLFW.getPrimaryMonitor
-        _ -> return Nothing
+  GL.vertexAttribPointer vertexAttribute $=
+    (GL.ToFloat,GL.VertexArrayDescriptor 3 GL.Float stride nullPtr)
 
-    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
+  GL.vertexAttribArray vertexAttribute $= GL.Enabled
+  GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo
 
-    GLFW.swapInterval 1
-    GL.clearColor $= GL.Color4 1 1 1 1
+  GL.vertexAttribPointer uvAttribute $=
+    (GL.ToFloat
+    ,GL.VertexArrayDescriptor 2 GL.Float stride (nullPtr `plusPtr` sizeOf (0 :: V3 CFloat)))
+  GL.vertexAttribArray uvAttribute $= GL.Enabled
 
-    rbox <- newIORef bbox
+  GL.vertexAttribPointer normalAttribute $=
+    (GL.ToFloat
+    ,GL.VertexArrayDescriptor 3 GL.Float stride
+      (nullPtr `plusPtr` sizeOf (0 :: V3 CFloat) `plusPtr` sizeOf (0 :: V2 CFloat)))
+  GL.vertexAttribArray normalAttribute $= GL.Enabled
 
-    GLFW.setFramebufferSizeCallback win $ Just $ \_ w h -> do
-        modifyIORef rbox $ size zero .~ fmap fromIntegral (V2 w h)
+  vertexShader <- GL.createShader GL.VertexShader
+  fragmentShader <- GL.createShader GL.FragmentShader
+  compileShader "shaders/vertex.glsl" vertexShader
+  compileShader "shaders/fragment.glsl" fragmentShader
+  shaderProg <- GL.createProgram
+  GL.attachShader shaderProg vertexShader
+  GL.attachShader shaderProg fragmentShader
+  GL.attribLocation shaderProg "in_Position" $= vertexAttribute
+  GL.attribLocation shaderProg "in_UV" $= uvAttribute
+  GL.attribLocation shaderProg "in_Normal" $= normalAttribute
+  GL.linkProgram shaderProg
+  GL.currentProgram $= Just shaderProg
+  
+  -- GL.blend $= GL.Disabled
+  GL.depthMask $= GL.Enabled
+  GL.depthFunc $= Just GL.Lequal
+  GL.colorMask $= GL.Color4 GL.Enabled GL.Enabled GL.Enabled GL.Enabled
+  {-
+  GL.depthMask $= GL.Disabled
+  GL.depthFunc $= Nothing
+  
+  GL.colorMask $= GL.Color4 GL.Enabled GL.Enabled GL.Enabled GL.Enabled
+  -}
+  -- GL.cullFace $= GL.Back
+  GL.blend      $= GL.Enabled
+  GL.blendFunc  $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
+  linked <- GL.get (GL.linkStatus shaderProg)
+  unless linked $ do
+    GL.get (GL.programInfoLog shaderProg) >>= putStrLn
+  
+  GL.lineSmooth $= GL.Enabled
+  GL.textureFunction $= GL.Combine
+  GL.clearColor $= GL.Color4 1 1 1 1
+  GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "useEnv"
+  GL.glUniform1i loc 0
 
-    return $ System rbox win
+  return shaderProg
 
 endGLFW :: System -> IO ()
 endGLFW sys = do
-    GLFW.destroyWindow (theWindow sys)
-    GLFW.terminate
+  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)
+  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
+  Image w h <$> V.unsafeFreeze mv
 
 screenshot :: System -> IO (Image PixelRGBA8)
 screenshot sys = flipVertically <$> screenshotFlipped sys
@@ -218,8 +206,8 @@ 
 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
+  oldFunc <- get GL.blendFunc
+  GL.blendFunc $= blendMode2BlendingFactors mode
+  a <- m
+  GL.blendFunc $= oldFunc
+  return a

@@ -10,6 +10,9 @@ import Linear
 import Control.Exception
 import Data.Typeable
+import qualified Data.Vector.Storable as V
+import qualified Data.Vector.Storable.Mutable as MV
+
 data Error = NotInitialized
   | UnanticipatedHostError
   | InvalidChannelCount
@@ -56,34 +59,35 @@       name <- peekCAString $ c'PaHostApiInfo'name info
       return (Host (fromIntegral i) name)
 -}
-callback :: (Int -> IO [V2 Float]) -> Ptr () -> Ptr () -> CULong -> x -> y -> z -> IO CUInt
-callback f (castPtr -> _) (castPtr -> pout) (fromIntegral -> n) _ _ _ = do
-  f n >>= pokeArray pout
+callback :: (Int -> IO (V.Vector (V2 Float))) -> Ptr () -> Ptr () -> CULong -> x -> y -> z -> IO CUInt
+callback f _ (castPtr -> pout) (fromIntegral -> n) _ _ _ = do
+  fp <- newForeignPtr_ pout
+  f n >>= V.unsafeCopy (MV.unsafeFromForeignPtr0 fp n)
   return c'paContinue
 
-with :: MonadIO m => Double -> Int -> (Int -> IO [V2 Float]) -> m a -> m a
+with :: MonadIO m => Float -> Int -> (Int -> IO (V.Vector (V2 Float))) -> m a -> m a
 with rate buf f m = do
-    w c'Pa_Initialize
-    cb <- liftIO $ mk'PaStreamCallback $ callback f
-    
-    ps <- liftIO malloc
-    w $ c'Pa_OpenDefaultStream ps
-        0
-        2
-        1 -- Float
-        (realToFrac rate)
-        (fromIntegral buf)
-        cb
-        nullPtr
-    s <- liftIO $ peek ps
+  w c'Pa_Initialize
+  cb <- liftIO $ mk'PaStreamCallback $ callback f
+  
+  ps <- liftIO malloc
+  w $ c'Pa_OpenDefaultStream ps
+      0
+      2
+      1 -- Float
+      (realToFrac rate)
+      (fromIntegral buf)
+      cb
+      nullPtr
+  s <- liftIO $ peek ps
 
-    w $ c'Pa_StartStream s
-    r <- m
-    w $ c'Pa_StopStream s
-    w $ c'Pa_CloseStream s
-    w $ c'Pa_Terminate
-    return r
-    where
-      w n = do
-        r <- liftIO n
-        unless (r == 0) $ liftIO $ throwIO $ fromErrorCode r
+  w $ c'Pa_StartStream s
+  r <- m
+  w $ c'Pa_StopStream s
+  w $ c'Pa_CloseStream s
+  w $ c'Pa_Terminate
+  return r
+  where
+    w n = do
+      r <- liftIO n
+      unless (r == 0) $ liftIO $ throwIO $ fromErrorCode r

@@ -1,85 +0,0 @@-{-# 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
-
-opacity :: Picture2D p => Float -> p a -> p a
-opacity a = color (Color 1 1 1 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)

@@ -0,0 +1,183 @@+{-# LANGUAGE TypeFamilies
+  , FlexibleContexts
+  , BangPatterns
+  , DeriveFunctor
+  , Rank2Types
+  , FlexibleInstances
+  , UndecidableInstances
+  , ViewPatterns
+  , ScopedTypeVariables
+  , GeneralizedNewtypeDeriving #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Scene
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-----------------------------------------------------------------------------
+module Call.Sight (Affine(..)
+    , Figure(..)
+    , Picture(..)
+    , bitmap
+    , toward
+    , Scene(..)
+    , transformScene
+    , vertices
+    , Sight(..)
+    , viewPicture
+    , viewScene
+    , fromPerspective
+    , VFX(..)
+    , applyVFX
+    , GL.PrimitiveMode(..)
+    ) where
+import qualified Call.Data.Bitmap as B
+import qualified Data.BoundingBox as X
+import Data.Monoid
+import Linear
+import qualified Data.Vector.Storable as V
+import Control.Lens
+import qualified Graphics.Rendering.OpenGL.GL as GL
+import Data.Color
+import Call.Types
+import Control.Monad.Trans.Writer.Strict as Strict
+import Control.Monad.Trans.Writer.Lazy as Lazy
+
+class Affine a where
+  type Vec a :: *
+  type Normal a :: *
+  rotateOn :: Normal a -> a -> a
+  scale :: Vec a -> a -> a
+  translate :: Vec a -> a -> a
+
+class Affine a => Figure a where
+  primitive :: GL.PrimitiveMode -> [Vec a] -> a
+  color :: RGBA -> a -> a
+  line :: [Vec a] -> a
+  polygon :: [Vec a] -> a
+  polygonOutline :: [Vec a] -> a
+  circle :: Normal a -> a
+  circleOutline :: Normal a -> a
+
+bitmap :: B.Bitmap -> Picture
+bitmap bmp = Picture $ Scene
+  $ \_ _ f _ _ -> f bmp GL.TriangleStrip
+    (V.fromList [V3 (-w/2) (-h/2) 0 `positionUV` V2 0 0
+        , V3 (w/2) (-h/2) 0 `positionUV` V2 1 0
+        , V3 (-w/2) (h/2) 0 `positionUV` V2 0 1
+        , V3 (w/2) (h/2) 0 `positionUV` V2 1 1]) where
+  V2 w h = fmap fromIntegral $ B.size bmp
+
+toward :: Vec3 -> Picture -> Scene
+toward n@((^/norm n) -> V3 x y z) (Picture s) = transformScene
+  (m33_to_m44 $ fromQuaternion $ axisAngle (V3 (-y) x 0) $ acos $ z / norm n)
+  s
+
+newtype Scene = Scene { unScene :: forall r.
+  r
+  -> (r -> r -> r)
+  -> (B.Bitmap -> GL.PrimitiveMode -> V.Vector Vertex -> r)
+  -> (VFX r -> r)
+  -> (M44 Float -> r -> r)
+  -> r
+  }
+
+data VFX r = SphericalAdd Bitmap r
+  | SphericalMultiply Bitmap r
+  | Diffuse RGBA r
+  deriving Functor
+  {-
+  | Opacity r
+  | Light RGBA Float (V3 Float) (V4 Float)
+  | Specular RGB
+  | Ambient RGB
+  -}
+
+instance Affine Scene where
+  type Vec Scene = V3 Float
+  type Normal Scene = V3 Float
+  rotateOn v = transformScene $ m33_to_m44 $ fromQuaternion $ axisAngle v (norm v)
+  scale (V3 x y z) = transformScene $ V4
+    (V4 x 0 0 0)
+    (V4 0 y 0 0)
+    (V4 0 0 z 0)
+    (V4 0 0 0 1)
+  translate v = transformScene $ translation .~ v $ eye4
+
+instance Figure Scene where
+  primitive m vs = Scene $ \_ _ f _ _ -> f Blank m (V.fromList $ map positionOnly vs)
+  color col (Scene s) = Scene $ \e a f b t -> b (Diffuse col (s e a f b t))
+  line = primitive GL.LineStrip
+  polygon = primitive GL.Polygon
+  polygonOutline = primitive GL.LineLoop
+  circle v = toward v $ circle $ norm v
+  circleOutline v = toward v $ circleOutline $ norm v
+
+unit_circle :: Int -> [V2 Float]
+unit_circle n = map angle [0,2*pi/fromIntegral n..2*pi]
+
+instance Monoid Scene where
+  mempty = Scene $ \e _ _ _ _ -> e
+  mappend (Scene x) (Scene y) = Scene $ \e a f b t -> a (x e a f b t) (y e a f b t)
+
+v2ToV3 :: Num a => V2 a -> V3 a
+v2ToV3 (V2 x y) = V3 x y 0
+
+vertices :: B.Bitmap -> GL.PrimitiveMode -> V.Vector Vertex -> Scene
+vertices b m v = Scene $ \_ _ f _ _ -> f b m v
+
+transformScene :: M44 Float -> Scene -> Scene
+transformScene m (Scene pic) = Scene $ \e a f b t -> t m (pic e a f b t)
+
+applyVFX :: VFX Scene -> Scene
+applyVFX vf = Scene $ \e a f b t -> b $ fmap (\(Scene s) -> s e a f b t) vf
+
+newtype Picture = Picture { unPicture :: Scene } deriving Monoid
+
+instance Affine Picture where
+  type Vec Picture = V2 Float
+  type Normal Picture = Float
+  rotateOn t (Picture s) = Picture (transformScene m s) where
+    m = V4 (V4 (cos t) (-sin t) 0 0) (V4 (sin t) (cos t) 0 0) (V4 0 0 1 0) (V4 0 0 0 1)
+  translate (V2 x y) (Picture s) = Picture $ transformScene (translation .~ V3 x y 0 $ eye4) s
+  scale (V2 x y) (Picture s) = Picture (transformScene m s) where
+    m = V4 (V4 x 0 0 0) (V4 0 y 0 0) (V4 0 0 1 0) (V4 0 0 0 1)
+
+instance Figure Picture where
+  primitive m v = Picture $ primitive m $ map v2ToV3 v
+  color col (Picture s) = Picture (color col s)
+  line = primitive GL.LineStrip
+  polygon = primitive GL.Polygon
+  polygonOutline = primitive GL.LineLoop
+  circle r = polygon $ map (^*r) $ unit_circle 33
+  circleOutline r = polygonOutline $ map (^*r) $ unit_circle 33
+
+newtype Sight = Sight { unSight
+  :: forall r. 
+  X.Box V2 Float
+  -> r
+  -> (r -> r -> r)
+  -> (X.Box V2 Float -> M44 Float -> Bool -> Scene -> r)
+  -> r
+  }
+
+instance Monoid Sight where
+  mempty = Sight $ \_ e _ _ -> e
+  mappend (Sight x) (Sight y) = Sight $ \b e a f -> a (x b e a f) (y b e a f)
+
+viewPicture :: Picture -> Sight
+viewPicture (Picture s) = Sight $ \box@(X.Box (V2 x0 y0) (V2 x1 y1)) _ _ f -> f box (ortho x0 x1 y1 y0 (-1) 1) False s
+
+viewScene :: Float -- ^ FOV
+  -> Float -- ^ Near plane
+  -> Float -- ^ Far plane
+  -> Scene -- ^ The scene
+  -> Sight
+viewScene fov near far = fromPerspective $ \box -> perspective fov (let V2 w h = box ^. X.size 0 in w/h) near far
+
+fromPerspective :: (X.Box V2 Float -> M44 Float) -> Scene -> Sight
+fromPerspective mat s = Sight $ \box _ _ f -> f box (mat box) True s

@@ -9,11 +9,14 @@ {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 -----------------------------------------------------------------------------
@@ -27,42 +30,89 @@ -- Portability :  non-portable
 --
 -----------------------------------------------------------------------------
-module Call.System (System, runSystem, MonadSystem(..), forkSystem) where
+module Call.System (
+  -- * The system
+  System
+  , runSystem
+  , forkSystem
+  -- * Time
+  , stand
+  , wait
+  , getTime
+  , setFPS
+  -- * Raw input
+  , keyPress
+  , mousePosition
+  , mouseButton
+  , enableCursor
+  , hideCursor
+  , disableCursor
+  , getGamepads
+  , gamepadButtons
+  , gamepadAxes
+  -- * Component
+  , linkGraphic
+  , linkPicture
+  , linkAudio
+  , linkKeyboard
+  , linkMouse
+  , linkGamepad
+  -- * Others
+  , setTitle
+  , clearColor
+  , getBoundingBox
+  , setBoundingBox
+  , takeScreenshot
+  ) where
 
-import Call.Component
 import Call.Data.Bitmap
-import Call.Picture
+import Call.Sight
 import Call.Types
 import Control.Applicative
 import Control.Concurrent
 import Control.Exception
-import Control.Monad.IO.Class
+import Control.Elevator
+import Control.Lens
+import Control.Monad.Objective
 import Control.Monad.Reader
 import Control.Object
-import Control.Monad.Objective
+import Data.BoundingBox (Box(..))
+import Data.Color
+import Data.OpenUnion1.Clean
 import Data.IORef
-import Data.Reflection
+import Data.Maybe
+import Data.Monoid
+import Foreign (castPtr, sizeOf, with)
+import Graphics.Rendering.OpenGL.GL.StateVar
 import Linear
 import qualified Call.Internal.GLFW as G
+import qualified Call.Internal.PortAudio as PA
+import qualified Codec.Picture as C
 import qualified Data.IntMap.Strict as IM
+import qualified Data.Vector.Storable as V
+import qualified Graphics.Rendering.OpenGL.GL as GL
+import qualified Graphics.Rendering.OpenGL.Raw as GL
 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 ()
+setFPS :: Float -> System s ()
+setFPS f = mkSystem $ \fo -> writeIORef (targetFPS fo) f
 
 newtype System s a = System (ReaderT (Foundation s) IO a) deriving (Functor, Applicative, Monad)
 
+instance MonadObjective (System s) where
+  data Instance e m (System s) = InstanceS (MVar (Object e m))
+  InstanceS m `invoke` e = do
+    c <- liftIO $ takeMVar m
+    return $ do
+      (a, c') <- runObject c e
+      return (liftIO (putMVar m c') >> return a)
+  new v = liftIO $ InstanceS `fmap` newMVar v
+
+instance Tower (System s) where
+  type Floors (System s) = IO :> Empty
+  toLoft = liftIO ||> exhaust
+
 unSystem :: Foundation s -> System s a -> IO a
 unSystem f m = unsafeCoerce m f
 
@@ -72,162 +122,307 @@ 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
+linkGraphic :: (Time -> System s Sight) -> System s ()
+linkGraphic f = mkSystem $ \fo -> do
+  g <- readIORef $ coreGraphic fo
+  writeIORef (coreGraphic fo) $ \dt -> liftA2 (<>) (f dt) (g dt)
 
-data Member c s = forall e. c e => Member (MVar (Object e (System s)))
+linkPicture :: (Time -> System s Picture) -> System s ()
+linkPicture f = linkGraphic (fmap viewPicture . f)
 
+linkAudio :: (Time -> Int -> System s (V.Vector Stereo)) -> System s ()
+linkAudio f = mkSystem $ \fo -> do
+  g <- readIORef $ coreAudio fo
+  writeIORef (coreAudio fo) $ \dt n -> liftA2 (V.zipWith (+)) (f dt n) (g dt n)
+
+linkKeyboard :: (Chatter Key -> System s ()) -> System s ()
+linkKeyboard f = mkSystem $ \fo -> do
+  g <- readIORef $ coreKeyboard fo
+  writeIORef (coreKeyboard fo) $ \k -> f k >> g k
+
+linkMouse :: (MouseEvent -> System s ()) -> System s ()
+linkMouse f = mkSystem $ \fo -> do
+  g <- readIORef $ coreMouse fo
+  writeIORef (coreMouse fo) $ \k -> f k >> g k
+
+linkGamepad :: (GamepadEvent -> System s ()) -> System s ()
+linkGamepad f = mkSystem $ \fo -> do
+  g <- readIORef $ coreJoypad fo
+  writeIORef (coreJoypad fo) $ \k -> f k >> g k
+
 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 ()
-    }
+  { sampleRate :: Float
+  , coreGraphic :: IORef (Time -> System s Sight)
+  , coreAudio :: IORef (Time -> Int -> System s (V.Vector (V2 Float)))
+  , coreKeyboard :: IORef (Chatter Key -> System s ())
+  , coreMouse :: IORef (MouseEvent -> System s ())
+  , coreJoypad :: IORef (GamepadEvent -> System s ())
+  , theTime :: MVar Time
+  , theSystem :: G.System
+  , targetFPS :: IORef Float
+  , textures :: IORef (IM.IntMap G.Texture)
+  , theEnd :: MVar ()
+  , theGamepadButtons :: IORef (IM.IntMap (String, IM.IntMap Bool))
+  }
 
+runSystem :: WindowMode -> Box V2 Float -> (forall s. System s a) -> IO (Maybe a)
+runSystem mode box m = do
+  sys <- G.beginGLFW mode box
+  f <- Foundation
+    <$> pure 44100 -- FIX THIS
+    <*> newIORef (const $ return mempty)
+    <*> newIORef (\_ n -> return $ V.replicate n zero)
+    <*> newIORef (const $ return ())
+    <*> newIORef (const $ return ())
+    <*> newIORef (const $ return ())
+    <*> newMVar 0
+    <*> pure sys
+    <*> newIORef 60
+    <*> newIORef IM.empty
+    <*> newEmptyMVar
+    <*> newIORef IM.empty
+  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
+  GL.UniformLocation loc <- GL.get $ GL.uniformLocation (G.theProgram sys) "color"
+  with (V4 1 1 1 1 :: V4 Float) $ \ptr -> GL.glUniform4fv loc 1 (castPtr ptr)
+
+  print =<< GLFW.getWindowClientAPI win
+  putStr "OpenGL Version: "
+  cv0 <- GLFW.getWindowContextVersionMajor    win
+  cv1 <- GLFW.getWindowContextVersionMinor    win
+  cv2 <- GLFW.getWindowContextVersionRevision win
+  putStrLn $ show cv0 ++ "." ++ show cv1 ++ "." ++ show cv2 
+  print =<< GLFW.getWindowContextRobustness win
+  putStr "Forward compat: "
+  print =<< GLFW.getWindowOpenGLForwardCompat win
+  putStr "Debug context: "
+  print =<< GLFW.getWindowOpenGLDebugContext win
+  print =<< GLFW.getWindowOpenGLProfile win
+  
+  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
+
+stand :: System s ()
+stand = mkSystem $ \fo -> takeMVar (theEnd fo)
+
+wait :: Time -> System s ()
+wait dt = mkSystem $ \fo -> do
+  t0 <- takeMVar (theTime fo)
+  Just t <- GLFW.getTime
+  threadDelay $ floor $ (t0 - realToFrac t + dt) * 1000 * 1000
+  putMVar (theTime fo) $ t0 + dt
+
+getTime :: System s Time
+getTime = mkSystem $ \fo -> readMVar (theTime fo)
+
+keyPress :: Key -> System s Bool
+keyPress k = mkSystem $ \fo -> fmap (/=GLFW.KeyState'Released)
+  $ GLFW.getKey (G.theWindow $ theSystem fo) (toEnum . fromEnum $ k)
+
+mousePosition :: System s (V2 Float)
+mousePosition = mkSystem $ \fo -> do
+  (x, y) <- GLFW.getCursorPos (G.theWindow $ theSystem fo)
+  return $ V2 (realToFrac x) (realToFrac y)
+
+hideCursor :: System s ()
+hideCursor = mkSystem $ \fo -> GLFW.setCursorInputMode (G.theWindow $ theSystem fo) GLFW.CursorInputMode'Hidden
+
+disableCursor :: System s ()
+disableCursor = mkSystem $ \fo -> GLFW.setCursorInputMode (G.theWindow $ theSystem fo) GLFW.CursorInputMode'Disabled
+
+enableCursor :: System s ()
+enableCursor = mkSystem $ \fo -> GLFW.setCursorInputMode (G.theWindow $ theSystem fo) GLFW.CursorInputMode'Normal
+
+mouseButton :: Int -> System s Bool
+mouseButton b = mkSystem $ \fo -> fmap (/=GLFW.MouseButtonState'Released)
+  $ GLFW.getMouseButton (G.theWindow $ theSystem fo) (toEnum b)
+
+getGamepads :: System s [Gamepad]
+getGamepads = mkSystem $ const $ fmap catMaybes $ forM [(GLFW.Joystick'1)..]
+  $ \j -> fmap (Gamepad (fromEnum j)) <$> GLFW.getJoystickName j
+
+gamepadAxes :: Gamepad -> System s [Float]
+gamepadAxes (Gamepad i _) = mkSystem $ const $ maybe [] (map realToFrac) <$> GLFW.getJoystickAxes (toEnum i)
+
+gamepadButtons :: Gamepad -> System s [Bool]
+gamepadButtons (Gamepad i _) = mkSystem $ const
+  $ maybe [] (map (==GLFW.JoystickButtonState'Pressed)) <$> GLFW.getJoystickButtons (toEnum i)
+
+clearColor :: RGBA -> System s ()
+clearColor col = liftIO $ GL.clearColor $= unsafeCoerce col
+
+setBoundingBox :: Box V2 Float -> System s ()
+setBoundingBox box@(Box (V2 x0 y0) (V2 x1 y1)) = mkSystem $ \fo -> do
+  GLFW.setWindowSize (G.theWindow $ theSystem fo) (floor (x1 - x0)) (floor (y1 - y0))
+  writeIORef (G.refRegion $ theSystem fo) box
+
+getBoundingBox :: System s (Box V2 Float)
+getBoundingBox = mkSystem $ \fo -> readIORef (G.refRegion $ theSystem fo)
+
+takeScreenshot :: System s Bitmap
+takeScreenshot = mkSystem $ \fo -> G.screenshot (theSystem fo) >>= liftImage'
+
+setTitle :: String -> System s ()
+setTitle str = mkSystem $ \fo -> GLFW.setWindowTitle (G.theWindow $ theSystem fo) str
+    
 instance MonadIO (System s) where
-    liftIO m = mkSystem $ const m
-    {-# INLINE liftIO #-}
+  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)
+pollGamepad :: Foundation s -> IO ()
+pollGamepad fo = do
+  m <- readIORef (coreJoypad fo)
+  ps <- IM.fromList <$> map (\p@(Gamepad i _) -> (i, p)) <$> unSystem fo getGamepads
+  bs0 <- readIORef (theGamepadButtons fo)
 
-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
+  bs0' <- forM (IM.toList $ ps IM.\\ bs0) $ \(i, p@(Gamepad _ s)) -> do
+    unSystem fo $ m $ PadConnection $ Up p
+    return (i, (s, IM.empty))
 
-    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)
+  bs0_ <- forM (IM.toList $ bs0 IM.\\ ps) $ \(i, (s, _)) -> do
+    unSystem fo $ m $ PadConnection $ Down $ Gamepad i s
+    return (i, ())
 
-runGraphic :: Foundation s -> Double -> IO ()
+  let bs1 = bs0 `IM.union` IM.fromList bs0' IM.\\ IM.fromList bs0_
+
+  ls <- forM (IM.toList ps) $ \(j, p@(Gamepad _ s)) -> do
+    bs <- zip [0..] <$> unSystem fo (gamepadButtons p)
+    forM_ bs $ \(i, v) -> case (v, maybe False id (bs1 ^? ix j . _2 . ix i)) of
+        (False, True) -> unSystem fo $ m $ PadButton p (Up i)
+        (True, False) -> unSystem fo $ m $ PadButton p (Down i)
+        _ -> return ()
+    return (j, (s, IM.fromList bs))
+
+  writeIORef (theGamepadButtons fo) $ foldr (uncurry IM.insert) bs1 ls
+
+runGraphic :: Foundation s -> Time -> 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
+  pollGamepad fo
+  fps <- readIORef (targetFPS fo)
+  let t1 = t0 + 1/fps
+  G.beginFrame (theSystem fo)
+  m <- readIORef (coreGraphic fo)
+  pic <- unSystem fo $ m (1/fps) -- is it appropriate?
+  drawSight fo pic
+  b <- G.endFrame (theSystem fo)
+  
+  Just t' <- GLFW.getTime
+  threadDelay $ floor $ (t1 - realToFrac t') * 1000 * 1000
 
-    tryTakeMVar (theEnd fo) >>= \case
-        Just _ -> return ()
-        _ | b -> putMVar (theEnd fo) ()
-          | otherwise -> runGraphic fo t1
+  tryTakeMVar (theEnd fo) >>= \case
+      Just _ -> return ()
+      _ | b -> putMVar (theEnd fo) ()
+        | otherwise -> runGraphic fo t1
 
-audioProcess :: Foundation s -> Int -> IO [V2 Float]
+audioProcess :: Foundation s -> Int -> IO (V.Vector Stereo)
 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
+  let dt = fromIntegral n / sampleRate fo
+  m <- readIORef (coreAudio fo)
+  unSystem fo $ m dt n
 
 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)
+  m <- readIORef (coreKeyboard fo)
+  unSystem fo $ m $ case st of
+    GLFW.KeyState'Released -> Up (toEnum . fromEnum $ k :: Key)
+    _ -> Down (toEnum . fromEnum $ k :: Key)
 
 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)
+  m <- readIORef (coreMouse fo)
+  unSystem fo $ m $ case st of
+    GLFW.MouseButtonState'Released -> Button $ Up (fromEnum btn)
+    _ -> Button $ Down (fromEnum btn)
 
 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)
+  m <- readIORef (coreMouse fo)
+  unSystem fo $ m $ Cursor $ fmap realToFrac $ 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)
+  m <- readIORef (coreMouse fo)
+  unSystem fo $ m $ Scroll $ fmap realToFrac $ V2 x y
 
-newtype TextureStorage = TextureStorage { getTextureStorage :: IORef (IM.IntMap G.Texture) }
+fetchTexture :: Foundation s -> C.Image C.PixelRGBA8 -> Int -> IO G.Texture
+fetchTexture fo bmp h = do
+  st <- readIORef (textures fo)
+  case IM.lookup h st of
+    Just t -> return t
+    Nothing -> do
+      t <- G.installTexture bmp
+      writeIORef (textures fo) $ IM.insert h t st
+      return t
 
-instance Affine IO where
-    translate = G.translate
-    rotateD = G.rotateD
-    rotateR t = let t' = t / pi * 180 in G.rotateD t'
-    scale = G.scale
+drawScene :: Foundation s -> Box V2 Float -> M44 Float -> Bool -> Scene -> IO ()
+drawScene fo (fmap round -> Box (V2 x0 y0) (V2 x1 y1)) proj _ (Scene s) = do
+  GL.viewport $= (GL.Position x0 y0, GL.Size (x1 - x0) (y1 - y0))
 
-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
+  GL.currentProgram $= Just shaderProg
+  GL.UniformLocation loc <- GL.get (GL.uniformLocation shaderProg "projection")
+  with proj $ \ptr -> GL.glUniformMatrix4fv loc 1 1 $ castPtr ptr
+  GL.UniformLocation locT <- GL.get $ GL.uniformLocation shaderProg "useTexture"
+  s (pure $ return ()) (liftA2 (>>)) (prim locT) fx trans (RGBA 1 1 1 1, 0)
+  where
+    shaderProg = G.theProgram $ theSystem fo
+    prim locT Blank mode vs _ = do
+      GL.glUniform1i locT 0
+      V.unsafeWith vs $ \v -> GL.bufferData GL.ArrayBuffer $=
+        (fromIntegral $ V.length vs * sizeOf (undefined :: Vertex), v, GL.StaticDraw)
+      GL.drawArrays mode 0 $ fromIntegral $ V.length vs
+    prim locT (Bitmap bmp _ h) mode vs _ = do
+      GL.glUniform1i locT 1
+      (tex, _, _) <- fetchTexture fo bmp h
+      GL.activeTexture $= GL.TextureUnit 0
+      GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
+      GL.textureBinding GL.Texture2D $= Just tex
+      V.unsafeWith vs $ \v -> GL.bufferData GL.ArrayBuffer $=
+        (fromIntegral $ V.length vs * sizeOf (undefined :: Vertex), v, GL.StaticDraw)
+      GL.drawArrays mode 0 $ fromIntegral $ V.length vs
+    trans f m (color0, n) = do
+      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "matrices"
+      GL.UniformLocation locN <- GL.get $ GL.uniformLocation shaderProg "level" 
+      with f $ \ptr -> GL.glUniformMatrix4fv (loc+n) 1 1 (castPtr ptr)
+      GL.glUniform1i locN (unsafeCoerce $ n + 1)
+      m (color0, n + 1)
+      GL.glUniform1i locN (unsafeCoerce n)
+    fx (Diffuse col m) (color0, n) = do
+      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "color"
+      let c = multRGBA col color0
+      with c $ \ptr -> GL.glUniform4fv loc 1 (castPtr ptr)
+      m (c, n)
+      with color0 $ \ptr -> GL.glUniform4fv loc 1 (castPtr ptr)
+    fx (SphericalAdd (Bitmap bmp _ h) m) c = do
+      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "useEnv"
+      GL.glUniform1i loc 1
+      (tex, _, _) <- fetchTexture fo bmp h
+      GL.activeTexture $= GL.TextureUnit 1
+      GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
+      GL.textureBinding GL.Texture2D $= Just tex
+      m c
+      GL.glUniform1i loc 0
+    fx (SphericalAdd Blank m) c = m c
+    fx (SphericalMultiply (Bitmap bmp _ h) m) c = do
+      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "useEnv"
+      GL.glUniform1i loc 2
+      (tex, _, _) <- fetchTexture fo bmp h
 
-    circle = G.circle
-    circleOutline = G.circleOutline
-    polygon = G.polygon
-    polygonOutline = G.polygonOutline
-    line = G.line
-    thickness = G.thickness
-    color = G.color
-    blendMode = G.blendMode
+      GL.activeTexture $= GL.TextureUnit 1
+      GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
+      GL.textureBinding GL.Texture2D $= Just tex
+      m c
+      GL.glUniform1i loc 0
+    fx (SphericalMultiply Blank m) c = m c
+
+drawSight :: Foundation s -> Sight -> IO ()
+drawSight fo (Sight s) = do
+  b <- readIORef $ G.refRegion $ theSystem fo
+  s b (return ()) (>>) (drawScene fo)

@@ -19,7 +19,7 @@ import Control.Applicative
 import Control.Monad
 import Data.Char
-import Call.Data.Bitmap
+import qualified Call.Data.Bitmap as Bitmap
 import Language.Haskell.TH
 import System.Directory
 import System.FilePath
@@ -35,7 +35,7 @@     sequence $ do
         p <- paths
         let name = pathToName p
-        [ return $ SigD (mkName name) (ConT ''Bitmap)
+        [ return $ SigD (mkName name) (ConT ''Bitmap.Bitmap)
             , funD (mkName name) [clause [] (normalB $ load name $ loc </> p) []]
             ]
     where
@@ -44,7 +44,7 @@ 
             appE (varE 'unsafePerformIO) $ uInfixE (appE getFullPath $ litE $ StringL fp)
                 (varE '(>>=))
-                (varE 'readBitmap)
+                (varE 'Bitmap.readFile)
 
 -- | 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.

@@ -13,26 +13,44 @@ module Call.Types (
     Time
     , Vec2
+    , Vec3
+    , Stereo
     , WindowMode(..)
-    , BoundingBox2
+    , MouseEvent(..)
+    , Gamepad(..)
+    , GamepadEvent(..)
+    , Chatter(..)
     , Key(..)
     , charToKey
     , BlendMode(..)
+    , Vertex(..)
+    , positionUV
+    , positionOnly
+    , Bitmap(..)
     ) where
 
+import Control.Applicative
 import Linear
 import Data.Typeable
-import Data.BoundingBox
 import Data.Char
+import Foreign.Storable
+import Foreign.Ptr
+import Call.Data.Bitmap
 
-type Time = Double
+type Time = Float
+type Stereo = V2 Float
+type Vec2 = V2 Float
+type Vec3 = V3 Float
+data WindowMode = Windowed | Resizable | FullScreen deriving (Show, Eq, Ord, Read, Typeable)
 
-data WindowMode = Windowed | Resizable | FullScreen deriving (Show, Eq, Ord, Read)
+data Chatter a = Up a | Down a deriving (Show, Eq, Ord, Read, Typeable)
 
-type Vec2 = V2 Double
+data MouseEvent = Button (Chatter Int) | Cursor Vec2 | Scroll Vec2 deriving (Show, Eq, Ord, Read, Typeable)
 
-type BoundingBox2 = Box V2 Double
+data Gamepad = Gamepad Int String deriving (Show, Eq, Ord, Read, Typeable)
 
+data GamepadEvent = PadButton Gamepad (Chatter Int) | PadConnection (Chatter Gamepad) deriving (Show, Eq, Ord, Read, Typeable)
+
 data Key =
       KeyUnknown
     | KeySpace
@@ -183,4 +201,33 @@     | Add
     | Multiply
     | Screen
-    deriving (Enum, Eq, Ord, Read, Show, Typeable)+    deriving (Enum, Eq, Ord, Read, Show, Typeable)
+
+data Vertex = Vertex { vPos :: {-# UNPACK #-} !Vec3
+  , vUV :: {-# UNPACK #-} !Vec2
+  , vNormal :: {-# UNPACK #-} !Vec3 }
+  deriving (Show, Eq, Ord, Read, Typeable)
+
+align1 :: Int
+align1 = sizeOf (vPos undefined)
+
+align2 :: Int
+align2 = align1 + sizeOf (vUV undefined)
+
+instance Storable Vertex where
+  sizeOf _ = sizeOf (undefined :: Vec3) + sizeOf (undefined :: Vec2) + sizeOf (undefined :: Vec3)
+  alignment _ = 0
+  peek ptr = Vertex
+    <$> peek (castPtr ptr)
+    <*> peek (castPtr $ ptr `plusPtr` align1)
+    <*> peek (castPtr $ ptr `plusPtr` align2)
+  poke ptr (Vertex v t n) = do
+    poke (castPtr ptr) v
+    poke (castPtr ptr `plusPtr` align1) t
+    poke (castPtr ptr `plusPtr` align2) n
+
+positionUV :: Vec3 -> Vec2 -> Vertex
+positionUV v p = Vertex v p zero
+
+positionOnly :: Vec3 -> Vertex
+positionOnly v = Vertex v zero zero

@@ -1,28 +1,21 @@+{-# LANGUAGE FlexibleContexts, GADTs #-}
 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
+import Call.Sight
+import Control.Monad.State
+import qualified Call.Data.Bitmap as Bitmap
+import Data.Functor.Request
 
-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))
+readBitmap :: MonadIO m => FilePath -> m Bitmap.Bitmap
+readBitmap = Bitmap.readFile
 
-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+animate :: Monad m => (Time -> Sight) -> Object (Request Time Sight) m
+animate f = go (0 :: Float) where
+  go t = Object $ \(Request dt cont) -> return (cont $ f t, go (t + dt))
+
+transit :: MonadPlus m => Time -> (Time -> Sight) -> Object (Request Time Sight) m
+transit len f = go 0 where
+  go t
+    | t >= len = Object $ const mzero
+    | otherwise = Object $ \(Request dt cont) -> return (cont $ f (t / len), go (t + dt))

@@ -0,0 +1,53 @@+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeOperators #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Util.Deck
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- The deck for a single stream
+--
+-----------------------------------------------------------------------------
+module Call.Util.Deck (Deck(..), empty, source, pos, playing, playback) where
+import Control.Lens
+import Control.Monad.State.Class
+import Call.Data.Wave
+import Call.Types
+import qualified Data.Vector.Storable as V
+
+data Deck = Deck
+  { _src :: Source Stereo
+  , _pos :: !Time
+  , _playing :: !Bool }
+
+empty :: Deck
+empty = Deck (Source $ const 0) 0 False
+
+source :: Lens' Deck (Source Stereo)
+source f s = f (_src s) <&> \a -> s { _src = a }
+
+pos :: Lens' Deck Time
+pos f s = f (_pos s) <&> \a -> s { _pos = a }
+
+playing :: Lens' Deck Bool
+playing f s = f (_playing s) <&> \a -> s { _playing = a }
+
+playback :: MonadState Deck m => Time -> Int -> m (V.Vector Stereo)
+playback dt n = do
+  Source s <- use source
+  pl <- use playing
+  t0 <- use pos
+  if pl
+    then do
+      pos += dt
+      return $ V.fromList $ take n $ map s [t0,t0 + dt / fromIntegral n..]
+    else return $ V.replicate n 0

@@ -0,0 +1,49 @@+{-# LANGUAGE FlexibleContexts #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Call.Util.Deck
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- Polyphonic sampler
+--
+-----------------------------------------------------------------------------
+module Call.Util.Sampler where
+import qualified Data.Vector.Storable as V
+import qualified Data.Vector.Storable.Mutable as MV
+import Control.Monad.ST
+import Control.Monad.State.Class
+import Call.Types
+import Call.Data.Wave
+import Control.Monad
+
+data Sampler = Sampler [(Sample Stereo, Time)]
+
+empty :: Sampler
+empty = Sampler []
+
+playback :: MonadState Sampler m => Time -> Int -> m (V.Vector Stereo) 
+playback dt n = do
+  Sampler vs <- get
+  let (vs'', r) = runST $ do
+        v <- MV.new n
+        vs' <- forM vs $ \(s0@(Sample d (Source s)), t0) -> do
+          if d > t0 then return []
+            else do
+              forM_ [0..n-1] $ \i -> do
+                z <- MV.unsafeRead v i
+                MV.unsafeWrite v i $ z + s (t0 + f * fromIntegral i)
+              return [(s0, t0 + dt)]
+        v' <- V.unsafeFreeze v
+        return (vs', v')
+  put $ Sampler $ concat vs''
+  return r
+  where
+    f = dt / fromIntegral n
+
+play :: MonadState Sampler m => Sample Stereo -> m ()
+play s = modify $ \(Sampler xs) -> Sampler $ (s, 0) : xs