split Scene 'Test' up in submodules per method and hunt warnings

pituicat.cabal

@@ -44,6 +44,10 @@ executable pituicat
                      , Classes.Physics.Mass
                      , Classes.Physics.Collidible
                      , Scenes.Test
+                     , Scenes.Test.Types
+                     , Scenes.Test.Util
+                     , Scenes.Test.Load
+                     , Scenes.Test.Update
                      , Map
                      , StateMachine
                      , Renderer

src/Classes/Graphics/Buffer.hs

@@ -4,8 +4,6 @@ module Classes.Graphics.Buffer where
 
 import qualified Graphics.Rendering.OpenGL as GL
 
-import SDL (($=), get)
-
 import Foreign.Storable
 
 -- internal imports

src/Scenes/Test.hs

@@ -1,45 +1,24 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Scenes.Test where
+module Scenes.Test 
+  ( module Test
+  ) where
 
 import Affection as A
 
-import qualified Graphics.Rendering.OpenGL as GL
-
 import qualified Data.Vector.Storable as VS
 import qualified Data.Vector as V
 
-import Data.String
-
 import Control.Concurrent.STM
 
-import Control.Arrow ((***))
-
-import Control.Monad (void)
-
-import Linear
-
 -- internal imports
 
 import Types
 import Classes
-import Map
 import Renderer as R
-
-data Test = Test
-  { testMap :: TMVar LevelMap
-  , testGraphics :: TMVar GLAssets
-  , testLoaded :: TVar Bool
-  , testStageSet :: TVar (V.Vector StageSet)
-  , testCast :: TVar (V.Vector Cast)
-  }
-
-data GLAssets = GLAssets
-  { glVA :: VertexArray
-  , glVB :: VertexBuffer
-  , glIB :: IndexBuffer
-  , glSP :: Shader
-  , glTx :: [Texture]
-  }
+import Scenes.Test.Types as Test
+import Scenes.Test.Util as Test
+import Scenes.Test.Load as Test
+import Scenes.Test.Update as Test
 
 instance Scene Test where
 
@@ -51,130 +30,11 @@ instance Scene Test where
       <*> newTVarIO V.empty
       <*> newTVarIO V.empty
 
-  loadScene level progress = do
-    atomically $ do
-      void $ takeTMVar progress
-      putTMVar progress (0, "Loading test level...")
-    loadedMap <- constructMap testLevelDesc 0
-    atomically $ putTMVar (testMap level) loadedMap
-    void $ atomically $ do
-      void $ takeTMVar progress
-      putTMVar progress (0.5, "Loaded test level map!")
-    void $ atomically $ swapTVar (testLoaded level) True
-
-    let projection = ortho 0 800 0 600 (-1) 1 :: M44 GL.GLfloat
-        view = mkTransformationMat
-          (identity :: M33 GL.GLfloat)
-          (V3 0 ((-64) * 32 + 600) 0)
-        model = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0)
-
-    vertexArray <- newVertexArray
-
-    bind vertexArray
-
-    vertexBuffer <- newVertexBuffer 1024
-
-    bind vertexBuffer
-
-    let vertices = VS.fromList (createQuad (V2 (400 - 16) (300 - 16)) 0)
-
-    write vertexBuffer 0 vertices
-
-    indexBuffer <- newIndexBuffer 1024
-
-    bind indexBuffer
-
-    let indices = VS.fromList [0, 1, 2, 2, 3, 0]
-
-    write indexBuffer 0 indices
-
-    addBuffer (undefined :: Vertex) vertexBuffer
-
-    (_, tex) <- newTexture "res/pituicat/pituicat.png" 1
-    bind tex
-
-    shader <- newShader
-      [ ShaderSource GL.VertexShader "./res/shaders/vert.shader"
-      , ShaderSource GL.FragmentShader "./res/shaders/frag.shader"
-      ]
-
-    bind shader
-    setUniform shader "u_mvp" (projection !*! view !*! model)
-    setUniformList
-      shader
-      "u_textures"
-      (map
-        textureSlot
-        [ (tileMapTexture $ mapTileMap loadedMap)
-        , tex
-        ]
-        )
-
-    let pituicat = Pituicat
-          (V2 100 1948)
-          (V2 0 0)
-          (V2 0 0)
-          100
-          tex
-
-    unbind vertexArray
-    unbind vertexBuffer
-    unbind indexBuffer
-    unbind tex
-    unbind shader
-
-    atomically $ do
-      putTMVar (testGraphics level)
-        (GLAssets vertexArray vertexBuffer indexBuffer shader [tex])
-      modifyTVar (testCast level) (\cast -> Cast pituicat `V.cons` cast)
-      writeTVar (testLoaded level) True
-
-    void $ atomically $ do
-      void $ takeTMVar progress
-      putTMVar progress (1, "Loaded graphics!")
-
+  loadScene = load
 
   isSceneLoaded = liftIO . readTVarIO . testLoaded
 
