Reader monad experimentation for config app

app/Main.hs

@@ -5,6 +5,7 @@ import System.IO (hFlush, stdout)
 
 import System.Exit (exitSuccess)
 
+import Control.Monad.Reader
 import Control.Monad (unless)
 import Control.Concurrent (threadDelay)
 
@@ -39,12 +40,18 @@ import qualified Coord as C
 import Game (GameState, Fighter (..))
 import qualified Game as G
 
+import Config (Configuration)
+import qualified Config as Co
+
 import Utils
 
-loadBackground :: Renderer-> FilePath -> TextureMap -> SpriteMap -> IO (TextureMap, SpriteMap)
-loadBackground rdr path tmap smap = do
+loadConfig :: IO Configuration
+loadConfig = return (Co.Config { Co.screenW = 1024, Co.screenH = 531})
+
+loadBackground :: Integer -> Integer -> Renderer-> FilePath -> TextureMap -> SpriteMap -> IO (TextureMap, SpriteMap)
+loadBackground sw sh rdr path tmap smap = do
   tmap' <- TM.loadTexture rdr path (TextureId "background") tmap
-  let sprite = S.defaultScale $ S.addImage S.createEmptySprite $ S.createImage (TextureId "background") (S.mkArea 0 0 1024 531)
+  let sprite = S.defaultScale $ S.addImage S.createEmptySprite $ S.createImage (TextureId "background") (S.mkArea 0 0 (fromIntegral sw) (fromIntegral sh))
   let smap' = SM.addSprite (SpriteId "background") sprite smap
   return (tmap', smap')
 
@@ -80,18 +87,21 @@ askName part defaultStr validateStr = do
 main :: IO ()
 main = do
   initializeAll
+  conf <- loadConfig
+  let sw = runReader (Co.getConf Co.screenW) conf
+  let sh = runReader (Co.getConf Co.screenH) conf
   name1 <- askName "Fighter 1 name" "Fighter 1" validateString
   name2 <- askName "Fighter 2 name" "Fighter 2" validateString
-  window <- createWindow "PAF Project - Street Fighter 2" $ defaultWindow { windowInitialSize = V2 1024 531 }
+  window <- createWindow "PAF Project - Street Fighter 2" $ defaultWindow { windowInitialSize = V2 (fromIntegral sw) (fromIntegral sh) }
   renderer <- createRenderer window (-1) defaultRenderer
   -- load assets
