call 0.1.0.1 → 0.1.1

raw patch · 10 files changed

+157/−45 lines, 10 filesdep +minioperationaldep ~objective

Dependencies added: minioperational

Dependency ranges changed: objective

Files

• call.cabal +6/−4
• examples/hello-world.hs +6/−3
• shaders/fragment.glsl +28/−17
• shaders/vertex.glsl +13/−5
• src/Call.hs +2/−0
• src/Call/Data/Wave.hs +1/−1
• src/Call/Internal/GLFW.hs +5/−3
• src/Call/Sight.hs +6/−2
• src/Call/System.hs +36/−10
• src/Call/Util/Text.hs +54/−0

@@ -1,5 +1,5 @@ name:                call
-version:             0.1.0.1
+version:             0.1.1
 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
@@ -37,9 +37,10 @@     Call.Util
     Call.Util.Deck
     Call.Util.Sampler
+    Call.Util.Text
   other-modules:
     Paths_call
-  ghc-options: -Wall -fexcess-precision -O2 -threaded
+  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,
@@ -61,7 +62,7 @@     lens >=4.0 && <5,
     linear >=1.13 && <2,
     mtl >=2.0 && <2.7,
-    objective >= 0.5 && <0.7,
+    objective >= 0.5.2 && <0.7,
     OpenGL == 2.9.*,
     OpenGLRaw >=1.4 && <1.7,
     random ==1.*,
@@ -70,7 +71,8 @@     text >= 1.0 && <1.5,
     transformers >=0.3 && <0.5,
     vector >=0.9 && <0.13,
-    WAVE >=0.1 && <0.2
+    WAVE >=0.1 && <0.2,
+    minioperational >= 0.4.7 && <0.6
   hs-source-dirs:      src
   default-language:    Haskell2010
 

@@ -4,6 +4,7 @@ import Call.Util.Deck
 import Control.Lens
 import Control.Monad.State.Strict
+import qualified Call.Util.Text as Text
 
 -- calculates the root-mean-square value of the playing sound
 currentRMS :: MonadState Deck m => Int -> m (V2 Float)
@@ -19,15 +20,17 @@   setTitle "Hello, world!"
   src <- readWAVE "examples/hello-world.wav"
   deck <- new $ variable $ Call.Util.Deck.empty & source .~ sampleSource src
+  text <- Text.simple defaultFont 32
   linkAudio $ ((deck .-) .) . playback
   linkPicture $ \_ -> do
     let s x = (10 + max (log (realToFrac x) / log 10) (-10)) / 10
     V2 a b <- fmap (fmap s) $ deck .- currentRMS 1024
-    return $ translate (V2 0 240) $ mconcat
+    translate (V2 0 240) $ mconcat
       [color black $ polygonOutline [V2 0 0, V2 40 0, V2 40 (-240), V2 0 (-240)]
       ,color red $ mconcat [polygonOutline [V2 0 0, V2 16 0, V2 16 (-a * 240), V2 0 (-a * 240)]
-        , polygonOutline [V2 24 0, V2 40 0, V2 40 (-b * 240), V2 24 (-b * 240)]]
-        ]
+      ,polygonOutline [V2 24 0, V2 40 0, V2 40 (-b * 240), V2 24 (-b * 240)]]
+      ,color black $ text (show (a + b))
+      ]
   linkKeyboard $ \case
     Down KeySpace -> deck .- pos .= 0
     _ -> return ()

@@ -1,25 +1,36 @@ #version 330
+out vec4 fragColor;
+
+// Texture
 in vec2 UV;
 in vec2 envUV;
-out vec4 fragColor;
-uniform vec4 color;
-uniform bool useTexture;
-uniform int useEnv;
+
+varying vec3 normal;
+varying vec3 lightDir;
+varying vec3 vBC;
+
+uniform vec4 diffuse;
+uniform vec3 specular = vec3(0.0);
+uniform vec3 ambient = vec3(0.0);
+uniform float shininess;
+
 uniform sampler2D tex;