-  update level dt = liftIO $ do
-    logIO Debug ("FPS: " <> fromString (show $ 1 / dt))
-
-    -- Let all Actors update themselves and check for collisions
-    -- (Typeclasses rock!)
-    atomically $ do
-      lmap <- readTMVar (testMap level)
-      let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap)
-      modifyTVar
-        (testCast level) $ \cast ->
-          let playedCast =
-                V.map
-                (\(Cast c) -> Cast (perform dt c))
-                cast
-              collidedCast =
-                (\(Cast c1) (Cast c2) ->
-                  Cast $
-                    if collisionCheck dt c1 c2
-                    then collide c1 c2
-                    else c1
-                  )
-                <$> playedCast <*> playedCast
-              wallCast (Cast c) = Cast $
-                V.foldl
-                (\member tile ->
-                  if collisionCheck dt member tile
-                  then collide member tile
-                  else member
-                  )
-                c
-                layer
-              walledCast =
-                V.map wallCast collidedCast
-          in
-            V.map
-            (\(Cast c) -> Cast $
-              move dt c
-              )
-            walledCast
+  update = Test.update
 
   onEvents _ _ = return ()
 
@@ -200,87 +60,3 @@ instance Scene Test where
     V.mapM_ (\(StageSet p) -> bindPropTexture p) stageSet
     V.mapM_ (\(Cast c) -> bindPropTexture c) cast
     R.draw va ib sh
-
-testLevelDesc :: LevelDescriptor
-testLevelDesc = LevelDescriptor
-  [ (0, "res/maps/00_test/00_test.bmp")
-  ]
-  0
-  "res/tiles/00_test/00_test.png"
-  (3, 3)
-
-createQuad :: V2 GL.GLfloat -> Int -> [Vertex]
-createQuad (V2 x y) index =
-  [ newVertex
-    (V3 x y 0)
-    (V4 0 0 0 1)
-    (V2 0 (1 - (50 / 1024)))
-    (fromIntegral index)
-  , newVertex
-    (V3 (x + 32) y 0)
-    (V4 0 0 0 1)
-    (V2 (50 / 1024) (1 - (50/1024)))
-    (fromIntegral index)
-  , newVertex
-    (V3 (x + 32) (y + 32) 0)
-    (V4 0 0 0 1)
-    (V2 (50 / 1024) 1)
-    (fromIntegral index)
-  , newVertex
-    (V3 x (y + 32) 0)
-    (V4 0 0 0 1)
-    (V2 0 1)
-    (fromIntegral index)
-  ]
-
-populate
-  :: V.Vector Layer
-  -> V.Vector StageSet
-  -> V.Vector Cast
-  -> (VS.Vector Word, VS.Vector Vertex)
-populate layers props actors =
-  (VS.convert *** VS.convert) $ foldl
-    (\(is, vs) (num, l) ->
-      let propsHere = V.filter (\(StageSet s) -> residentLayer s == num) props
-          actorsHere = V.filter (\(Cast c) -> residentLayer c == num) actors
-          (pisRaw, pvs) = V.foldl
-            (\(ais, avs) (StageSet s) ->
-              let (nis, nvs) = toVertices s
-              in
-                ( ais V.++ nis
-                , avs V.++ nvs)
-              )
-            (V.empty, V.empty)
-            propsHere
-          (cisRaw, cvs) = V.foldl
-            (\(ais, avs) (Cast c) ->
-              let (nis, nvs) = toVertices c
-              in
-                ( ais V.++ nis
-                , avs V.++ nvs)
-              )
-            (V.empty, V.empty)
-            actorsHere
-          (lisRaw, lvs) = toVertices l
-          lis = V.map
-            (+ if null is then 0 else V.maximum is + 1)
-            lisRaw
-          pis = V.map
-            (+
-              if null (is V.++ lis)
-              then 0
-              else V.maximum (is V.++ lis) + 1)
-            pisRaw
-          cis = V.map
-            (+
-              if null (is V.++ lis V.++ pis)
-              then 0
-              else V.maximum (is V.++ lis V.++ pis) + 1)
-            cisRaw
-      in
-        ( is V.++ lis V.++ pis V.++ cis
-        , vs V.++ lvs V.++ pvs V.++ cvs
-        )
-      )
-    (V.empty, V.empty)
-    (V.zip (V.fromList [0 ..]) layers)

