call 0.1.4.2 → 0.2
raw patch · 16 files changed
+452/−1422 lines, 16 filesdep +audiovisualdep +reflection
Dependencies added: audiovisual, reflection
Files
- call.cabal +4/−12
- data/VL-PGothic-Regular.ttf too large to diff
- shaders/fragment.glsl +11/−6
- shaders/vertex.glsl +8/−4
- src/Call.hs +420/−30
- src/Call/Data/Bitmap.hs +0/−101
- src/Call/Data/Font.hs +0/−120
- src/Call/Data/Wave.hs +0/−55
- src/Call/Internal/GLFW.hs +9/−10
- src/Call/Sight.hs +0/−183
- src/Call/System.hs +0/−436
- src/Call/TH.hs +0/−67
- src/Call/Types.hs +0/−233
- src/Call/Util/Deck.hs +0/−58
- src/Call/Util/Sampler.hs +0/−52
- src/Call/Util/Text.hs +0/−55
call.cabal view
@@ -1,5 +1,5 @@ name: call-version: 0.1.4.2+version: 0.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@@ -12,7 +12,6 @@ build-type: Simple data-files: shaders/*.glsl- data/*.ttf cabal-version: >=1.10 flag BuildHelloWorld@@ -31,25 +30,17 @@ 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:+ audiovisual, base >=4.6 && <5, bindings-portaudio,+ audiovisual, boundingboxes >=0.2 && <0.4, colors >=0.3 && <0.4, containers >=0.5 && <0.7,@@ -74,6 +65,7 @@ transformers >=0.3 && <0.5, vector >=0.9 && <0.13, WAVE >=0.1 && <0.2,+ reflection, deepseq hs-source-dirs: src default-language: Haskell2010
− data/VL-PGothic-Regular.ttf
file too large to diff
shaders/fragment.glsl view
@@ -2,24 +2,29 @@ out vec4 fragColor; // Texture-in vec2 UV;-in vec2 envUV;+in vec2 texUV; in vec3 normal; in vec3 lightDir; -uniform sampler2D env; uniform sampler2D tex;+uniform sampler2D normalMap; uniform vec4 diffuse;+uniform vec3 specular; uniform float normalMix; uniform float textureMix; void main(void){- // vec3 n = mix(normal, texture(normalMap, UV).rgb * 2 - 1, normalMix);+ vec3 n = mix(normal, texture(normalMap, texUV).rgb * 2 - 1, normalMix); - vec4 d = mix(vec4(1.0), texture(tex, UV).rgba, textureMix) * diffuse;+ vec4 d = mix(vec4(1.0), texture(tex, texUV).rgba, textureMix) * diffuse; - fragColor = vec4(d.rgb, d.a);+ vec3 view = vec3(0,0,1);+ float brightness = 1.0;++ float shine = dot(reflect(lightDir, n), view);++ fragColor = vec4(d.rgb * brightness + specular * shine, d.a); }
shaders/vertex.glsl view
@@ -2,13 +2,15 @@ uniform mat4 projection; uniform mat4 matrices[13]; uniform int level;-uniform bool useEnv;-out vec2 UV;-out vec2 envUV;+ in vec3 in_Position; in vec2 in_UV; in vec3 in_Normal; +out vec2 texUV;+out vec3 normal;+out vec3 lightDir;+ void main(void) { mat4 model = mat4(1.0); for(int i=0; i < level; i++)@@ -16,5 +18,7 @@ model *= matrices[i]; } gl_Position = projection * model * vec4(in_Position, 1.0);- UV = in_UV;+ texUV = in_UV;+ normal = in_Normal;+ lightDir = vec3(0.0, 0.0, 0.0); }
src/Call.hs view
@@ -1,45 +1,435 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-} {-# 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,+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE CPP #-}+module Call (+ runCallDefault+ , readBitmap+ -- * The system+ , Call+ , Foundation+ , runCall+ , WindowMode(..)+ -- * Time+ , stand+ , wait+ , getTime+ , setFPS+ , getSlowdown+ , getFPS+ -- * Raw input+ , keyPress+ , mousePosition+ , mouseButton+ , enableCursor+ , hideCursor+ , disableCursor+ , getGamepads+ , gamepadButtons+ , gamepadAxes+ -- * Component+ , linkGraphic+ , linkPicture+ , linkAudio+ , linkKeyboard+ , linkMouse+ , linkGamepad+ -- * Others+ , setTitle+ , clearColor+ , getBoundingBox+ , setBoundingBox+ , takeScreenshot -- * 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.IO.Class+ , module Data.Audio+ , module Data.Graphics+ , module Data.Input.Event+ , 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.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.Concurrent+import Control.Exception+import Control.Lens+import Control.Monad hiding (sequence, sequence_, mapM, mapM_, forM, forM_, msum)+import Control.Monad.IO.Class import Control.Object+import Data.Audio+import Data.BoundingBox import Data.Color import Data.Color.Names+import Data.Traversable as T+import Data.Foldable as F hiding (foldr)+import Data.Typeable+import Data.Graphics as U+import Data.Graphics+import Data.Graphics.Bitmap as Bitmap+import Data.Input.Event+import Data.IORef+import Data.Maybe import Data.Monoid+import Data.Reflection+import Foreign (castPtr, sizeOf, with)+import Graphics.Rendering.OpenGL.GL.StateVar import Linear-import Data.BoundingBox-import qualified Call.Data.Bitmap as Bitmap+import qualified Call.Internal.GLFW as G+import qualified Call.Internal.PortAudio as PA+import qualified Codec.Picture as C+import qualified Data.Map.Strict as Map+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 -runSystemDefault :: (forall s. System s a) -> IO (Maybe a)-runSystemDefault = runSystem Windowed (Box (V2 0 0) (V2 640 480))+data WindowMode = Windowed | Resizable | FullScreen deriving (Show, Eq, Ord, Read, Typeable) +runCallDefault :: (Call => IO a) -> IO (Maybe a)+runCallDefault = runCall Windowed (Box (V2 0 0) (V2 640 480))+ readBitmap :: MonadIO m => FilePath -> m Bitmap.Bitmap readBitmap = Bitmap.readFile++setFPS :: Call => Float -> IO ()+setFPS f = writeIORef (targetFPS given) f++-- | @(Actual FPS) = (Target FPS) / (1 + (Slowdown))@+getFPS :: Call => IO Float+getFPS = do+ t <- readIORef (targetFPS given)+ r <- getSlowdown+ return $ t / (1 + r)++type Call = Given Foundation++linkGraphic :: Call => (Time -> IO Sight) -> IO ()+linkGraphic f = do+ g <- readIORef $ coreGraphic given+ writeIORef (coreGraphic given) $ \dt -> liftA2 (<>) (f dt) (g dt)++linkPicture :: Call => (Time -> IO Picture) -> IO ()+linkPicture f = linkGraphic (fmap viewPicture . f)++linkAudio :: Call => (Time -> Int -> IO (V.Vector Stereo)) -> IO ()+linkAudio f = do+ g <- readIORef $ coreAudio given+ writeIORef (coreAudio given) $ \dt n -> liftA2 (V.zipWith (+)) (f dt n) (g dt n)++linkKeyboard :: Call => (Chatter Key -> IO ()) -> IO ()+linkKeyboard f = do+ g <- readIORef $ coreKeyboard given+ writeIORef (coreKeyboard given) $ \k -> f k >> g k++linkMouse :: Call => (MouseEvent -> IO ()) -> IO ()+linkMouse f = do+ g <- readIORef $ coreMouse given+ writeIORef (coreMouse given) $ \k -> f k >> g k++linkGamepad :: Call => (GamepadEvent -> IO ()) -> IO ()+linkGamepad f = do+ g <- readIORef $ coreJoypad given+ writeIORef (coreJoypad given) $ \k -> f k >> g k++data Foundation = Foundation+ { sampleRate :: Float+ , coreGraphic :: IORef (Time -> IO Sight)+ , coreAudio :: IORef (Time -> Int -> IO (V.Vector (V2 Float)))+ , coreKeyboard :: IORef (Chatter Key -> IO ())+ , coreMouse :: IORef (MouseEvent -> IO ())+ , coreJoypad :: IORef (GamepadEvent -> IO ())+ , 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))+ , slowdown :: IORef (Map.Map Time Time)+ }++runCall :: WindowMode -> Box V2 Float -> (Call => IO a) -> IO (Maybe a)+runCall mode box m = do+ sys <- G.beginGLFW (mode == FullScreen) (mode == Resizable) box+ fd <- 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+ <*> newIORef Map.empty+ let win = G.theWindow sys+ give fd $ do+ GLFW.setKeyCallback win $ Just keyCallback+ GLFW.setMouseButtonCallback win $ Just mouseButtonCallback+ GLFW.setCursorPosCallback win $ Just cursorPosCallback+ GLFW.setScrollCallback win $ Just scrollCallback+ 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)) (give fd m)+ give fd $ PA.with 44100 512 audioProcess $ liftIO $ do+ GLFW.setTime 0+ runGraphic 0+ G.endGLFW sys+ tryTakeMVar ref++stand :: Call => IO ()+stand = takeMVar (theEnd given)++wait :: Call => Time -> IO ()+wait dt = do+ t0 <- takeMVar (theTime given)+ Just t <- GLFW.getTime+ threadDelay $ floor $ (t0 - realToFrac t + dt) * 1000 * 1000+ putMVar (theTime given) $ t0 + dt++getTime :: Call => IO Time+getTime = readMVar (theTime given)++keyPress :: Call => Key -> IO Bool+keyPress k = fmap (/=GLFW.KeyState'Released)+ $ GLFW.getKey (G.theWindow $ theSystem given) (toEnum . fromEnum $ k)++mousePosition :: Call => IO (V2 Float)+mousePosition = do+ (x, y) <- GLFW.getCursorPos (G.theWindow $ theSystem given)+ return $ V2 (realToFrac x) (realToFrac y)++hideCursor :: Call => IO ()+hideCursor = GLFW.setCursorInputMode (G.theWindow $ theSystem given) GLFW.CursorInputMode'Hidden++disableCursor :: Call => IO ()+disableCursor = GLFW.setCursorInputMode (G.theWindow $ theSystem given) GLFW.CursorInputMode'Disabled++enableCursor :: Call => IO ()+enableCursor = GLFW.setCursorInputMode (G.theWindow $ theSystem given) GLFW.CursorInputMode'Normal++mouseButton :: Int -> Call => IO Bool+mouseButton b = fmap (/=GLFW.MouseButtonState'Released)+ $ GLFW.getMouseButton (G.theWindow $ theSystem given) (toEnum b)++getGamepads :: Call => IO [Gamepad]+getGamepads = fmap catMaybes $ forM [(GLFW.Joystick'1)..]+ $ \j -> fmap (Gamepad (fromEnum j)) <$> GLFW.getJoystickName j++gamepadAxes :: Call => Gamepad -> IO [Float]+gamepadAxes (Gamepad i _) = maybe [] (map realToFrac) <$> GLFW.getJoystickAxes (toEnum i)++gamepadButtons :: Call => Gamepad -> IO [Bool]+gamepadButtons (Gamepad i _) = maybe [] (map (==GLFW.JoystickButtonState'Pressed)) <$> GLFW.getJoystickButtons (toEnum i)++clearColor :: Call => V4 Float -> IO ()+clearColor (V4 r g b a) = liftIO $ GL.clearColor $= GL.Color4 (realToFrac r) (realToFrac g) (realToFrac b) (realToFrac a)++setBoundingBox :: Call => Box V2 Float -> IO ()+setBoundingBox box@(Box (V2 x0 y0) (V2 x1 y1)) = do+ GLFW.setWindowSize (G.theWindow $ theSystem given) (floor (x1 - x0)) (floor (y1 - y0))+ writeIORef (G.refRegion $ theSystem given) box++getBoundingBox :: Call => IO (Box V2 Float)+getBoundingBox = readIORef (G.refRegion $ theSystem given)++takeScreenshot :: Call => IO Bitmap+takeScreenshot = G.screenshot (theSystem given) >>= liftImage'++setTitle :: Call => String -> IO ()+setTitle str = GLFW.setWindowTitle (G.theWindow $ theSystem given) str++pollGamepad :: Call => IO ()+pollGamepad = do+ m <- readIORef (coreJoypad given)+ ps <- IM.fromList <$> map (\p@(Gamepad i _) -> (i, p)) <$> getGamepads+ bs0 <- readIORef (theGamepadButtons given)++ bs0' <- forM (IM.toList $ ps IM.\\ bs0) $ \(i, p@(Gamepad _ s)) -> do+ m $ PadConnection $ Up p+ return (i, (s, IM.empty))++ bs0_ <- forM (IM.toList $ bs0 IM.\\ ps) $ \(i, (s, _)) -> do+ 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..] <$> gamepadButtons p+ forM_ bs $ \(i, v) -> case (v, maybe False id (bs1 ^? ix j . _2 . ix i)) of+ (False, True) -> m $ PadButton p (Up i)+ (True, False) -> m $ PadButton p (Down i)+ _ -> return ()+ return (j, (s, IM.fromList bs))++ writeIORef (theGamepadButtons given) $ foldr (uncurry IM.insert) bs1 ls++getSlowdown :: Call => IO Float+getSlowdown = do+ m <- readIORef (slowdown given)+ Just t0 <- GLFW.getTime+ return $ F.sum m++runGraphic :: Call => Time -> IO ()+runGraphic t0 = do+ pollGamepad+ fps <- readIORef (targetFPS given)+ G.beginFrame (theSystem given)+ m <- readIORef (coreGraphic given)+ pic <- m (1/fps) -- is it appropriate?+ drawSight pic+ b <- G.endFrame (theSystem given)++ Just t <- fmap (fmap realToFrac) $ GLFW.getTime++ case t0 + 1/fps - realToFrac t of+ dt | dt > 0 -> threadDelay $ floor $ dt * 1000 * 1000+ | otherwise -> modifyIORef' (slowdown given) $ \m -> m+ & at t ?~ negate dt+ & Map.split (t - 1)+ & snd++ tryTakeMVar (theEnd given) >>= \case+ Just _ -> return ()+ _ | b -> putMVar (theEnd given) ()+ | otherwise -> runGraphic (max t (t0 + 1/fps))++audioProcess :: Call => Int -> IO (V.Vector Stereo)+audioProcess n = do+ let dt = fromIntegral n / sampleRate given+ m <- readIORef (coreAudio given)+ m dt n++keyCallback :: Call => GLFW.KeyCallback+keyCallback _ k _ st _ = do+ m <- readIORef (coreKeyboard given)+ m $ case st of+ GLFW.KeyState'Released -> Up (toEnum . fromEnum $ k :: Key)+ _ -> Down (toEnum . fromEnum $ k :: Key)++mouseButtonCallback :: Call => GLFW.MouseButtonCallback+mouseButtonCallback _ btn st _ = do+ m <- readIORef (coreMouse given)+ m $ case st of+ GLFW.MouseButtonState'Released -> Button $ Up (fromEnum btn)+ _ -> Button $ Down (fromEnum btn)++cursorPosCallback :: Call => GLFW.CursorPosCallback+cursorPosCallback _ x y = do+ m <- readIORef (coreMouse given)+ m $ Cursor $ fmap realToFrac $ V2 x y++scrollCallback :: Call => GLFW.ScrollCallback+scrollCallback _ x y = do+ m <- readIORef (coreMouse given)+ m $ Scroll $ fmap realToFrac $ V2 x y++fetchTexture :: Call => C.Image C.PixelRGBA8 -> Int -> IO G.Texture+fetchTexture bmp h = do+ st <- readIORef (textures given)+ case IM.lookup h st of+ Just t -> return t+ Nothing -> do+ t <- G.installTexture bmp+ writeIORef (textures given) $ IM.insert h t st+ return t++drawScene :: Call => Box V2 Float -> M44 Float -> Bool -> Scene -> IO ()+drawScene (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 locTextureMix <- GL.get $ GL.uniformLocation shaderProg "textureMix"+ GL.UniformLocation locMats <- GL.get $ GL.uniformLocation shaderProg "matrices"+ GL.UniformLocation locLevel <- GL.get $ GL.uniformLocation shaderProg "level"+ GL.UniformLocation locDiffuse <- GL.get $ GL.uniformLocation shaderProg "diffuse"+ with (V4 1 1 (1 :: Float) 1) $ \ptr -> GL.glUniform4fv locDiffuse 1 (castPtr ptr)+ s (pure $ return ()) (liftA2 (>>)) (prim locTextureMix) (fx locDiffuse) (trans locMats locLevel) (V4 1 1 1 1, 0)+ where+ shaderProg = G.theProgram $ theSystem given+ prim locTextureMix Blank mode vs _ = do+ GL.glUniform1f locTextureMix 0+ V.unsafeWith vs $ \v -> GL.bufferData GL.ArrayBuffer $=+ (fromIntegral $ V.length vs * sizeOf (undefined :: Vertex), v, GL.StaticDraw)+ GL.drawArrays (convPrimitiveMode mode) 0 $ fromIntegral $ V.length vs++ prim locTextureMix (Bitmap bmp _ h) mode vs _ = do+ GL.glUniform1f locTextureMix 1+ (tex, _, _) <- fetchTexture 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 (convPrimitiveMode mode) 0 $ fromIntegral $ V.length vs++ trans locMats locLevel f m (color0, n) = do+ with f $ \ptr -> GL.glUniformMatrix4fv (locMats + n) 1 1 (castPtr ptr)+ GL.glUniform1i locLevel (unsafeCoerce $ n + 1)+ () <- m (color0, n + 1)+ GL.glUniform1i locLevel (unsafeCoerce n)++ fx locDiffuse (EmbedIO m) c = m >>= ($ c)++ fx locDiffuse (Diffuse col m) (color0, n) = do+ let c = col * color0+ with c $ \ptr -> GL.glUniform4fv locDiffuse 1 (castPtr ptr)+ m (c, n)+ with color0 $ \ptr -> GL.glUniform4fv locDiffuse 1 (castPtr ptr)++drawSight :: Call => Sight -> IO ()+drawSight (Sight s) = do+ b <- readIORef $ G.refRegion $ theSystem given+ s b (return ()) (>>) drawScene++convPrimitiveMode :: U.PrimitiveMode -> GL.PrimitiveMode+convPrimitiveMode U.LineStrip = GL.LineStrip+convPrimitiveMode U.TriangleFan = GL.TriangleFan+convPrimitiveMode U.TriangleStrip = GL.TriangleStrip+convPrimitiveMode U.LineLoop = GL.LineLoop
− src/Call/Data/Bitmap.hs
@@ -1,101 +0,0 @@-{-# 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"-
− src/Call/Data/Font.hs
@@ -1,120 +0,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)
− src/Call/Data/Wave.hs
@@ -1,55 +0,0 @@-{-# LANGUAGE BangPatterns, DeriveFunctor #-}--------------------------------------------------------------------------------- |--- 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-import Data.Monoid-import Control.Applicative--newtype Source a = Source (Time -> a) deriving Functor--instance Applicative Source where- pure a = Source (const a)- Source f <*> Source g = Source (f <*> g)--instance Num a => Monoid (Source a) where- mempty = pure 0- mappend = liftA2 (+)--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
src/Call/Internal/GLFW.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns, DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Call.Internal.GLFW@@ -15,14 +15,14 @@ import Control.Applicative import Control.Lens import Data.IORef-import Call.Types import Data.BoundingBox+import Data.Graphics.Class+import Data.Graphics.Vertex 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.Rendering.OpenGL.GLU.Errors as GL import qualified Graphics.UI.GLFW as GLFW import Unsafe.Coerce import qualified Data.Vector.Storable as V@@ -75,24 +75,22 @@ GLFW.pollEvents GLFW.windowShouldClose (theWindow sys) -beginGLFW :: WindowMode -> Box V2 Float -> IO System-beginGLFW mode bbox@(Box (V2 x0 y0) (V2 x1 y1)) = do+beginGLFW :: Bool -> Bool -> Box V2 Float -> IO System+beginGLFW full resiz 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+ mon <- if full then GLFW.getPrimaryMonitor else return Nothing GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 3 GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 2 GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core GLFW.windowHint $ GLFW.WindowHint'OpenGLForwardCompat True - GLFW.windowHint $ GLFW.WindowHint'Resizable $ mode == Resizable+ GLFW.windowHint $ GLFW.WindowHint'Resizable resiz win <- GLFW.createWindow ww wh title mon Nothing >>= maybe (fail "Failed to create a window") return GLFW.makeContextCurrent (Just win) prog <- initializeGL@@ -172,7 +170,7 @@ GL.lineSmooth $= GL.Enabled GL.textureFunction $= GL.Combine- GL.clearColor $= GL.Color4 1 1 1 1+ GL.clearColor $= GL.Color4 0 0 0 1 GL.UniformLocation loc0 <- GL.get $ GL.uniformLocation shaderProg "useEnv" GL.glUniform1i loc0 0 GL.UniformLocation loc1 <- GL.get $ GL.uniformLocation shaderProg "tex"@@ -183,6 +181,7 @@ GL.glUniform1f loc3 0 GL.UniformLocation loc4 <- GL.get $ GL.uniformLocation shaderProg "envMul" GL.glUniform1f loc4 0+ GL.cullFace $= Just GL.Back return shaderProg
− src/Call/Sight.hs
@@ -1,183 +0,0 @@-{-# 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
− src/Call/System.hs
@@ -1,436 +0,0 @@-{-# 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.Lens-import Control.Monad.Reader-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--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--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.textureBinding GL.Texture2D $= Just tex- GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')- 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.textureBinding GL.Texture2D $= Just tex- GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')- 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)
− src/Call/TH.hs
@@ -1,67 +0,0 @@-{-# 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 = '_'
− src/Call/Types.hs
@@ -1,233 +0,0 @@-{-# 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
− src/Call/Util/Deck.hs
@@ -1,58 +0,0 @@-{-# 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.Object--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 :: (MonadIO m, MonadState Deck b) => Instance b m -> Time -> Int -> m (V.Vector Stereo)-playbackOf i = \dt n -> i .- playback dt n
− src/Call/Util/Sampler.hs
@@ -1,52 +0,0 @@-{-# 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.Object--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 :: (MonadIO m, MonadState Sampler b) => Instance b m -> Time -> Int -> m (V.Vector Stereo)-playbackOf i = \dt n -> i .- playback dt n
− src/Call/Util/Text.hs
@@ -1,55 +0,0 @@-{-# LANGUAGE ConstraintKinds, FlexibleContexts, BangPatterns, DeriveFunctor #-}-module Call.Util.Text (renderer, Typewriting(..), 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.Free-import Control.Monad.State.Class-import Control.Monad.Trans-import Control.Applicative-import Control.Object-import Data.Monoid-import Linear-import Control.DeepSeq--data Typewriting a = Render (Picture -> a) | Type Char a deriving Functor--renderer :: (MonadIO m, Applicative 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 (Free Typewriting) m-typewriter l req = iterative $ stateful go (V2 0 0, mempty) where- go (Type '\3' cont) = do- put (V2 0 0, mempty)- return cont- go (Type '\r' cont) = return cont- go (Type '\n' cont) = do- _1 . _y += l- _1 . _x .= 0- return cont- go (Type 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 (Render cont) = uses _2 cont--putStr :: String -> Free Typewriting ()-putStr [] = return ()-putStr (c:cs) = wrap (Type c (putStr cs))--clear :: Free Typewriting ()-clear = liftF $ Type '\3' ()--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 .- liftF (Render id)- t .- clear- return $! unPicture p