-  (tmap, smap) <- loadBackground renderer "assets/background.bmp" TM.createTextureMap SM.createSpriteMap
+  (tmap, smap) <- loadBackground sw sh renderer "assets/background.bmp" TM.createTextureMap SM.createSpriteMap
   (tmap1, smap1) <- loadFighter (fighterAssetId 1 G.None) 80 160 renderer "assets/fighter1.bmp" tmap smap
   (tmap1', smap1') <- loadFighter (fighterAssetId 1 G.Kick) 110 160 renderer "assets/fighter1K.bmp" tmap1 smap1
   (tmap2, smap2) <- loadFighter (fighterAssetId 2 G.None) 80 160 renderer "assets/fighter2.bmp" tmap1' smap1'
   (tmap2', smap2') <- loadFighter (fighterAssetId 2 G.Kick) 110 160 renderer "assets/fighter2K.bmp" tmap2 smap2
   -- init game (#ToDo : sizes, default positions in argument)
-  let gameState = G.createGameState name1 name2
+  let gameState = G.createGameState sw sh name1 name2
   let kbd = K.createKeyboard
   gameLoop 60 renderer tmap2' smap2' kbd gameState
 

package.yaml

@@ -21,6 +21,7 @@ description:         Please see the README on GitHub at <https://github.com/epat
 dependencies:
 - base >= 4.7 && < 5
 - containers
+- mtl
 - linear
 - sdl2
 - random

src/Config.hs

@@ -0,0 +1,13 @@
+module Config where
+
+import Control.Monad.Reader
+
+data Configuration = Config {
+    screenW :: Integer,
+    screenH :: Integer
+}
+
+getConf :: (Configuration -> Integer) -> Reader Configuration Integer
+getConf conf_accessor = do
+    conf <- ask
+    return (conf_accessor conf)

src/Game.hs

@@ -67,12 +67,12 @@ prop_inv_gameState GameIn {
 createFighter :: Integer -> String -> Integer -> Integer -> Hitbox -> Direction -> Fighter
 createFighter id name x y h d = Fighter (FighterId id) name (Coord x y) h d None (OK 10)
 
-createGameState :: String -> String -> GameState
-createGameState name1 name2 =
+createGameState :: Integer -> Integer -> String -> String -> GameState
+createGameState sw sh name1 name2 =
     GameIn
         (createFighter 1 name1 300 350 (createHitbox 1 300 350) R)
         (createFighter 2 name2 500 350 (createHitbox 2 500 350) L)
-        (createZone 1024 531)    -- default size
+        (createZone sw sh)
         5
         True
 

test/GameSpec.hs

@@ -14,19 +14,19 @@ genDir = elements [U,D,R,L]
 gameUT = do
   describe "Game - Unit tests" $ do
     it "Specific createGameState" $ do
-      let GameIn f1 f2 z s i = createGameState "name1" "name2" in
+      let GameIn f1 f2 z s i = createGameState 1024 531 "name1" "name2" in
         prop_inv_gameState (GameIn f1 f2 z s i) &&
         prop_inv_hitbox (hitboxF f1) &&
         prop_inv_hitbox (hitboxF f2) &&
         prop_inv_zone_hitbox z (hitboxF f1) &&
         prop_inv_zone_hitbox z (hitboxF f2)
           `shouldBe` True
     it "Specific action KO" $
-      let GameIn f1 (Fighter i2 n2 c2 h2 d2 a2 (OK l2)) z s i = createGameState "name1" "name2" in
+      let GameIn f1 (Fighter i2 n2 c2 h2 d2 a2 (OK l2)) z s i = createGameState 1024 531 "name1" "name2" in
       let GameIn af1 (Fighter ai2 an2 ac2 ah2 ad2 aa2 (OK al2)) az as ai = action 1 Kick (GameIn f1 (Fighter i2 n2 c2 h2 d2 a2 (OK l2)) z s i) in
         al2 `shouldBe` l2
     it "Specific action OK" $
-      let GameIn f1 (Fighter i2 n2 c2 h2 d2 a2 (OK l2)) z s i = createGameState "name1" "name2" in
+      let GameIn f1 (Fighter i2 n2 c2 h2 d2 a2 (OK l2)) z s i = createGameState 1024 531 "name1" "name2" in
       let GameIn af1 (Fighter ai2 an2 ac2 ah2 ad2 aa2 (OK al2)) az as ai = action 1 Kick (GameIn f1 (Fighter i2 n2 c2 (moveHitbox 2 (Coord 350 350)) d2 a2 (OK l2)) z s i) in
         al2 `shouldBe` (l2-1)
 
@@ -35,10 +35,10 @@ gameQCT = do
   describe "Game - QuickCheck tests" $ do
     it "createGameState" $ property $
       \name1 -> collect (length name1) $ \name2 -> collect (length name2) $
-        prop_inv_gameState (createGameState name1 name2)
+        prop_inv_gameState (createGameState 1024 531 name1 name2)
     it "moveD" $ property $
       forAll (oneof [return 1, return 2]) $ \fid -> forAll genDir $ \dir -> \name1 name2 ->
-        let GameIn f1 f2 z s i = moveD fid dir (createGameState name1 name2) in
+        let GameIn f1 f2 z s i = moveD fid dir (createGameState 1024 531 name1 name2) in
           prop_inv_gameState (GameIn f1 f2 z s i) &&
           prop_inv_hitbox (hitboxF f1) &&
           prop_inv_hitbox (hitboxF f2) &&