From 17ab1c5de83149dbf296e217366c4249c527431b Mon Sep 17 00:00:00 2001 From: Andrew Chen Date: Sun, 15 Dec 2024 15:05:54 -0500 Subject: [PATCH] Introduced lenses and got rid of all traces of overloaded record plugin #1 --- package.yaml | 2 + src/Card.hs | 30 +++++----- src/Combat.hs | 100 +++++++++++++++---------------- src/Controller.hs | 71 ++++++++++------------ src/Logic.hs | 77 ++++++++++-------------- src/Model.hs | 149 +++++++++++++++++++++------------------------- src/Utils.hs | 22 ++----- src/View.hs | 40 +++++-------- 8 files changed, 222 insertions(+), 269 deletions(-) diff --git a/package.yaml b/package.yaml index ddf23dc..cb55e40 100644 --- a/package.yaml +++ b/package.yaml @@ -45,10 +45,12 @@ library: - parsec - pretty-simple - text == 2.0.2 + - lens - large-generics == 0.2.2 - large-records == 0.4.1 - record-hasfield - free == 5.2 + - effectful executables: diff --git a/src/Card.hs b/src/Card.hs index 12787f2..20bd609 100644 --- a/src/Card.hs +++ b/src/Card.hs @@ -8,39 +8,39 @@ pool :: [Card] pool = [dummy, dumber, triDummy, dumbo, bigDumbo, kingDumbo] defCard :: Card -defCard = Card {cardName = PlaceHolder, cardTier = -1, baseCost = -1, attack = -1, health = -1, deathrattle = []} +defCard = Card {_cardName = PlaceHolder, _cardTier = -1, _baseCost = -1, _attack = -1, _health = -1, _deathrattle = []} skeleton :: Card -skeleton = defCard {cardName = Skeleton, cardTier = 1, baseCost = error "Skeleton has no base cost.", attack = 1, health = 1} +skeleton = defCard {_cardName = Skeleton, _cardTier = 1, _baseCost = error "Skeleton has no base cost.", _attack = 1, _health = 1} harmlessBonehead :: Card harmlessBonehead = defCard - { cardName = HarmlessBonehead, - cardTier = 1, - baseCost = 3, - attack = 1, - health = 1, - deathrattle = [Summon (SpecificCard skeleton), Summon (SpecificCard skeleton)] + { _cardName = HarmlessBonehead, + _cardTier = 1, + _baseCost = 3, + _attack = 1, + _health = 1, + _deathrattle = [Summon (SpecificCard skeleton), Summon (SpecificCard skeleton)] } dummy :: Card -dummy = defCard {cardName = Dummy, cardTier = 1, baseCost = 3, attack = 1, health = 1} +dummy = defCard {_cardName = Dummy, _cardTier = 1, _baseCost = 3, _attack = 1, _health = 1} dumber :: Card -dumber = defCard {cardName = Dumber, cardTier = 2, baseCost = 3, attack = 2, health = 2} +dumber = defCard {_cardName = Dumber, _cardTier = 2, _baseCost = 3, _attack = 2, _health = 2} triDummy :: Card -triDummy = defCard {cardName = TriDummy, cardTier = 3, baseCost = 3, attack = 3, health = 3} +triDummy = defCard {_cardName = TriDummy, _cardTier = 3, _baseCost = 3, _attack = 3, _health = 3} dumbo :: Card -dumbo = defCard {cardName = Dumbo, cardTier = 4, baseCost = 3, attack = 4, health = 4} +dumbo = defCard {_cardName = Dumbo, _cardTier = 4, _baseCost = 3, _attack = 4, _health = 4} bigDumbo :: Card -bigDumbo = defCard {cardName = BigDumbo, cardTier = 5, baseCost = 3, attack = 5, health = 5} +bigDumbo = defCard {_cardName = BigDumbo, _cardTier = 5, _baseCost = 3, _attack = 5, _health = 5} kingDumbo :: Card -kingDumbo = defCard {cardName = KingDumbo, cardTier = 6, baseCost = 3, attack = 6, health = 6} +kingDumbo = defCard {_cardName = KingDumbo, _cardTier = 6, _baseCost = 3, _attack = 6, _health = 6} dummyWithALongNameItKeepsGoing :: Card -dummyWithALongNameItKeepsGoing = defCard {cardName = DummyWithALongNameItKeepsGoing, cardTier = 1, baseCost = 3, attack = 1, health = 1} +dummyWithALongNameItKeepsGoing = defCard {_cardName = DummyWithALongNameItKeepsGoing, _cardTier = 1, _baseCost = 3, _attack = 1, _health = 1} diff --git a/src/Combat.hs b/src/Combat.hs index 92d6421..8536103 100644 --- a/src/Combat.hs +++ b/src/Combat.hs @@ -1,16 +1,10 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedRecordUpdate #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Combat where +import Control.Lens hiding (Index) import Control.Monad.Random import Data.Bifunctor (Bifunctor (second)) import Data.List (findIndex, mapAccumL) import Data.Maybe (fromJust) -import Data.Record.Overloading import Debug.Trace (trace) import Logic (genId) import Model hiding (turn) @@ -30,21 +24,23 @@ fight p1 p2 gs = do let sim = CombatSimulation [] sequence result case result of Tie -> return (gs, sim) - Loss fighter dmg -> + Loss fighter dmg -> do let loser = case fighter of One -> Player Two -> AI loserState = selectPlayer loser gs - (hp', armor') = dealDmg dmg (loserState.hp, loserState.armor) - loserState' = loserState {hp = hp', armor = armor', alive = hp' > 0} - in return (updatePlayer loser loserState' gs, sim) + (hp', armor') = dealDmg dmg (loserState ^. hp, loserState ^. armor) + loserState' = loserState & hp .~ hp' + & armor .~ armor' + & alive .~ (hp' > 0) + return (updatePlayer loser loserState' gs, sim) simulateCombat :: (MonadRandom m) => Player -> Player -> GameState -> m CombatHistory simulateCombat p1 p2 gs = do let (p1State, p2State) = (selectPlayer p1 gs, selectPlayer p2 gs) - initialAttacker <- initAttacker p1State.board p2State.board + initialAttacker <- initAttacker (p1State ^. board) (p2State ^. board) go - (CombatState initialAttacker (FighterState p1State 0) (FighterState p2State 0) gs.config) + (CombatState initialAttacker (FighterState p1State 0) (FighterState p2State 0) (gs ^. config)) [] -- initial board is part of state where go :: (MonadRandom m) => CombatState -> CombatHistory -> m CombatHistory @@ -52,15 +48,17 @@ simulateCombat p1 p2 gs = do if combatEnded combatState then return history else do - let defendingBoard = case combatState.attacker of - One -> combatState.two.playerState.board - Two -> combatState.one.playerState.board + let defendingBoard = case combatState ^. attacker of + One -> combatState ^. two . fplayerState . board + Two -> combatState ^. one . fplayerState . board defenderIndex <- getRandomR (0, length defendingBoard - 1) let (combatState', newHistorySlices) = turn defenderIndex combatState go combatState' (history ++ newHistorySlices) combatEnded :: CombatState -> Bool - combatEnded combatState = null combatState.one.playerState.board || null combatState.two.playerState.board + combatEnded combatState = + null (combatState ^. one . fplayerState . board) || + null (combatState ^. two . fplayerState . board) turn :: DefenderIndex -> -- Since the caller of `turn` specifies the `di`, testing single turns is easy. @@ -68,17 +66,15 @@ turn :: (CombatState, CombatHistory) turn di cs = (cs''', history) where - (attackingState, _) = case cs.attacker of - One -> (cs.one, cs.two) - Two -> (cs.two, cs.one) - cs' = trade attackingState.nextAttackIndex di cs + (attackingState, _) = case cs ^. attacker of + One -> (cs ^. one, cs ^. two) + Two -> (cs ^. two, cs ^. one) + cs' = trade (attackingState ^. nextAttackIndex) di cs (cs'', snapshots) = handleDeaths cs' -- `handleDeath` does not clean the battleground (clear deaths) - cs''' = - cs'' - { attacker = alternate cs''.attacker, - one.playerState.board = clearDeath cs''.one.playerState.board, - two.playerState.board = clearDeath cs''.two.playerState.board - } + cs''' = cs'' + & attacker .~ alternate (cs'' ^. attacker) + & one . fplayerState . board .~ clearDeath (cs'' ^. one . fplayerState . board) + & two . fplayerState . board .~ clearDeath (cs'' ^. two . fplayerState . board) history = map extractBoards [cs, cs'] ++ [extractBoards cs'' | not (null snapshots)] ++ [extractBoards cs'''] -- handleDeaths is recursive because certain deathrattles cause other minions to die. @@ -95,27 +91,26 @@ handleDeaths cs = prepareDeathrattles = undefined extractBoards :: CombatState -> (Board, Board) -extractBoards cs = (cs.one.playerState.board, cs.two.playerState.board) +extractBoards cs = (cs ^. one . fplayerState . board, cs ^. two . fplayerState . board) interpCombatEffect :: CombatEffectContext -> CardEffect -> CombatState interpCombatEffect (CombatEffectContext cs fighter minionId) (Summon (SpecificCard card)) = case fighter of - One -> cs {one = fs'} - Two -> cs {two = fs'} + One -> cs & one .~ fs' + Two -> cs & two .~ fs' where fs = case fighter of - One -> cs.one - Two -> cs.two - aliveCount = countAlive fs.playerState.board - summonerInd = dIndex minionId fs.playerState.board -- Summoner is the one who issued the summoning + One -> cs ^. one + Two -> cs ^. two + aliveCount = countAlive (fs ^. fplayerState . board) + summonerInd = dIndex minionId (fs ^. fplayerState . board) -- Summoner is the one who issued the summoning fs' | aliveCount < 7 = fs - { playerState.board = insertAt (summonerInd + 1) (CardInstance card id) fs.playerState.board, - playerState.idGen = idGen' - } + & fplayerState . board .~ insertAt (summonerInd + 1) (CardInstance card id) (fs ^. fplayerState . board) + & fplayerState . idGen .~ idGen' | otherwise = fs where - (idGen', id) = genId fs.playerState.idGen + (idGen', id) = genId (fs ^. fplayerState . idGen) interpCombatEffect _ cf = error $ "Effect `" ++ show cf ++ "` is not yet implemented" countAlive :: Board -> Int @@ -123,29 +118,32 @@ countAlive = undefined -- deterministically find a minion's index and its index through its id dIndex :: MinionID -> Board -> Index -dIndex id = fromJust . findIndex (\ci -> ci.id == id) +dIndex mId = fromJust . findIndex (\ci -> ci ^. Model.id == mId) clearDeath :: Board -> Board -clearDeath = filter (\ci -> ci.card.health > 0) +clearDeath = filter (\ci -> ci ^. card . health > 0) -- A single attack, only the involved minions are updated. Cleave logic is handled here. trade :: AttackerIndex -> DefenderIndex -> CombatState -> CombatState trade ai di cs = cs' where - (attackingBoard, defendingBoard) = case cs.attacker of - One -> (cs.one.playerState.board, cs.two.playerState.board) - Two -> (cs.two.playerState.board, cs.one.playerState.board) + (attackingBoard, defendingBoard) = case cs ^. attacker of + One -> (cs ^. one.fplayerState.board, cs ^. two.fplayerState.board) + Two -> (cs ^. two.fplayerState.board, cs ^. one.fplayerState.board) + (attackingMinion, defendingMinion) = (attackingBoard !! ai, defendingBoard !! di) (attackingMinion', defendingMinion') = dmgOther (attackingMinion, defendingMinion) - (attackingBoard', defendingBoard') = (setAt ai attackingMinion' attackingBoard, setAt di defendingMinion' defendingBoard) - cs' = case cs.attacker of - One -> cs {one.playerState.board = attackingBoard', two.playerState.board = defendingBoard'} - Two -> cs {one.playerState.board = defendingBoard', two.playerState.board = attackingBoard'} + + cs' = case cs ^. attacker of + One -> cs & one.fplayerState.board .~ attackingBoard + & two.fplayerState.board .~ defendingBoard + Two -> cs & one.fplayerState.board .~ defendingBoard + & two.fplayerState.board .~ attackingBoard dmgOther :: (CardInstance, CardInstance) -> (CardInstance, CardInstance) dmgOther (attacker, defender) = - ( attacker {card.health = attacker.card.health - defender.card.attack}, - defender {card.health = defender.card.health - attacker.card.attack} + ( attacker & card . health .~ attacker ^. card . health - defender ^. card . attack, + defender & card . health .~ defender ^. card . health - attacker ^. card . attack ) alternate :: Fighter -> Fighter @@ -162,8 +160,8 @@ initAttacker board1 board2 calculateResult :: (Board, Board) -> CombatResult calculateResult (board1, board2) - | not (null board1) && null board2 = Loss Two (sum $ map (\ci -> ci.card.cardTier) board1) - | null board1 && not (null board2) = Loss One (sum $ map (\ci -> ci.card.cardTier) board2) + | not (null board1) && null board2 = Loss Two (sum $ map (\ci -> ci ^. card . cardTier) board1) + | null board1 && not (null board2) = Loss One (sum $ map (\ci -> ci ^. card . cardTier) board2) | otherwise = Tie setAt :: Int -> a -> [a] -> [a] diff --git a/src/Controller.hs b/src/Controller.hs index 116ff53..576eb50 100644 --- a/src/Controller.hs +++ b/src/Controller.hs @@ -1,15 +1,4 @@ -- Controller: Handles input, game loop -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedRecordUpdate #-} -{-# LANGUAGE RebindableSyntax #-} -{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} module Controller (module Controller) where @@ -28,6 +17,7 @@ import Text.Parsec.String (Parser) import Text.Pretty.Simple (pPrint, pShow) import Text.Read (readMaybe) import View +import Control.Lens -- START: Functions for ingesting terminal input as PlayerAction -- -- Examples: @@ -89,28 +79,30 @@ playArgParser = do -- END -- initGameState :: GameState -initGameState = GameState {playerState = defPlayerState, aiState = tutorialAI, turn = 0, config = Config {maxBoardSize = 7, maxHandSize = 10}} +initGameState = GameState {_playerState = defPlayerState, _aiState = tutorialAI, _turn = 0, _config = Config {_maxBoardSize = 7, _maxHandSize = 10}} tutorialAI :: PlayerState -tutorialAI = mainPlayerState {board = [CardInstance bigDumbo 0], hp = 5} +tutorialAI = mainPlayerState + & board .~ [CardInstance bigDumbo 0] + & hp .~ 5 mainPlayerState :: PlayerState mainPlayerState = PlayerState - { tier = 1, - maxGold = 300, -- By `enter`ing into the first turn, this becomes 3 as required. - curGold = 2, - tierUpCost = 6, -- By `enter`ing into the first turn, this becomes 5 as required. - rerollCost = 1, - shop = [], - board = [], - hand = [], - frozen = False, - hp = 20, - armor = 0, - alive = True, - phase = Recruit, - idGen = IdGen 0 + { _tier = 1, + _maxGold = 300, -- By `enter`ing into the first turn, this becomes 3 as required. + _curGold = 2, + _tierUpCost = 6, -- By `enter`ing into the first turn, this becomes 5 as required. + _rerollCost = 1, + _shop = [], + _board = [], + _hand = [], + _frozen = False, + _hp = 20, + _armor = 0, + _alive = True, + _phase = Recruit, + _idGen = IdGen 0 } runGame :: IO () @@ -122,30 +114,33 @@ runGame = do loop :: (MonadIO m, MonadRandom m) => m GameState -> m GameState loop mgs = do gs <- mgs - -- Go to EndScreen if applicable - let gs' = gs {playerState.phase = if isGameOver gs then EndScreen else gs.playerState.phase} - -- trace (TL.unpack $ pShow gs) - case gs'.playerState.phase of + let gs' = gs & playerState.phase %~ \p -> if isGameOver gs then EndScreen else p + + case gs' ^. playerState.phase of Recruit -> do - replenishedPlayer <- replenish gs'.playerState - replenishedAI <- replenish gs'.aiState - let gs'' = gs' {playerState = replenishedPlayer, aiState = replenishedAI} + replenishedPlayer <- replenish (gs' ^. playerState) + replenishedAI <- replenish (gs' ^. aiState) + let gs'' = gs' & playerState .~ replenishedPlayer + & aiState .~ replenishedAI recruitLoop gs'' >>= (loop . return) + Combat -> do (gs'', sim) <- fight Player AI gs' liftIO $ replayCombat 1 sim - liftIO flushInput -- ignore input entered during combat phase + liftIO flushInput liftIO $ putStrLn "finished playing" - loop $ return gs'' {playerState.phase = Recruit, aiState.phase = Recruit} + loop $ return $ gs'' & playerState.phase .~ Recruit + & aiState.phase .~ Recruit + EndScreen -> do - -- Note EndScreen doesn't invoke `loop`. Game logic stops here. liftIO $ putStrLn $ endScreenMsg gs' return gs + _ -> error "Other phases not yet implemented" recruitLoop :: (MonadIO m, MonadRandom m) => GameState -> m GameState recruitLoop gs - | gs.playerState.phase == Recruit = do + | gs ^. playerState.phase == Recruit = do liftIO $ putStrLn $ fmtRecruit gs Player liftIO $ putStr "> " liftIO $ hFlush stdout diff --git a/src/Logic.hs b/src/Logic.hs index b0fee74..6054e04 100644 --- a/src/Logic.hs +++ b/src/Logic.hs @@ -1,27 +1,16 @@ -- Logic: Handles recruit phase logic, executing user commands -- TODO: Modularize out the recruit logic, since Combat.hs is already separate. -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedRecordUpdate #-} {-# LANGUAGE ParallelListComp #-} -{-# LANGUAGE RebindableSyntax #-} module Logic (module Logic) where import Card (pool) import Control.Monad.Random import Data.List (foldl', mapAccumL) -import Data.Record.Overloading import Model import Utils import View (helpMenu) +import Control.Lens hiding (Index) execCommand :: (MonadIO m, MonadRandom m) => Command -> GameState -> Player -> m (Either String GameState) execCommand (Buy ind) gs p = return $ buy ind gs p >>= (\ps' -> Right $ updatePlayer p ps' gs) @@ -29,7 +18,7 @@ execCommand (Sell ind) gs p = return $ sell ind (selectPlayer p gs) >>= (\ps' -> execCommand (Play ind) gs p = return $ play ind gs p >>= (\ps' -> Right $ updatePlayer p ps' gs) execCommand Help gs Player = liftIO (putStrLn helpMenu) >> pure (Right gs) execCommand Help gs AI = error "Dev Error: AI shouldn't issue `Help`." -execCommand EndTurn gs Player = return $ Right gs {playerState.phase = Combat} +execCommand EndTurn gs Player = return $ Right gs { _playerState = (gs ^. playerState) { _phase = Combat } } -- In tutorial mode, the single player issues the combat (on their will) and fights the AI always -- In multiplayer, the server issues the combat (by a timer) and pairs up who to fight execCommand EndTurn _ AI = error "Dev Error: AI really shouldn't issue `EndTurn`." @@ -42,20 +31,20 @@ execCommand Concede gs p = return $ concede (selectPlayer p gs) >>= (\ps' -> Rig -- Game over if exactly one player is alive isGameOver :: GameState -> Bool -isGameOver gs = gs.playerState.alive /= gs.aiState.alive +isGameOver gs = gs ^. playerState . alive /= gs ^. aiState . alive -- Performed when we first transition to a new game phase. replenish :: (MonadRandom m) => PlayerState -> m PlayerState replenish ps = do - (idGen', newShop) <- randomShop ps.idGen ps.tier + (idGen', newShop) <- randomShop (ps ^. idGen) (ps ^. tier) return ps - { phase = Recruit, - maxGold = ps.maxGold + 1, - curGold = ps.maxGold + 1, - frozen = False, - shop = if ps.frozen then ps.shop else newShop, - idGen = idGen' + { _phase = Recruit, + _maxGold = ps ^. maxGold + 1, + _curGold = ps ^. maxGold + 1, + _frozen = False, + _shop = if ps ^. frozen then ps ^. shop else newShop, + _idGen = idGen' } -- START: Utility Methods for PlayerAction Functions -- @@ -75,12 +64,12 @@ remove 0 (_ : xs) = xs remove n (x : xs) = x : remove (n - 1) xs canTierUp :: PlayerState -> Bool -canTierUp ps = ps.curGold >= ps.tierUpCost +canTierUp ps = ps ^. curGold >= ps ^. tierUpCost genId :: IdGen -> (IdGen, MinionID) -genId gen = (IdGen {unIdGen = newId + 1}, newId) +genId gen = (IdGen {_unIdGen = newId + 1}, newId) where - newId = unIdGen gen + newId = _unIdGen gen genIds :: Int -> IdGen -> (IdGen, [MinionID]) genIds n gen = mapAccumL (\gen _ -> genId gen) gen [1 .. n] @@ -100,7 +89,7 @@ randomShop gen t = do 6 -> 6 _ -> 6 availableCards :: [Card] - availableCards = filter (\c -> c.cardTier <= t) pool + availableCards = filter (\c -> c ^. cardTier <= t) pool sampleNFromList :: (MonadRandom m) => Int -> [a] -> m [a] sampleNFromList _ [] = return [] @@ -115,39 +104,39 @@ sampleNFromList n xs = replicateM n sample -- START: Functions that Command maps to -- play :: Index -> GameState -> Player -> Either String PlayerState play ind gs p - | ind < 0 || ind >= length ps.hand || length ps.board >= gs.config.maxBoardSize = Left "Out of bounds." - | otherwise = Right ps {board = ps.board ++ [findCard ind ps.hand], hand = remove ind ps.hand} + | ind < 0 || ind >= length (ps ^. hand) || length (ps ^. board) >= gs ^. config . maxBoardSize = Left "Out of bounds." + | otherwise = Right ps {_board = ps ^. board ++ [findCard ind (ps ^. hand)], _hand = remove ind (ps ^. hand)} where ps = selectPlayer p gs buy :: Index -> GameState -> Player -> Either String PlayerState buy ind gs p | shopSize == 0 = Left "Cannot buy. Your shop is empty." - | length ps.hand >= gs.config.maxHandSize = Left "Your hand is full" + | length (ps ^. hand) >= gs ^. config . maxHandSize = Left "Your hand is full" | ind < 0 || ind >= shopSize = Left "Out of bounds." | cost > moneyLeft = Left "Attempted buying without enough money." | otherwise = - Right ps {curGold = moneyLeft - cost, shop = remove ind ps.shop, hand = ps.hand ++ [cardInstance]} + Right ps {_curGold = moneyLeft - cost, _shop = remove ind (ps ^. shop), _hand = ps ^. hand ++ [cardInstance]} where ps = selectPlayer p gs - cardInstance = findCard ind ps.shop - cost = cardInstance.card.baseCost - moneyLeft = ps.curGold - shopSize = length ps.shop + cardInstance = findCard ind (ps ^. shop) + cost = cardInstance ^. card . baseCost + moneyLeft = ps ^. curGold + shopSize = length (ps ^. shop) sell :: Index -> PlayerState -> Either String PlayerState sell ind ps - | ind < 0 || ind >= length ps.board = Left "Out of bounds." - | otherwise = Right ps {curGold = ps.curGold + 1, board = remove ind ps.board} + | ind < 0 || ind >= length (ps ^. board) = Left "Out of bounds." + | otherwise = Right ps {_curGold = ps ^. curGold + 1, _board = remove ind (ps ^. board)} roll :: (MonadRandom m) => PlayerState -> m (Either String PlayerState) roll ps = - if ps.curGold < ps.rerollCost + if ps ^. curGold < ps ^. rerollCost then return $ Left "Attempted rollings without enough money" else do - (idGen', newShop) <- randomShop ps.idGen ps.tier - return $ Right $ ps {curGold = ps.curGold - 1, shop = newShop, idGen = idGen'} + (idGen', newShop) <- randomShop (ps ^. idGen) (ps ^. tier) + return $ Right $ ps {_curGold = ps ^. curGold - 1, _shop = newShop, _idGen = idGen'} -- Cost for going to the TavernTier baseTierUpCost :: TavernTier -> Int @@ -161,18 +150,18 @@ baseTierUpCost t = case t of tierUp :: PlayerState -> Either String PlayerState tierUp ps - | ps.tier == 6 = Left "Attempted to tier up but already on Tavern 6" - | ps.curGold < ps.tierUpCost = Left "Attempted tier up without enough money" - | otherwise = return $ ps {curGold = ps.curGold - ps.tierUpCost, tier = newTier, tierUpCost = if newTier == 6 then 10000 else baseTierUpCost (newTier + 1)} + | ps ^. tier == 6 = Left "Attempted to tier up but already on Tavern 6" + | ps ^. curGold < ps ^. tierUpCost = Left "Attempted tier up without enough money" + | otherwise = return $ ps {_curGold = ps ^. curGold - ps ^. tierUpCost, _tier = newTier, _tierUpCost = if newTier == 6 then 10000 else baseTierUpCost (newTier + 1)} where - newTier = ps.tier + 1 + newTier = ps ^. tier + 1 -- toggle frozen freeze :: PlayerState -> Either String PlayerState -freeze ps = return ps {frozen = not ps.frozen} +freeze ps = return ps {_frozen = not (ps ^. frozen)} -- Kill player and move their render screen to the EndScreen concede :: PlayerState -> Either String PlayerState -concede ps = return ps {alive = False} +concede ps = return ps {_alive = False} -- END -- diff --git a/src/Model.hs b/src/Model.hs index 27b8569..f061b17 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -1,23 +1,10 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedRecordUpdate #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} +{-# LANGUAGE TemplateHaskell #-} module Model (module Model) where -import Data.Record.Plugin import Prelude +import Control.Lens +import Control.Lens.TH {- Design Philosophy: @@ -53,35 +40,33 @@ data Keyword = Deathrattle deriving (Eq, Show) data CardCriteria = SpecificCard Card | ByKeyword Keyword deriving (Eq, Show) -data TargetSelection = RandomTarget | LeftmostTarget | RightmostTarget | SpecificTarget Index +data TargetSelection = RandomTarget | LeftmostTarget | RightmostTarget | SpecificTarget Model.Index deriving (Eq, Show) -data CombatEffectContext = CombatEffectContext {combatState :: CombatState, fromFighter :: Fighter, fromId :: MinionID} +data CombatEffectContext = CombatEffectContext {_combatState :: CombatState, _fromFighter :: Fighter, _fromId :: MinionID} data CardEffect = Summon CardCriteria | DealDamage Int TargetSelection deriving (Eq, Show) -{-# ANN type Card largeRecord #-} data Card = Card - { cardName :: CardName, - cardTier :: TavernTier, - baseCost :: CardCost, - attack :: Attack, - health :: Health, - deathrattle :: [CardEffect] + { _cardName :: CardName, + _cardTier :: TavernTier, + _baseCost :: CardCost, + _attack :: Attack, + _health :: Health, + _deathrattle :: [CardEffect] } deriving (Eq, Show) type MinionID = Int -newtype IdGen = IdGen {unIdGen :: MinionID} deriving (Eq, Show) +newtype IdGen = IdGen {_unIdGen :: MinionID} deriving (Eq, Show) -{-# ANN type CardInstance largeRecord #-} data CardInstance = CardInstance - { card :: Card, - id :: MinionID + { _card :: Card, + _id :: MinionID } deriving (Eq, Show) @@ -104,14 +89,12 @@ data Phase = HeroSelect | Recruit | Combat | EndScreen deriving (Show, Eq) -- For now, GameState just keeps track of the solo player and one AI. data Player = Player | AI deriving (Show, Eq) -{-# ANN type Config largeRecord #-} -data Config = Config {maxBoardSize :: Int, maxHandSize :: Int, maxCombatBoardSize :: Int} deriving (Eq, Show) +data Config = Config {_maxBoardSize :: Int, _maxHandSize :: Int, _maxCombatBoardSize :: Int} deriving (Eq, Show) -{-# ANN type CombatSimulation largeRecord #-} data CombatSimulation = CombatSimulation - { combatMoves :: [CombatMove], - boardSequences :: [(Board, Board)], - result :: CombatResult + { _combatMoves :: [CombatMove], + _boardSequences :: [(Board, Board)], + _result :: CombatResult } deriving (Show) @@ -123,15 +106,13 @@ data CombatMove type NextAttackIndex = Int -- When player becomes Attacker, which of their minion attacks next? -{-# ANN type FighterState largeRecord #-} data FighterState = FighterState - { playerState :: PlayerState, -- so that we can perform effects (add cards to hand), deal damage to players, etc - nextAttackIndex :: NextAttackIndex + { _fplayerState :: PlayerState, -- so that we can perform effects (add cards to hand), deal damage to players, etc + _nextAttackIndex :: NextAttackIndex } deriving (Eq, Show) -{-# ANN type CombatState largeRecord #-} -data CombatState = CombatState {attacker :: Fighter, one :: FighterState, two :: FighterState, config :: Config} deriving (Eq, Show) +data CombatState = CombatState {_attacker :: Fighter, _one :: FighterState, _two :: FighterState, _cconfig :: Config} deriving (Eq, Show) data Fighter = One | Two deriving (Show, Eq) @@ -144,65 +125,73 @@ type Damage = Int type CombatHistory = [(Board, Board)] -{-# ANN type PlayerState largeRecord #-} data PlayerState = PlayerState - { tier :: TavernTier, - maxGold :: Gold, - curGold :: Gold, - tierUpCost :: Gold, - shop :: Shop, - board :: Board, - hand :: Hand, - frozen :: Bool, - hp :: Health, - armor :: Armor, - alive :: Bool, - rerollCost :: Gold, - phase :: Phase, - idGen :: IdGen + { _tier :: TavernTier, + _maxGold :: Gold, + _curGold :: Gold, + _tierUpCost :: Gold, + _shop :: Shop, + _board :: Board, + _hand :: Hand, + _frozen :: Bool, + _hp :: Health, + _armor :: Armor, + _alive :: Bool, + _rerollCost :: Gold, + _phase :: Phase, + _idGen :: IdGen } deriving (Eq, Show) defPlayerState :: PlayerState defPlayerState = PlayerState { - tier = 0, - maxGold = 0, - curGold = 0, - tierUpCost = 0, - shop = [], - frozen = False, - board = [], - hand = [], - hp = 10, - armor = 0, - alive = True, - rerollCost = 1, - phase = Recruit, - idGen = IdGen 0 + _tier = 0, + _maxGold = 0, + _curGold = 0, + _tierUpCost = 0, + _shop = [], + _frozen = False, + _board = [], + _hand = [], + _hp = 10, + _armor = 0, + _alive = True, + _rerollCost = 1, + _phase = Recruit, + _idGen = IdGen 0 } -{-# ANN type GameState largeRecord #-} data GameState = GameState - { playerState :: PlayerState, - aiState :: PlayerState, - config :: Config, - turn :: Turn + { _playerState :: PlayerState, + _aiState :: PlayerState, + _config :: Config, + _turn :: Turn } deriving (Eq, Show) type Index = Int -type DefenderIndex = Index +type DefenderIndex = Model.Index -type AttackerIndex = Index +type AttackerIndex = Model.Index data Command - = Buy Index - | Sell Index - | Play Index + = Buy Model.Index + | Sell Model.Index + | Play Model.Index | Roll | TierUp | Freeze | EndTurn | Help - | Concede \ No newline at end of file + | Concede + +-- Generate lenses for all records +makeLenses ''Card +makeLenses ''CardInstance +makeLenses ''PlayerState +makeLenses ''GameState +makeLenses ''Config +makeLenses ''CombatState +makeLenses ''CombatEffectContext +makeLenses ''FighterState diff --git a/src/Utils.hs b/src/Utils.hs index 64f3951..6ef74be 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,24 +1,14 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedRecordUpdate #-} -{-# LANGUAGE RebindableSyntax #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} + module Utils (module Utils) where import Model -import Data.Record.Overloading +import Control.Lens updatePlayer :: Player -> PlayerState -> GameState -> GameState -updatePlayer Player ps gs = gs { playerState = ps } -updatePlayer AI ps gs = gs { aiState = ps} +updatePlayer Player ps gs = gs & playerState .~ ps +updatePlayer AI ps gs = gs & aiState .~ ps selectPlayer :: Player -> GameState -> PlayerState -selectPlayer Player gs = gs.playerState -selectPlayer AI gs = gs.aiState \ No newline at end of file +selectPlayer Player gs = gs ^. playerState +selectPlayer AI gs = gs ^. aiState \ No newline at end of file diff --git a/src/View.hs b/src/View.hs index fe0a586..444fc4a 100644 --- a/src/View.hs +++ b/src/View.hs @@ -1,24 +1,14 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedRecordUpdate #-} -{-# LANGUAGE RebindableSyntax #-} -{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} + module View (module View) where -import Data.Record.Overloading import Control.Concurrent (threadDelay) import Control.Monad (forM_) import Data.List (intercalate) import Debug.Trace (trace) import Model import Utils (selectPlayer) +import Control.Lens rowWidth :: Int rowWidth = 142 @@ -30,13 +20,13 @@ maxRowContentWidth :: Int maxRowContentWidth = length $ intercalate " | " $ replicate 7 "Rockpool Hunter" -- 123 renderCard :: CardInstance -> String -renderCard ci = abbrev maxCardNameDisplayLength (show ci.card.cardName) ++ "(" ++ show ci.card.attack ++ "/" ++ show ci.card.health ++ ")" +renderCard ci = abbrev maxCardNameDisplayLength (show (ci ^. card . cardName)) ++ "(" ++ show (ci ^. card . attack) ++ "/" ++ show (ci ^. card . health) ++ ")" hBorder :: [Char] hBorder = "+" ++ replicate (rowWidth - 2) '-' ++ "+" endScreenMsg :: GameState -> String -endScreenMsg gs = if gs.playerState.alive then "Victory! Ending now." else "You loss. Ending now." +endScreenMsg gs = if gs ^. playerState . alive then "Victory! Ending now." else "You loss. Ending now." -- fmtRecruit creates the following string. In the example below, the names and entries are maxed out. -- I.e., 15 characters is the longest permitting name (Rockpool Hunter and playeracgodman1 have 15 chars). Shop and board have 7 entries max, hand has 10 max. @@ -84,17 +74,17 @@ fmtRecruit gs p = ] where ps = selectPlayer p gs - shopCardNames = [(abbrev maxCardNameDisplayLength . show) cardInstance.card.cardName | cardInstance <- ps.shop] - boardCardNames = [(abbrev maxCardNameDisplayLength . show) cardInstance.card.cardName | cardInstance <- ps.board] - handCardNames = [(abbrev maxCardNameDisplayLength . show) cardInstance.card.cardName | cardInstance <- ps.hand] - freezeText = if ps.frozen then "Freeze: Yes" else "Freeze: No" - rerollCostText = "Reroll Cost: " ++ show ps.rerollCost - tierText = "Tier: " ++ show ps.tier - tierUpCostText = "Upgrade Cost: " ++ if ps.tier < 6 then show ps.tierUpCost else "-" - healthText = "Health: " ++ show ps.hp - armorText = "Armor: " ++ show ps.armor - goldText = "Gold: " ++ show ps.curGold ++ "/" ++ show ps.maxGold - oppInfoText = "Tutorial AI" ++ ": " ++ show gs.aiState.hp ++ " + " ++ show gs.aiState.armor + shopCardNames = [(abbrev maxCardNameDisplayLength . show) (cardInstance ^. card . cardName) | cardInstance <- ps ^. shop] + boardCardNames = [(abbrev maxCardNameDisplayLength . show) (cardInstance ^. card . cardName) | cardInstance <- ps ^. board] + handCardNames = [(abbrev maxCardNameDisplayLength . show) (cardInstance ^. card . cardName) | cardInstance <- ps ^. hand] + freezeText = if ps ^. frozen then "Freeze: Yes" else "Freeze: No" + rerollCostText = "Reroll Cost: " ++ show (ps ^. rerollCost) + tierText = "Tier: " ++ show (ps ^. tier) + tierUpCostText = "Upgrade Cost: " ++ if ps ^. tier < 6 then show (ps ^. tierUpCost) else "-" + healthText = "Health: " ++ show (ps ^. hp) + armorText = "Armor: " ++ show (ps ^. armor) + goldText = "Gold: " ++ show (ps ^. curGold) ++ "/" ++ show (ps ^. maxGold) + oppInfoText = "Tutorial AI" ++ ": " ++ show (gs ^. aiState . hp) ++ " + " ++ show (gs ^. aiState . armor) abbrev :: Int -> String -> String abbrev maxLen s =