{-# 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 , MovementSpecs(..) , movVerbL , movFreeL , movMinimumL , movAmountL , movForcedL , movSpendTokensL , movEndMoveTriggerL , movCompelledL , Effect(..) , Player(..) , PPair , forPlayer , everybody , otherPlayer , Token(..) , ofToken , Stat(..) , BaseStats(..) , nameL , hpL , movL , dfL , armL , traitsL , actionsL , 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 , 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 , ForcedMoveType(..) , flipDirection , ProtoMovementSpecs(..) , basicMove , forcedMove , allStatsAreMonoids , HasMonoidInstance , Hook(..) , hookTriggerL , hookEffectL , Modifier(..) , Trait(..) , traitNameL , traitHooksL , traitModifiersL , computeStat_ , runHooks_ ) where import Util (toMaybe, dup, secondClassLensNames, (??)) import Control.Applicative (Alternative (..)) import Control.Arrow ((>>>), Arrow (second)) import Control.Monad (join, mfilter, zipWithM) 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 (Sum, Any) 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 deriving (Eq, Show) data OrthagonalDirection = North | East | South | West deriving (Enum, Read, Eq, Ord, Show) orthagonalDirections :: [OrthagonalDirection] orthagonalDirections = [North, East, South, West] flipDirection :: OrthagonalDirection -> OrthagonalDirection flipDirection North = South flipDirection East = West flipDirection South = North flipDirection West = East 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 ForcedMoveType = Push | Pull | Shift deriving (Show, Eq) 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 -- | Details which characterize any kind of movement data MovementSpecs = MovementSpecs { movVerb :: String -- ^ The verb used to describe this move, e.g. "Move" or "Step" , movFree :: Bool -- ^ Indicates whether moving with free movement , movMinimum :: Bool -- ^ This movement gets to move at least 1 tile regardless of cost , movAmount :: Natural -- ^ The amount of MV available to spend , movForced :: Maybe (Point, ForcedMoveType, Player) -- ^ If this is a forced move, the locus, direction, and compelling player , movSpendTokens :: Bool -- ^ Whether this movement uses up movement tokens , movEndMoveTrigger :: Bool -- ^ Whether this movement should trigger "after MOVE" effects , movCompelled :: Bool -- ^ If movement can be stopped prematurely } -- | A version of `MovementSpecs` where some values will be populated dynamically data ProtoMovementSpecs = ProtoMovementSpecs { movVerb :: String -- ^ The verb used to describe this move, e.g. "Move" or "Step" , movFree' :: Maybe Bool -- ^ Whether moving with free movement, or Nothing to compute at init , movMinimum :: Bool -- ^ This movement gets to move at least 1 tile regardless of cost , movAmount' :: Maybe Natural -- ^ How many spaces to move, or Nothing to compute at init , movForced' :: Maybe (Either CharacterIdentifier Point, ForcedMoveType, Player) -- ^ If this is a forced move, the locus, direction, and compelling player , movSpendTokens :: Bool -- ^ Whether this movement spends speed/slow tokens , movEndMoveTrigger :: Bool -- ^ Whether this movement should trigger "after MOVE" effects , movCompelled :: Bool -- ^ If movement can be stopped prematurely } basicMove :: CharacterIdentifier -> Effect basicMove = InitMove $ ProtoMovementSpecs { movVerb = "Move" , movFree' = Nothing , movMinimum = True , movAmount' = Nothing , movForced' = Nothing , movSpendTokens = True , movEndMoveTrigger = True , movCompelled = False } forcedMove :: ForcedMoveType -> Natural -> Player -> Either CharacterIdentifier Point -> CharacterIdentifier -> Effect forcedMove fmType amt compeller locus = InitMove $ ProtoMovementSpecs { movVerb = show fmType , movFree' = Just True , movMinimum = False , movAmount' = Just amt , movForced' = Just (locus, fmType, compeller) , movSpendTokens = False , movEndMoveTrigger = False , movCompelled = True } 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 ProtoMovementSpecs 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 MovementSpecs -- ^ Details about the movement 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 -- | Remove up to one token from the given category from a unit | forall n. Num n => DropToken (Token n) -- ^ The token category to drop from CharacterIdentifier -- ^ Which character drops a token -- | 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 (Sum Int) DefenseDice :: Stat (Sum Int) FreeMove :: Stat Any statEq :: Stat a -> Stat b -> Maybe (a :~: b) statEq AttackDice AttackDice = Just Refl statEq DefenseDice DefenseDice = Just Refl statEq FreeMove FreeMove = Just Refl statEq _ _ = Nothing data HasMonoidInstance a = forall m. Monoid m => HasMonoidInstance (a :~: m) allStatsAreMonoids :: Stat a -> HasMonoidInstance a allStatsAreMonoids AttackDice = HasMonoidInstance Refl allStatsAreMonoids DefenseDice = HasMonoidInstance Refl allStatsAreMonoids FreeMove = HasMonoidInstance Refl data BaseStats = BaseStats { name :: String , hp :: Natural , mov :: Natural , df :: DieFace , arm :: Armor , traits :: [Trait] , actions :: [CharacterIdentifier -> Choice] } -- | Some effect which is activated by some trigger event data Hook h = Hook { hookTrigger :: Trigger -- ^ The trigger which should activate this effect -- | What this effect does. Recieves board & this character's CID , hookEffect :: BoardState -> h } -- | A modifier which conditionally affects thet value of some stat for a unit data Modifier = forall a. Monoid a => Modifier { modifierStat :: Stat a -- ^ Which stat this modifier effects -- | What the effects of this modifier are , modifierEffect :: BoardState -> CharacterIdentifier -> a } queryModifier :: BoardState -> CharacterIdentifier -> Stat a -> Modifier -> a queryModifier board cid queryStat (Modifier {..}) = case queryStat `statEq` modifierStat of Just Refl -> modifierEffect board cid Nothing -> case allStatsAreMonoids queryStat of HasMonoidInstance Refl -> mempty -- | A passive trait on a unit -- Can affect a unit or surrounding units by directly and conditionally modifying that -- units stats, or by running certain 'Effect's on a given trigger data Trait = Trait { traitName :: String -- ^ The name of this trait, e.g. "Formation" , traitHooks :: [Hook (CharacterIdentifier -> [Effect])] -- ^ Any hooks which this trait needs , traitModifiers :: [Modifier] -- ^ Any modifiers this trait imposes } 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 makeLensesWith secondClassLensNames ''MovementSpecs makeLensesWith secondClassLensNames ''Hook makeLensesWith secondClassLensNames ''Trait 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 :: Bool -> Character -> Natural getSpeed preventReducions c | spdTokenCount > 0 = 2 + baseSpeed | spdTokenCount < 0 && not preventReducions = 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 -- | Compute a stat for a unit by accumulating the modifiers for the stat in all places -- -- This includes so called global modifiers, but in order to keep game rules seperate from -- the model, global modifiers must be provided as the first argument. computeStat_ :: [Modifier] -> BoardState -> CharacterIdentifier -> Stat a -> a computeStat_ globalModifiers board cid stat = case allStatsAreMonoids stat of HasMonoidInstance Refl -> let queryStatsL = each . to (queryModifier board cid stat) globalBonus = globalModifiers ^. queryStatsL traitBonus = board ^. ixCharacter cid . baseStats . traitsL . each . traitModifiersL . queryStatsL in globalBonus <> traitBonus -- | Activate all of the relevant hooks on the board -- -- Searches through all hooks in traits and global hooks, accumulates all their effects, -- then adds all the resulting effects to the effect stack. Similar to `computeStat_`, -- this is additionall searches so called global hooks, but only recognizes global hooks -- passed as an argument. runHooks_ :: [Hook [Effect]] -> Trigger -> BoardState -> BoardState runHooks_ globalHooks trigger board = board <++ characterEffects <++ globalEffects where filterActivatedL :: Traversal' (Hook a) (Hook a) filterActivatedL = filtered ((==trigger) . hookTrigger) unitHooksL :: SimpleFold Character (BoardState -> CharacterIdentifier -> [Effect]) unitHooksL = baseStats . traitsL . each . traitHooksL . each . filterActivatedL . hookEffectL charRunHooks :: (CharacterIdentifier, Character) -> [Effect] charRunHooks (cid, c) = (c ^. unitHooksL) board cid characterEffects :: [Effect] characterEffects = board ^. enumerateUnits . to charRunHooks globalEffects :: [Effect] globalEffects = (globalHooks ^. each . filterActivatedL . hookEffectL) board 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)) -- | A traversal over pairs in the form (`CharacterIdentifier`, `Character`) -- -- On modifying these pairs: Modifications to the `Character` will be applied to the -- original character, but __changes to the `CharacterIdentifier` will be completely -- ignored__. This means you /cannot/ use this traversal to change the order of -- characters, switch characters between players, or anything like that. enumerateUnits :: Traversal' BoardState (CharacterIdentifier, Character) enumerateUnits = enumerateUnits' where enumerateUnits' :: forall f. Applicative f => ((CharacterIdentifier, Character) -> f (CharacterIdentifier, Character)) -> BoardState -> f BoardState enumerateUnits' f = characters fCharacters where fUnit :: Player -> Int -> Character -> f Character fUnit player indx c = snd <$> f ((player, indx), c) fRoster :: Player -> [Character] -> f [Character] fRoster player roster = zipWithM (fUnit player) [0..] roster fCharacters :: PPair [Character] -> f (PPair [Character]) fCharacters (PPair p1 p2) = PPair <$> fRoster Min p1 <*> fRoster Max p2 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 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)