call 0.1.2 → 0.1.3

raw patch · 16 files changed

+1768/−1767 lines, 16 filesdep +extensibledep ~OpenGLdep ~elevatordep ~objective

Dependencies added: extensible

Dependency ranges changed: OpenGL, elevator, objective

Files

• call.cabal +94/−93
• examples/hello-world.hs +1/−1
• shaders/fragment.glsl +30/−30
• src/Call.hs +47/−47
• src/Call/Data/Bitmap.hs +101/−101
• src/Call/Data/Font.hs +120/−120
• src/Call/Data/Wave.hs +45/−45
• src/Call/Internal/GLFW.hs +226/−227
• src/Call/Internal/PortAudio.hs +1/−1
• src/Call/Sight.hs +183/−183
• src/Call/System.hs +453/−453
• src/Call/TH.hs +67/−67
• src/Call/Types.hs +232/−232
• src/Call/Util/Deck.hs +59/−59
• src/Call/Util/Sampler.hs +53/−53
• src/Call/Util/Text.hs +56/−55

@@ -1,93 +1,94 @@-name:                call
-version:             0.1.2
-synopsis:            The call game engine
-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
-author:              Fumiaki Kinoshita
-maintainer:          Fumiaki Kinoshita <fumiexcel@gmail.com>
-copyright:           (c) Fumiaki Kinoshita 2014
-category:            Game
-build-type:          Simple
-data-files:
-  shaders/*.glsl
-  data/*.ttf
-cabal-version:       >=1.10
-
-flag BuildHelloWorld
-  default: False
-
-flag GLForwardCompat
-  default: True
-
-flag GLCoreProfile
-  default: True
-
-source-repository head
-  type: git
-  location: https://github.com/fumieval/call.git
-
-library
-  exposed-modules:
-    Call
-    Call.Types
-    Call.TH
-    Call.System
-    Call.Sight
-    Call.Internal.GLFW
-    Call.Internal.PortAudio
-    Call.Data.Wave
-    Call.Data.Font
-    Call.Data.Bitmap
-    Call.Util.Deck
-    Call.Util.Sampler
-    Call.Util.Text
-  other-modules:
-    Paths_call
-  ghc-options: -Wall -fexcess-precision -O2
-  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,
-    bindings-portaudio,
-    boundingboxes >=0.2 && <0.4,
-    clean-unions >= 0.1 && <0.3,
-    colors >=0.3 && <0.4,
-    containers >=0.5 && <0.7,
-    control-bool >=0.2 && <0.4,
-    directory,
-    distributive == 0.4.*,
-    elevator,
-    filepath,
-    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.6.2 && <0.7,
-    OpenGL == 2.9.*,
-    OpenGLRaw >=1.4 && <1.7,
-    random ==1.*,
-    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,
-    minioperational >= 0.4.7 && <0.6,
-    deepseq
-  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.2, lens == 4.*
-  default-language:    Haskell2010
+name:                call+version:             0.1.3+synopsis:            The call game engine+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+author:              Fumiaki Kinoshita+maintainer:          Fumiaki Kinoshita <fumiexcel@gmail.com>+copyright:           (c) Fumiaki Kinoshita 2014+category:            Game+build-type:          Simple+data-files:+  shaders/*.glsl+  data/*.ttf+cabal-version:       >=1.10++flag BuildHelloWorld+  default: False++flag GLForwardCompat+  default: True++flag GLCoreProfile+  default: True++source-repository head+  type: git+  location: https://github.com/fumieval/call.git++library+  exposed-modules:+    Call+    Call.Types+    Call.TH+    Call.System+    Call.Sight+    Call.Internal.GLFW+    Call.Internal.PortAudio+    Call.Data.Wave+    Call.Data.Font+    Call.Data.Bitmap+    Call.Util.Deck+    Call.Util.Sampler+    Call.Util.Text+  other-modules:+    Paths_call+  ghc-options: -Wall -fexcess-precision -O2 -optc-ffast-math+  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,+    bindings-portaudio,+    boundingboxes >=0.2 && <0.4,+    clean-unions >= 0.1 && <0.3,+    colors >=0.3 && <0.4,+    containers >=0.5 && <0.7,+    control-bool >=0.2 && <0.4,+    directory,+    distributive == 0.4.*,+    elevator >= 0.2 && <0.3,+    extensible >= 0.2.6 && <0.3,+    filepath,+    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.6.5 && <0.7,+    OpenGL >= 2.9 && <2.12,+    OpenGLRaw >=1.4 && <1.7,+    random ==1.*,+    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,+    minioperational >= 0.4.7 && <0.6,+    deepseq+  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.2, lens == 4.*+  default-language:    Haskell2010

@@ -37,4 +37,4 @@     _ -> return ()
   deck .- playing .= True
   stand
- +

@@ -1,30 +1,30 @@-#version 330
-out vec4 fragColor;
-
-// Texture
-in vec2 UV;
-in vec2 envUV;
-
-in vec3 normal;
-in vec3 lightDir;
-
-uniform sampler2D env;
-uniform sampler2D tex;
-
-uniform vec4 diffuse;
-uniform float normalMix;
-uniform float textureMix;
-uniform float envAdd;
-uniform float envMul;
-
-void main(void){
-  // vec3 n = mix(normal, texture(normalMap, UV).rgb * 2 - 1, normalMix);
-
-  vec4 d = mix(vec4(1.0), texture(tex, UV).rgba, textureMix) * diffuse;
-
-  fragColor = vec4(d.rgb, d.a);
-
-  fragColor += texture(env, envUV).rgba * envAdd;
-  fragColor *= mix(vec4(1.0), texture(env, envUV).rgba, envMul);
-
-}
+#version 330+out vec4 fragColor;++// Texture+in vec2 UV;+in vec2 envUV;++in vec3 normal;+in vec3 lightDir;++uniform sampler2D env;+uniform sampler2D tex;++uniform vec4 diffuse;+uniform float normalMix;+uniform float textureMix;+uniform float envAdd;+uniform float envMul;++void main(void){+  // vec3 n = mix(normal, texture(normalMap, UV).rgb * 2 - 1, normalMix);++  vec4 d = mix(vec4(1.0), texture(tex, UV).rgba, textureMix) * diffuse;++  fragColor = vec4(d.rgb, d.a);++  fragColor += texture(env, envUV).rgba * envAdd;+  fragColor *= mix(vec4(1.0), texture(env, envUV).rgba, envMul);++}

@@ -1,47 +1,47 @@-{-# LANGUAGE Rank2Types #-}
-module Call ( -- * System
-    runSystemDefault,
-    readBitmap,
-    module Call.Sight,
-    module Call.System,
-    module Call.Types,
-    module Call.TH,
-    module Call.Data.Wave,
-    module Call.Data.Font,
-    -- * 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.Data.Wave
-import Call.Data.Font
-import Call.Sight
-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 Data.Monoid
-import Linear
-import Data.BoundingBox
-import qualified Call.Data.Bitmap as Bitmap
-
-runSystemDefault :: (forall s. System s a) -> IO (Maybe a)
-runSystemDefault = runSystem Windowed (Box (V2 0 0) (V2 640 480))
-
-readBitmap :: MonadIO m => FilePath -> m Bitmap.Bitmap
-readBitmap = Bitmap.readFile
+{-# LANGUAGE Rank2Types #-}+module Call ( -- * System+    runSystemDefault,+    readBitmap,+    module Call.Sight,+    module Call.System,+    module Call.Types,+    module Call.TH,+    module Call.Data.Wave,+    module Call.Data.Font,+    -- * 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.Data.Wave+import Call.Data.Font+import Call.Sight+import Call.System+import Control.Monad.IO.Class+import Control.Monad+import Control.Applicative+import Control.Bool+import Control.Object hiding (invoke)+import Control.Monad.Objective.Class+import Data.Color+import Data.Color.Names+import Data.Monoid+import Linear+import Data.BoundingBox+import qualified Call.Data.Bitmap as Bitmap++runSystemDefault :: (forall s. System s a) -> IO (Maybe a)+runSystemDefault = runSystem Windowed (Box (V2 0 0) (V2 640 480))++readBitmap :: MonadIO m => FilePath -> m Bitmap.Bitmap+readBitmap = Bitmap.readFile

@@ -1,101 +1,101 @@-{-# LANGUAGE TemplateHaskell #-}
------------------------------------------------------------------------------
--- |
--- 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 (
-  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 qualified Data.BoundingBox as B
-import Linear
-import System.Random
-import Control.Applicative
-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 = Blank | Bitmap { _image :: !(C.Image C.PixelRGBA8), _offset :: !(V2 Int), _hash :: !Int }
-
-image :: Traversal' Bitmap (C.Image C.PixelRGBA8)
-image _ Blank = pure Blank
-image f (Bitmap i o h) = f i <&> \i' -> Bitmap i' o h
-
-offset :: Traversal' Bitmap (V2 Int)
-offset _ Blank = pure Blank
-offset f (Bitmap i o h) = f o <&> \o' -> Bitmap i o' h
-
-hash :: Traversal' Bitmap Int
-hash _ Blank = pure Blank
-hash f (Bitmap i o h) = f h <&> \h' -> Bitmap i o h'
-
--- | `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
-
-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))
-
-clip Blank _ = Blank
-
-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"
-
+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------------------------+-- |+-- 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 (+  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 qualified Data.BoundingBox as B+import Linear+import System.Random+import Control.Applicative+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 = Blank | Bitmap { _image :: !(C.Image C.PixelRGBA8), _offset :: !(V2 Int), _hash :: !Int }++image :: Traversal' Bitmap (C.Image C.PixelRGBA8)+image _ Blank = pure Blank+image f (Bitmap i o h) = f i <&> \i' -> Bitmap i' o h++offset :: Traversal' Bitmap (V2 Int)+offset _ Blank = pure Blank+offset f (Bitmap i o h) = f o <&> \o' -> Bitmap i o' h++hash :: Traversal' Bitmap Int+hash _ Blank = pure Blank+hash f (Bitmap i o h) = f h <&> \h' -> Bitmap i o h'++-- | `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++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))++clip Blank _ = Blank++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"+

@@ -1,120 +1,120 @@------------------------------------------------------------------------------
--- |
--- 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
-  , defaultFont
-  , fontBoundingBox
-  , metricsAscent
-  , metricsDescent
-  , renderChar
-  ) where
-
-import Control.Applicative
-import Control.Monad.IO.Class
-import Control.Monad
-import Data.BoundingBox
-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
-import Paths_call
-
--- | Font object
-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 (F.bbox f)
-    asc <- peek (ascender f)
-    desc <- peek (descender f)
-    u <- fromIntegral <$> peek (units_per_EM f)
-    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 -> Float
-metricsAscent (Font _ (a, _) _) = a
-
--- | Get the font's metrics.
-metricsDescent :: Font -> Float
-metricsDescent (Font _ (_, d) _) = d
-
--- | Get the font's bounding box.
-fontBoundingBox :: Font -> Box V2 Float
-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
-
-renderChar :: Font -> Float -> Char -> IO (Bitmap, V2 Float, V2 Float)
-renderChar (Font face _ _) pixel ch = do
-  let dpi = 300
-
-  runFreeType $ ft_Set_Char_Size face 0 (floor $ pixel * 72 / fromIntegral dpi * 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 <- 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)
+-----------------------------------------------------------------------------+-- |+-- 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+  , defaultFont+  , fontBoundingBox+  , metricsAscent+  , metricsDescent+  , renderChar+  ) where++import Control.Applicative+import Control.Monad.IO.Class+import Control.Monad+import Data.BoundingBox+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+import Paths_call++-- | Font object+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 (F.bbox f)+    asc <- peek (ascender f)+    desc <- peek (descender f)+    u <- fromIntegral <$> peek (units_per_EM f)+    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 -> Float+metricsAscent (Font _ (a, _) _) = a++-- | Get the font's metrics.+metricsDescent :: Font -> Float+metricsDescent (Font _ (_, d) _) = d++-- | Get the font's bounding box.+fontBoundingBox :: Font -> Box V2 Float+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++renderChar :: Font -> Float -> Char -> IO (Bitmap, V2 Float, V2 Float)+renderChar (Font face _ _) pixel ch = do+  let dpi = 300++  runFreeType $ ft_Set_Char_Size face 0 (floor $ pixel * 72 / fromIntegral dpi * 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 <- 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)

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

@@ -1,227 +1,226 @@-{-# 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.Lens
-import Data.IORef
-import Call.Types
-import Data.BoundingBox
-import Control.Monad
-import Graphics.Rendering.OpenGL.GL.StateVar
-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
-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
-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 (Box V2 Float)
-  , theWindow :: GLFW.Window
-  , theProgram :: GL.Program
-  }
-
-type Texture = (GL.TextureObject, Double, Double)
-
-gf :: Float -> GL.GLfloat
-{-# INLINE gf #-}
-gf = unsafeCoerce
-
-gsizei :: Int -> GL.GLsizei
-{-# INLINE gsizei #-}
-gsizei = unsafeCoerce
-
-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 _ = do
-  GL.clear [GL.ColorBuffer, GL.DepthBuffer]
-
-endFrame :: System -> IO Bool
-endFrame sys = do
-  GLFW.swapBuffers $ theWindow sys
-  GLFW.pollEvents
-  GLFW.windowShouldClose (theWindow sys)
-
-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")
-
-  mon <- case mode of
-    FullScreen -> GLFW.getPrimaryMonitor
-    _ -> return Nothing
-
-  GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 3
-  GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 3
-  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
-
-  GLFW.swapInterval 1
-  -- GL.clearColor $= GL.Color4 1 1 1 1
-
-  (fw, fh) <- GLFW.getFramebufferSize win
-
-  rbox <- newIORef $ bbox & size zero .~ fmap fromIntegral (V2 fw fh)
-
-  GLFW.setFramebufferSizeCallback win $ Just $ \_ w h -> do
-      modifyIORef rbox $ size zero .~ fmap fromIntegral (V2 w h)
-
-  return $ System rbox win prog
-
-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
-
-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
-
-  GL.bindVertexArrayObject $= Just cubeVao
-  GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo
-
-  let stride = fromIntegral $ sizeOf (undefined :: Vertex)
-
-  GL.vertexAttribPointer vertexAttribute $=
-    (GL.ToFloat,GL.VertexArrayDescriptor 3 GL.Float stride nullPtr)
-
-  GL.vertexAttribArray vertexAttribute $= GL.Enabled
-  GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo
-
-  GL.vertexAttribPointer uvAttribute $=
-    (GL.ToFloat
-    ,GL.VertexArrayDescriptor 2 GL.Float stride (nullPtr `plusPtr` sizeOf (0 :: V3 CFloat)))
-  GL.vertexAttribArray uvAttribute $= GL.Enabled
-
-  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
-
-  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 loc0 <- GL.get $ GL.uniformLocation shaderProg "useEnv"
-  GL.glUniform1i loc0 0
-  GL.UniformLocation loc1 <- GL.get $ GL.uniformLocation shaderProg "tex"
-  GL.glUniform1i loc1 0
-  GL.UniformLocation loc2 <- GL.get $ GL.uniformLocation shaderProg "env"
-  GL.glUniform1i loc2 1
-  GL.UniformLocation loc3 <- GL.get $ GL.uniformLocation shaderProg "envAdd"
-  GL.glUniform1f loc3 0
-  GL.UniformLocation loc4 <- GL.get $ GL.uniformLocation shaderProg "envMul"
-  GL.glUniform1f loc4 0
-
-  GL.glPixelStorei GL.gl_UNPACK_ALIGNMENT 4
-  return shaderProg
-
-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
+{-# 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.Lens+import Data.IORef+import Call.Types+import Data.BoundingBox+import Control.Monad+import Graphics.Rendering.OpenGL.GL.StateVar+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+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+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 (Box V2 Float)+  , theWindow :: GLFW.Window+  , theProgram :: GL.Program+  }++type Texture = (GL.TextureObject, Double, Double)++gf :: Float -> GL.GLfloat+{-# INLINE gf #-}+gf = unsafeCoerce++gsizei :: Int -> GL.GLsizei+{-# INLINE gsizei #-}+gsizei = unsafeCoerce++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 _ = do+  GL.clear [GL.ColorBuffer, GL.DepthBuffer]++endFrame :: System -> IO Bool+endFrame sys = do+  GLFW.swapBuffers $ theWindow sys+  GLFW.pollEvents+  GLFW.windowShouldClose (theWindow sys)++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")++  mon <- case mode of+    FullScreen -> GLFW.getPrimaryMonitor+    _ -> return Nothing++  GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 3+  GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 3+  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++  GLFW.swapInterval 1+  -- GL.clearColor $= GL.Color4 1 1 1 1++  (fw, fh) <- GLFW.getFramebufferSize win++  rbox <- newIORef $ bbox & size zero .~ fmap fromIntegral (V2 fw fh)++  GLFW.setFramebufferSizeCallback win $ Just $ \_ w h -> do+      modifyIORef rbox $ size zero .~ fmap fromIntegral (V2 w h)++  return $ System rbox win prog++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++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++  GL.bindVertexArrayObject $= Just cubeVao+  GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo++  let stride = fromIntegral $ sizeOf (undefined :: Vertex)++  GL.vertexAttribPointer vertexAttribute $=+    (GL.ToFloat,GL.VertexArrayDescriptor 3 GL.Float stride nullPtr)++  GL.vertexAttribArray vertexAttribute $= GL.Enabled+  GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo++  GL.vertexAttribPointer uvAttribute $=+    (GL.ToFloat+    ,GL.VertexArrayDescriptor 2 GL.Float stride (nullPtr `plusPtr` sizeOf (0 :: V3 CFloat)))+  GL.vertexAttribArray uvAttribute $= GL.Enabled++  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++  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 loc0 <- GL.get $ GL.uniformLocation shaderProg "useEnv"+  GL.glUniform1i loc0 0+  GL.UniformLocation loc1 <- GL.get $ GL.uniformLocation shaderProg "tex"+  GL.glUniform1i loc1 0+  GL.UniformLocation loc2 <- GL.get $ GL.uniformLocation shaderProg "env"+  GL.glUniform1i loc2 1+  GL.UniformLocation loc3 <- GL.get $ GL.uniformLocation shaderProg "envAdd"+  GL.glUniform1f loc3 0+  GL.UniformLocation loc4 <- GL.get $ GL.uniformLocation shaderProg "envMul"+  GL.glUniform1f loc4 0++  return shaderProg++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

@@ -69,7 +69,7 @@ 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

@@ -1,183 +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(..)
-    , opacity
-    , 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
-
-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 Float -> a -> a
-  line :: [Vec a] -> a
-  polygon :: [Vec a] -> a
-  polygonOutline :: [Vec a] -> a
-  circle :: Normal a -> a
-  circleOutline :: Normal a -> a
-
-opacity :: Figure a => Float -> a -> a
-opacity p = color (V4 1 1 1 p)
-
-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 (V4 Float) r
---  | Specular (V3 Float) r
---  | Ambient (V3 Float) r
---  | NormalMap Bitmap r
-  | EmbedIO (IO r)
-  deriving Functor
-
-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.TriangleFan
-  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.TriangleFan
-  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
+{-# 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(..)+    , opacity+    , 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++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 Float -> a -> a+  line :: [Vec a] -> a+  polygon :: [Vec a] -> a+  polygonOutline :: [Vec a] -> a+  circle :: Normal a -> a+  circleOutline :: Normal a -> a++opacity :: Figure a => Float -> a -> a+opacity p = color (V4 1 1 1 p)++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 (V4 Float) r+--  | Specular (V3 Float) r+--  | Ambient (V3 Float) r+--  | NormalMap Bitmap r+  | EmbedIO (IO r)+  deriving Functor++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.TriangleFan+  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.TriangleFan+  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

@@ -1,453 +1,453 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE KindSignatures #-}
-{-# 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 #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Call.System
--- Copyright   :  (c) Fumiaki Kinoshita 2014
--- License     :  BSD3
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  experimental
--- Portability :  non-portable
---
------------------------------------------------------------------------------
-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.Data.Bitmap
-import Call.Sight
-import Call.Types
-import Control.Applicative
-import Control.Concurrent
-import Control.Exception
-import Control.Elevator
-import Control.Lens
-import Control.Monad.Objective
-import Control.Monad.Reader
-import Control.Object
-import Data.BoundingBox (Box(..))
-import Data.OpenUnion1.Clean
-import Data.IORef
-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 Unsafe.Coerce
-
-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 Affine a => Affine (System s a) where
-  type Vec (System s a) = Vec a
-  type Normal (System s a) = Normal a
-  translate t = fmap (translate t)
-  scale t = fmap (scale t)
-  rotateOn t = fmap (rotateOn t)
-
-instance Figure a => Figure (System s a) where
-  primitive p v = return $ primitive p v
-  color c = fmap (color c)
-  line = return . line
-  polygon = return . polygon
-  polygonOutline = return . polygonOutline
-  circle = return . circle
-  circleOutline = return . circleOutline
-
-instance Monoid a => Monoid (System s a) where
-  mempty = return mempty
-  mappend = liftA2 mappend
-
-instance ObjectiveBase (System s) where
-  data Inst (System s) f g = InstS (MVar (Object f g))
-  invoke mr gr (InstS m) e = do
-    c <- mr $ liftIO $ takeMVar m
-    (a, c') <- gr (runObject c e)
-    mr $ liftIO $ putMVar m c'
-    return a
-  new v = liftIO $ InstS `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
-
-mkSystem :: (Foundation s -> IO a) -> System s a
-mkSystem = unsafeCoerce
-
-forkSystem :: System s () -> System s ThreadId
-forkSystem m = mkSystem $ \fo -> forkIO (unSystem fo m)
-
-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)
-
-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
-  { 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 :: V4 Float -> 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 #-}
-
-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)
-
-  bs0' <- forM (IM.toList $ ps IM.\\ bs0) $ \(i, p@(Gamepad _ s)) -> do
-    unSystem fo $ m $ PadConnection $ Up p
-    return (i, (s, IM.empty))
-
-  bs0_ <- forM (IM.toList $ bs0 IM.\\ ps) $ \(i, (s, _)) -> do
-    unSystem fo $ m $ PadConnection $ Down $ Gamepad i s
-    return (i, ())
-
-  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
-  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
-
-audioProcess :: Foundation s -> Int -> IO (V.Vector Stereo)
-audioProcess fo n = do
-  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
-  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
-  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
-  m <- readIORef (coreMouse fo)
-  unSystem fo $ m $ Cursor $ fmap realToFrac $ V2 x y
-
-scrollCallback :: Foundation s -> GLFW.ScrollCallback
-scrollCallback fo _ x y = do
-  m <- readIORef (coreMouse fo)
-  unSystem fo $ m $ Scroll $ fmap realToFrac $ V2 x y
-
-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
-
-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))
-
-  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 "textureMix"
-  s (pure $ return ()) (liftA2 (>>)) (prim locT) fx trans (V4 1 1 1 1, 0)
-  where
-    shaderProg = G.theProgram $ theSystem fo
-    prim locT Blank mode vs _ = do
-      GL.glUniform1f 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.glUniform1f locT 1
-      (tex, _, _) <- fetchTexture fo bmp h
-      GL.activeTexture $= GL.TextureUnit 0
-      GL.textureBinding GL.Texture2D $= Just tex
-      GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
-      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 (EmbedIO m) c = m >>= ($ c)
-    fx (Diffuse col m) (color0, n) = do
-      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "diffuse"
-      let c = 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
-      withLoc "useEnv" $ \loc -> GL.glUniform1i loc 1
-      withLoc "envAdd" $ \loc -> GL.glUniform1f 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
-      withLoc "useEnv" $ \loc -> GL.glUniform1i loc 0
-      withLoc "envAdd" $ \loc -> GL.glUniform1f loc 0
-    fx (SphericalAdd Blank m) c = m c
-    fx (SphericalMultiply (Bitmap bmp _ h) m) c = do
-      withLoc "useEnv" $ \loc -> GL.glUniform1i loc 1
-      withLoc "envMul" $ \loc -> GL.glUniform1f 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
-      withLoc "useEnv" $ \loc -> GL.glUniform1i loc 0
-      withLoc "envMul" $ \loc -> GL.glUniform1f loc 0
-    fx (SphericalMultiply Blank m) c = m c
-    withLoc str m = do
-      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg str
-      m loc
-
-drawSight :: Foundation s -> Sight -> IO ()
-drawSight fo (Sight s) = do
-  b <- readIORef $ G.refRegion $ theSystem fo
-  s b (return ()) (>>) (drawScene fo)
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE KindSignatures #-}+{-# 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 #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Call.System+-- Copyright   :  (c) Fumiaki Kinoshita 2014+-- License     :  BSD3+--+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-----------------------------------------------------------------------------+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.Data.Bitmap+import Call.Sight+import Call.Types+import Control.Applicative+import Control.Concurrent+import Control.Exception+import Control.Elevator+import Control.Lens+import Control.Monad.Objective+import Control.Monad.Reader+import Control.Object+import Data.BoundingBox (Box(..))+import Data.IORef+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 Unsafe.Coerce+import Data.Extensible++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 Affine a => Affine (System s a) where+  type Vec (System s a) = Vec a+  type Normal (System s a) = Normal a+  translate t = fmap (translate t)+  scale t = fmap (scale t)+  rotateOn t = fmap (rotateOn t)++instance Figure a => Figure (System s a) where+  primitive p v = return $ primitive p v+  color c = fmap (color c)+  line = return . line+  polygon = return . polygon+  polygonOutline = return . polygonOutline+  circle = return . circle+  circleOutline = return . circleOutline++instance Monoid a => Monoid (System s a) where+  mempty = return mempty+  mappend = liftA2 mappend++instance ObjectiveBase (System s) where+  data Inst (System s) f g = InstS (MVar (Object f g))+  invoke mr gr (InstS m) e = do+    c <- mr $ liftIO $ takeMVar m+    (a, c') <- gr (runObject c e)+    mr $ liftIO $ putMVar m c'+    return a+  new v = liftIO $ InstS `fmap` newMVar v++instance Tower (System s) where+  type Floors (System s) = Floors IO+  stairs = hmap (\(Gondola f) -> Gondola (liftIO . f)) stairs++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)++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)++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+  { 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 :: V4 Float -> 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 #-}++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)++  bs0' <- forM (IM.toList $ ps IM.\\ bs0) $ \(i, p@(Gamepad _ s)) -> do+    unSystem fo $ m $ PadConnection $ Up p+    return (i, (s, IM.empty))++  bs0_ <- forM (IM.toList $ bs0 IM.\\ ps) $ \(i, (s, _)) -> do+    unSystem fo $ m $ PadConnection $ Down $ Gamepad i s+    return (i, ())++  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+  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++audioProcess :: Foundation s -> Int -> IO (V.Vector Stereo)+audioProcess fo n = do+  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+  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+  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+  m <- readIORef (coreMouse fo)+  unSystem fo $ m $ Cursor $ fmap realToFrac $ V2 x y++scrollCallback :: Foundation s -> GLFW.ScrollCallback+scrollCallback fo _ x y = do+  m <- readIORef (coreMouse fo)+  unSystem fo $ m $ Scroll $ fmap realToFrac $ V2 x y++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++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))++  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 "textureMix"+  s (pure $ return ()) (liftA2 (>>)) (prim locT) fx trans (V4 1 1 1 1, 0)+  where+    shaderProg = G.theProgram $ theSystem fo+    prim locT Blank mode vs _ = do+      GL.glUniform1f 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.glUniform1f locT 1+      (tex, _, _) <- fetchTexture fo bmp h+      GL.activeTexture $= GL.TextureUnit 0+      GL.textureBinding GL.Texture2D $= Just tex+      GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')+      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 (EmbedIO m) c = m >>= ($ c)+    fx (Diffuse col m) (color0, n) = do+      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "diffuse"+      let c = 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+      withLoc "useEnv" $ \loc -> GL.glUniform1i loc 1+      withLoc "envAdd" $ \loc -> GL.glUniform1f 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+      withLoc "useEnv" $ \loc -> GL.glUniform1i loc 0+      withLoc "envAdd" $ \loc -> GL.glUniform1f loc 0+    fx (SphericalAdd Blank m) c = m c+    fx (SphericalMultiply (Bitmap bmp _ h) m) c = do+      withLoc "useEnv" $ \loc -> GL.glUniform1i loc 1+      withLoc "envMul" $ \loc -> GL.glUniform1f 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+      withLoc "useEnv" $ \loc -> GL.glUniform1i loc 0+      withLoc "envMul" $ \loc -> GL.glUniform1f loc 0+    fx (SphericalMultiply Blank m) c = m c+    withLoc str m = do+      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg str+      m loc++drawSight :: Foundation s -> Sight -> IO ()+drawSight fo (Sight s) = do+  b <- readIORef $ G.refRegion $ theSystem fo+  s b (return ()) (>>) (drawScene fo)

@@ -1,67 +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 qualified Call.Data.Bitmap as 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.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 '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.
-
-
-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 = '_'
+{-# 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 qualified Call.Data.Bitmap as 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.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 '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.+++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 = '_'

@@ -1,233 +1,233 @@-{-# 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
-    , Vec3
-    , Stereo
-    , WindowMode(..)
-    , MouseEvent(..)
-    , Gamepad(..)
-    , GamepadEvent(..)
-    , Chatter(..)
-    , Key(..)
-    , charToKey
-    , BlendMode(..)
-    , Vertex(..)
-    , positionUV
-    , positionOnly
-    , Bitmap(..)
-    ) where
-
-import Control.Applicative
-import Linear
-import Data.Typeable
-import Data.Char
-import Foreign.Storable
-import Foreign.Ptr
-import Call.Data.Bitmap
-
-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 Chatter a = Up a | Down a deriving (Show, Eq, Ord, Read, Typeable)
-
-data MouseEvent = Button (Chatter Int) | Cursor Vec2 | Scroll Vec2 deriving (Show, Eq, Ord, Read, Typeable)
-
-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
-    | 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)
-
-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
+{-# 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+    , Vec3+    , Stereo+    , WindowMode(..)+    , MouseEvent(..)+    , Gamepad(..)+    , GamepadEvent(..)+    , Chatter(..)+    , Key(..)+    , charToKey+    , BlendMode(..)+    , Vertex(..)+    , positionUV+    , positionOnly+    , Bitmap(..)+    ) where++import Control.Applicative+import Linear+import Data.Typeable+import Data.Char+import Foreign.Storable+import Foreign.Ptr+import Call.Data.Bitmap++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 Chatter a = Up a | Down a deriving (Show, Eq, Ord, Read, Typeable)++data MouseEvent = Button (Chatter Int) | Cursor Vec2 | Scroll Vec2 deriving (Show, Eq, Ord, Read, Typeable)++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+    | 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)++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,59 +1,59 @@-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE ConstraintKinds #-}
------------------------------------------------------------------------------
--- |
--- 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, playbackOf) where
-import Control.Lens
-import Control.Monad.State.Strict
-import Call.Data.Wave
-import Call.Types
-import qualified Data.Vector.Storable as V
-import Control.Monad.Objective
-import Control.Elevator
-
-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
-
-playbackOf :: (MonadObjective b m, Elevate n m) => Inst b (State Deck) n -> Time -> Int -> m (V.Vector Stereo)
-playbackOf i = \dt n -> i .^ playback dt n
+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+-----------------------------------------------------------------------------+-- |+-- 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, playbackOf) where+import Control.Lens+import Control.Monad.State.Strict+import Call.Data.Wave+import Call.Types+import qualified Data.Vector.Storable as V+import Control.Monad.Objective+import Control.Elevator++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++playbackOf :: (MonadObjective b m, Elevate n m) => Inst b (State Deck) n -> Time -> Int -> m (V.Vector Stereo)+playbackOf i = \dt n -> i .- playback dt n

@@ -1,53 +1,53 @@-{-# LANGUAGE FlexibleContexts, ConstraintKinds #-}
------------------------------------------------------------------------------
--- |
--- 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.Strict
-import Call.Types
-import Call.Data.Wave
-import Control.Monad.Objective
-import Control.Elevator
-
-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
-
-playbackOf :: (MonadObjective b m, Elevate n m) => Inst b (State Sampler) n -> Time -> Int -> m (V.Vector Stereo)
-playbackOf i = \dt n -> i .^ playback dt n
+{-# LANGUAGE FlexibleContexts, ConstraintKinds #-}+-----------------------------------------------------------------------------+-- |+-- 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.Strict+import Call.Types+import Call.Data.Wave+import Control.Monad.Objective+import Control.Elevator++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++playbackOf :: (MonadObjective b m, Elevate n m) => Inst b (State Sampler) n -> Time -> Int -> m (V.Vector Stereo)+playbackOf i = \dt n -> i .- playback dt n

@@ -1,55 +1,56 @@-{-# LANGUAGE ConstraintKinds, FlexibleContexts, BangPatterns #-}
-module Call.Util.Text where
-import Prelude hiding (putStr)
-import Call.Data.Bitmap (Bitmap(..))
-import Call.Data.Font
-import Call.Sight
-import Control.Lens
-import Control.Monad.Objective
-import Control.Monad.Operational.Mini
-import Control.Monad.State.Class
-import Control.Monad.Trans
-import Control.Object
-import Data.Functor.PushPull
-import Data.Functor.Request
-import Data.Monoid
-import Linear
-import Control.DeepSeq
-
-renderer :: MonadIO m => Font -> Float -> Object (Request Char (Bitmap, V2 Float, V2 Float)) m
-renderer font size = flyweight (liftIO . renderChar font size)
-
-typewriter :: MonadIO m => Float -> (Char -> m (Bitmap, V2 Float, V2 Float)) -> Object (ReifiedProgram (PushPull Char Picture)) m
-typewriter l req = sequential $ stateful go (V2 0 0, mempty) where
-  go (Push '\3' cont) = do
-    put (V2 0 0, mempty)
-    return cont
-  go (Push '\r' cont) = return cont
-  go (Push '\n' cont) = do
-    _1 . _y += l
-    _1 . _x .= 0
-    return cont
-  go (Push ch cont) = do
-    (pos, pic) <- get
-    (!bmp@(Bitmap img _ _), !ofs, !adv) <- lift $ req ch
-    return $! rnf img
-    put (pos + adv, pic <> translate (pos + ofs) (bitmap bmp))
-    return cont
-  go (Pull cont) = uses _2 cont
-
-putStr :: String -> ReifiedProgram (PushPull Char Picture) ()
-putStr [] = return ()
-putStr (c:cs) = Push c () :>>= const (putStr cs)
-
-clear :: ReifiedProgram (PushPull Char Picture) ()
-clear = Push '\3' () :>>= return
-
-simple :: MonadIO m => Font -> Float -> m (String -> Picture)
-simple font size = liftIO $ do
-  r <- new $ renderer font size
-  t <- new $ typewriter (size * 1.2) ((r.-) . request)
-  return $ \s -> Picture $ applyVFX $ EmbedIO $ do
-    t .- putStr s
-    p <- t .- (Pull id :>>= return)
-    t .- clear
-    return $! unPicture p
+{-# LANGUAGE ConstraintKinds, FlexibleContexts, BangPatterns #-}+module Call.Util.Text (renderer, typewriter, putStr, clear, simple) where+import Prelude hiding (putStr)+import Call.Data.Bitmap (Bitmap(..))+import Call.Data.Font+import Call.Sight+import Control.Lens hiding (simple)+import Control.Monad.Objective+import Control.Monad.Operational.Mini+import Control.Monad.State.Class+import Control.Monad.Trans+import Control.Object+import Data.Monoid+import Linear+import Control.DeepSeq++renderer :: MonadIO m => Font -> Float -> Object (Request Char (Bitmap, V2 Float, V2 Float)) m+renderer font size = flyweight (liftIO . renderChar font size)++typewriter :: MonadIO m => Float -> (Char -> m (Bitmap, V2 Float, V2 Float)) -> Object (ReifiedProgram (PushPull Char Picture)) m+typewriter l req = sequential $ stateful go (V2 0 0, mempty) where+  go (Push '\3' cont) = do+    put (V2 0 0, mempty)+    return cont+  go (Push '\r' cont) = return cont+  go (Push '\n' cont) = do+    _1 . _y += l+    _1 . _x .= 0+    return cont+  go (Push ch cont) = do+    (pos, pic) <- get+    (!bmp@(Bitmap img _ _), !ofs, !adv) <- lift $ req ch+    return $! rnf img+    put (pos + adv, pic <> translate (pos + ofs) (bitmap bmp))+    return cont+  go (Pull cont) = uses _2 cont++putStr :: String -> ReifiedProgram (PushPull Char Picture) ()+putStr [] = return ()+putStr (c:cs) = Push c () :>>= const (putStr cs)++clear :: ReifiedProgram (PushPull Char Picture) ()+clear = Push '\3' () :>>= return++new' :: ObjectiveBase b => Object f b -> b (Inst b f b)+new' = new++simple :: MonadIO m => Font -> Float -> m (String -> Picture)+simple font size = liftIO $ do+  r <- new' $ renderer font size+  t <- new' $ typewriter (size * 1.2) ((r.-) . request)+  return $ \s -> Picture $ applyVFX $ EmbedIO $ do+    t .- putStr s+    p <- t .- (Pull id :>>= return)+    t .- clear+    return $! unPicture p