call 0.1.1.1 → 0.1.1.2
raw patch · 10 files changed
+64/−56 lines, 10 filesdep +deepseqdep ~objective
Dependencies added: deepseq
Dependency ranges changed: objective
Files
- call.cabal +11/−4
- examples/hello-world.hs +3/−2
- shaders/fragment.glsl +7/−13
- shaders/vertex.glsl +3/−6
- src/Call/Data/Bitmap.hs +1/−1
- src/Call/Data/Font.hs +4/−8
- src/Call/Data/Wave.hs +1/−1
- src/Call/Internal/GLFW.hs +12/−0
- src/Call/System.hs +9/−9
- src/Call/Util/Text.hs +13/−12
call.cabal view
@@ -1,5 +1,5 @@ name: call -version: 0.1.1.1 +version: 0.1.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 @@ -16,8 +16,14 @@ cabal-version: >=1.10 flag BuildHelloWorld - default: False + default: False +flag GLForwardCompat + default: True + +flag GLCoreProfile + default: True + source-repository head type: git location: https://github.com/fumieval/call.git @@ -62,7 +68,7 @@ lens >=4.0 && <5, linear >=1.13 && <2, mtl >=2.0 && <2.7, - objective >= 0.5.2 && <0.7, + objective >= 0.6.1 && <0.7, OpenGL == 2.9.*, OpenGLRaw >=1.4 && <1.7, random ==1.*, @@ -72,7 +78,8 @@ transformers >=0.3 && <0.5, vector >=0.9 && <0.13, WAVE >=0.1 && <0.2, - minioperational >= 0.4.7 && <0.6 + minioperational >= 0.4.7 && <0.6, + deepseq hs-source-dirs: src default-language: Haskell2010
examples/hello-world.hs view
@@ -21,15 +21,16 @@ 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 - translate (V2 0 240) $ mconcat + return $ translate (V2 0 240) $ mconcat [color black $ polygonOutline [V2 0 0, V2 40 0, V2 40 (-240), V2 0 (-240)] ,color red $ mconcat [polygonOutline [V2 0 0, V2 16 0, V2 16 (-a * 240), V2 0 (-a * 240)] ,polygonOutline [V2 24 0, V2 40 0, V2 40 (-b * 240), V2 24 (-b * 240)]] - ,color black $ text (show (a + b)) + ,translate (V2 40 40) $ color black $ text "Hello, world" ] linkKeyboard $ \case Down KeySpace -> deck .- pos .= 0
shaders/fragment.glsl view
@@ -1,22 +1,17 @@-#version 330 +#version 330 core out vec4 fragColor; // Texture in vec2 UV; in vec2 envUV; -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; +in vec3 normal; +in vec3 lightDir; -uniform sampler2D tex; -uniform sampler2D normalMap; uniform sampler2D env; +uniform sampler2D tex; + +uniform vec4 diffuse; uniform float normalMix; uniform float textureMix; uniform float envAdd; @@ -26,9 +21,8 @@ // 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 = 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 +#version 330 core uniform mat4 projection; uniform mat4 matrices[13]; uniform int level; @@ -8,10 +8,8 @@ in vec3 in_Position; in vec2 in_UV; in vec3 in_Normal; -attribute vec3 barycentric; -varying vec3 lightDir; -varying vec3 vBC; -varying vec3 normal; +out vec3 lightDir; +out vec3 normal; void main(void) { mat4 model = mat4(1.0); @@ -28,7 +26,6 @@ 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); }
src/Call/Data/Bitmap.hs view
@@ -38,7 +38,7 @@ import Control.Lens import Control.Monad.ST -data Bitmap = Blank | Bitmap { _image :: C.Image C.PixelRGBA8, _offset :: V2 Int, _hash :: Int } +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
src/Call/Data/Font.hs view
@@ -91,15 +91,11 @@ runFreeType $ ft_Init_FreeType p peek p --- | The resolution used to render fonts. -resolutionDPI :: Int -resolutionDPI = 300 - renderChar :: Font -> Float -> Char -> IO (Bitmap, V2 Float, V2 Float) -renderChar (Font face _ _) siz ch = do - let dpi = fromIntegral resolutionDPI +renderChar (Font face _ _) pixel ch = do + let dpi = 300 - runFreeType $ ft_Set_Char_Size face 0 (floor $ siz * 64) dpi dpi + 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 @@ -118,7 +114,7 @@ adv <- peek $ GS.advance slot b <- liftImage' $ fromColorAndOpacity (PixelRGB8 255 255 255) - $ Image w h $ V.unsafeFromForeignPtr0 fptr $ h * w + $ 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 view
@@ -33,7 +33,7 @@ rate = fromIntegral (waveFrameRate h) !dur = fromIntegral (V.length vec) / rate sample t - | t < 0 || t >= dur = zero + | t < 0 || t >= dur - (1/rate) = zero | otherwise = vec V.! round (t * rate) return $ Sample dur (Source sample) where
src/Call/Internal/GLFW.hs view
@@ -55,6 +55,8 @@ [tex] <- GL.genObjectNames 1 GL.textureBinding GL.Texture2D GL.$= Just tex let siz = GL.TextureSize2D (gsizei w) (gsizei h) + GL.glTexParameteri GL.gl_TEXTURE_2D GL.gl_TEXTURE_BASE_LEVEL 0 + GL.glTexParameteri GL.gl_TEXTURE_2D GL.gl_TEXTURE_MAX_LEVEL 0 V.unsafeWith v $ GL.texImage2D GL.Texture2D GL.NoProxy 0 GL.RGBA8 siz 0 . GL.PixelData GL.ABGR GL.UnsignedInt8888 @@ -89,6 +91,7 @@ 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) @@ -179,7 +182,16 @@ 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.glPixelStorei GL.gl_UNPACK_ALIGNMENT 4 return shaderProg endGLFW :: System -> IO ()
src/Call/System.hs view
@@ -120,14 +120,14 @@ 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 - c <- liftIO $ takeMVar m - return $ do - (a, c') <- runObject c e - return (liftIO (putMVar m c') >> return a) - new v = liftIO $ InstanceS `fmap` newMVar v +instance 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 @@ -402,8 +402,8 @@ GL.glUniform1f locT 1 (tex, _, _) <- fetchTexture fo bmp h GL.activeTexture $= GL.TextureUnit 0 - GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear') GL.textureBinding GL.Texture2D $= Just tex + 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
src/Call/Util/Text.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE ConstraintKinds, FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds, FlexibleContexts, BangPatterns #-} module Call.Util.Text where import Prelude hiding (putStr) -import Call.Data.Bitmap (Bitmap) +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 @@ -15,6 +14,7 @@ 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) @@ -31,17 +31,18 @@ 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) + (!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 :: (Monad m, Elevate (PushPull Char a) m) => String -> m () +putStr :: String -> ReifiedProgram (PushPull Char Picture) () putStr [] = return () -putStr (c:cs) = push c >> putStr cs +putStr (c:cs) = Push c () :>>= const (putStr cs) -clear :: (Elevate (PushPull Char a) m) => m () -clear = push '\3' +clear :: ReifiedProgram (PushPull Char Picture) () +clear = Push '\3' () :>>= return simple :: MonadIO m => Font -> Float -> m (String -> Picture) simple font size = liftIO $ do @@ -49,6 +50,6 @@ 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)+ p <- t .- (Pull id :>>= return) + t .- clear + return $! unPicture p