{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Eta reduce" #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} module GameModel ( DieFace(..) , bestOrWorst , EnvTile(..) , Armor(..) , DamageType(..) , Attack(Attack) , headshotEffectsL , meleeL , otherEffectsL , damageTypeL , damageAmountL , headshotEffects , melee , otherEffects , damageType , damageAmount , simpleRangedAttack , simpleMeleeAttack , blocks , Point(..) , Trigger(..) , OrthagonalDirection(..) , orthagonalDirections , offset , cardinalDirections , offsetCardinal , identifyDirection , identifyCardinalDirection , adjacentPoints , distanceCardinal , Effect(..) , Player(..) , PPair , forPlayer , everybody , otherPlayer , Token(..) , ofToken , Stat(..) , BaseStats(..) , nameL , hpL , movL , dfL , armL , hooksL , actionsL , statBonusL , instantiate , Character(..) , baseStats , movedThisRound , tokenCount , removeTokenInCategory , clearUpToNTokens , getSpeed , getDefense , CharacterIdentifier , owner , ownerL , isNecromancer , showCID , untapped , BoardState , atPoint , tiles , width , height , characters , soul , movingUnit , roundNumber , turn , effectStack , activePlayer , switchActivePlayer , popEffect , usingBoardDimensions , offsetB , cidsInRange , isAlive , pushEffects , unitPosition , listHooks , terrainAt , characterAt , adjacentUnits , adjacentAllies , isElevated , removeUnit , nextRound , changeMovingUnit , moveUnit , finalizeMove , (<++) , Choice , decisionSequenceL , effectsL , decisionSequence , effects , mkChoice , prependDecision , tap , characterLocations , eachCID , ixCharacter , ofPlayer , untappedUnits , newBoard , characterHandle , renderCharacterHandle ) where import Util (toMaybe, dup, secondClassLensNames, (??)) import Control.Applicative (liftA2, Alternative (..)) import Control.Arrow ((>>>), Arrow (second)) import Control.Monad (join, mfilter) import Data.Ix (inRange) import Data.List (intersperse, elemIndex) import Data.List.NonEmpty as NonEmpty (cons, NonEmpty, singleton) import Data.Maybe (mapMaybe, catMaybes) import Numeric.Natural (Natural) import Safe (headMay) import Lens.Micro import Data.Monoid (First) import Lens.Micro.TH (makeLenses, makeLensesWith, generateUpdateableOptics) import Lens.Micro.Extras (preview) import Data.Data ((:~:)(..)) import System.Random (Random(..)) data DieFace = One | Two | Three | Four | Five | Six deriving (Eq, Ord, Enum, Read) instance Random DieFace where randomR (low, hi) g = (toEnum r, g') where lowN = fromEnum low hiN = fromEnum hi (r, g') = randomR (lowN, hiN) g random g = randomR (One, Six) g bestOrWorst :: Bool -> [DieFace] -> DieFace bestOrWorst True = maximum bestOrWorst False = minimum instance Show DieFace where show One = "1" show Two = "2" show Three = "3" show Four = "4" show Five = "5" show Six = "6" instance Num DieFace where One + One = Two Two + One = Three Three + One = Four Four + One = Five One + Two = Three Two + Two = Four Three + Two = Five Two + Three = Five _ + _ = Six Six - One = Five Six - Two = Four Six - Three = Three Six - Four = Two Five - One = Four Five - Two = Three Five - Three = Two Four - One = Three Four - Two = Two _ - _ = One One * n = n n * One = n Two * n = n + n n * Two = n + n _ * _ = Six abs n = n signum = const One fromInteger 1 = One fromInteger 2 = Two fromInteger 3 = Three fromInteger 4 = Four fromInteger 5 = Five fromInteger 6 = Six fromInteger n = error ("The integer literal " ++ show n ++ " is not a face on a d6") type CharacterIdentifier = (Player, Int) owner :: CharacterIdentifier -> Player owner = fst ownerL :: Lens' CharacterIdentifier Player ownerL = _1 isNecromancer :: CharacterIdentifier -> Bool isNecromancer = snd >>> (== 0) showCID :: CharacterIdentifier -> Char showCID (cidOwner, idx) = (if cidOwner == Max then upperLetters else lowerLetters) !! idx where lowerLetters = "abcdefghijklmnopqrstuvwxyz" upperLetters = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" data Player = Max | Min deriving (Eq, Ord, Show) data PPair t = PPair t t toPPair :: (Player -> t) -> PPair t toPPair f = PPair (f Min) (f Max) forPlayer :: Player -> Lens' (PPair a) a forPlayer Min f (PPair p_min p_max) = PPair <$> f p_min ?? p_max forPlayer Max f (PPair p_min p_max) = PPair p_min <$> f p_max everybody :: Traversal (PPair a) (PPair b) a b everybody f (PPair p_min p_max) = PPair <$> f p_min <*> f p_max data EnvTile = Wall | Rough | Hazard | Elevation | Stairs deriving (Enum, Read, Eq, Show) data Armor = NoArmor | PhysicalArmor | MagicArmor | SuperArmor deriving (Enum, Read, Eq) instance Show Armor where show NoArmor = "-" show PhysicalArmor = "PHY" show MagicArmor = "MAG" show SuperArmor = "SUP" data DamageType = BasicDamage | SpecialDamage | Unblockable | DevilDamage deriving (Enum, Read, Eq, Show) blocks :: Armor -> DamageType -> Bool blocks _ Unblockable = False blocks _ DevilDamage = False blocks PhysicalArmor BasicDamage = True blocks MagicArmor SpecialDamage = True blocks SuperArmor _ = True blocks _ _ = False newtype Point = Point Natural deriving (Show, Read, Eq, Ord) enumeratePoints :: Natural -> Natural -> [Point] enumeratePoints w h = Point <$> [0..w * h - 1] data Trigger = TurnStart | TookDamage CharacterIdentifier | Died CharacterIdentifier Point | EndMove CharacterIdentifier data OrthagonalDirection = North | East | South | West deriving (Enum, Read, Eq, Ord, Show) orthagonalDirections :: [OrthagonalDirection] orthagonalDirections = [North, East, South, West] offset :: Natural -> Natural -> Point -> OrthagonalDirection -> Maybe Point offset width _ (Point indx) North = toMaybe (indx >= width) (Point $ indx - width) offset width height (Point indx) South = toMaybe (indx `div` width < height - 1) (Point $ indx + width) offset width _ (Point indx) West = toMaybe (indx `rem` width > 0) (Point $ indx - 1) offset width _ (Point indx) East = toMaybe (indx `rem` width < width - 1) (Point $ indx + 1) identifyDirection :: Natural -> Natural -> Point -> Point -> Maybe OrthagonalDirection identifyDirection w h from to = headMay $ filter ((== Just to) . offset w h from) orthagonalDirections identifyCardinalDirection :: Natural -> Natural -> Point -> Point -> [OrthagonalDirection] identifyCardinalDirection w _ from to = northOrSouth ++ eastOrWest where (fromX, fromY) = coordinates w from (toX, toY) = coordinates w to northOrSouth | fromY > toY = [South] | fromY < toY = [North] | otherwise = [ ] eastOrWest | fromX > toX = [East] | fromX < toX = [West] | otherwise = [ ] cardinalDirections :: [[OrthagonalDirection]] cardinalDirections = [[North], [North, East], [East], [South, East], [South], [South, West], [West], [North, West]] offsetCardinal :: Natural -> Natural -> Point -> [OrthagonalDirection] -> Maybe Point offsetCardinal w h point = foldr ((=<<) . flip (offset w h)) (Just point) adjacentPoints :: Natural -> Natural -> Point -> [Point] adjacentPoints w h center = mapMaybe (offsetCardinal w h center) cardinalDirections coordinates :: Natural -> Point -> (Natural, Natural) coordinates w (Point x) = (x `rem` w, x `div` w) distanceCardinal :: Natural -> Natural -> Point -> Point -> Natural distanceCardinal w _ a b = max xDist yDist where (aX, aY) = coordinates w a (bX, bY) = coordinates w b xDist = max aX bX - min aX bX yDist = max aY bY - min aY bY data Token a where StrWeak :: Token Int VitalVulnr :: Token Int SpeedSlow :: Token Int Berserk :: Token Natural Doom :: Token Natural Plague :: Token Natural Mutation :: Token Natural Reload :: Token Natural Health :: Token Natural data Effect -- | Does nothing = NoOp | StartTurn -- | Send some trigger to every Unit | Event Trigger -- | Active player chooses whether they want to move or act first | ChooseActMove CharacterIdentifier -- | Active player may choose whether they want to act or move | ActOrMove CharacterIdentifier -- | Mark the start of movement -- Can be finalized later with FinalizeMove | InitMove CharacterIdentifier -- | Active player may MOVE this character -- Should evaluate to a choice for every OrthagonalDirection which is valid to move in, -- where each choice includes another Move. Additionally, the user may choose -- to neglect to move. The first move of a turn should also push an EndMove onto the -- stack. | Move Bool -- ^ Whether this is the first step of this MOVE Natural -- ^ Number of MOV points remaining CharacterIdentifier -- ^ Which character is being moved -- | Pick up a character and put them down on another space -- Should trigger effects like overwatch and hazard damage | MoveTo Point -- | Confirms a Move, placing the unit in the target space | ConfirmMove -- | Allow a character to Act | Act CharacterIdentifier -- | Target a unit in a given range, then run a different event | Target CharacterIdentifier -- ^ ACTing unit (Natural, Natural) -- ^ Range (BoardState -> CharacterIdentifier -> Bool) -- ^ Target filter (CharacterIdentifier -> [Effect]) -- ^ Ultimate effect -- | Check if a character can body block -- If they can, offer a choice of target to the targetted player. Pass result on to -- the effect. | BodyBlock CharacterIdentifier (CharacterIdentifier -> [Effect]) -- | Resolve an attack | ResolveAttack CharacterIdentifier -- ^ Attacker Attack -- ^ Attack information CharacterIdentifier -- ^ Target | InflictDamage DamageType Natural -- ^ Damage amount CharacterIdentifier -- ^ Target | forall n. Num n => InflictTokens (Token n) -- ^ Token kind n -- ^ Token amount CharacterIdentifier -- ^ Target | Kill CharacterIdentifier -- | Tap the active unit, change the active player | EndTurn CharacterIdentifier data Attack = Attack { headshotEffects :: [Effect] , melee :: Bool , otherEffects :: [Effect] , damageType :: DamageType , damageAmount :: Natural } simpleRangedAttack :: [Effect] -> DamageType -> Natural -> Attack simpleRangedAttack = Attack [] False simpleMeleeAttack :: [Effect] -> DamageType -> Natural -> Attack simpleMeleeAttack = Attack [] True data Choice = Choice { decisionSequence :: NonEmpty String , effects :: [Effect] } otherPlayer :: Player -> Player otherPlayer Max = Min otherPlayer Min = Max data Stat a where AttackDice :: Stat Int DefenseDice :: Stat Int data BaseStats = BaseStats { name :: String , hp :: Natural , mov :: Natural , df :: DieFace , arm :: Armor , hooks :: BoardState -> CharacterIdentifier -> Trigger -> [Effect] , actions :: [CharacterIdentifier -> Choice] , statBonus :: forall a. BoardState -> CharacterIdentifier -> Stat a -> a } instance Show BaseStats where show stats = "===== " ++ name stats ++ " =====\nMV: " ++ show (mov stats) ++ " DF: " ++ show (df stats) ++ "+ ARM: " ++ show (arm stats) newtype TokenCount = TokenCount (forall n. Token n -> n) instance Show TokenCount where show tc = mconcat $ intersperse "\n" $ filter (/=[]) [ showHealth , showReload , " " , showDualTokens ("Strength", "Weakness") ("+1 damage", "-1 damage") StrWeak , showDualTokens ("Vitality", "Vulnerability") ("take -1 damage", "take +1 damage") VitalVulnr , showDualTokens ("Speed", "Slow") ("move +2 spaces", "move at most one space") SpeedSlow , showMonoToken "Berserk" "splash self after ACTing" Berserk , showMonoToken "Doom" "die after round 4" Doom , showMonoToken "Plague" "take 1 damage / turn" Plague , showMonoToken "Mutation" "spend as any other token" Mutation ] where showTokensInner :: Integral n => String -> String -> n -> String showTokensInner name effectText count | count > 0 = name ++ ": " ++ replicate (fromIntegral count) '*' ++ if effectText /= "" then " (" ++ effectText ++ ")" else "" | otherwise = "" showMonoToken name effectText t = showTokensInner name effectText (tc ^. ofToken t) showDualTokens (goodName, badName) (goodEffect, badEffet) t | count >= 0 = showTokensInner goodName goodEffect count | otherwise = showTokensInner badName badEffet (negate count) where count = tc ^. ofToken t hp = fromIntegral $ tc ^. ofToken Health rel = fromIntegral $ tc ^. ofToken Reload showHealth | hp == 0 = "HP: 💀" | otherwise = "HP: " ++ replicate hp '*' showReload | rel == 0 = [] | rel == 1 = "Needs reload!" | rel == 2 = "Needs reload! (Twice)" | otherwise = "Needs reload! (" ++ replicate rel '*' ++ ")" tokenEq :: Token a -> Token b -> Maybe (a :~: b) tokenEq StrWeak StrWeak = Just Refl tokenEq VitalVulnr VitalVulnr = Just Refl tokenEq SpeedSlow SpeedSlow = Just Refl tokenEq Berserk Berserk = Just Refl tokenEq Doom Doom = Just Refl tokenEq Plague Plague = Just Refl tokenEq Mutation Mutation = Just Refl tokenEq Reload Reload = Just Refl tokenEq Health Health = Just Refl tokenEq _ _ = Nothing ofToken :: forall n. Token n -> Lens' TokenCount n ofToken token f (TokenCount initCount) = update' <$> innerMapped where innerMapped = f $ initCount token update :: n -> forall m. Token m -> m update newTokenVal queryToken = case tokenEq token queryToken of Just Refl -> newTokenVal Nothing -> initCount queryToken update' :: n -> TokenCount update' newVal = TokenCount $ update newVal data Character = Character { _baseStats :: BaseStats , _movedThisRound :: Bool , _tokenCount :: TokenCount } instance Show Character where show c = show (_baseStats c) ++ (if _movedThisRound c then "\n(already moved this round)" else "\n") ++ '\n' : show (_tokenCount c) noTokens :: TokenCount noTokens = TokenCount noTokens' where noTokens' :: Token n -> n noTokens' StrWeak = 0 noTokens' VitalVulnr = 0 noTokens' SpeedSlow = 0 noTokens' Berserk = 0 noTokens' Doom = 0 noTokens' Plague = 0 noTokens' Mutation = 0 noTokens' Reload = 0 noTokens' Health = 0 data BoardState = BoardState { _tiles :: [(Maybe CharacterIdentifier, [EnvTile])] , _width :: Natural , _height :: Natural , _characters :: PPair [Character] , _soul :: PPair Natural , _movingUnit :: Maybe (CharacterIdentifier, Point) , _roundNumber :: Natural , _turn :: Player , _effectStack :: [Effect] } makeLenses ''Character makeLensesWith (secondClassLensNames & generateUpdateableOptics .~ False) ''Attack makeLensesWith secondClassLensNames ''Choice makeLenses ''BoardState makeLensesWith (secondClassLensNames & generateUpdateableOptics .~ False) ''BaseStats instantiate :: BaseStats -> Character instantiate stats = Character stats False noTokens & tokenCount . ofToken Health .~ hp stats clearUpToNTokens :: (Num a, Ord a) => Token a -> a -> Character -> Character clearUpToNTokens t n = tokenCount . ofToken t %~ clearUpToN n where clearUpToN toClear currentCount | currentCount > 0 && toClear < 0 || currentCount < 0 && toClear > 0 = currentCount | abs currentCount > abs toClear = currentCount - toClear | otherwise = 0 removeTokenInCategory :: Num a => Token a -> Character -> Character removeTokenInCategory t = tokenCount . ofToken t %~ minusSignum where minusSignum n = n - signum n getSpeed :: Character -> Natural getSpeed c | spdTokenCount > 0 = 2 + baseSpeed | spdTokenCount < 0 = 1 | otherwise = baseSpeed where baseSpeed = c ^. baseStats . movL spdTokenCount = c ^. tokenCount . ofToken SpeedSlow getDefense :: Character -> DieFace getDefense = df . _baseStats tap :: Character -> Character tap = movedThisRound .~ True untapped :: Character -> Bool untapped = not . _movedThisRound untap :: Character -> Character untap = movedThisRound .~ False instance Show BoardState where show board = join (intersperse "\n" showTiles) ++ '\n':showRound ++ "\n" ++ showCharacters where renderUpperCorner :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char renderUpperCorner (_, (_, tiles)) | Wall `elem` tiles = '█' | Rough `elem` tiles = '~' | otherwise = ' ' renderLowerLeftCorner :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char renderLowerLeftCorner t@(_, (_, tiles)) | Wall `elem` tiles = '█' | Elevation `elem` tiles = '▛' | otherwise = renderUpperCorner t renderLowerRightCorner :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char renderLowerRightCorner t@(_, (_, tiles)) | Wall `elem` tiles = '█' | Elevation `elem` tiles = '▜' | otherwise = renderUpperCorner t renderBorderTile :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char renderBorderTile (_, (_, tiles)) |Wall `elem` tiles = '█' |Hazard `elem` tiles = '⩚' |Rough `elem` tiles = '~' | otherwise = ' ' renderLowerBorderTile :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char renderLowerBorderTile t@(_, (_, tiles)) |Wall `elem` tiles = '█' |Elevation `elem` tiles = '▀' | otherwise = renderBorderTile t renderUpperCenterTile :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char renderUpperCenterTile t@(_, (_, tiles)) | Wall `elem` tiles = '█' | Stairs `elem` tiles = '≣' | otherwise = renderBorderTile t renderLowerCenterTile :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char renderLowerCenterTile t@(_, (_, tiles)) | Wall `elem` tiles = '█' | Elevation `elem` tiles = '▀' | otherwise = renderUpperCenterTile t renderLeftCenterTile :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char renderLeftCenterTile t@(_, (_, tiles)) | Wall `elem` tiles = '█' | Stairs `elem` tiles = '▙' | otherwise = renderBorderTile t renderRightCenterTile :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char renderRightCenterTile t@(_, (_, tiles)) | Wall `elem` tiles = '█' | Stairs `elem` tiles = '▟' | otherwise = renderBorderTile t renderMidTile :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char renderMidTile (_, (_, tiles)) | Wall `elem` tiles = '█' | otherwise = ' ' renderTrueCenter :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> Char renderTrueCenter (p, (Nothing, tiles)) | board ^? movingUnit . _Just . _2 == Just p = '*' | Wall `elem` tiles = '█' | otherwise = ' ' renderTrueCenter (p, (Just cid, _)) | board ^? movingUnit . _Just . _2 == Just p = '*' | board ^? movingUnit . _Just . _1 == Just cid = ' ' | otherwise = showCID cid renderTile :: (Point, (Maybe CharacterIdentifier, [EnvTile])) -> [String] renderTile t = [ [renderUpperCorner t , renderBorderTile t , renderUpperCenterTile t, renderBorderTile t , renderUpperCorner t ] , [renderLeftCenterTile t , renderMidTile t , renderTrueCenter t , renderMidTile t , renderRightCenterTile t ] , [renderLowerLeftCorner t, renderLowerBorderTile t, renderLowerCenterTile t, renderLowerBorderTile t, renderLowerRightCorner t] ] renderRow :: [(Point, (Maybe CharacterIdentifier, [EnvTile]))] -> [String] renderRow tiles = foldr (zipWith $ (++) . ('│':)) (repeat "│") (renderTile <$> tiles) hIndicies = [0..board ^. width - 1] vIndicies = [0..board ^. height - 1] arrIndicies :: [[Point]] arrIndicies = zipWith (\x y -> Point $ x + y * _height board) hIndicies . replicate (fromIntegral $ _width board) <$> vIndicies arrValues :: [[(Point, (Maybe CharacterIdentifier, [EnvTile]))]] arrValues = arrIndicies & traversed . traversed %~ (\p -> (p, board ^?! atPoint p)) hLine :: String hLine = "─────" mkLine :: Char -> Char -> Char -> String mkLine l m r = l : (replicate (fromIntegral $ board ^. width) hLine & intersperse [m] & mconcat) ++ [r] floor :: String floor = mkLine '├' '┼' '┤' roof :: String roof = mkLine '┌' '┬' '┐' basement :: String basement = mkLine '└' '┴' '┘' showTiles :: [String] showTiles = mconcat $ [roof] : intersperse [floor] (renderRow <$> arrValues) ++ [[basement]] showRound :: String showRound = "Round: " ++ show (board ^. roundNumber) showCharPair (cid, c) = "\n\n===== [" ++ showCID cid : "] " ++ drop 6 (show c) showCharacters = board ^.. enumerateUnits . to showCharPair . each newBoard :: Natural -> Natural -> (Point -> Maybe (Player, BaseStats)) -> (Point -> [EnvTile]) -> BoardState newBoard width height initialLayout terrain = BoardState { _tiles = tiles , _width = width , _height = height , _characters = characters , _soul = toPPair $ const 0 , _movingUnit = Nothing , _roundNumber = 1 , _turn = Max , _effectStack = [StartTurn] } where allPoints = enumeratePoints width height buildCharacter :: (Point, Maybe (Player, BaseStats)) -> Maybe (Player, (Point, BaseStats)) buildCharacter (p, Just (player, stats)) = Just (player, (p, stats)) buildCharacter (_, Nothing) = Nothing protocharacters :: [(Player, (Point, BaseStats))] protocharacters = mapMaybe (buildCharacter . second initialLayout . dup) allPoints pointToCID :: Player -> Point -> Maybe CharacterIdentifier pointToCID player point = (player,) <$> characterIndex where playersOccupiedTiles :: [Point] playersOccupiedTiles = map (fst . snd) $ filter ((==player) . fst) protocharacters characterIndex :: Maybe Int characterIndex = elemIndex point playersOccupiedTiles tiles :: [(Maybe CharacterIdentifier, [EnvTile])] tiles = (\p -> (pointToCID Min p <|> pointToCID Max p, terrain p)) <$> enumeratePoints width height characters :: PPair [Character] characters = toPPair (\player -> protocharacters ^.. each . filtered ((==player) . fst). _2 . _2 . to instantiate) activePlayer :: Lens' BoardState Player activePlayer = turn switchActivePlayer :: BoardState -> BoardState switchActivePlayer = turn %~ otherPlayer popEffect :: BoardState -> Maybe (Effect, BoardState) popEffect board@(BoardState {_effectStack = topEffect : remainingEffects}) = Just (topEffect, board {_effectStack = remainingEffects}) popEffect _ = Nothing usingBoardDimensions :: BoardState -> (Natural -> Natural -> a) -> a usingBoardDimensions (BoardState {_width, _height}) f = f _width _height offsetB :: BoardState -> Point -> OrthagonalDirection -> Maybe Point offsetB b = usingBoardDimensions b offset eachCID :: Monoid m => Getting m BoardState CharacterIdentifier eachCID = tiles . each . _1 . _Just ixCharacter :: CharacterIdentifier -> Traversal' BoardState Character ixCharacter (player, indx) = characters . forPlayer player . ix indx renderCharacterHandle :: BoardState -> CharacterIdentifier -> String renderCharacterHandle board cid = maybe "[💀]" (characterHandle cid) $ board ^? ixCharacter cid eachCharacter :: Traversal' BoardState Character eachCharacter = characters . everybody . traverse characterLocations :: Monoid m => Getting m BoardState (Point, CharacterIdentifier) characterLocations = to listCIDsWithLocations' . each where listCIDsWithLocations' :: BoardState -> [(Point, CharacterIdentifier)] listCIDsWithLocations' (BoardState {_tiles}) = catMaybes $ zipWith (\p (cid, _) -> (Point p,) <$> cid) [0..] _tiles cidsInRange :: BoardState -> (Natural, Natural) -> Point -> [CharacterIdentifier] cidsInRange board range locus = board ^.. inner where inner :: SimpleFold BoardState CharacterIdentifier inner = characterLocations . filtered (fst >>> usingBoardDimensions board distanceCardinal locus >>> inRange range) . _2 ofPlayer :: Player -> Traversal' CharacterIdentifier CharacterIdentifier ofPlayer player = filtered (owner >>> (== player)) lookupCIDs :: Monoid r => [CharacterIdentifier] -> Getting r BoardState (CharacterIdentifier, Character) lookupCIDs chars = to lookupCIDs' . each where ixCharacter' :: CharacterIdentifier -> Getting (First Character) BoardState Character ixCharacter' cid = ixCharacter cid lookupCIDs' :: BoardState -> [(CharacterIdentifier, Character)] lookupCIDs' boardstate = mapMaybe (liftA2 (fmap . (,)) id ((boardstate ^?) . ixCharacter')) chars enumerateUnits :: SimpleFold BoardState (CharacterIdentifier, Character) enumerateUnits f board = lookupCIDs (board ^.. eachCID) f board untappedUnits :: SimpleFold BoardState CharacterIdentifier untappedUnits = enumerateUnits . filtered (untapped . snd) . _1 isAlive :: BoardState -> CharacterIdentifier -> Bool isAlive board cid = has (eachCID . filtered (== cid)) board pushEffects :: [Effect] -> BoardState -> BoardState pushEffects newEffects = effectStack %~ (newEffects ++) unitPosition :: BoardState -> CharacterIdentifier -> Maybe Point unitPosition (BoardState {_movingUnit=Just (movingCid, movingPoint)}) cid | movingCid == cid = Just movingPoint unitPosition (BoardState {_tiles}) cid = headMay $ catMaybes $ zipWith aux [0..] _tiles where aux :: Natural -> (Maybe CharacterIdentifier, [EnvTile]) -> Maybe Point aux p (potentialCid, _) | potentialCid == Just cid = Just $ Point p | otherwise = Nothing listHooks :: BoardState -> Trigger -> [Effect] listHooks boardState = mconcat <$> traverse characterHooks (boardState ^.. enumerateUnits) where characterHooks :: (CharacterIdentifier, Character) -> Trigger -> [Effect] characterHooks (cid, c) = hooks (_baseStats c) boardState cid atPoint :: Point -> Traversal' BoardState (Maybe CharacterIdentifier, [EnvTile]) atPoint p = tiles . ixp p where ixp :: Point -> Traversal' [a] a ixp (Point n) = ix $ fromIntegral n characterAt :: Point -> Traversal' BoardState (Maybe CharacterIdentifier) characterAt p f board = inner f board where inner :: Traversal' BoardState (Maybe CharacterIdentifier) inner = atPoint p . _1 . filtered (/= board ^? movingUnit . _Just . _1) adjacentUnits :: BoardState -> CharacterIdentifier -> Maybe [CharacterIdentifier] adjacentUnits board cid = do originalLocation <- unitPosition board cid let adjacentTiles = usingBoardDimensions board adjacentPoints originalLocation let characterAt' p = characterAt p . _Just :: SimpleFold BoardState CharacterIdentifier let unitsAdjacent = mapMaybe (flip preview board . characterAt') adjacentTiles return unitsAdjacent adjacentAllies :: BoardState -> CharacterIdentifier -> Maybe [CharacterIdentifier] adjacentAllies board cid = filter (owner >>> (owner cid ==)) <$> adjacentUnits board cid isElevated :: BoardState -> CharacterIdentifier -> Bool isElevated board cid = maybe False (\p -> elem Elevation $ board ^. terrainAt p) $ unitPosition board cid removeUnit :: CharacterIdentifier -> BoardState -> BoardState removeUnit cid = tiles . each . _1 %~ mfilter (/= cid) setUnit :: CharacterIdentifier -> Point -> BoardState -> BoardState setUnit character point = atPoint point . _1 ?~ character terrainAt :: Point -> Traversal' BoardState [EnvTile] terrainAt p = atPoint p . _2 -- | Untap all units, dish out SOUL, and increment the round number nextRound :: BoardState -> BoardState nextRound = (soul . everybody +~ 1) . (roundNumber +~ 1) . (eachCharacter %~ untap) . (<++ [StartTurn]) changeMovingUnit :: BoardState -> CharacterIdentifier -> BoardState changeMovingUnit board unit = board & movingUnit .~ ((unit,) <$> unitPosition board unit) moveUnit :: Point -> BoardState -> BoardState moveUnit point = movingUnit . _Just . _2 .~ point finalizeMove :: BoardState -> BoardState finalizeMove board@(BoardState {_movingUnit = Just (unit, newLocation)}) = removeUnit unit board & setUnit unit newLocation & movingUnit .~ Nothing finalizeMove board = board (<++) :: BoardState -> [Effect] -> BoardState (<++) = flip pushEffects mkChoice :: String -> [Effect] -> Choice mkChoice = Choice . NonEmpty.singleton prependDecision :: String -> Choice -> Choice prependDecision decision = decisionSequenceL %~ NonEmpty.cons decision characterHandle :: CharacterIdentifier -> Character -> String characterHandle cid c = '[' : showCID cid : "] " ++ (c ^. baseStats . nameL)