src/Scenes/Test/Load.hs

@@ -0,0 +1,107 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Scenes.Test.Load where
+
+import qualified Graphics.Rendering.OpenGL as GL
+
+import qualified Data.Vector.Storable as VS
+import qualified Data.Vector as V
+
+import Control.Concurrent.STM
+
+import Control.Monad (void)
+
+import Linear
+
+-- internal imports
+
+import Types
+import Classes
+import Map
+import Scenes.Test.Types
+import Scenes.Test.Util
+
+load
+  :: Test
+  -> TMVar Progress
+  -> IO ()
+load level progress = do
+  atomically $ do
+    void $ takeTMVar progress
+    putTMVar progress (0, "Loading test level...")
+  loadedMap <- constructMap testLevelDesc 0
+  atomically $ putTMVar (testMap level) loadedMap
+  void $ atomically $ do
+    void $ takeTMVar progress
+    putTMVar progress (0.5, "Loaded test level map!")
+  void $ atomically $ swapTVar (testLoaded level) True
+
+  let projection = ortho 0 800 0 600 (-1) 1 :: M44 GL.GLfloat
+      view = mkTransformationMat
+        (identity :: M33 GL.GLfloat)
+        (V3 0 ((-64) * 32 + 600) 0)
+      model = mkTransformationMat (identity :: M33 GL.GLfloat) (V3 0 0 0)
+
+  vertexArray <- newVertexArray
+
+  bind vertexArray
+
+  vertexBuffer <- newVertexBuffer 1024
+
+  bind vertexBuffer
+
+  let vertices = VS.fromList (createQuad (V2 (400 - 16) (300 - 16)) 0)
+
+  write vertexBuffer 0 vertices
+
+  indexBuffer <- newIndexBuffer 1024
+
+  bind indexBuffer
+
+  let indices = VS.fromList [0, 1, 2, 2, 3, 0]
+
+  write indexBuffer 0 indices
+
+  addBuffer (undefined :: Vertex) vertexBuffer
+
+  (_, tex) <- newTexture "res/pituicat/pituicat.png" 1
+  bind tex
+
+  shader <- newShader
+    [ ShaderSource GL.VertexShader "./res/shaders/vert.shader"
+    , ShaderSource GL.FragmentShader "./res/shaders/frag.shader"
+    ]
+
+  bind shader
+  setUniform shader "u_mvp" (projection !*! view !*! model)
+  setUniformList
+    shader
+    "u_textures"
+    (map
+      textureSlot
+      [ (tileMapTexture $ mapTileMap loadedMap)
+      , tex
+      ]
+      )
+
+  let pituicat = Pituicat
+        (V2 100 1948)
+        (V2 0 0)
+        (V2 0 0)
+        100
+        tex
+
+  unbind vertexArray
+  unbind vertexBuffer
+  unbind indexBuffer
+  unbind tex
+  unbind shader
+
+  atomically $ do
+    putTMVar (testGraphics level)
+      (GLAssets vertexArray vertexBuffer indexBuffer shader [tex])
+    modifyTVar (testCast level) (\cast -> Cast pituicat `V.cons` cast)
+    writeTVar (testLoaded level) True
+
+  void $ atomically $ do
+    void $ takeTMVar progress
+    putTMVar progress (1, "Loaded graphics!")

src/Scenes/Test/Types.hs

@@ -0,0 +1,25 @@
+module Scenes.Test.Types where
+
+import Control.Concurrent.STM
+
+import qualified Data.Vector as V
+
+-- internal imports
+
+import Types
+
+data Test = Test
+  { testMap :: TMVar LevelMap
+  , testGraphics :: TMVar GLAssets
+  , testLoaded :: TVar Bool
+  , testStageSet :: TVar (V.Vector StageSet)
+  , testCast :: TVar (V.Vector Cast)
+  }
+
+data GLAssets = GLAssets
+  { glVA :: VertexArray
+  , glVB :: VertexBuffer
+  , glIB :: IndexBuffer
+  , glSP :: Shader
+  , glTx :: [Texture]
+  }

