From ad8bf1d8541415d05f6ec5b4355b418b3b8d6f30 Mon Sep 17 00:00:00 2001 From: flober Date: Mon, 1 Jul 2024 22:57:41 -0400 Subject: [PATCH] initial player setup, buy, sell --- src/Controller/Terminal.hs | 48 ++++++++++++++---------- src/Logic.hs | 75 +++++++++++++++++++++++++++----------- src/Model.hs | 20 +++++----- src/View/Terminal.hs | 1 - 4 files changed, 92 insertions(+), 52 deletions(-) diff --git a/src/Controller/Terminal.hs b/src/Controller/Terminal.hs index 8de9d85..bcd7b25 100644 --- a/src/Controller/Terminal.hs +++ b/src/Controller/Terminal.hs @@ -1,15 +1,18 @@ module Controller.Terminal (module Controller.Terminal) where import Card (bigDumbo) +import Control.Lens import Control.Monad.Random (MonadRandom (getRandom)) import Data.Map hiding (foldl, map) -import Model (Action (..), CardInstance (CardInstance), GameState (..), Phase (Blank), PlayerState (..)) +import Data.Maybe (fromJust) +import Logic (execAction, isGameOver, validateAction) +import Model (Action (..), CardInstance (CardInstance), GameState (..), Phase (HeroSelect), PlayerState (..), playerStates) import Text.Parsec hiding (Error) import Text.Parsec.String (Parser) import Text.Read (readMaybe) import View.Terminal (render) -import Data.Maybe (fromJust) -import Logic (validateAction, execAction, isGameOver) +import Control.Monad.IO.Class (liftIO) +import qualified Data.Map as Map -- START: Functions for ingesting terminal input as Action -- -- Examples: @@ -21,13 +24,13 @@ import Logic (validateAction, execAction, isGameOver) -- help -> Help interp :: String -> Either String Action interp s = case parse actionParser "" s of - Left _ -> Left "Unrecognized or incorrectly formatted command. Enter :h for command list." - Right a -> Right a + Left _ -> Left "Unrecognized or incorrectly formatted command. Enter h for command list." + Right a -> Right a -- Parse the full input string actionParser :: Parser Action actionParser = do - cmd <- choice $ map (try . string) ["buy", "b", "sell", "s", "help", "h", "endturn", "e"] + cmd <- choice $ map (try . string) ["buy", "b", "sell", "s", "help", "h", "endturn", "e", "play", "p"] spaces action <- actionArgumentParser cmd eof @@ -38,6 +41,7 @@ actionArgumentParser :: String -> Parser Action actionArgumentParser cmd | cmd `elem` ["buy", "b"] = buyArgParser | cmd `elem` ["sell", "s"] = sellArgParser + | cmd `elem` ["play", "p"] = playArgParser | cmd `elem` ["help", "h"] = return Help | cmd `elem` ["endturn", "e"] = return EndTurn | otherwise = error "Unexpected path: actionArgumentParser should only run if it matched a command." @@ -56,13 +60,18 @@ sellArgParser = do Just ind -> return $ Sell ind Nothing -> fail "Sell's argument should be a valid number." +playArgParser :: Parser Action +playArgParser = do + indStr <- many1 digit + case readMaybe indStr of + Just ind -> return $ Play ind + Nothing -> fail "Play's argument should be a valid number." -- END -- - initGameState :: (MonadRandom m) => m GameState initGameState = do tutorialAIGameState <- tutorialAI - return $ GameState {playerStates = fromList [("player", defPlayerState), ("tutorialAI", tutorialAIGameState)], turn = 0} + return $ GameState {_playerStates = fromList [("player", defPlayerState), ("tutorialAI", tutorialAIGameState)], turn = 0} tutorialAI :: (MonadRandom m) => m PlayerState tutorialAI = do @@ -80,7 +89,7 @@ defPlayerState = shop = [], board = [], hand = [], - phase = Blank, + phase = HeroSelect, frozen = False, hp = 20, armor = 0, @@ -91,24 +100,23 @@ defPlayerState = runGame :: IO () runGame = do gs <- initGameState - _ <- loop gs + initialMainPlayerState <- execAction StartGame ((gs ^. playerStates) Map.! "player") + let gs' = gs & playerStates . ix "player" .~ initialMainPlayerState + _ <- loop gs' putStrLn "Game Finished." where + -- Repeat Recruit and Combat until game over loop gs = if isGameOver gs then do return gs else do - let mainPlayerState = fromJust $ Data.Map.lookup "player" (playerStates gs) + let mainPlayerState = fromJust $ Data.Map.lookup "player" (_playerStates gs) putStrLn $ render mainPlayerState input <- getLine - let action = interp input - either - (\err -> putStrLn err >> loop gs) - ( \action' -> do - let action'' = validateAction action' gs - gs' <- execAction action'' gs - loop gs' - ) - action + case interp input >>= (`validateAction` mainPlayerState) of + Left err -> putStrLn err >> loop gs + Right action' -> do + newPlayerState <- liftIO $ execAction action' mainPlayerState + loop (gs & playerStates . at "player" ?~ newPlayerState) diff --git a/src/Logic.hs b/src/Logic.hs index 49a2281..6eb0715 100644 --- a/src/Logic.hs +++ b/src/Logic.hs @@ -6,27 +6,54 @@ module Logic (module Logic) where import Card (pool) import Control.Lens ((^.)) import Control.Monad.Random -import Data.UUID import Model import View.Terminal (helpMenu) -- START: Functions interfacing with Action. -- -validateAction :: Action -> GameState -> Action -validateAction = const -execAction :: (MonadIO m) => Action -> GameState -> m GameState -execAction (Error msg) gs = liftIO (putStrLn msg) >> return gs +-- Can action occur in given PlayerState? Yes then thread the same action through. False then error message. +validateAction :: Action -> PlayerState -> Either String Action +validateAction (Buy ind) gs + | shopSize == 0 = Left "Your shop is empty." + | ind < shopSize = return (Buy ind) + | shopSize == 1 = Left "This hand only permits shop 0" + | otherwise = Left $ "This shop only permits buy 0 to buy " ++ show (shopSize - 1) + where + shopSize = length (shop gs) +validateAction (Sell ind) gs + | boardSize == 0 = Left "You have no board." + | ind < boardSize = return (Sell ind) + | boardSize == 1 = Left "This hand only permits sell 0" + | otherwise = Left $ "This board only permits sell 0 to sell " ++ show (boardSize - 1) + where + boardSize = length (board gs) +validateAction (Play ind) gs + | handSize == 0 = Left "You have an empty hand." + | ind < handSize = return (Play ind) + | handSize == 1 = Left "This hand only permits play 0" + | otherwise = Left $ "This hand only permits play 0 to play " ++ show (handSize - 1) + where + handSize = length (hand gs) +validateAction StartGame ps = if phase ps == HeroSelect then return StartGame else Left "No need to start game if you're not in HeroSelect" +validateAction EndTurn ps = if phase ps == Recruit then return EndTurn else Left "Doesn't make sense to end turn if you're not in Recruit" +validateAction x _ = return x + +execAction :: (MonadIO m, MonadRandom m) => Action -> PlayerState -> m PlayerState +execAction (Buy ind) gs = return $ buy ind gs +execAction (Sell ind) gs = return $ sell ind gs +execAction (Play ind) gs = return $ play ind gs +execAction StartGame gs = enter Recruit gs -- For now, StartGame skips hero select. It should go into HeroSelect in the future +execAction EndTurn gs = enter Combat gs execAction Help gs = liftIO (putStrLn helpMenu) >> return gs -execAction _ gs = return gs -- END -- -- START: Game Transition Functions -- -- Check if only one player alive isGameOver :: GameState -> Bool -isGameOver gs = playersAlive == 1 +isGameOver gs = playersAlive == (1 :: Integer) where - playersAlive = foldl (\acc ps -> if alive ps then acc + 1 else acc) 0 (playerStates gs) + playersAlive = foldl (\acc ps -> if alive ps then acc + 1 else acc) 0 (_playerStates gs) -- Performed when we first transition to a new game phase. enter :: (MonadRandom m) => Phase -> PlayerState -> m PlayerState @@ -42,23 +69,27 @@ enter Recruit ps = do } where newGold = maxGold ps + 1 -enter Combat _ = undefined +enter Combat ps = return $ ps { phase = Combat } enter _ _ = error "Other phases should not be enterable" -- END -- -- START: Utility Methods for Action Functions -- +-- Determinisitc functions should only be used when the usage permits only the happy path + deterministicLookup :: (Eq a) => a -> [(a, b)] -> b deterministicLookup a xs = case lookup a xs of Nothing -> error "Unexpected path: deterministicLookup should always find." Just c -> c -findCard :: UUID -> [CardInstance] -> CardInstance -findCard cardId instances = deterministicLookup cardId ([(_cardId cardInstance, cardInstance) | cardInstance <- instances]) +findCard :: Index -> [CardInstance] -> CardInstance +findCard ind instances = instances !! ind -removeCard :: UUID -> [CardInstance] -> [CardInstance] -removeCard cardId = filter (\ci -> _cardId ci /= cardId) +remove :: Int -> [a] -> [a] +remove _ [] = [] +remove 0 (_ : xs) = xs +remove n (x : xs) = x : remove (n - 1) xs canTierUp :: PlayerState -> Bool canTierUp ps = curGold ps >= tierUpCost ps @@ -82,23 +113,23 @@ sampleNFromList n xs = replicateM n sample -- END -- --- START: Functions that Actions directly map to -- -play :: UUID -> PlayerState -> PlayerState -play targetId ps = ps {board = board ps ++ [findCard targetId (hand ps)], hand = removeCard targetId (hand ps)} +-- START: Functions that Actions map to -- +play :: Index -> PlayerState -> PlayerState +play ind ps = ps {board = board ps ++ [findCard ind (hand ps)], hand = remove ind (hand ps)} -buy :: UUID -> PlayerState -> PlayerState -buy targetId ps = - let cardInstance = findCard targetId (shop ps) +buy :: Index -> PlayerState -> PlayerState +buy ind ps = + let cardInstance = findCard ind (shop ps) card = _card cardInstance cost = _baseCost card moneyLeft = curGold ps in if cost > moneyLeft then error "Logic error: Attempted buying without enough money." - else ps {curGold = moneyLeft - cost, shop = removeCard targetId (shop ps), hand = hand ps ++ [cardInstance]} + else ps {curGold = moneyLeft - cost, shop = remove ind (shop ps), hand = hand ps ++ [cardInstance]} -sell :: UUID -> PlayerState -> PlayerState -sell targetId ps = ps {curGold = curGold ps + 1, board = removeCard targetId (board ps)} +sell :: Index -> PlayerState -> PlayerState +sell ind ps = ps {curGold = curGold ps + 1, board = remove ind (board ps)} roll :: (MonadRandom m) => PlayerState -> m PlayerState roll ps = do diff --git a/src/Model.hs b/src/Model.hs index 8aca5a1..f0d3818 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -4,7 +4,6 @@ module Model (module Model) where import Control.Lens hiding (Index) -import Control.Lens.TH import Data.Map (Map) import Data.UUID (UUID) import System.Random (StdGen) @@ -26,7 +25,7 @@ type TavernTier = Int type CardCost = Int -data CardName = Dummy | Dumber | TriDummy | Dumbo | BigDumbo | KingDumbo | DummyWithALongNameItKeepsGoing deriving Show +data CardName = Dummy | Dumber | TriDummy | Dumbo | BigDumbo | KingDumbo | DummyWithALongNameItKeepsGoing deriving (Show) data Card = Card { _cardName :: CardName, @@ -57,14 +56,15 @@ type Turn = Int -- What turn are we on? type UserName = String -data Phase = HeroSelect | Blank | Recruit | Combat +data Phase = HeroSelect | Recruit | Combat deriving (Eq) data GameState = GameState - { playerStates :: Map UserName PlayerState, + { _playerStates :: Map UserName PlayerState, turn :: Turn } -data OppInfo = OppInfo { oppHP :: Health, oppArmor :: Armor } +data OppInfo = OppInfo {oppHP :: Health, oppArmor :: Armor} + data PlayerState = PlayerState { tier :: TavernTier, maxGold :: Gold, @@ -82,11 +82,13 @@ data PlayerState = PlayerState opponentInformation :: Map UserName OppInfo } +$(makeLenses ''GameState) +$(makeLenses ''PlayerState) -data Env = Env { - gen :: StdGen -} +data Env = Env + { gen :: StdGen + } type Index = Int -data Action = Buy Index | Sell Index | Play Index | Help | StartGame | EndTurn | Error String \ No newline at end of file +data Action = Buy Index | Sell Index | Play Index | Help | StartGame | EndTurn \ No newline at end of file diff --git a/src/View/Terminal.hs b/src/View/Terminal.hs index 1fcbb4d..68b8a97 100644 --- a/src/View/Terminal.hs +++ b/src/View/Terminal.hs @@ -41,7 +41,6 @@ render :: PlayerState -> String render ps = case phase ps of Recruit -> renderRecruit ps - Blank -> "blank todo" HeroSelect -> "heroselect todo" Combat -> "combat todo"