commit
f696af0784
GPG Key ID:
A12F2C2FFDC3D847
|
|
@ -0,0 +1,4 @@
|
|||
.stack-work/
|
||||
*~
|
||||
result
|
||||
maleghast.cabal
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
# The Fuck Around and Find Out License, version 0.2
|
||||
|
||||
Licensed authored by [boringcactus](https://git.sr.ht/~boringcactus/fafol)
|
||||
|
||||
|
||||
## Purpose
|
||||
|
||||
This license gives everyone as much permission to work with
|
||||
this software as possible, while protecting contributors
|
||||
from liability, and ensuring this software is used
|
||||
ethically.
|
||||
|
||||
## Acceptance
|
||||
|
||||
In order to receive this license, you must agree to its
|
||||
rules. The rules of this license are both obligations
|
||||
under that agreement and conditions to your license.
|
||||
You must not do anything with this software that triggers
|
||||
a rule that you cannot or will not follow.
|
||||
|
||||
## Copyright
|
||||
|
||||
Each contributor licenses you to do everything with this
|
||||
software that would otherwise infringe that contributor's
|
||||
copyright in it.
|
||||
|
||||
## Ethics
|
||||
|
||||
This software must be used for Good, not Evil, as
|
||||
determined by the primary contributors to the software.
|
||||
|
||||
## Excuse
|
||||
|
||||
If anyone notifies you in writing that you have not
|
||||
complied with [Ethics](#ethics), you can keep your
|
||||
license by taking all practical steps to comply within 30
|
||||
days after the notice. If you do not do so, your license
|
||||
ends immediately.
|
||||
|
||||
## Patent
|
||||
|
||||
Each contributor licenses you to do everything with this
|
||||
software that would otherwise infringe any patent claims
|
||||
they can license or become able to license.
|
||||
|
||||
## Reliability
|
||||
|
||||
No contributor can revoke this license.
|
||||
|
||||
## No Liability
|
||||
|
||||
***As far as the law allows, this software comes as is,
|
||||
without any warranty or condition, and no contributor
|
||||
will be liable to anyone for any damages related to this
|
||||
software or this license, under any kind of legal claim.***
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
# Maleghast Engine
|
||||
|
||||
**A prototype Maleghast game engine, plus a simple CLI interface.**
|
||||
|
||||
This is a work in progress engine for Maleghast, whose main goal currently includes building an accurate choice tree for any valid board state. Current implementation is very limited, but several core mechanics are currently implemented.
|
||||
|
||||
Currently missing core mechanics include:
|
||||
- Hazards
|
||||
- Pushing/Pulling
|
||||
- LoS blocking
|
||||
- Tyrants
|
||||
- Thralls
|
||||
- Loadout / Layout chooser
|
||||
- Line attacks
|
||||
- Splash attacks
|
||||
- Curseproof
|
||||
- Obliteration
|
||||
- Targetting walls
|
||||
- Corpses
|
||||
- Most faction tags/tokens
|
||||
|
||||
## Building
|
||||
|
||||
Can be built with Stack:
|
||||
|
||||
```bash
|
||||
stack build
|
||||
# OR to run
|
||||
stack run
|
||||
```
|
||||
|
|
@ -0,0 +1,82 @@
|
|||
module Main (main) where
|
||||
|
||||
import System.IO (hFlush, stdout)
|
||||
import Util (note)
|
||||
import GameModel (Point(..), Player(..), newBoard, BaseStats, BoardState, EnvTile (..), DieFace, bestOrWorst)
|
||||
import Units.Carcass (gunwight)
|
||||
import Units.Debug (basic)
|
||||
import GameLogic (buildChoiceTree, ChoiceTree(..), ChoiceTree'(..), makeChoice, ctTree)
|
||||
|
||||
import Text.Read (readMaybe)
|
||||
import qualified Control.Monad
|
||||
import Control.Monad (replicateM, void)
|
||||
import System.Random (randomIO)
|
||||
|
||||
initialPlacement :: Point -> Maybe (Player, BaseStats)
|
||||
initialPlacement = flip lookup [(Point 5, (Max, basic)), (Point 0, (Max, gunwight)), (Point 23, (Min, basic)), (Point 22, (Min, gunwight))]
|
||||
|
||||
initialTerrain :: Point -> [EnvTile]
|
||||
initialTerrain (Point 4) = [Rough]
|
||||
initialTerrain (Point 5) = [Stairs]
|
||||
initialTerrain (Point 6) = [Elevation]
|
||||
initialTerrain (Point 7) = [Elevation]
|
||||
initialTerrain (Point 8) = [Stairs, Hazard]
|
||||
initialTerrain (Point 11) = [Stairs, Rough]
|
||||
initialTerrain (Point 12) = [Hazard]
|
||||
initialTerrain (Point 17) = [Wall]
|
||||
initialTerrain (Point 18) = [Wall]
|
||||
initialTerrain (Point 20) = [Rough, Hazard]
|
||||
initialTerrain _ = []
|
||||
|
||||
initialBoard :: BoardState
|
||||
initialBoard = newBoard 5 5 initialPlacement initialTerrain
|
||||
|
||||
choiceTree :: ChoiceTree
|
||||
choiceTree = buildChoiceTree initialBoard
|
||||
|
||||
readPrompt :: Read a => String -> (a -> Either String b) -> IO b
|
||||
readPrompt prompt validate = do
|
||||
putStr prompt
|
||||
hFlush stdout
|
||||
line <- getLine
|
||||
case readMaybe line of
|
||||
Just input -> case validate input of
|
||||
Right out -> return out
|
||||
Left error -> do
|
||||
putStrLn error
|
||||
putChar '\n'
|
||||
readPrompt prompt validate
|
||||
Nothing -> do
|
||||
putStrLn "Malformed input\n"
|
||||
readPrompt prompt validate
|
||||
|
||||
roll :: IO DieFace
|
||||
roll = do
|
||||
getLine
|
||||
result <- randomIO
|
||||
putStr $ show result
|
||||
hFlush stdout
|
||||
return result
|
||||
|
||||
runGame :: ChoiceTree -> IO (Maybe Player)
|
||||
runGame tree = do
|
||||
print tree
|
||||
case tree of
|
||||
ChoiceTree ct@(Node {}) -> do
|
||||
choiceMade <- readPrompt "=> " (note "Out of range" . flip makeChoice ct)
|
||||
runGame choiceMade
|
||||
ChoiceTree ct@(Random nDice pos outcomes) -> do
|
||||
putStr "[Press enter to roll]"
|
||||
hFlush stdout
|
||||
dice <- replicateM (fromIntegral nDice) roll
|
||||
putChar '\n'
|
||||
let result = bestOrWorst pos dice
|
||||
putStr "Done! Final result: "
|
||||
print result
|
||||
putStrLn "[Press enter to continue]"
|
||||
getLine
|
||||
runGame $ ctTree $ outcomes result
|
||||
ChoiceTree ct@(EndOfGame winner) -> return winner
|
||||
|
||||
main :: IO ()
|
||||
main = void (runGame choiceTree)
|
||||
|
|
@ -0,0 +1,78 @@
|
|||
name: maleghast
|
||||
version: 0.1.0.0
|
||||
github: "githubuser/maleghast"
|
||||
license: BSD-3-Clause
|
||||
author: "Ember Hearth"
|
||||
maintainer: "ember@corviform.gay"
|
||||
copyright: "full"
|
||||
|
||||
extra-source-files:
|
||||
- README.md
|
||||
|
||||
# Metadata used when publishing your package
|
||||
# synopsis: Short description of your package
|
||||
# category: Web
|
||||
|
||||
# To avoid duplicated efforts in documentation and dealing with the
|
||||
# complications of embedding Haddock markup inside cabal files, it is
|
||||
# common to point users to the README.md file.
|
||||
description: A prototype Maleghast game engine, plus a simple CLI interface.
|
||||
|
||||
dependencies:
|
||||
- base >= 4.7 && < 5
|
||||
- microlens
|
||||
- safe
|
||||
- microlens-th
|
||||
- template-haskell
|
||||
- random
|
||||
|
||||
ghc-options:
|
||||
- -Wall
|
||||
- -Wcompat
|
||||
- -Widentities
|
||||
- -Wincomplete-record-updates
|
||||
- -Wincomplete-uni-patterns
|
||||
- -Wmissing-export-lists
|
||||
- -Wmissing-home-modules
|
||||
- -Wpartial-fields
|
||||
- -Wredundant-constraints
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
default-extensions:
|
||||
- NamedFieldPuns
|
||||
- TupleSections
|
||||
- MonadComprehensions
|
||||
- GADTs
|
||||
- RankNTypes
|
||||
- RecordWildCards
|
||||
- TemplateHaskell
|
||||
- TypeOperators
|
||||
- ScopedTypeVariables
|
||||
- EmptyCase
|
||||
- DuplicateRecordFields
|
||||
|
||||
executables:
|
||||
maleghast-exe:
|
||||
main: Main.hs
|
||||
source-dirs: app
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- maleghast
|
||||
- random
|
||||
default-extensions:
|
||||
- GADTs
|
||||
|
||||
tests:
|
||||
maleghast-test:
|
||||
main: Spec.hs
|
||||
source-dirs: test
|
||||
ghc-options:
|
||||
- -threaded
|
||||
- -rtsopts
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- maleghast
|
||||
|
|
@ -0,0 +1,305 @@
|
|||
{-# OPTIONS_GHC -Wno-type-defaults #-}
|
||||
module GameLogic
|
||||
( chooseCharacter
|
||||
, applyEffect
|
||||
, EngineState
|
||||
, playerChoice
|
||||
, unitChoice
|
||||
, activePlayerChoice
|
||||
, continue
|
||||
, ChoiceTree(..)
|
||||
, ChoiceTree'(..)
|
||||
, buildChoiceTree
|
||||
, Token(..)
|
||||
, makeChoice
|
||||
, ctTree
|
||||
, ctDecisions
|
||||
, ctDecisionsL
|
||||
) where
|
||||
|
||||
import GameModel
|
||||
import Units (computeStat)
|
||||
import Util (toMaybe, Never, (??), never)
|
||||
|
||||
import Data.Maybe (fromMaybe, mapMaybe, isJust)
|
||||
import Data.List ( nub, intersperse )
|
||||
import Data.List.NonEmpty as NonEmpty (NonEmpty, nonEmpty, toList, head, tail)
|
||||
import Numeric.Natural (Natural)
|
||||
import Lens.Micro
|
||||
import Safe (atMay)
|
||||
|
||||
import Debug.Trace
|
||||
|
||||
data EngineState
|
||||
= PlayerChoice Player [Choice]
|
||||
| Roll
|
||||
Natural -- ^ Number of dice
|
||||
Bool -- ^ True = Xd6kh1, False = Xd6kl1
|
||||
(DieFace -> Choice) -- ^ Outcomes
|
||||
| Continue BoardState
|
||||
| Victory Player
|
||||
|
||||
playerChoice :: Player -> [Choice] -> EngineState
|
||||
playerChoice = PlayerChoice
|
||||
|
||||
unitChoice :: CharacterIdentifier -> [Choice] -> EngineState
|
||||
unitChoice = playerChoice . owner
|
||||
|
||||
activePlayerChoice :: BoardState -> [Choice] -> EngineState
|
||||
activePlayerChoice = playerChoice . (^. activePlayer)
|
||||
|
||||
continue :: BoardState -> EngineState
|
||||
continue = Continue
|
||||
|
||||
chooseCharacter :: BoardState -> Maybe EngineState
|
||||
chooseCharacter board = playerChoice player <$> fmap toList (nonEmpty $ board ^.. possibleActivations)
|
||||
where
|
||||
player :: Player
|
||||
player = board ^. activePlayer
|
||||
possibleActivations :: SimpleFold BoardState Choice
|
||||
possibleActivations = untappedUnits . filtered ((== player) . owner) . to activateUnit
|
||||
activateUnit :: CharacterIdentifier -> Choice
|
||||
activateUnit cid = mkChoice ("Activate unit " ++ c) [ChooseActMove cid]
|
||||
where
|
||||
c = renderCharacterHandle board cid
|
||||
|
||||
computePossibleSteps :: BoardState -> Player -> Bool -> Natural -> Point -> [(Point, Natural)]
|
||||
computePossibleSteps board _ firstStep currentMove originalLocation = mapMaybe getRemainingMov validDirections
|
||||
where
|
||||
validDirections = offsetB board originalLocation `mapMaybe` orthagonalDirections
|
||||
currentTerrain = board ^. terrainAt originalLocation
|
||||
paysElevationCost = not (elem Stairs currentTerrain || elem Elevation currentTerrain)
|
||||
baseMovementCost = if Rough `elem` currentTerrain then 2 else 1
|
||||
getRemainingMov :: Point -> Maybe (Point, Natural)
|
||||
getRemainingMov dest = toMaybe (not unreachable) (dest, remainingMovement)
|
||||
where
|
||||
(destCharacter, destTerrain) = board ^?! atPoint dest
|
||||
destElevated = Elevation `elem` destTerrain
|
||||
movingCharacter :: Maybe CharacterIdentifier
|
||||
movingCharacter = board ^? movingUnit . _Just . _1
|
||||
occupied = isJust destCharacter && destCharacter /= movingCharacter
|
||||
hostileOccupied = occupied && (owner <$> destCharacter) /= (owner <$> movingCharacter)
|
||||
hasMovementBlocker = Wall `elem` destTerrain || hostileOccupied
|
||||
totalCost = if paysElevationCost && destElevated then succ baseMovementCost else baseMovementCost
|
||||
unreachable = (currentMove < totalCost && not firstStep) || hasMovementBlocker || (occupied && totalCost >= currentMove)
|
||||
remainingMovement = if unreachable then 0 else currentMove - totalCost
|
||||
|
||||
dontAct :: Choice
|
||||
dontAct = mkChoice "Do nothing" []
|
||||
|
||||
applyEffect :: Effect -> BoardState -> EngineState
|
||||
applyEffect NoOp board = continue board
|
||||
applyEffect StartTurn board = case (chooseCharacter board, chooseCharacter opponentTurn) of
|
||||
(Just pickUnits, _) -> pickUnits
|
||||
(_, Just _) -> continue $ opponentTurn <++ [StartTurn]
|
||||
_ -> continue advanceRound
|
||||
where
|
||||
opponentTurn = switchActivePlayer board
|
||||
advanceRound =
|
||||
if board ^. roundNumber == 6
|
||||
then board
|
||||
else nextRound board
|
||||
applyEffect (Event trigger) board = continue $ pushEffects (listHooks board trigger) board
|
||||
applyEffect (ChooseActMove cid) _ = unitChoice cid [moveFirst, actFirst]
|
||||
where
|
||||
moveFirst = mkChoice "Move first" [InitMove cid, ActOrMove cid, EndTurn cid]
|
||||
actFirst = mkChoice "Act first" [Act cid, InitMove cid, EndTurn cid]
|
||||
applyEffect (ActOrMove cid) _ = unitChoice cid [moveAgain, nowAct]
|
||||
where
|
||||
moveAgain = mkChoice "Move again" [InitMove cid]
|
||||
nowAct = mkChoice "Act" [Act cid]
|
||||
applyEffect (InitMove cid) board = continue $ changeMovingUnit board cid <++ [Move True characterMovement cid]
|
||||
where
|
||||
characterMovement = board ^?! ixCharacter cid . to getSpeed
|
||||
applyEffect (Move _ 0 _) board = continue $ board <++ [ConfirmMove]
|
||||
applyEffect (Move firstMove mov cid) board = case unitPosition board cid of
|
||||
Nothing -> continue board
|
||||
Just originalLocation ->
|
||||
let
|
||||
generateChoice :: (Point, Natural) -> Choice
|
||||
generateChoice (dest, remainingMov) =
|
||||
mkChoice
|
||||
("Move " ++ show direction)
|
||||
( MoveTo dest
|
||||
: if remainingMov > 0 then [Move False remainingMov cid] else [ConfirmMove, Event $ EndMove cid]
|
||||
)
|
||||
where
|
||||
direction = fromMaybe North $ usingBoardDimensions board identifyDirection originalLocation dest
|
||||
possibleSteps = computePossibleSteps board (board ^. activePlayer) firstMove mov originalLocation
|
||||
movementChoices = generateChoice <$> possibleSteps
|
||||
dontMove = mkChoice "Don't move" [ConfirmMove]
|
||||
finishMoving = mkChoice "Finish moving" [ConfirmMove, Event $ EndMove cid]
|
||||
allowedToEndMovement = not $ has (atPoint originalLocation . _1 . _Just) board
|
||||
noMovement
|
||||
| firstMove = [dontMove]
|
||||
| allowedToEndMovement = [finishMoving]
|
||||
| otherwise = []
|
||||
in unitChoice cid $ noMovement ++ movementChoices
|
||||
applyEffect (MoveTo dest) board = continue $ moveUnit dest board
|
||||
applyEffect ConfirmMove board = continue $
|
||||
case board ^? movingUnit . _Just . _1 of
|
||||
Just cid -> finalizeMove board & ixCharacter cid %~ removeTokenInCategory SpeedSlow
|
||||
Nothing -> board
|
||||
applyEffect (Act cid) board = case board ^.. ixCharacter cid . baseStats . actionsL . each . to ($ cid) of
|
||||
[] -> continue board
|
||||
act -> unitChoice cid (dontAct : act)
|
||||
applyEffect (Target fromPerspective range eligability ultimateEffect) board = unitChoice fromPerspective choices
|
||||
where
|
||||
locus = unitPosition board fromPerspective
|
||||
potentialUnits = maybe [] (cidsInRange board range) locus
|
||||
eligableUnits = filter (eligability board) potentialUnits
|
||||
buildChoice targetCid =
|
||||
mkChoice
|
||||
("Target " ++ renderCharacterHandle board targetCid)
|
||||
[BodyBlock targetCid ultimateEffect]
|
||||
choices = buildChoice <$> eligableUnits
|
||||
applyEffect (BodyBlock targettedUnit ultimateEffect) board = if canBB then allChoices else cantBBResult
|
||||
where
|
||||
potentialBBers = fromMaybe [] $ adjacentAllies board targettedUnit
|
||||
canBB = isNecromancer targettedUnit && potentialBBers /= []
|
||||
buildChoice bber = mkChoice ("Bodyblock with " ++ renderCharacterHandle board bber) (ultimateEffect bber)
|
||||
dontBodyblock = mkChoice "Take the hit to your necromancer" (ultimateEffect targettedUnit)
|
||||
bbChoices = buildChoice <$> potentialBBers
|
||||
allChoices = unitChoice targettedUnit $ dontBodyblock : bbChoices
|
||||
cantBBResult = continue $ board <++ ultimateEffect targettedUnit
|
||||
applyEffect (ResolveAttack attacker attack defender) board = Roll actualDiceRolled keepHighest consequence
|
||||
where
|
||||
attacker' = board ^? ixCharacter attacker
|
||||
defender' = board ^? ixCharacter defender
|
||||
attackerDieBonus = computeStat board attacker AttackDice
|
||||
defenderDieBonus = computeStat board defender DefenseDice
|
||||
attackerPosition = unitPosition board attacker
|
||||
defenderPosition = unitPosition board defender
|
||||
potentialCoverDirections =
|
||||
usingBoardDimensions board identifyCardinalDirection <$> attackerPosition <*> defenderPosition
|
||||
potentialCoverLocations =
|
||||
fromMaybe [] $
|
||||
(mapMaybe . offsetB board <$> defenderPosition) <*> potentialCoverDirections
|
||||
coveringTerrain = nub $ (\p -> board ^. terrainAt p) =<< potentialCoverLocations
|
||||
defenderElevated = isElevated board defender
|
||||
validCover = if defenderElevated then [Wall] else [Wall, Elevation]
|
||||
hasCover = or $ (==) <$> validCover <*> coveringTerrain
|
||||
coverBonus = if not (melee attack) && hasCover then 1 else 0
|
||||
netDice = attackerDieBonus - (defenderDieBonus + coverBonus)
|
||||
actualDiceRolled = fromIntegral $ if netDice <= 0 then 2 else netDice
|
||||
keepHighest = netDice > 0
|
||||
toHit = maybe 1 getDefense defender'
|
||||
attackerStrWeak = fromMaybe 0 $ attacker' ^? _Just . tokenCount . ofToken StrWeak
|
||||
tokenDamageModifier
|
||||
| attackerStrWeak < 0 = \x -> x-1
|
||||
| attackerStrWeak > 0 = (+1)
|
||||
| otherwise = id
|
||||
missDamage = InflictDamage (damageType attack) (tokenDamageModifier 1) defender
|
||||
hitDamage = InflictDamage (damageType attack) (tokenDamageModifier $ damageAmount attack) defender
|
||||
onMiss = [missDamage]
|
||||
onHit = hitDamage : otherEffects attack
|
||||
onHeadshot = onHit ++ headshotEffects attack
|
||||
consequence Six
|
||||
| not $ null $ headshotEffects attack = mkChoice "Headshot!" onHeadshot
|
||||
consequence r
|
||||
| r >= toHit = mkChoice "Hit!" onHit
|
||||
| otherwise = mkChoice "Graze" onMiss
|
||||
applyEffect (InflictDamage damageType incomingAmount recipient) board = continue $ board' <++ damageEffects
|
||||
where
|
||||
incomingAmount' = fromIntegral incomingAmount
|
||||
recipient' = board ^? ixCharacter recipient
|
||||
armorType = maybe NoArmor (^. baseStats . armL) recipient'
|
||||
armorReduction = if armorType `blocks` damageType then 1 else 0
|
||||
tokenReduction = signum $ fromMaybe 0 $ recipient' ^? _Just . tokenCount . ofToken VitalVulnr
|
||||
totalReduction = if damageType == DevilDamage then min 0 tokenReduction else armorReduction + tokenReduction
|
||||
netDamage
|
||||
| totalReduction >= incomingAmount' = 0
|
||||
| otherwise = fromIntegral $ incomingAmount' - totalReduction
|
||||
board' = trace ("iA': " ++ show incomingAmount' ++ " | aR: " ++ show armorReduction ++ " | r: " ++ show recipient) $ board
|
||||
& ixCharacter recipient %~ clearUpToNTokens Health netDamage
|
||||
& if incomingAmount' > armorReduction
|
||||
then ixCharacter recipient %~ removeTokenInCategory VitalVulnr
|
||||
else id
|
||||
updatedHealth = fromMaybe 9999 $ board' ^? ixCharacter recipient . tokenCount . ofToken Health
|
||||
dead = updatedHealth == 0
|
||||
damageEffects = [Event $ TookDamage recipient, if dead then Kill recipient else NoOp]
|
||||
applyEffect (InflictTokens tokenType numberToAdd target) board = continue $ board &
|
||||
ixCharacter target . tokenCount . ofToken tokenType +~ numberToAdd
|
||||
applyEffect (Kill unit) board = if isNecromancer unit
|
||||
then Victory $ otherPlayer $ owner unit
|
||||
else continue $ unitRemoved <++ [deathAlert]
|
||||
where
|
||||
deathLocation = unitPosition board unit
|
||||
unitRemoved = removeUnit unit board
|
||||
deathAlert = maybe NoOp (Event . Died unit) deathLocation
|
||||
applyEffect (EndTurn cid) board = continue $ afterPlayerSwitched <++ [StartTurn]
|
||||
where
|
||||
afterUnitTapped = board & ixCharacter cid %~ tap
|
||||
afterPlayerSwitched = switchActivePlayer afterUnitTapped
|
||||
|
||||
data ChoiceTree' inp where
|
||||
Node :: BoardState -> Player -> [ChoiceTreeChoice] -> ChoiceTree' Int
|
||||
Random ::
|
||||
Natural -- ^ Number of dice
|
||||
-> Bool -- ^ True = Xd6kh1, False = Xd6kl1
|
||||
-> (DieFace -> ChoiceTreeChoice) -- ^ Outcomes
|
||||
-> ChoiceTree' DieFace
|
||||
EndOfGame :: Maybe Player -> ChoiceTree' Never
|
||||
|
||||
data ChoiceTree = forall i. ChoiceTree (ChoiceTree' i)
|
||||
|
||||
instance Show (ChoiceTree' a) where
|
||||
show (EndOfGame Nothing) = "It's a draw!"
|
||||
show (EndOfGame (Just player)) = show player ++ " Wins!"
|
||||
show (Node board player choices) = show board ++ "\n\n\n[" ++ show player ++ "]\n" ++ viewChoices
|
||||
where
|
||||
choicesText :: [String]
|
||||
choicesText = firstDecisions choices
|
||||
numberedChoices :: [String]
|
||||
numberedChoices = zipWith (\n c -> show (1+n) ++ ") " ++ c) [0..] choicesText
|
||||
viewChoices :: String
|
||||
viewChoices = mconcat $ intersperse "\n" numberedChoices
|
||||
show (Random numDice rollType _) = "Roll " ++ show numDice ++ "d6 and take the " ++ (if rollType then "highest" else "lowest")
|
||||
|
||||
instance Show ChoiceTree where
|
||||
show (ChoiceTree t) = show t
|
||||
|
||||
data ChoiceTreeChoice = ChoiceTreeChoice (NonEmpty String) ChoiceTree
|
||||
|
||||
firstDecisions :: [ChoiceTreeChoice] -> [String]
|
||||
firstDecisions choices = nub $ choices ^.. each . ctDecisionsL . to NonEmpty.head
|
||||
|
||||
ctDecisions :: ChoiceTreeChoice -> NonEmpty String
|
||||
ctDecisions (ChoiceTreeChoice decs _) = decs
|
||||
ctDecisionsL :: Lens' ChoiceTreeChoice (NonEmpty String)
|
||||
ctDecisionsL f (ChoiceTreeChoice decs choices) = ChoiceTreeChoice <$> f decs ?? choices
|
||||
ctTree :: ChoiceTreeChoice -> ChoiceTree
|
||||
ctTree (ChoiceTreeChoice _ tree) = tree
|
||||
|
||||
convertChoice :: BoardState -> Choice -> ChoiceTreeChoice
|
||||
convertChoice board choice =
|
||||
ChoiceTreeChoice
|
||||
(decisionSequence choice)
|
||||
(buildChoiceTree $ board <++ effects choice)
|
||||
|
||||
buildChoiceTree :: BoardState -> ChoiceTree
|
||||
buildChoiceTree board = case popEffect board of
|
||||
Nothing -> ChoiceTree $ EndOfGame Nothing
|
||||
Just (effect, board') ->
|
||||
case applyEffect effect board' of
|
||||
PlayerChoice chooser choices -> ChoiceTree $ Node board' chooser (convertChoice board' <$> choices)
|
||||
Roll n d outcomes -> ChoiceTree $ Random n d (convertChoice board' <$> outcomes)
|
||||
Continue board'' -> buildChoiceTree board''
|
||||
Victory player -> ChoiceTree $ EndOfGame $ Just player
|
||||
|
||||
makeChoice :: n -> ChoiceTree' n -> Maybe ChoiceTree
|
||||
makeChoice n (EndOfGame _) = never n
|
||||
makeChoice die (Random _ _ outcomes) = Just $ ctTree $ outcomes die
|
||||
makeChoice indx (Node b p options) = trimmedChoices <$> providedDecision
|
||||
where
|
||||
providedDecision :: Maybe String
|
||||
providedDecision = firstDecisions options `atMay` (indx - 1)
|
||||
matchingChoices :: String -> [ChoiceTreeChoice]
|
||||
matchingChoices decision = filter ((== decision) . NonEmpty.head . ctDecisions) options
|
||||
trimChoice :: ChoiceTreeChoice -> Either ChoiceTree ChoiceTreeChoice
|
||||
trimChoice (ChoiceTreeChoice decs tree) =
|
||||
case nonEmpty $ NonEmpty.tail decs of
|
||||
Just newDecs -> Right $ ChoiceTreeChoice newDecs tree
|
||||
Nothing -> Left tree
|
||||
trimmedChoices :: String -> ChoiceTree
|
||||
trimmedChoices decision = either id (ChoiceTree . Node b p) $ traverse trimChoice (matchingChoices decision)
|
||||
|
|
@ -0,0 +1,866 @@
|
|||
{-# 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)
|
||||
|
|
@ -0,0 +1,70 @@
|
|||
module Units
|
||||
( computeStat
|
||||
, AttackT(..)
|
||||
, anyTarget
|
||||
, buildAttack
|
||||
, SelfAbilityT(..)
|
||||
, mkSelfAbility
|
||||
)
|
||||
where
|
||||
|
||||
import GameModel
|
||||
( Attack(..)
|
||||
, baseStats
|
||||
, BoardState
|
||||
, CharacterIdentifier
|
||||
, Choice
|
||||
, DamageType
|
||||
, Effect(..)
|
||||
, isElevated
|
||||
, Stat(..)
|
||||
, statBonusL
|
||||
, mkChoice, ixCharacter
|
||||
)
|
||||
import Util ((??))
|
||||
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Numeric.Natural (Natural)
|
||||
import Lens.Micro
|
||||
|
||||
computeStat :: BoardState -> CharacterIdentifier -> Stat a -> a
|
||||
computeStat board cid stat = case stat of
|
||||
AttackDice -> 1 + elevationBonus + fromMaybe 0 specialtyBonus
|
||||
DefenseDice -> 0 + elevationBonus + fromMaybe 0 specialtyBonus
|
||||
where
|
||||
statBonuses = ixCharacter cid . baseStats . statBonusL
|
||||
specialtyBonus = case board ^? statBonuses of
|
||||
Just statB -> Just $ statB board cid stat
|
||||
Nothing -> Nothing
|
||||
elevationBonus :: Int
|
||||
elevationBonus = if isElevated board cid then 1 else 0
|
||||
|
||||
data AttackT = AttackT
|
||||
{ tName :: String
|
||||
, tRange :: (Natural, Natural)
|
||||
, tValidTargets :: BoardState -> CharacterIdentifier -> Bool
|
||||
, tMelee :: Bool
|
||||
, tDamageType :: DamageType
|
||||
, tDamageAmount :: Natural
|
||||
, tHeadshotEffects :: [CharacterIdentifier -> Effect]
|
||||
, tStandardEffects :: [CharacterIdentifier -> Effect]
|
||||
}
|
||||
|
||||
anyTarget :: BoardState -> CharacterIdentifier -> Bool
|
||||
anyTarget = const $ const True
|
||||
|
||||
buildAttack :: AttackT -> CharacterIdentifier -> Choice
|
||||
buildAttack (AttackT {..}) attacker = mkChoice tName [targetEffect]
|
||||
where
|
||||
attackDetails =
|
||||
Attack <$> sequence tHeadshotEffects ?? tMelee <*> sequence tStandardEffects ?? tDamageType ?? tDamageAmount
|
||||
attackEffect target = [ResolveAttack attacker (attackDetails target) target]
|
||||
targetEffect = Target attacker tRange tValidTargets attackEffect
|
||||
|
||||
data SelfAbilityT = SelfAbilityT
|
||||
{ tName :: String
|
||||
, tEffects :: [CharacterIdentifier -> Effect]
|
||||
}
|
||||
|
||||
mkSelfAbility :: SelfAbilityT -> CharacterIdentifier -> Choice
|
||||
mkSelfAbility (SelfAbilityT {..}) = mkChoice tName <$> sequence tEffects
|
||||
|
|
@ -0,0 +1,59 @@
|
|||
module Units.Carcass
|
||||
( gunwight
|
||||
)
|
||||
where
|
||||
|
||||
import GameModel
|
||||
( adjacentAllies
|
||||
, Armor(..)
|
||||
, BaseStats(..)
|
||||
, BoardState
|
||||
, CharacterIdentifier
|
||||
, Choice
|
||||
, DamageType(..)
|
||||
, Effect(..)
|
||||
, Stat(..)
|
||||
, Token(..)
|
||||
, Trigger(..)
|
||||
)
|
||||
import Units
|
||||
( AttackT(..)
|
||||
, anyTarget
|
||||
, buildAttack
|
||||
)
|
||||
|
||||
gunwight :: BaseStats
|
||||
gunwight = BaseStats
|
||||
{ name = "Gunwight"
|
||||
, hp = 2
|
||||
, mov = 2
|
||||
, df = 4
|
||||
, arm = NoArmor
|
||||
, hooks = gunwightHooks
|
||||
, actions = gunwightActions
|
||||
, statBonus = gunwightStatBonuses
|
||||
}
|
||||
|
||||
gunwightHooks :: BoardState -> CharacterIdentifier -> Trigger -> [Effect]
|
||||
gunwightHooks board cid TurnStart = []
|
||||
gunwightHooks board cid (TookDamage _) = []
|
||||
gunwightHooks board cid (Died _ _) = []
|
||||
gunwightHooks board cid (EndMove _) = []
|
||||
|
||||
gunwightActions :: [CharacterIdentifier -> Choice]
|
||||
gunwightActions =
|
||||
[ buildAttack $ AttackT
|
||||
{ tName = "OL45"
|
||||
, tRange = (2, 3)
|
||||
, tValidTargets = anyTarget
|
||||
, tMelee = False
|
||||
, tDamageType = Unblockable
|
||||
, tDamageAmount = 2
|
||||
, tHeadshotEffects = [InflictTokens VitalVulnr (-1)]
|
||||
, tStandardEffects = []
|
||||
}
|
||||
]
|
||||
|
||||
gunwightStatBonuses :: BoardState -> CharacterIdentifier -> Stat a -> a
|
||||
gunwightStatBonuses board cid AttackDice = if adjacentAllies board cid /= Just [] then 1 else 0
|
||||
gunwightStatBonuses _ _ DefenseDice = 0
|
||||
|
|
@ -0,0 +1,103 @@
|
|||
module Units.Debug
|
||||
( basic
|
||||
)
|
||||
where
|
||||
|
||||
import GameModel
|
||||
( adjacentAllies
|
||||
, Armor(..)
|
||||
, BaseStats(..)
|
||||
, BoardState
|
||||
, CharacterIdentifier
|
||||
, Choice
|
||||
, DamageType(..)
|
||||
, Effect(..)
|
||||
, Stat(..)
|
||||
, Token(..)
|
||||
, Trigger(..)
|
||||
)
|
||||
import Units
|
||||
( AttackT(..)
|
||||
, anyTarget
|
||||
, buildAttack
|
||||
, SelfAbilityT(..)
|
||||
, mkSelfAbility
|
||||
)
|
||||
|
||||
basic :: BaseStats
|
||||
basic = BaseStats
|
||||
{ name = "Basic Debug Unit"
|
||||
, hp = 4
|
||||
, mov = 4
|
||||
, df = 4
|
||||
, arm = NoArmor
|
||||
, hooks = basicHooks
|
||||
, actions = basicActions
|
||||
, statBonus = basicStatBonuses
|
||||
}
|
||||
|
||||
basicHooks :: BoardState -> CharacterIdentifier -> Trigger -> [Effect]
|
||||
basicHooks _ _ TurnStart = []
|
||||
basicHooks _ _ (TookDamage _) = []
|
||||
basicHooks _ _ (Died _ _) = []
|
||||
basicHooks _ _ (EndMove _) = []
|
||||
|
||||
basicActions :: [CharacterIdentifier -> Choice]
|
||||
basicActions =
|
||||
[ buildAttack $ AttackT
|
||||
{ tName = "Peashooter"
|
||||
, tRange = (1, 3)
|
||||
, tValidTargets = anyTarget
|
||||
, tMelee = False
|
||||
, tDamageType = BasicDamage
|
||||
, tDamageAmount = 1
|
||||
, tHeadshotEffects = []
|
||||
, tStandardEffects = []
|
||||
}
|
||||
, buildAttack $ AttackT
|
||||
{ tName = "Jarate"
|
||||
, tRange = (1, 3)
|
||||
, tValidTargets = anyTarget
|
||||
, tMelee = False
|
||||
, tDamageType = BasicDamage
|
||||
, tDamageAmount = 0
|
||||
, tHeadshotEffects = []
|
||||
, tStandardEffects = [InflictTokens VitalVulnr (-1)]
|
||||
}
|
||||
, buildAttack $ AttackT
|
||||
{ tName = "Slime"
|
||||
, tRange = (1, 3)
|
||||
, tValidTargets = anyTarget
|
||||
, tMelee = False
|
||||
, tDamageType = BasicDamage
|
||||
, tDamageAmount = 0
|
||||
, tHeadshotEffects = []
|
||||
, tStandardEffects = [InflictTokens SpeedSlow (-1)]
|
||||
}
|
||||
, buildAttack $ AttackT
|
||||
{ tName = "Nerf"
|
||||
, tRange = (1, 3)
|
||||
, tValidTargets = anyTarget
|
||||
, tMelee = False
|
||||
, tDamageType = BasicDamage
|
||||
, tDamageAmount = 0
|
||||
, tHeadshotEffects = []
|
||||
, tStandardEffects = [InflictTokens StrWeak (-1)]
|
||||
}
|
||||
, mkSelfAbility $ SelfAbilityT
|
||||
{ tName = "Calcify"
|
||||
, tEffects = [InflictTokens VitalVulnr 1]
|
||||
}
|
||||
, mkSelfAbility $ SelfAbilityT
|
||||
{ tName = "Zoomify"
|
||||
, tEffects = [InflictTokens SpeedSlow 1]
|
||||
}
|
||||
, mkSelfAbility $ SelfAbilityT
|
||||
{ tName = "Get String"
|
||||
, tEffects = [InflictTokens StrWeak 1]
|
||||
}
|
||||
]
|
||||
|
||||
basicStatBonuses :: BoardState -> CharacterIdentifier -> Stat a -> a
|
||||
basicStatBonuses _ _ AttackDice = 0
|
||||
basicStatBonuses _ _ DefenseDice = 0
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
module Util
|
||||
( toMaybe
|
||||
, dup
|
||||
, secondClassLensNames
|
||||
, (??)
|
||||
, Never
|
||||
, never
|
||||
, note
|
||||
) where
|
||||
|
||||
import Data.Bool (bool)
|
||||
import Lens.Micro.TH (LensRules, lensRules, lensField, DefName (TopName))
|
||||
import Language.Haskell.TH (mkName, nameBase)
|
||||
import Lens.Micro
|
||||
|
||||
toMaybe :: Bool -> a -> Maybe a
|
||||
toMaybe p = if p then Just else const Nothing
|
||||
|
||||
dup :: a -> (a, a)
|
||||
dup a = (a, a)
|
||||
|
||||
infixl 4 ??
|
||||
(??) :: Functor f => f (a -> b) -> a -> f b
|
||||
f ?? a = ($ a) <$> f
|
||||
|
||||
secondClassLensNames :: LensRules
|
||||
secondClassLensNames = lensRules & lensField .~ (\_ _ n -> [TopName $ mkName $ nameBase n ++ "L"])
|
||||
|
||||
data Never
|
||||
|
||||
never :: Never -> a
|
||||
never n = case n of
|
||||
|
||||
note :: a -> Maybe b -> Either a b
|
||||
note _ (Just b) = Right b
|
||||
note n Nothing = Left n
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
# This file was automatically generated by 'stack init'
|
||||
#
|
||||
# Some commonly used options have been documented as comments in this file.
|
||||
# For advanced use and comprehensive documentation of the format, please see:
|
||||
# https://docs.haskellstack.org/en/stable/yaml_configuration/
|
||||
|
||||
# Resolver to choose a 'specific' stackage snapshot or a compiler version.
|
||||
# A snapshot resolver dictates the compiler version and the set of packages
|
||||
# to be used for project dependencies. For example:
|
||||
#
|
||||
# resolver: lts-3.5
|
||||
# resolver: nightly-2015-09-21
|
||||
resolver: ghc-9.7.8
|
||||
|
||||
compiler: ghc-9.2.8
|
||||
#
|
||||
# The location of a snapshot can be provided as a file or url. Stack assumes
|
||||
# a snapshot provided as a file might change, whereas a url resource does not.
|
||||
#
|
||||
# resolver: ./custom-snapshot.yaml
|
||||
# resolver: https://example.com/snapshots/2018-01-01.yaml
|
||||
resolver:
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/21.yaml
|
||||
|
||||
# User packages to be built.
|
||||
# Various formats can be used as shown in the example below.
|
||||
#
|
||||
# packages:
|
||||
# - some-directory
|
||||
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
|
||||
# subdirs:
|
||||
# - auto-update
|
||||
# - wai
|
||||
packages:
|
||||
- .
|
||||
# Dependency packages to be pulled from upstream that are not in the resolver.
|
||||
# These entries can reference officially published versions as well as
|
||||
# forks / in-progress versions pinned to a git hash. For example:
|
||||
#
|
||||
# extra-deps:
|
||||
# - acme-missiles-0.3
|
||||
# - git: https://github.com/commercialhaskell/stack.git
|
||||
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||
#
|
||||
# extra-deps: []
|
||||
|
||||
# Override default flag values for local packages and extra-deps
|
||||
# flags: {}
|
||||
|
||||
# Extra package databases containing global packages
|
||||
# extra-package-dbs: []
|
||||
|
||||
# Control whether we use the GHC we find on the path
|
||||
# system-ghc: true
|
||||
#
|
||||
# Require a specific version of stack, using version ranges
|
||||
# require-stack-version: -any # Default
|
||||
# require-stack-version: ">=2.9"
|
||||
#
|
||||
# Override the architecture used by stack, especially useful on Windows
|
||||
# arch: i386
|
||||
# arch: x86_64
|
||||
#
|
||||
# Extra directories used by stack for building
|
||||
# extra-include-dirs: [/path/to/dir]
|
||||
# extra-lib-dirs: [/path/to/dir]
|
||||
#
|
||||
# Allow a newer minor version of GHC than the snapshot specifies
|
||||
# compiler-check: newer-minor
|
||||
|
||||
nix:
|
||||
enable: True
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
# This file was autogenerated by Stack.
|
||||
# You should not edit this file by hand.
|
||||
# For more information, please see the documentation at:
|
||||
# https://docs.haskellstack.org/en/stable/lock_files
|
||||
|
||||
packages: []
|
||||
snapshots:
|
||||
- completed:
|
||||
sha256: 7d4b649cf368f9076d8aa049aa44efe58950971d105892734e9957b2a26a2186
|
||||
size: 640060
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/21.yaml
|
||||
original:
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/21.yaml
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
main :: IO ()
|
||||
main = putStrLn "Test suite not yet implemented"
|
||||
Loading…
Reference in New Issue