Brute force game building

TODO.md

@@ -0,0 +1,4 @@
+# Todo
+
+- [x] Remove Splash screen
+- [ ] Restore Splash screen

lib/Labyrinth/Game.hs

@@ -7,6 +7,7 @@ module Labyrinth.Game
   , Configuration
   , Position
   , defaultGame
+  , playing
   )
 where
 
@@ -23,7 +24,7 @@ import           Labyrinth.Game.Player          ( Player(..)
                                                 )
 import qualified Labyrinth.Game.Treasure       as T
 import           Labyrinth.Game.Configuration   ( Configuration )
-import           Labyrinth.Game.Class           ( Game(..) )
+import           Labyrinth.Game.Class           ( Game(..), playing )
 import qualified Labyrinth.Game.Board          as Board
 import           Labyrinth.Game.Board           ( Board(..) )
 import qualified Labyrinth.Game.Cell           as Cell

lib/Labyrinth/Game/Configuration.hs

@@ -9,7 +9,6 @@ module Labyrinth.Game.Configuration
   , insert
   , delete
   , availableColors
-  , firstPlayer
   )
 where
 
@@ -62,6 +61,3 @@ availableColors ps = Set.toList available
   available = Set.difference existing taken
   existing  = Set.fromList P.colors
   taken     = Set.fromList $ map (^. P.color) (toList ps)
-
-firstPlayer :: Configuration -> Maybe Player
-firstPlayer = P.first . (^. players)

lib/Labyrinth/Game/NewGame.hs

@@ -42,9 +42,10 @@ import           Labyrinth.Game.Position        ( Position )
 import           Labyrinth.Game.Treasure        ( Treasure )
 import qualified Labyrinth.Game.Direction      as D
 import           Labyrinth.Game.Direction       ( Direction )
+import qualified Labyrinth.Game.Player         as P
 import           Labyrinth.Game.Player          ( Players
                                                 , Player
-                                                , PlayOrder(First)
+                                                , PlayOrder
                                                 )
 import           Labyrinth.Game.Class           ( Game(..) )
 
@@ -75,7 +76,7 @@ newGame tiles gates players rows cols treasures extraTile positions = do
     >>= addPositions shufPos
     >>= addTreasures shufTre
     >>= traverse mkTile
-    >>= \ts -> players !? First >>= \playing -> do
+    >>= \ts -> P.first players >>= \playing -> do
           let cellBoard = Board $ Map.fromList ts
           Just $ Game { _players   = players
                       , _playing   = playing

lib/Labyrinth/Store/Event/Setup.hs

@@ -4,11 +4,13 @@ module Labyrinth.Store.Event.Setup
 where
 
 import           Data.Maybe                     ( maybe )
+import           Control.Monad.IO.Class         ( liftIO )
 import           Brick
 import           Brick.Forms                    ( handleFormEvent )
 import qualified Graphics.Vty                  as V
 import           Lens.Micro                     ( (&)
                                                 , (.~)
+                                                , (^.)
                                                 )
 import           Labyrinth.Store.Internal
 import           Labyrinth.UI                   ( SetupS
@@ -17,11 +19,14 @@ import           Labyrinth.UI                   ( SetupS
 import qualified Labyrinth.UI.Screen.Setup     as S
 import qualified Labyrinth.UI.Widget           as UI
 import qualified Labyrinth.UI.Modal            as UI
+import qualified Labyrinth.Game                as G
 import           Labyrinth.Game                 ( PlayOrder(..)
                                                 , Player
                                                 , Players
                                                 )
 
+
+
 type RegistrationEventHandler e = EventHandler (SetupS e) e
 
 handle :: RegistrationEventHandler e
@@ -36,26 +41,28 @@ handle s store ev = handleEvent s store ev
     VtyEvent (V.EvKey V.KEnter []) -> submit
     _ -> processInput
 
+play :: RegistrationEventHandler e
+play s store _ = maybe (continue store) beginGame (S.players s)
+ where
+  beginGame ps = do
+    mg <- liftIO $ G.defaultGame ps
+    case mg of
+      Nothing -> halt store -- but in reality this is a runtime error
+      Just g  -> do
+        let p = g ^. G.playing
+        showModal store $ UI.mkOkModal "start" (UI.nextPlayerPrompt p) halt
+
+edit :: PlayOrder -> RegistrationEventHandler e
+edit i s store _ =
+  continue $ update store $ maybe s (S.editPlayer s) (S.playerAt s i)
+
 submit :: RegistrationEventHandler e
 submit s store _ =
   continue $ if S.validate s then update store (S.submitPlayer s) else store
 
-play :: RegistrationEventHandler e
-play s store _ = maybe (continue store) promptToPlay (S.setup s)
- where
-  promptToPlay (p, ps) = showModal store
-    $ UI.mkOkModal "start" (UI.nextPlayerPrompt p) (continueToNewGame p ps)
-
 processInput :: RegistrationEventHandler e
 processInput s store ev =
   S.processForm s (handleFormEvent ev) >>= continue . update store
 
-edit :: PlayOrder -> RegistrationEventHandler e
-edit i s store _ =
-  continue $ update store $ maybe s (S.editPlayer s) (S.playerAt s i)
-
 update :: Store e -> SetupS e -> Store e
 update store s = store & state .~ Setup s
-
-continueToNewGame :: Player -> Players -> ModalCallback Store e
-continueToNewGame _ _ = halt

lib/Labyrinth/UI/Screen/Game.hs

@@ -11,4 +11,4 @@ data GameS = GameS
   } deriving (Show)
 
 initial :: Game -> GameS
-initial g = GameS { _game = g }
+initial g = GameS { _game = g }

lib/Labyrinth/UI/Screen/Setup.hs

@@ -9,9 +9,7 @@ module Labyrinth.UI.Screen.Setup
   , extractPlayer
   , initial
   , draw
-  , firstPlayer
   , players
-  , setup
   --
   , form
   , register
@@ -48,7 +46,7 @@ import           Labyrinth.Game                 ( Player(..)
                                                 , PlayOrder(..)
                                                 )
 import qualified Labyrinth.Game.Configuration  as C
-import qualified Labyrinth.Game.Player        as P
+import qualified Labyrinth.Game.Player         as P
 import           Labyrinth.UI.Widget
 import           Labyrinth.UI.Internal
 
@@ -177,13 +175,7 @@ chooseCursor s = case (s ^. form) of
   Nothing    -> Nothing
   Just form' -> Just (focusRingCursor formFocus $ extractForm form')
 
-firstPlayer :: SetupS e -> Maybe Player
-firstPlayer = C.firstPlayer . (^. conf)
-
-players :: SetupS e -> Players
-players = (^. (conf . C.players))
-
-setup :: SetupS e -> Maybe (Player, Players)
-setup s = do
+players :: SetupS e -> Maybe Players
+players s = do
   guard (hasEnoughPlayers s)
-  firstPlayer s >>= Just . (, players s)
+  Just $ s ^. (conf . C.players)