packages feed

call 0.1.1.3 → 0.1.2

raw patch · 12 files changed

+45/−61 lines, 12 filesdep ~colors

Dependency ranges changed: colors

Files

call.cabal view
@@ -1,5 +1,5 @@ name:                call
-version:             0.1.1.3
+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
@@ -40,7 +40,6 @@     Call.Data.Wave
     Call.Data.Font
     Call.Data.Bitmap
-    Call.Util
     Call.Util.Deck
     Call.Util.Sampler
     Call.Util.Text
@@ -53,7 +52,7 @@     bindings-portaudio,
     boundingboxes >=0.2 && <0.4,
     clean-unions >= 0.1 && <0.3,
-    colors >=0.2 && <0.3,
+    colors >=0.3 && <0.4,
     containers >=0.5 && <0.7,
     control-bool >=0.2 && <0.4,
     directory,
shaders/fragment.glsl view
@@ -1,4 +1,4 @@-#version 330 core
+#version 330
 out vec4 fragColor;
 
 // Texture
@@ -23,8 +23,8 @@   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);
 
-}+}
shaders/vertex.glsl view
@@ -1,4 +1,4 @@-#version 330 core
+#version 330
 uniform mat4 projection;
 uniform mat4 matrices[13];
 uniform int level;
@@ -28,4 +28,4 @@   }
   normal = in_Normal;
   lightDir = vec3(0.0);
-}+}
src/Call.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE Rank2Types #-}
 module Call ( -- * System
     runSystemDefault,
+    readBitmap,
     module Call.Sight,
-    module Call.Util,
     module Call.System,
     module Call.Types,
     module Call.TH,
@@ -27,7 +27,6 @@ import Call.Data.Font
 import Call.Sight
 import Call.System
-import Call.Util
 import Control.Monad.IO.Class
 import Control.Monad
 import Control.Applicative
@@ -39,6 +38,10 @@ 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
src/Call/Data/Bitmap.hs view
@@ -97,4 +97,5 @@ -- | 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"+writeFile _ Blank = fail "Blank bitmap"
+
src/Call/Data/Wave.hs view
@@ -40,6 +40,6 @@     fr [a, b] = V2 (double2Float $ sampleToDouble a) (double2Float $ sampleToDouble b)
     fr _ = zero
 
-data Sample a = Sample { sampleLength :: Time ,sampleSource :: Source a} 
+data Sample a = Sample { sampleLength :: Time ,sampleSource :: Source a}
 
--- TODO: Lazy processing+-- TODO: Lazy processing
src/Call/Internal/GLFW.hs view
@@ -178,16 +178,16 @@   GL.lineSmooth $= GL.Enabled
   GL.textureFunction $= GL.Combine
   GL.clearColor $= GL.Color4 1 1 1 1
-  GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "useEnv"
-  GL.glUniform1i loc 0
-  GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "tex"
-  GL.glUniform1i loc 0
-  GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "env"
-  GL.glUniform1i loc 1
-  GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "envAdd"
-  GL.glUniform1f loc 0
-  GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "envMul"
-  GL.glUniform1f loc 0
+  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
src/Call/Sight.hs view
@@ -22,6 +22,7 @@ module Call.Sight (Affine(..)
     , Figure(..)
     , Picture(..)
+    , opacity
     , bitmap
     , toward
     , Scene(..)
@@ -54,13 +55,16 @@ 
 class Affine a => Figure a where
   primitive :: GL.PrimitiveMode -> [Vec a] -> a
-  color :: RGBA -> 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
@@ -86,7 +90,7 @@ 
 data VFX r = SphericalAdd Bitmap r
   | SphericalMultiply Bitmap r
-  | Diffuse RGBA r
+  | Diffuse (V4 Float) r
 --  | Specular (V3 Float) r
 --  | Ambient (V3 Float) r
 --  | NormalMap Bitmap r
@@ -153,7 +157,7 @@   circleOutline r = polygonOutline $ map (^*r) $ unit_circle 33
 
 newtype Sight = Sight { unSight
-  :: forall r. 
+  :: forall r.
   X.Box V2 Float
   -> r
   -> (r -> r -> r)
@@ -176,4 +180,4 @@ 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+fromPerspective mat s = Sight $ \box _ _ f -> f box (mat box) True s
src/Call/System.hs view
@@ -77,7 +77,6 @@ import Control.Monad.Reader
 import Control.Object
 import Data.BoundingBox (Box(..))
-import Data.Color
 import Data.OpenUnion1.Clean
 import Data.IORef
 import Data.Maybe
@@ -110,7 +109,7 @@ instance Figure a => Figure (System s a) where
   primitive p v = return $ primitive p v
   color c = fmap (color c)
-  line = return . line 
+  line = return . line
   polygon = return . polygon
   polygonOutline = return . polygonOutline
   circle = return . circle
@@ -214,14 +213,14 @@   cv0 <- GLFW.getWindowContextVersionMajor    win
   cv1 <- GLFW.getWindowContextVersionMinor    win
   cv2 <- GLFW.getWindowContextVersionRevision win
-  putStrLn $ show cv0 ++ "." ++ show cv1 ++ "." ++ show cv2 
+  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
@@ -276,7 +275,7 @@ gamepadButtons (Gamepad i _) = mkSystem $ const
   $ maybe [] (map (==GLFW.JoystickButtonState'Pressed)) <$> GLFW.getJoystickButtons (toEnum i)
 
-clearColor :: RGBA -> System s ()
+clearColor :: V4 Float -> System s ()
 clearColor col = liftIO $ GL.clearColor $= unsafeCoerce col
 
 setBoundingBox :: Box V2 Float -> System s ()
@@ -292,7 +291,7 @@ 
 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 #-}
@@ -333,7 +332,7 @@   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
 
@@ -390,7 +389,7 @@   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 (RGBA 1 1 1 1, 0)
+  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
@@ -409,7 +408,7 @@       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" 
+      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)
@@ -417,7 +416,7 @@     fx (EmbedIO m) c = m >>= ($ c)
     fx (Diffuse col m) (color0, n) = do
       GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "diffuse"
-      let c = multRGBA col color0
+      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)
− src/Call/Util.hs 
@@ -1,21 +0,0 @@-{-# LANGUAGE FlexibleContexts, GADTs #-}
-module Call.Util where
-import Control.Object
-import Call.Types
-import Call.Sight
-import Control.Monad.State
-import qualified Call.Data.Bitmap as Bitmap
-import Data.Functor.Request
-
-readBitmap :: MonadIO m => FilePath -> m Bitmap.Bitmap
-readBitmap = Bitmap.readFile
-
-animate :: Monad m => (Time -> Sight) -> Object (Request Time Sight) m
-animate f = go (0 :: Float) where
-  go t = Object $ \(Request dt cont) -> return (cont $ f t, go (t + dt))
-
-transit :: MonadPlus m => Time -> (Time -> Sight) -> Object (Request Time Sight) m
-transit len f = go 0 where
-  go t
-    | t >= len = Object $ const mzero
-    | otherwise = Object $ \(Request dt cont) -> return (cont $ f (t / len), go (t + dt))
src/Call/Util/Deck.hs view
@@ -56,4 +56,4 @@     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
+playbackOf i = \dt n -> i .^ playback dt n
src/Call/Util/Sampler.hs view
@@ -19,7 +19,6 @@ import Control.Monad.State.Strict
 import Call.Types
 import Call.Data.Wave
-import Control.Monad
 import Control.Monad.Objective
 import Control.Elevator
 
@@ -51,4 +50,4 @@ 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
+playbackOf i = \dt n -> i .^ playback dt n