src/Scenes/Test/Update.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Scenes.Test.Update where
+
+import Affection
+
+import Control.Concurrent.STM
+
+import qualified Data.Vector as V
+
+import Data.String (fromString)
+
+-- internal imports
+
+import Scenes.Test.Types
+import Classes
+import Types
+
+update
+  :: Test
+  -> Double
+  -> Affection ()
+update level dt = liftIO $ do
+  logIO Debug ("FPS: " <> fromString (show $ 1 / dt))
+
+  -- Let all Actors update themselves and check for collisions
+  -- (Typeclasses rock!)
+  atomically $ do
+    lmap <- readTMVar (testMap level)
+    let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap)
+    modifyTVar
+      (testCast level) $ \cast ->
+        let playedCast =
+              V.map
+              (\(Cast c) -> Cast (perform dt c))
+              cast
+            collidedCast =
+              (\(Cast c1) (Cast c2) ->
+                Cast $
+                  if collisionCheck dt c1 c2
+                  then collide c1 c2
+                  else c1
+                )
+              <$> playedCast <*> playedCast
+            wallCast (Cast c) = Cast $
+              V.foldl
+              (\member tile ->
+                if collisionCheck dt member tile
+                then collide member tile
+                else member
+                )
+              c
+              layer
+            walledCast =
+              V.map wallCast collidedCast
+        in
+          V.map
+          (\(Cast c) -> Cast $
+            move dt c
+            )
+          walledCast

src/Scenes/Test/Util.hs

@@ -0,0 +1,99 @@
+module Scenes.Test.Util where
+
+import qualified Graphics.Rendering.OpenGL as GL
+
+import Linear
+
+import qualified Data.Vector as V
+import qualified Data.Vector.Storable as VS
+
+import Control.Arrow ((***))
+
+-- internal imports
+
+import Classes
+import Types
+
+testLevelDesc :: LevelDescriptor
+testLevelDesc = LevelDescriptor
+  [ (0, "res/maps/00_test/00_test.bmp")
+  ]
+  0
+  "res/tiles/00_test/00_test.png"
+  (3, 3)
+
+createQuad :: V2 GL.GLfloat -> Int -> [Vertex]
+createQuad (V2 x y) index =
+  [ newVertex
+    (V3 x y 0)
+    (V4 0 0 0 1)
+    (V2 0 (1 - (50 / 1024)))
+    (fromIntegral index)
+  , newVertex
+    (V3 (x + 32) y 0)
+    (V4 0 0 0 1)
+    (V2 (50 / 1024) (1 - (50/1024)))
+    (fromIntegral index)
+  , newVertex
+    (V3 (x + 32) (y + 32) 0)
+    (V4 0 0 0 1)
+    (V2 (50 / 1024) 1)
+    (fromIntegral index)
+  , newVertex
+    (V3 x (y + 32) 0)
+    (V4 0 0 0 1)
+    (V2 0 1)
+    (fromIntegral index)
+  ]
+
+populate
+  :: V.Vector Layer
+  -> V.Vector StageSet
+  -> V.Vector Cast
+  -> (VS.Vector Word, VS.Vector Vertex)
+populate layers props actors =
+  (VS.convert *** VS.convert) $ foldl
+    (\(is, vs) (num, l) ->
+      let propsHere = V.filter (\(StageSet s) -> residentLayer s == num) props
+          actorsHere = V.filter (\(Cast c) -> residentLayer c == num) actors
+          (pisRaw, pvs) = V.foldl
+            (\(ais, avs) (StageSet s) ->
+              let (nis, nvs) = toVertices s
+              in
+                ( ais V.++ nis
+                , avs V.++ nvs)
+              )
+            (V.empty, V.empty)
+            propsHere
+          (cisRaw, cvs) = V.foldl
+            (\(ais, avs) (Cast c) ->
+              let (nis, nvs) = toVertices c
+              in
+                ( ais V.++ nis
+                , avs V.++ nvs)
+              )
+            (V.empty, V.empty)
+            actorsHere
+          (lisRaw, lvs) = toVertices l
+          lis = V.map
+            (+ if null is then 0 else V.maximum is + 1)
+            lisRaw
+          pis = V.map
+            (+
+              if null (is V.++ lis)
+              then 0
+              else V.maximum (is V.++ lis) + 1)
+            pisRaw
+          cis = V.map
+            (+
+              if null (is V.++ lis V.++ pis)
+              then 0
+              else V.maximum (is V.++ lis V.++ pis) + 1)
+            cisRaw
+      in
+        ( is V.++ lis V.++ pis V.++ cis
+        , vs V.++ lvs V.++ pvs V.++ cvs
+        )
+      )
+    (V.empty, V.empty)
+    (V.zip (V.fromList [0 ..]) layers)

src/Types/Graphics/Shader.hs

@@ -3,27 +3,19 @@
 
 module Types.Graphics.Shader where
 
-import SDL (($=), get)
-
 import qualified Graphics.Rendering.OpenGL as GL
 import qualified Graphics.GL as GLRaw
 