+uniform sampler2D normalMap;
 uniform sampler2D env;
+uniform float normalMix;
+uniform float textureMix;
+uniform float envAdd;
+uniform float envMul;
 
 void main(void){
-  if(useTexture){
-    fragColor = texture( tex, UV ).rgba * color;
-  }else{
-    fragColor = color;
-  }
-  if (useEnv == 1)
-  {
-    fragColor += texture( env, envUV ).rgba;
-  }
-  else if (useEnv == 2)
-  {
-    fragColor *= texture( env, envUV ).rgba;
-  }
+  // vec3 n = mix(normal, texture(normalMap, UV).rgb * 2 - 1, normalMix);
+
+  vec4 d = mix(vec4(1.0), texture(tex, UV).rgba, textureMix) * diffuse;
+  vec3 s = vec3(0.0);
+
+  fragColor = vec4(ambient + d.rgb + specular * s, d.a);
+  
+  fragColor += texture(env, envUV).rgba * envAdd;
+  fragColor *= mix(vec4(1.0), texture(env, envUV).rgba, envMul);
+
 }

@@ -2,12 +2,16 @@ uniform mat4 projection;
 uniform mat4 matrices[13];
 uniform int level;
-uniform int useEnv;
+uniform bool useEnv;
 out vec2 UV;
 out vec2 envUV;
 in vec3 in_Position;
 in vec2 in_UV;
 in vec3 in_Normal;
+attribute vec3 barycentric;
+varying vec3 lightDir;
+varying vec3 vBC;
+varying vec3 normal;
 
 void main(void) {
   mat4 model = mat4(1.0);
@@ -17,10 +21,14 @@   }
   gl_Position = projection * model * vec4(in_Position, 1.0);
   UV = in_UV;
-  if(useEnv != 0)
+
+  if(useEnv)
   {
-    vec3 r = reflect( normalize(vec3(model * vec4(in_Position, 1.0))), in_Normal );
-    float m = 2.0 * sqrt( r.x*r.x + r.y*r.y + (r.z+1.0)*(r.z+1.0) );
-    envUV = r.xy / m + 0.5;
+    vec3 refl = reflect( normalize(vec3(model * vec4(in_Position, 1.0))), in_Normal );
+    float m = 2.0 * sqrt( refl.x*refl.x + refl.y*refl.y + (refl.z+1.0)*(refl.z+1.0) );
+    envUV = refl.xy / m + 0.5;
   }
+  vBC = barycentric;
+  normal = in_Normal;
+  lightDir = vec3(0.0);
 }

@@ -7,6 +7,7 @@     module Call.Types,
     module Call.TH,
     module Call.Data.Wave,
+    module Call.Data.Font,
     -- * Reexports
     module Control.Monad,
     module Control.Applicative,
@@ -23,6 +24,7 @@ import Call.TH
 import Call.Types
 import Call.Data.Wave
+import Call.Data.Font
 import Call.Sight
 import Call.System
 import Call.Util

@@ -34,7 +34,7 @@       !dur = fromIntegral (V.length vec) / rate
       sample t
         | t < 0 || t >= dur = zero
-        | otherwise = vec V.! floor (t * rate)
+        | otherwise = vec V.! round (t * rate)
   return $ Sample dur (Source sample)
   where
     fr [a, b] = V2 (double2Float $ sampleToDouble a) (double2Float $ sampleToDouble b)

@@ -86,9 +86,9 @@     _ -> return Nothing
 
   GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 3
-  GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 2
+  GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 3
   GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
-  GLFW.windowHint $ GLFW.WindowHint'OpenGLForwardCompat True
+  -- 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)
@@ -97,7 +97,9 @@   GLFW.swapInterval 1
   -- GL.clearColor $= GL.Color4 1 1 1 1
   
-  rbox <- newIORef bbox
+  (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)

@@ -87,6 +87,10 @@ data VFX r = SphericalAdd Bitmap r
   | SphericalMultiply Bitmap r
   | Diffuse RGBA r
