1179 lines
42 KiB
Haskell
1179 lines
42 KiB
Haskell
{-# OPTIONS_GHC -Wno-name-shadowing #-}
|
|
module GameModel
|
|
( DieFace(..)
|
|
, bestOrWorst
|
|
, EnvTile(..)
|
|
, Armor(..)
|
|
, DamageType(..)
|
|
, Attack(Attack)
|
|
, ActingUnit(..)
|
|
, actingUnit
|
|
, TargettedUnit(..)
|
|
, targettedUnit
|
|
, 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
|
|
, tokenEq
|
|
, Broadcast(..)
|
|
, Stat(..)
|
|
, BaseStats(..)
|
|
, nameL
|
|
, hpL
|
|
, movL
|
|
, dfL
|
|
, armL
|
|
, traitsL
|
|
, actionsL
|
|
, instantiate
|
|
, Character(..)
|
|
, baseStats
|
|
, movedThisRound
|
|
, tokenCount
|
|
, removeTokenInCategory
|
|
, clearUpToNTokens
|
|
, getSpeed
|
|
, getDefense
|
|
, statusEffects
|
|
, CharacterIdentifier
|
|
, cidEq
|
|
, 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(..)
|
|
, hookToFunc
|
|
, hooksToFunc
|
|
, Modifier(..)
|
|
, Trait(..)
|
|
, traitNameL
|
|
, traitHooksL
|
|
, traitModifiersL
|
|
, computeStat_
|
|
, runHooks_
|
|
, StatusEffect(..)
|
|
) 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(..))
|
|
import Data.Coerce
|
|
|
|
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 = randomR (One, Six)
|
|
|
|
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)
|
|
|
|
cidEq :: (Coercible a b, Eq b) => a -> b -> Bool
|
|
cidEq = (==) . coerce
|
|
|
|
owner :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> Player
|
|
owner cid' = fst cid
|
|
where
|
|
cid :: CharacterIdentifier
|
|
cid = coerce cid'
|
|
|
|
ownerL :: Lens' CharacterIdentifier Player
|
|
ownerL = _1
|
|
|
|
isNecromancer :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> Bool
|
|
isNecromancer cid' = (==0) $ snd cid
|
|
where
|
|
cid :: CharacterIdentifier
|
|
cid = coerce cid'
|
|
|
|
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 a where
|
|
TurnStart :: Trigger ()
|
|
TookDamage :: Trigger TargettedUnit
|
|
Died :: Trigger (TargettedUnit, Point)
|
|
EndMove :: Trigger ActingUnit
|
|
|
|
deriving instance Eq (Trigger a)
|
|
deriving instance Show (Trigger a)
|
|
|
|
-- | Compare to triggers to check if they're equal
|
|
--
|
|
-- If they are, you get a proof of the equality of their associated data types.
|
|
triggerEq :: Trigger a -> Trigger b -> Maybe (a :~: b)
|
|
triggerEq TurnStart TurnStart = Just Refl
|
|
triggerEq TookDamage TookDamage = Just Refl
|
|
triggerEq Died Died = Just Refl
|
|
triggerEq EndMove EndMove = Just Refl
|
|
triggerEq _ _ = Nothing
|
|
|
|
-- | A pair containing a 'Trigger' and its associated data
|
|
--
|
|
-- Effectively an event as a whole
|
|
data Broadcast = forall d. Broadcast (Trigger d) d
|
|
|
|
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 :: ActingUnit -> Effect
|
|
basicMove = (InitMove $ ProtoMovementSpecs
|
|
{ movVerb = "Move"
|
|
, movFree' = Nothing
|
|
, movMinimum = True
|
|
, movAmount' = Nothing
|
|
, movForced' = Nothing
|
|
, movSpendTokens = True
|
|
, movEndMoveTrigger = True
|
|
, movCompelled = False
|
|
}) . (^. actingUnit)
|
|
|
|
forcedMove :: ForcedMoveType -> Natural -> Player -> Either CharacterIdentifier Point -> TargettedUnit -> 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
|
|
}) . (^. targettedUnit)
|
|
|
|
-- | Designates a character identifier of the unit acting in an effect/event
|
|
--
|
|
-- Acting includes moving, attacking, or using an ability
|
|
newtype ActingUnit = ActingUnit CharacterIdentifier
|
|
deriving (Eq, Show)
|
|
|
|
-- | A lens reaching into `ActingUnit`
|
|
actingUnit :: Lens' ActingUnit CharacterIdentifier
|
|
actingUnit f (ActingUnit au) = ActingUnit <$> f au
|
|
|
|
-- | Designates a character identifier of the unit being targetted by an effect/attack
|
|
newtype TargettedUnit = TargettedUnit CharacterIdentifier
|
|
deriving (Eq, Show)
|
|
|
|
-- | A lens reaching into `TargettedUnit`
|
|
targettedUnit :: Lens' TargettedUnit CharacterIdentifier
|
|
targettedUnit f (TargettedUnit au) = TargettedUnit <$> f au
|
|
|
|
data Effect
|
|
|
|
-- | Does nothing
|
|
= NoOp
|
|
|
|
| StartTurn
|
|
|
|
-- | Send some trigger to every Unit
|
|
| Event Broadcast
|
|
|
|
-- | Active player chooses whether they want to move or act first
|
|
| ChooseActMove ActingUnit
|
|
|
|
-- | Active player may choose whether they want to act or move
|
|
| ActOrMove ActingUnit
|
|
|
|
-- | 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
|
|
TargettedUnit -- ^ Which character drops a token
|
|
|
|
-- | Confirms a Move, placing the unit in the target space
|
|
| ConfirmMove
|
|
|
|
-- | Allow a character to Act
|
|
| Act ActingUnit
|
|
|
|
-- | Target a unit in a given range, then run a different event
|
|
| Target
|
|
ActingUnit -- ^ ACTing unit
|
|
(Natural, Natural) -- ^ Range
|
|
(BoardState -> TargettedUnit -> Bool) -- ^ Target filter
|
|
(TargettedUnit -> [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 TargettedUnit (TargettedUnit -> [Effect])
|
|
|
|
-- | Resolve an attack
|
|
| ResolveAttack
|
|
ActingUnit -- ^ Attacker
|
|
Attack -- ^ Attack information
|
|
TargettedUnit -- ^ Target
|
|
|
|
| InflictDamage
|
|
DamageType
|
|
Natural -- ^ Damage amount
|
|
TargettedUnit -- ^ Target
|
|
|
|
-- | Add a status effect to a character
|
|
| InflictStatusEffect
|
|
StatusEffect -- ^ Effect to inflict
|
|
TargettedUnit -- ^ Target
|
|
|
|
| forall n. Num n => InflictTokens
|
|
(Token n) -- ^ Token kind
|
|
n -- ^ Token amount
|
|
TargettedUnit -- ^ Target
|
|
|
|
| Kill TargettedUnit
|
|
|
|
-- | Tap the active unit, change the active player
|
|
| EndTurn ActingUnit
|
|
|
|
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 :: [ActingUnit -> Choice]
|
|
}
|
|
|
|
-- | Some effect which is activated by some trigger event
|
|
data Hook o = forall d. Hook
|
|
{ hookTrigger :: Trigger d -- ^ The trigger which should activate this effect
|
|
-- | What this effect does. Recieves board & this character's CID
|
|
, hookEffect :: d -> BoardState -> o
|
|
}
|
|
|
|
-- | Evaluate a hook for a given trigger
|
|
--
|
|
-- If the trigger does not apply to this hook, then `mempty` is returned.
|
|
hookToFunc :: Monoid h => Hook h -> Broadcast -> BoardState -> h
|
|
hookToFunc (Hook {..}) (Broadcast trigger assocData) = case hookTrigger `triggerEq` trigger of
|
|
Just Refl -> hookEffect assocData
|
|
Nothing -> mempty
|
|
|
|
-- | A version of `hookToFunc` which evaluates several hooks at once
|
|
hooksToFunc :: Monoid h => [Hook h] -> Broadcast -> BoardState -> h
|
|
hooksToFunc = mconcat . fmap hookToFunc
|
|
|
|
-- | 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
|
|
}
|
|
|
|
-- | Some inflicted/bestowed trait that applies to a character
|
|
--
|
|
-- Some status effects track internal state (here, the type variable a), which affect
|
|
-- either what the effect does or how long it exists.
|
|
--
|
|
-- A couple examples of status effects:
|
|
-- - Gargamox's Leech's "superate", which adds a Deathburst to a unit, and lasts for the
|
|
-- whole game
|
|
-- - C.A.R.C.A.S.'s Ammo Goblin's "bone shards" which causes the unit to take damage when
|
|
-- pushed or pulled, and expires after dealing three damage or the end of the goblin's
|
|
-- next turn.
|
|
data StatusEffect = forall a. StatusEffect
|
|
{ seName :: String -- ^ The name of the effect
|
|
, seHooks :: [Hook (a -> CharacterIdentifier -> [Effect])] -- ^ Triggers which produce effects
|
|
, seModifiers :: [Modifier] -- ^ Any stat modifiers inflicted by this effect
|
|
|
|
-- | Triggers which update the internal state or remove the effect
|
|
--
|
|
-- Returning `Just` updates the internal state, and returning `Nothing` removes the
|
|
-- effect completely.
|
|
, seUpdate :: [Hook (a -> CharacterIdentifier -> Maybe a)]
|
|
|
|
-- | Whatever internal state is needed by this effect
|
|
, seState :: a
|
|
|
|
-- | Render the internal state
|
|
--
|
|
-- Suffixed with the name when `show`ing this status effect
|
|
, seShowState :: a -> String
|
|
}
|
|
|
|
instance Show StatusEffect where
|
|
show (StatusEffect {..}) = '+' : seName ++ ' ' : seShowState seState
|
|
|
|
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 (not . null)
|
|
[ 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
|
|
, _statusEffects :: [StatusEffect]
|
|
}
|
|
|
|
instance Show Character where
|
|
show c =
|
|
show (_baseStats c)
|
|
++ (if _movedThisRound c then "\n(already moved this round)" else "\n")
|
|
++ '\n' : show (_tokenCount c)
|
|
++ '\n' : mconcat (intersperse "\n" (show <$> _statusEffects c))
|
|
++ "\n"
|
|
|
|
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
|
|
|
|
instance Functor Hook where
|
|
fmap f (Hook {..}) = Hook {hookEffect = hookEffect <&> (<&> f), ..}
|
|
v <$ Hook {..} = Hook {hookEffect = const $ const v, ..}
|
|
|
|
-- | Extract the hooks from a status effect, hiding internal state
|
|
seGetHooks :: StatusEffect -> [Hook (CharacterIdentifier -> [Effect])]
|
|
seGetHooks (StatusEffect {..}) = seHooks <&> (<&> ($ seState))
|
|
|
|
seDoUpdate :: Broadcast -> BoardState -> CharacterIdentifier -> StatusEffect -> Maybe StatusEffect
|
|
seDoUpdate (Broadcast trigger assocData) board cid (StatusEffect {..}) = case relevantUpdates of
|
|
[] -> Just $ StatusEffect {..}
|
|
Nothing : _ -> Nothing
|
|
Just newState : _ -> Just $ StatusEffect {seState = newState, ..}
|
|
where
|
|
seUpdate' = seUpdate & each . mapped %~ (($ cid) . ($ seState))
|
|
getRelevantHookEffects :: Hook t -> Maybe (BoardState -> t)
|
|
getRelevantHookEffects (Hook {..}) = case hookTrigger `triggerEq` trigger of
|
|
Just Refl -> Just $ hookEffect assocData
|
|
Nothing -> Nothing
|
|
relevantHooks = seUpdate' ^.. each . to getRelevantHookEffects . _Just
|
|
relevantUpdates = sequence relevantHooks board
|
|
|
|
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_ :: (Coercible cid c, c ~ CharacterIdentifier) => [Modifier] -> BoardState -> cid -> Stat a -> a
|
|
computeStat_ globalModifiers board cid' stat = case allStatsAreMonoids stat of
|
|
HasMonoidInstance Refl ->
|
|
let
|
|
cid = coerce cid'
|
|
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, statuse effects and global hooks, accumulates all
|
|
-- their effects, then adds all the resulting effects to the effect stack. Then, all
|
|
-- necessary status effect updates are applied. Similar to `computeStat_`, this is
|
|
-- additionall searches so called global hooks, but only recognizes global hooks passed as
|
|
-- an argument.
|
|
runHooks_ :: [Hook [Effect]] -> Broadcast -> BoardState -> BoardState
|
|
runHooks_ globalHooks trigger board = boardWithUpdates <++ allEffects
|
|
where
|
|
unitAllEffectHooks :: (CharacterIdentifier, Character) -> [Hook [Effect]]
|
|
unitAllEffectHooks (cid, c) = allHooks <&> (?? cid)
|
|
where
|
|
statusHooks :: [Hook (CharacterIdentifier -> [Effect])]
|
|
statusHooks = c ^.. statusEffects . each . to seGetHooks . each
|
|
classHooks :: [Hook (CharacterIdentifier -> [Effect])]
|
|
classHooks = c ^.. baseStats . traitsL . each . traitHooksL . each
|
|
allHooks = statusHooks ++ classHooks
|
|
unitUpdateStatuses :: (CharacterIdentifier, Character) -> (CharacterIdentifier, Character)
|
|
unitUpdateStatuses i@(cid, _) = i & _2 . statusEffects %~ mapMaybe (seDoUpdate trigger board cid)
|
|
unitHooks = board ^.. enumerateUnits . to unitAllEffectHooks . each
|
|
allHooks = unitHooks ++ globalHooks
|
|
allEffects = hooksToFunc allHooks trigger board
|
|
boardWithUpdates = board & enumerateUnits %~ unitUpdateStatuses
|
|
|
|
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 :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> Traversal' BoardState Character
|
|
ixCharacter cid = case coerce cid of (player, indx) -> characters . forPlayer player . ix indx
|
|
|
|
renderCharacterHandle :: (Coercible a b, b ~ CharacterIdentifier) => BoardState -> a -> String
|
|
renderCharacterHandle board cid' = maybe "[💀]" (characterHandle cid) $ board ^? ixCharacter cid
|
|
where
|
|
cid = coerce 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]
|
|
fCharacters :: PPair [Character] -> f (PPair [Character])
|
|
fCharacters (PPair p1 p2) = PPair <$> fRoster Min p1 <*> fRoster Max p2
|
|
fRoster player = zipWithM (fUnit player) [0..]
|
|
|
|
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 :: (Coercible cid c, c ~ CharacterIdentifier) => BoardState -> cid -> Maybe Point
|
|
unitPosition (BoardState {_movingUnit=Just (movingCid, movingPoint)}) cid
|
|
| movingCid == coerce 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 (coerce 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 :: (Coercible cid c, c ~ CharacterIdentifier) => BoardState -> cid -> 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 :: (Coercible cid c, c ~ CharacterIdentifier) => BoardState -> cid -> Maybe [CharacterIdentifier]
|
|
adjacentAllies board cid = filter (owner >>> (owner cid ==)) <$> adjacentUnits board cid
|
|
|
|
isElevated :: (Coercible cid c, c ~ CharacterIdentifier) => BoardState -> cid -> Bool
|
|
isElevated board cid = any (\p -> elem Elevation $ board ^. terrainAt p) $ unitPosition board cid
|
|
|
|
removeUnit :: (Coercible cid c, c ~ CharacterIdentifier) => cid -> BoardState -> BoardState
|
|
removeUnit cid = tiles . each . _1 %~ mfilter (/= coerce 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) |