866 lines
29 KiB
Haskell
866 lines
29 KiB
Haskell
{-# 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) |