-import Data.List as L
-
 import Data.StateVar
 
 import qualified Data.ByteString as B
 
-import Data.Maybe (fromJust)
-
 import Control.Concurrent.MVar
 
 import Linear
 
-import Foreign.Marshal.Utils (with)
 import Foreign.Marshal.Array (withArray)
 import Foreign.Storable
-import Foreign.Ptr
 
 -- internal imports
 
@@ -54,7 +46,7 @@ data ShaderUniform = ShaderUniform
 
 -- orphan instance to make linear's M44 uniforms
 instance GL.Uniform (M44 GL.GLfloat) where
-  uniform loc@(GL.UniformLocation ul) = makeStateVar getter setter
+  uniform (GL.UniformLocation ul) = makeStateVar getter setter
     where
       getter = error "cannot implement: get uniform M44 GLfloat"
         -- GL.withNewMatrix GL.RowMajor $ getUniformWith GLRaw.glGetUniformfv loc
@@ -65,7 +57,7 @@ instance GL.Uniform (M44 GL.GLfloat) where
         (V4 m n o p)) = do
           mat <- GL.newMatrix GL.RowMajor [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p] :: IO (GL.GLmatrix GL.GLfloat)
           GL.withMatrix mat $ GLRaw.glUniformMatrix4fv ul 1 . isRowMajor
-  uniformv (GL.UniformLocation ul) count buf = error "can not implement uniformv for M44 GLfloat"
+  uniformv (GL.UniformLocation _) _ _ = error "can not implement uniformv for M44 GLfloat"
     -- GLRaw.glUniformMatrix4fv ul count 0 (castPtr buf `asTypeOf` elemType buf)
     -- where
     --   elemType = undefined :: GL.MatrixComponent c => Ptr (GL.GLmatrix c) -> Ptr c

src/Types/Graphics/VertexArray.hs

@@ -3,22 +3,11 @@ module Types.Graphics.VertexArray where
 
 import qualified Graphics.Rendering.OpenGL as GL
 
-import SDL (($=), get)
-
-import qualified Data.Vector as V
-
-import Foreign (sizeOf)
-import Foreign.Ptr
-
-import Control.Concurrent.STM
-
-import Control.Monad (void)
+import SDL (($=))
 
 -- internal imports
 
 import Classes.Graphics.Bindable
-import Classes.Graphics.Buffer
-import Types.Graphics.VertexBuffer
 
 newtype VertexArray = VertexArray
   { vArrId :: GL.VertexArrayObject
@@ -29,7 +18,7 @@ instance Bindable VertexArray where
 
   bind va = GL.bindVertexArrayObject $= Just (vArrId va)
 
-  unbind va = GL.bindVertexArrayObject $= Nothing
+  unbind _ = GL.bindVertexArrayObject $= Nothing
 
 newVertexArray :: IO VertexArray
 newVertexArray = VertexArray

src/Types/Map.hs

@@ -29,9 +29,9 @@ instance Drawable Layer where
   -- type VertexList Layer = V.Vector
 
   toVertices vt = V.foldl
-    (\(acci, accv) (mult, a) ->
+    (\(acci, accv) (multi, a) ->
       let (ris, vs) = toVertices a
-          is = V.map (mult * 4 +) ris
+          is = V.map (multi * 4 +) ris
       in (acci V.++ is, accv V.++ vs)
       )
     (V.empty, V.empty)

src/Types/Player.hs

@@ -108,4 +108,4 @@ instance Collidible Pituicat where
       Debug
       ("*boing* meow! other: " <>
         fromString (show other))
-      (elasticCollision 0.3 cat other)
+      (elasticCollision 0.9 cat other)

src/Types/Subsystems.hs

@@ -13,10 +13,14 @@ data Subsystems = Subsystems
   , subTranslator :: SubTranslator
   }
 
-newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
-newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection ())])
-newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
-newtype SubTranslator = SubTranslator (TVar [(UUID, TranslatorMessage -> Affection ())])
+newtype SubWindow =
+  SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
+newtype SubMouse =
+  SubMouse (TVar [(UUID, MouseMessage -> Affection ())])
+newtype SubKeyboard =
+  SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
+newtype SubTranslator =
+  SubTranslator (TVar [(UUID, TranslatorMessage -> Affection ())])
 
 data TranslatorMessage = TranslatorMessage
   { tmAction :: Action

src/Types/Texture.hs

@@ -1,6 +1,6 @@
 module Types.Texture where
 
-import SDL (($=), get)
+import SDL (($=))
 
 import qualified Graphics.Rendering.OpenGL as GL