diff --git a/app/labyrinth/src/Labyrinth/App.hs b/app/labyrinth/src/Labyrinth/App.hs index 229e6be..daca933 100644 --- a/app/labyrinth/src/Labyrinth/App.hs +++ b/app/labyrinth/src/Labyrinth/App.hs @@ -1,6 +1,7 @@ module Labyrinth.App where import qualified Data.Map as Map +import qualified Data.String as Str import qualified Hydra.Domain as D import Labyrinth.Prelude as L @@ -8,6 +9,7 @@ import Labyrinth.Domain import Labyrinth.Types import Labyrinth.Render import Labyrinth.Algorithms +import Labyrinth.Gen import Labyrinth.Lens data Passage @@ -100,21 +102,24 @@ setGameState st = writeVarIO (st ^. gameState) getGameState :: AppState -> LangL GameState getGameState st = readVarIO $ st ^. gameState -nextWormhole :: AppState -> Int -> Int -nextWormhole st n | (n + 1 < Map.size (st ^. wormholes)) = n + 1 - | otherwise = 0 +nextWormhole :: Wormholes -> Int -> Int +nextWormhole wms n | (n + 1 < Map.size wms) = n + 1 + | otherwise = 0 executeWormhole :: AppState -> Int -> LangL () -executeWormhole st (nextWormhole st -> n) = case Map.lookup n (st ^. wormholes) of - Nothing -> throwException $ InvalidOperation $ "Wormhole not found: " +|| n ||+ "" - Just pos -> setPlayerPos st pos +executeWormhole st prevWormhole = do + wormholes <- readVarIO $ st ^. labWormholes + let n = nextWormhole wormholes prevWormhole + case Map.lookup n wormholes of + Nothing -> throwException $ InvalidOperation $ "Wormhole not found: " +|| n ||+ "" + Just pos -> setPlayerPos st pos cancelPlayerLeaving :: AppState -> LangL () cancelPlayerLeaving st = do gameSt <- getGameState st case gameSt of - PlayerIsAboutLeaving _ -> addMoveMessage st "Okay, continue." - PlayerIsAboutLossLeavingConfirmation -> addMoveMessage st "Okay, continue." + PlayerIsAboutLeaving _ -> addGameMessage st "Okay, continue." + PlayerIsAboutLossLeavingConfirmation -> addGameMessage st "Okay, continue." _ -> pure () setGameState st PlayerMove @@ -128,17 +133,17 @@ performPlayerContentEvent st = do performPlayerContentEvent' :: AppState -> Pos -> Content -> LangL () performPlayerContentEvent' _ _ NoContent = pure () performPlayerContentEvent' st pos Treasure = do - addMoveMessage st "You found a treasure!" + addGameMessage st "You found a treasure!" writeVarIO (st ^. playerInventory . treasure) True setCellContent st pos NoContent performPlayerContentEvent' st _ (Wormhole n) = do - addMoveMessage st $ "You found a wormhole. You have been moved to the next wormhole." + addGameMessage st $ "You found a wormhole. You have been moved to the next wormhole." executeWormhole st n -addMoveMessage :: AppState -> String -> LangL () -addMoveMessage st msg = do - msgs <- readVarIO $ st ^. moveMessages - writeVarIO (st ^. moveMessages) $ msgs ++ [msg] +addGameMessage :: AppState -> String -> LangL () +addGameMessage st msg = do + msgs <- readVarIO $ st ^. gameMessages + writeVarIO (st ^. gameMessages) $ msgs ++ [msg] makeMove :: AppState -> Direction -> LangL () makeMove st dir = do @@ -146,10 +151,10 @@ makeMove st dir = do moveResult <- testMove st dir case moveResult of InvalidMove msg -> throwException $ InvalidOperation msg - ImpossibleMove msg -> addMoveMessage st msg + ImpossibleMove msg -> addGameMessage st msg ExitFound hasTreasure -> setGameState st $ PlayerIsAboutLeaving hasTreasure SuccessfullMove newPos _ _ -> do - addMoveMessage st "Step executed." + addGameMessage st "Step executed." setPlayerPos st newPos performPlayerContentEvent st @@ -166,10 +171,10 @@ handleYes st = do gameSt <- getGameState st case gameSt of PlayerIsAboutLossLeavingConfirmation -> do - addMoveMessage st loosing + addGameMessage st loosing setGameState st GameFinished PlayerIsAboutLeaving _ -> throwException $ InvalidOperation "handleYes: Invalid state: PlayerIsAboutLeaving" - _ -> addMoveMessage st $ unknownCommand "yes" + _ -> addGameMessage st $ unknownCommand "yes" handleNo :: AppState -> LangL () handleNo st = do @@ -177,14 +182,13 @@ handleNo st = do case gameSt of PlayerIsAboutLeaving _ -> throwException $ InvalidOperation "handleNo: Invalid state: PlayerIsAboutLeaving" PlayerIsAboutLossLeavingConfirmation -> cancelPlayerLeaving st - _ -> addMoveMessage st $ unknownCommand "no" + _ -> addGameMessage st $ unknownCommand "no" printLab :: AppState -> LangL () printLab st = do - lab <- readVarIO $ st ^. labyrinth - bounds <- readVarIO $ st ^. labyrinthSize - plPos <- readVarIO $ st ^. playerPos - let template = st ^. labRenderTemplate + lab <- readVarIO $ st ^. labyrinth + plPos <- readVarIO $ st ^. playerPos + template <- readVarIO $ st ^. labRenderTemplate printLabRender' $ renderLabyrinth' template lab plPos @@ -193,20 +197,21 @@ onStep st _ = do gameSt <- scenario $ getGameState st isFinished <- scenario $ case gameSt of PlayerIsAboutLeaving True -> do - addMoveMessage st winning + addGameMessage st winning setGameState st GameFinished pure True PlayerIsAboutLeaving False -> do - addMoveMessage st leaveWithoutTreasure + addGameMessage st leaveWithoutTreasure setGameState st PlayerIsAboutLossLeavingConfirmation pure False PlayerIsAboutLossLeavingConfirmation -> throwException $ InvalidOperation "OnStep: Invalid state: PlayerIsAboutLossLeavingConfirmation" PlayerMove -> pure False GameFinished -> pure True + GameStart -> pure False - msgs <- readVarIO $ st ^. moveMessages - writeVarIO (st ^. moveMessages) [] + msgs <- readVarIO $ st ^. gameMessages + writeVarIO (st ^. gameMessages) [] let outputMsg = intercalate "\n" msgs case isFinished of @@ -215,29 +220,71 @@ onStep st _ = do False | null outputMsg -> pure D.CliLoop | otherwise -> pure $ D.CliOutputMsg outputMsg -onUnknownCommand :: String -> AppL CliAction -onUnknownCommand "" = pure D.CliLoop -onUnknownCommand cmdStr = pure $ D.CliOutputMsg $ unknownCommand cmdStr +startGame :: AppState -> Int -> LangL String +startGame st s = generateLabyrinth (s, s) >>= startGame' st + +startRndGame :: AppState -> LangL () +startRndGame st = do + lab <- generateRndLabyrinth + msg <- startGame' st lab + addGameMessage st msg + +startGame' :: AppState -> Labyrinth -> LangL String +startGame' st lab = do + let (bounds, wormholes) = analyzeLabyrinth lab + let renderTemplate = renderSkeleton bounds + + writeVarIO (st ^. labyrinth) lab + writeVarIO (st ^. labBounds) bounds + writeVarIO (st ^. labRenderTemplate) renderTemplate + writeVarIO (st ^. labRenderVar) renderTemplate + writeVarIO (st ^. labWormholes) wormholes + writeVarIO (st ^. playerPos) (0, 0) + writeVarIO (st ^. playerInventory . treasure) False + writeVarIO (st ^. gameState) PlayerMove + + pure "New game started." + + +onUnknownCommand :: AppState -> String -> AppL CliAction +onUnknownCommand _ "" = pure D.CliLoop +onUnknownCommand st cmdStr = do + case Str.words cmdStr of + ["start", sizeStr] -> case readMaybe sizeStr of + Nothing -> pure $ D.CliOutputMsg $ "start command should have 1 int argument." + Just s -> scenario (startGame st s) >>= pure . D.CliOutputMsg + _ -> pure $ D.CliOutputMsg $ unknownCommand cmdStr + +onPlayerMove :: AppState -> LangL () -> LangL () +onPlayerMove st act = do + gs <- getGameState st + case gs of + GameFinished -> addGameMessage st "Game finished. Please type 'start ' to start a new game." + GameStart -> addGameMessage st "Game is not yet started. Please type 'start ' to start a new game." + _ -> act app :: AppState -> AppL () app st = do scenario $ putStrLn "Labyrinth (aka Terra Incognita) game" + scenario $ putStrLn "Please type 'start ' to start a new game." - cliToken <- cli (onStep st) onUnknownCommand $ do - cmd "go up" $ makeMove st DirUp - cmd "go down" $ makeMove st DirDown - cmd "go left" $ makeMove st DirLeft - cmd "go right" $ makeMove st DirRight + cliToken <- cli (onStep st) (onUnknownCommand st) $ do + cmd "go up" $ onPlayerMove st $ makeMove st DirUp + cmd "go down" $ onPlayerMove st $ makeMove st DirDown + cmd "go left" $ onPlayerMove st $ makeMove st DirLeft + cmd "go right" $ onPlayerMove st $ makeMove st DirRight - cmd "up" $ makeMove st DirUp - cmd "down" $ makeMove st DirDown - cmd "left" $ makeMove st DirLeft - cmd "right" $ makeMove st DirRight + cmd "up" $ onPlayerMove st $ makeMove st DirUp + cmd "down" $ onPlayerMove st $ makeMove st DirDown + cmd "left" $ onPlayerMove st $ makeMove st DirLeft + cmd "right" $ onPlayerMove st $ makeMove st DirRight cmd "yes" $ handleYes st cmd "no" $ handleNo st - cmd "skip" $ evalSkip st + cmd "skip" $ onPlayerMove st $ evalSkip st + + cmd "start" $ startRndGame st cmd "quit" $ quit st cmd "q" $ quit st diff --git a/app/labyrinth/src/Labyrinth/Gen.hs b/app/labyrinth/src/Labyrinth/Gen.hs index 069e666..cf65f9b 100644 --- a/app/labyrinth/src/Labyrinth/Gen.hs +++ b/app/labyrinth/src/Labyrinth/Gen.hs @@ -178,13 +178,16 @@ removeWalls' lab pos dir = do <> ", cells:" <> show (mbC1, mbC2) -generateLabyrinth :: LangL Labyrinth -generateLabyrinth = do +generateRndLabyrinth :: LangL Labyrinth +generateRndLabyrinth = do xSize <- getRandomInt (4, 10) ySize <- getRandomInt (4, 10) - exits <- getRandomInt (1, 4) + generateLabyrinth (xSize, ySize) + +generateLabyrinth :: Bounds -> LangL Labyrinth +generateLabyrinth bounds = do + exits <- getRandomInt (1, 4) wormholes <- getRandomInt (2, 5) - let bounds = (xSize, ySize) generateGrid bounds >>= generatePaths bounds >>= generateExits bounds exits diff --git a/app/labyrinth/src/Labyrinth/Types.hs b/app/labyrinth/src/Labyrinth/Types.hs index c6c83eb..824b4d5 100644 --- a/app/labyrinth/src/Labyrinth/Types.hs +++ b/app/labyrinth/src/Labyrinth/Types.hs @@ -13,22 +13,23 @@ data Inventory = Inventory } data GameState - = PlayerMove + = GameStart + | GameFinished + | PlayerMove | PlayerIsAboutLeaving HasTreasure | PlayerIsAboutLossLeavingConfirmation - | GameFinished deriving (Show, Eq) data AppState = AppState { _labyrinth :: StateVar Labyrinth - , _labyrinthSize :: StateVar Bounds - , _labRenderTemplate :: LabRender + , _labBounds :: StateVar Bounds + , _labRenderTemplate :: StateVar LabRender , _labRenderVar :: StateVar LabRender - , _wormholes :: Wormholes + , _labWormholes :: StateVar Wormholes , _playerPos :: StateVar Pos , _playerInventory :: Inventory , _gameState :: StateVar GameState - , _moveMessages :: StateVar [String] + , _gameMessages :: StateVar [String] } data AppException diff --git a/app/labyrinth/src/Main.hs b/app/labyrinth/src/Main.hs index 0c7d908..21cd191 100644 --- a/app/labyrinth/src/Main.hs +++ b/app/labyrinth/src/Main.hs @@ -12,7 +12,6 @@ import Labyrinth.Domain import Labyrinth.Render import Labyrinth.Labyrinths import Labyrinth.Algorithms -import Labyrinth.Gen loggerCfg :: D.LoggerConfig loggerCfg = D.LoggerConfig @@ -28,20 +27,22 @@ initAppState lab = do let (bounds, wormholes) = analyzeLabyrinth lab let renderTemplate = renderSkeleton bounds - labRenderVar <- newVarIO renderTemplate - labVar <- newVarIO lab - labSizeVar <- newVarIO bounds - posVar <- newVarIO (0, 0) - inv <- Inventory <$> newVarIO False - gameStateVar <- newVarIO PlayerMove - moveMsgsVar <- newVarIO [] + renderTemplateVar <- newVarIO renderTemplate + labRenderVar <- newVarIO renderTemplate + labVar <- newVarIO lab + labBoundsVar <- newVarIO bounds + wormholesVar <- newVarIO wormholes + posVar <- newVarIO (0, 0) + inv <- Inventory <$> newVarIO False + gameStateVar <- newVarIO GameStart + moveMsgsVar <- newVarIO [] pure $ AppState labVar - labSizeVar - renderTemplate + labBoundsVar + renderTemplateVar labRenderVar - wormholes + wormholesVar posVar inv gameStateVar