diff --git a/README.md b/README.md index b3335db..c18b794 100644 --- a/README.md +++ b/README.md @@ -17,7 +17,6 @@ Currently missing core mechanics include: - Obliteration - Targetting walls - Corpses -- Free movement - Stepping - Most faction tags/tokens diff --git a/app/Main.hs b/app/Main.hs index f831067..2cbf13b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -3,8 +3,7 @@ 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 Units.Debug (basic, freeMoveTester) import GameLogic (buildChoiceTree, ChoiceTree(..), ChoiceTree'(..), makeChoice, ctTree) import Text.Read (readMaybe) @@ -13,7 +12,7 @@ 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))] +initialPlacement = flip lookup [(Point 5, (Max, basic)), (Point 0, (Max, freeMoveTester)), (Point 23, (Min, basic)), (Point 22, (Min, freeMoveTester))] initialTerrain :: Point -> [EnvTile] initialTerrain (Point 4) = [Rough] diff --git a/src/GameLogic.hs b/src/GameLogic.hs index 3666c36..4be7020 100644 --- a/src/GameLogic.hs +++ b/src/GameLogic.hs @@ -63,13 +63,27 @@ chooseCharacter board = playerChoice player <$> fmap toList (nonEmpty $ board ^. where c = renderCharacterHandle board cid -computePossibleSteps :: BoardState -> Player -> Bool -> Natural -> Point -> [(Point, Natural)] -computePossibleSteps board _ firstStep currentMove originalLocation = mapMaybe getRemainingMov validDirections +forcedMovementValidDirections :: Natural -> Natural -> Point -> (Point, ForcedMoveType, Player) -> [OrthagonalDirection] +forcedMovementValidDirections w h currentLocation (locus, moveType, _) = + case moveType of + Shift -> orthagonalDirections + Pull -> directionToLocus + Push -> flipDirection <$> directionToLocus 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 + directionToLocus = identifyCardinalDirection w h currentLocation locus + +computePossibleSteps :: BoardState -> MovementSpecs -> Point -> [(Point, Natural)] +computePossibleSteps board (MovementSpecs {..}) currentLocation = mapMaybe getRemainingMov validDestinations + where + validDirections = + maybe + orthagonalDirections + (usingBoardDimensions board forcedMovementValidDirections currentLocation) + movForced + validDestinations = mapMaybe (offsetB board currentLocation) validDirections + currentTerrain = board ^. terrainAt currentLocation + paysElevationCost = not (elem Stairs currentTerrain || elem Elevation currentTerrain || movFree) + baseMovementCost = if Rough `elem` currentTerrain && not movFree then 2 else 1 getRemainingMov :: Point -> Maybe (Point, Natural) getRemainingMov dest = toMaybe (not unreachable) (dest, remainingMovement) where @@ -81,8 +95,27 @@ computePossibleSteps board _ firstStep currentMove originalLocation = mapMaybe g 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 + unreachable = (movAmount < totalCost && not movMinimum) || hasMovementBlocker || (occupied && totalCost >= movAmount) + remainingMovement = if unreachable then 0 else movAmount - totalCost + +endOfMovementEffects :: MovementSpecs -> CharacterIdentifier -> [Effect] +endOfMovementEffects (MovementSpecs {..}) cid = + [ConfirmMove] + ++ [DropToken SpeedSlow cid | movSpendTokens ] + ++ [Event $ EndMove cid | movEndMoveTrigger] + +generateMovementChoice :: BoardState -> MovementSpecs -> CharacterIdentifier -> Point -> (Point, Natural) -> Choice +generateMovementChoice board specs@(MovementSpecs {..}) cid originalLocation (dest, remainingMov) = + mkChoice + (movVerb ++ ' ' : show direction) + ( MoveTo dest + : if remainingMov > 0 + then [Move updatedSpecs cid] + else endOfMovementEffects specs cid + ) + where + direction = fromMaybe North $ usingBoardDimensions board identifyDirection originalLocation dest + updatedSpecs = specs & movAmountL .~ remainingMov & movMinimumL .~ False dontAct :: Choice dontAct = mkChoice "Do nothing" [] @@ -102,44 +135,70 @@ applyEffect StartTurn board = case (chooseCharacter board, chooseCharacter oppon 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] + moveFirst = mkChoice "Move first" [basicMove cid, ActOrMove cid, EndTurn cid] + actFirst = mkChoice "Act first" [Act cid, basicMove cid, EndTurn cid] applyEffect (ActOrMove cid) _ = unitChoice cid [moveAgain, nowAct] where - moveAgain = mkChoice "Move again" [InitMove cid] + moveAgain = mkChoice "Move again" [basicMove cid] nowAct = mkChoice "Act" [Act cid] -applyEffect (InitMove cid) board = continue $ changeMovingUnit board cid <++ [Move True characterMovement cid] +applyEffect (InitMove (ProtoMovementSpecs {..}) cid) board = continue $ case adjustedFm of + Just movForced -> changeMovingUnit board cid <++ [Move (MovementSpecs {..}) cid] + Nothing -> board 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 + movFree = fromMaybe (computeStat board cid FreeMove) movFree' + adjustedFm = case movForced' of + Nothing -> Just Nothing + Just (Right p, fmType, forcer) -> Just $ Just (p, fmType, forcer) + Just (Left locusUnit, fmType, forcer) -> case unitPosition board locusUnit of + Just p -> Just $ Just (p, fmType, forcer) + Nothing -> Nothing -- Locus unit died before pull began + characterMovement = board ^?! ixCharacter cid . to (getSpeed movFree) + movAmount = fromMaybe characterMovement movAmount' +applyEffect (Move (MovementSpecs {movAmount = 0}) _) board = continue $ board <++ [ConfirmMove] +applyEffect (Move specs@(MovementSpecs{..}) cid) board = case unitPosition board cid of + Nothing -> -- Unit died mid-move + if movEndMoveTrigger + then continue $ board <++ [endMoveTrigger] + else 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 + possibleSteps = computePossibleSteps board specs originalLocation + movementChoices = + generateMovementChoice + board + specs + cid + originalLocation + <$> possibleSteps + -- Possibilities: + -- Standard move, first step, movement possible (Standard movement choices + Don't move) + -- Standard move, first step, movement impossible (Silent don't move) + -- Standard move, subsequent step, movement possible (Standard movement choices + Finish moving) + -- Standard move, subsequent step, movement impossible (Silent finish moving) + -- Compelled move, first step, movement possible (Standard movement choices) + -- Compelled move, first step, movement impossible (Silent finish moving) + -- Compelled move, subsequent step, movement possible (Standard movement choices) + -- Compelled move, subsequent step, movement impossible (Silent finish moving) + in if null possibleSteps + then continue $ board <++ if movMinimum + then dontMoveEffects + else finishMoveEffects + else choiceBuilder $ (++ movementChoices) $ if movCompelled + then [] + else if movMinimum + then [dontMoveChoice] + else [finishMoveChoice] + where + dontMoveEffects = [ConfirmMove] + dontMoveChoice = mkChoice "Don't move" dontMoveEffects + finishMoveEffects = endOfMovementEffects specs cid + finishMoveChoice = mkChoice "Finish moving" finishMoveEffects + endMoveTrigger = Event $ EndMove cid + choiceBuilder = maybe (unitChoice cid) playerChoice $ movForced ^? _Just . _3 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 (DropToken token unit) board = continue $ + ixCharacter unit %~ removeTokenInCategory token $ board +applyEffect ConfirmMove board = continue $ finalizeMove board applyEffect (Act cid) board = case board ^.. ixCharacter cid . baseStats . actionsL . each . to ($ cid) of [] -> continue board act -> unitChoice cid (dontAct : act) diff --git a/src/GameModel.hs b/src/GameModel.hs index 242b26b..02c5327 100644 --- a/src/GameModel.hs +++ b/src/GameModel.hs @@ -32,6 +32,15 @@ module GameModel , identifyCardinalDirection , adjacentPoints , distanceCardinal + , MovementSpecs(..) + , movVerbL + , movFreeL + , movMinimumL + , movAmountL + , movForcedL + , movSpendTokensL + , movEndMoveTriggerL + , movCompelledL , Effect(..) , Player(..) , PPair @@ -113,6 +122,11 @@ module GameModel , newBoard , characterHandle , renderCharacterHandle + , ForcedMoveType(..) + , flipDirection + , ProtoMovementSpecs(..) + , basicMove + , forcedMove ) where import Util (toMaybe, dup, secondClassLensNames, (??)) @@ -288,6 +302,12 @@ data OrthagonalDirection 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) @@ -331,6 +351,12 @@ distanceCardinal w _ a b = max xDist yDist 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 @@ -342,6 +368,55 @@ data Token a where Reload :: Token Natural Health :: Token Natural + +-- | Details which characterize any kind of movement +data MovementSpecs = MovementSpecs + { movVerb :: String -- ^ The verb used to describe this move, e.g. "Move" or "Step" + , movFree :: Bool -- ^ Indicates whether moving with free movement + , movMinimum :: Bool -- ^ This movement gets to move at least 1 tile regardless of cost + , movAmount :: Natural -- ^ The amount of MV available to spend + , movForced :: Maybe (Point, ForcedMoveType, Player) -- ^ If this is a forced move, the locus, direction, and compelling player + , movSpendTokens :: Bool -- ^ Whether this movement uses up movement tokens + , movEndMoveTrigger :: Bool -- ^ Whether this movement should trigger "after MOVE" effects + , movCompelled :: Bool -- ^ If movement can be stopped prematurely + } + +-- | A version of `MovementSpecs` where some values will be populated dynamically +data ProtoMovementSpecs = ProtoMovementSpecs + { movVerb :: String -- ^ The verb used to describe this move, e.g. "Move" or "Step" + , movFree' :: Maybe Bool -- ^ Whether moving with free movement, or Nothing to compute at init + , movMinimum :: Bool -- ^ This movement gets to move at least 1 tile regardless of cost + , movAmount' :: Maybe Natural -- ^ How many spaces to move, or Nothing to compute at init + , movForced' :: Maybe (Either CharacterIdentifier Point, ForcedMoveType, Player) -- ^ If this is a forced move, the locus, direction, and compelling player + , movSpendTokens :: Bool -- ^ Whether this movement spends speed/slow tokens + , movEndMoveTrigger :: Bool -- ^ Whether this movement should trigger "after MOVE" effects + , movCompelled :: Bool -- ^ If movement can be stopped prematurely + } + +basicMove :: CharacterIdentifier -> Effect +basicMove = InitMove $ ProtoMovementSpecs + { movVerb = "Move" + , movFree' = Nothing + , movMinimum = True + , movAmount' = Nothing + , movForced' = Nothing + , movSpendTokens = True + , movEndMoveTrigger = True + , movCompelled = False + } + +forcedMove :: ForcedMoveType -> Natural -> Player -> Either CharacterIdentifier Point -> CharacterIdentifier -> Effect +forcedMove fmType amt compeller locus = InitMove $ ProtoMovementSpecs + { movVerb = show fmType + , movFree' = Just True + , movMinimum = False + , movAmount' = Just amt + , movForced' = Just (locus, fmType, compeller) + , movSpendTokens = False + , movEndMoveTrigger = False + , movCompelled = True + } + data Effect -- | Does nothing @@ -360,7 +435,7 @@ data Effect -- | Mark the start of movement -- Can be finalized later with FinalizeMove - | InitMove CharacterIdentifier + | InitMove ProtoMovementSpecs CharacterIdentifier -- | Active player may MOVE this character -- Should evaluate to a choice for every OrthagonalDirection which is valid to move in, @@ -368,14 +443,18 @@ data Effect -- 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 + MovementSpecs -- ^ Details about the movement CharacterIdentifier -- ^ Which character is being moved -- | Pick up a character and put them down on another space -- Should trigger effects like overwatch and hazard damage | MoveTo Point + -- | Remove up to one token from the given category from a unit + | forall n. Num n => DropToken + (Token n) -- ^ The token category to drop from + CharacterIdentifier -- ^ Which character drops a token + -- | Confirms a Move, placing the unit in the target space | ConfirmMove @@ -441,6 +520,7 @@ otherPlayer Min = Max data Stat a where AttackDice :: Stat Int DefenseDice :: Stat Int + FreeMove :: Stat Bool data BaseStats = BaseStats { name :: String @@ -562,6 +642,8 @@ makeLenses ''BoardState makeLensesWith (secondClassLensNames & generateUpdateableOptics .~ False) ''BaseStats +makeLensesWith secondClassLensNames ''MovementSpecs + instantiate :: BaseStats -> Character instantiate stats = Character stats False noTokens & tokenCount . ofToken Health .~ hp stats @@ -578,10 +660,10 @@ removeTokenInCategory t = tokenCount . ofToken t %~ minusSignum where minusSignum n = n - signum n -getSpeed :: Character -> Natural -getSpeed c +getSpeed :: Bool -> Character -> Natural +getSpeed preventReducions c | spdTokenCount > 0 = 2 + baseSpeed - | spdTokenCount < 0 = 1 + | spdTokenCount < 0 && not preventReducions = 1 | otherwise = baseSpeed where baseSpeed = c ^. baseStats . movL diff --git a/src/Units.hs b/src/Units.hs index 4d48345..1ff11da 100644 --- a/src/Units.hs +++ b/src/Units.hs @@ -31,6 +31,7 @@ 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 + FreeMove -> fromMaybe False specialtyBonus where statBonuses = ixCharacter cid . baseStats . statBonusL specialtyBonus = case board ^? statBonuses of diff --git a/src/Units/Carcass.hs b/src/Units/Carcass.hs index 143a157..0c2543e 100644 --- a/src/Units/Carcass.hs +++ b/src/Units/Carcass.hs @@ -56,4 +56,5 @@ gunwightActions = gunwightStatBonuses :: BoardState -> CharacterIdentifier -> Stat a -> a gunwightStatBonuses board cid AttackDice = if adjacentAllies board cid /= Just [] then 1 else 0 -gunwightStatBonuses _ _ DefenseDice = 0 \ No newline at end of file +gunwightStatBonuses _ _ DefenseDice = 0 +gunwightStatBonuses _ _ FreeMove = False \ No newline at end of file diff --git a/src/Units/Debug.hs b/src/Units/Debug.hs index f48b39a..b73c08a 100644 --- a/src/Units/Debug.hs +++ b/src/Units/Debug.hs @@ -1,11 +1,10 @@ module Units.Debug ( basic - ) + , freeMoveTester) where import GameModel - ( adjacentAllies - , Armor(..) + ( Armor(..) , BaseStats(..) , BoardState , CharacterIdentifier @@ -14,7 +13,8 @@ import GameModel , Effect(..) , Stat(..) , Token(..) - , Trigger(..) + , Trigger(..), ixCharacter, tokenCount, ofToken + , forcedMove, ForcedMoveType (Pull), Player (..) ) import Units ( AttackT(..) @@ -23,6 +23,7 @@ import Units , SelfAbilityT(..) , mkSelfAbility ) +import Lens.Micro basic :: BaseStats basic = BaseStats @@ -84,6 +85,16 @@ basicActions = , tHeadshotEffects = [] , tStandardEffects = [InflictTokens StrWeak (-1)] } + , buildAttack $ AttackT + { tName = "Yoink" + , tRange = (1, 4) + , tValidTargets = anyTarget + , tMelee = False + , tDamageType = BasicDamage + , tDamageAmount = 0 + , tHeadshotEffects = [] + , tStandardEffects = [forcedMove Pull 3 Min (Left (Max, 1))] + } , mkSelfAbility $ SelfAbilityT { tName = "Calcify" , tEffects = [InflictTokens VitalVulnr 1] @@ -100,4 +111,34 @@ basicActions = basicStatBonuses :: BoardState -> CharacterIdentifier -> Stat a -> a basicStatBonuses _ _ AttackDice = 0 -basicStatBonuses _ _ DefenseDice = 0 \ No newline at end of file +basicStatBonuses _ _ DefenseDice = 0 +basicStatBonuses _ _ FreeMove = False + +freeMoveTester :: BaseStats +freeMoveTester = BaseStats + { name = "Free Move Debug Unit" + , hp = 4 + , mov = 4 + , df = 1 + , arm = NoArmor + , hooks = freeMoveHooks + , actions = freeMoveActions + , statBonus = freeMoveStatBonuses + } + +freeMoveHooks :: BoardState -> CharacterIdentifier -> Trigger -> [Effect] +freeMoveHooks _ _ TurnStart = [] +freeMoveHooks _ _ (TookDamage _) = [] +freeMoveHooks _ _ (Died _ _) = [] +freeMoveHooks _ _ (EndMove _) = [] + +freeMoveActions :: [CharacterIdentifier -> Choice] +freeMoveActions = + [ + ] + +freeMoveStatBonuses :: BoardState -> CharacterIdentifier -> Stat a -> a +freeMoveStatBonuses _ _ AttackDice = 0 +freeMoveStatBonuses _ _ DefenseDice = 0 +freeMoveStatBonuses board cid FreeMove = -- Has free movement when below max health + maybe True (<4) $ board ^? ixCharacter cid . tokenCount . ofToken Health \ No newline at end of file