+--  | Specular (V3 Float) r
+--  | Ambient (V3 Float) r
+--  | NormalMap Bitmap r
+  | EmbedIO (IO r)
   deriving Functor
 
 instance Affine Scene where
@@ -104,7 +108,7 @@   primitive m vs = Scene $ \_ _ f _ _ -> f Blank m (V.fromList $ map positionOnly vs)
   color col (Scene s) = Scene $ \e a f b t -> b (Diffuse col (s e a f b t))
   line = primitive GL.LineStrip
-  polygon = primitive GL.Polygon
+  polygon = primitive GL.TriangleFan
   polygonOutline = primitive GL.LineLoop
   circle v = toward v $ circle $ norm v
   circleOutline v = toward v $ circleOutline $ norm v
@@ -143,7 +147,7 @@   primitive m v = Picture $ primitive m $ map v2ToV3 v
   color col (Picture s) = Picture (color col s)
   line = primitive GL.LineStrip
-  polygon = primitive GL.Polygon
+  polygon = primitive GL.TriangleFan
   polygonOutline = primitive GL.LineLoop
   circle r = polygon $ map (^*r) $ unit_circle 33
   circleOutline r = polygonOutline $ map (^*r) $ unit_circle 33

@@ -100,6 +100,26 @@ 
 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 MonadObjective (System s) where
   data Instance e m (System s) = InstanceS (MVar (Object e m))
   InstanceS m `invoke` e = do
@@ -369,17 +389,17 @@   GL.currentProgram $= Just shaderProg
   GL.UniformLocation loc <- GL.get (GL.uniformLocation shaderProg "projection")
   with proj $ \ptr -> GL.glUniformMatrix4fv loc 1 1 $ castPtr ptr
-  GL.UniformLocation locT <- GL.get $ GL.uniformLocation shaderProg "useTexture"
+  GL.UniformLocation locT <- GL.get $ GL.uniformLocation shaderProg "textureMix"
   s (pure $ return ()) (liftA2 (>>)) (prim locT) fx trans (RGBA 1 1 1 1, 0)
   where
     shaderProg = G.theProgram $ theSystem fo
     prim locT Blank mode vs _ = do
-      GL.glUniform1i locT 0
+      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.glUniform1i locT 1
+      GL.glUniform1f locT 1
       (tex, _, _) <- fetchTexture fo bmp h
       GL.activeTexture $= GL.TextureUnit 0
       GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
@@ -394,33 +414,39 @@       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 "color"
+      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "diffuse"
       let c = multRGBA col color0
       with c $ \ptr -> GL.glUniform4fv loc 1 (castPtr ptr)
       m (c, n)
       with color0 $ \ptr -> GL.glUniform4fv loc 1 (castPtr ptr)
     fx (SphericalAdd (Bitmap bmp _ h) m) c = do
-      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "useEnv"
-      GL.glUniform1i loc 1
+      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
-      GL.glUniform1i loc 0
+      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
-      GL.UniformLocation loc <- GL.get $ GL.uniformLocation shaderProg "useEnv"
-      GL.glUniform1i loc 2
+      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
-      GL.glUniform1i loc 0
+      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

@@ -0,0 +1,54 @@+{-# LANGUAGE ConstraintKinds, FlexibleContexts #-}
+module Call.Util.Text where
+import Prelude hiding (putStr)
+import Call.Data.Bitmap (Bitmap)
+import Call.Data.Font
+import Call.Sight
+import Control.Elevator
+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
+
+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, ofs, adv) <- lift $ req ch
+    put (pos + adv, translate (pos + ofs) (bitmap bmp) <> pic)
+    return cont
+  go (Pull cont) = uses _2 cont
+
+putStr :: (Monad m, Elevate (PushPull Char a) m) => String -> m ()
+putStr [] = return ()
+putStr (c:cs) = push c >> putStr cs
+
+clear :: (Elevate (PushPull Char a) m) => m ()
+clear = push '\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 .- pull
+    t .- push '\3'
+    return (unPicture p)