Rework movement to accomodate free move + push/pull

README.md

@@ -17,7 +17,6 @@ Currently missing core mechanics include:
 - Obliteration
 - Targetting walls
 - Corpses
-- Free movement
 - Stepping
 - Most faction tags/tokens
 

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, freeMoveTester)
-import Units.Debug (basic)
 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]

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)]
+forcedMovementValidDirections :: Natural -> Natural -> Point -> (Point, ForcedMoveType, Player) -> [OrthagonalDirection]
-computePossibleSteps board _ firstStep currentMove originalLocation = mapMaybe getRemainingMov validDirections
+forcedMovementValidDirections w h currentLocation (locus, moveType, _) =
+  case moveType of
+    Shift -> orthagonalDirections
+    Pull -> directionToLocus
+    Push -> flipDirection <$> directionToLocus
   where
-    validDirections = offsetB board originalLocation `mapMaybe` orthagonalDirections
+    directionToLocus = identifyCardinalDirection w h currentLocation locus
-    currentTerrain = board ^. terrainAt originalLocation
+
-    paysElevationCost = not (elem Stairs currentTerrain || elem Elevation currentTerrain)
+computePossibleSteps :: BoardState -> MovementSpecs -> Point -> [(Point, Natural)]
-    baseMovementCost = if Rough `elem` currentTerrain then 2 else 1
+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)
+        unreachable = (movAmount < totalCost && not movMinimum) || hasMovementBlocker || (occupied && totalCost >= movAmount)
-        remainingMovement = if unreachable then 0 else currentMove - totalCost
+        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]
+    moveFirst = mkChoice "Move first" [basicMove cid, ActOrMove cid, EndTurn cid]
-    actFirst = mkChoice "Act first" [Act cid, InitMove 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
+    movFree = fromMaybe (computeStat board cid FreeMove) movFree'
-applyEffect (Move _ 0 _) board = continue $ board <++ [ConfirmMove]
+    adjustedFm = case movForced' of
-applyEffect (Move firstMove mov cid) board = case unitPosition board cid of
+      Nothing -> Just Nothing
-  Nothing -> continue board
+      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
+      possibleSteps = computePossibleSteps board specs originalLocation
-      generateChoice (dest, remainingMov) =
+      movementChoices =
-        mkChoice
+        generateMovementChoice
-          ("Move " ++ show direction)
+          board
-          ( MoveTo dest
+          specs
-          : if remainingMov > 0 then [Move False remainingMov cid] else [ConfirmMove, Event $ EndMove cid]
+          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
-          direction = fromMaybe North $ usingBoardDimensions board identifyDirection originalLocation dest
+    dontMoveEffects   = [ConfirmMove]
-      possibleSteps = computePossibleSteps board (board ^. activePlayer) firstMove mov originalLocation
+    dontMoveChoice    = mkChoice "Don't move" dontMoveEffects
-      movementChoices = generateChoice <$> possibleSteps
+    finishMoveEffects = endOfMovementEffects specs cid
-      dontMove = mkChoice "Don't move" [ConfirmMove]
+    finishMoveChoice  = mkChoice "Finish moving" finishMoveEffects
-      finishMoving = mkChoice "Finish moving" [ConfirmMove, Event $ EndMove cid]
+    endMoveTrigger = Event $ EndMove cid
-      allowedToEndMovement = not $ has (atPoint originalLocation . _1 . _Just) board
+    choiceBuilder = maybe (unitChoice cid) playerChoice $ movForced ^? _Just . _3
-      noMovement
-        | firstMove = [dontMove]
-        | allowedToEndMovement = [finishMoving]
-        | otherwise = []
-    in unitChoice cid $ noMovement ++ movementChoices
 applyEffect (MoveTo dest) board = continue $ moveUnit dest board
-applyEffect ConfirmMove board = continue $
+applyEffect (DropToken token unit) board = continue $
-  case board ^? movingUnit . _Just . _1 of
+  ixCharacter unit %~ removeTokenInCategory token $ board
-    Just cid -> finalizeMove board & ixCharacter cid %~ removeTokenInCategory SpeedSlow
+applyEffect ConfirmMove board = continue $ finalizeMove board
-    Nothing -> board
 applyEffect (Act cid) board = case board ^.. ixCharacter cid . baseStats . actionsL . each . to ($ cid) of
   [] -> continue board
   act -> unitChoice cid (dontAct : act)

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
+    MovementSpecs -- ^ Details about the movement
-    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
 
+  -- | 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 :: Bool -> Character -> Natural
-getSpeed c
+getSpeed preventReducions c
   | spdTokenCount > 0 = 2 + baseSpeed
-  | spdTokenCount < 0 = 1
+  | spdTokenCount < 0 && not preventReducions = 1
   | otherwise         = baseSpeed
   where
     baseSpeed = c ^. baseStats . movL

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

src/Units/Carcass.hs

@@ -57,3 +57,4 @@ gunwightActions =
 gunwightStatBonuses :: BoardState -> CharacterIdentifier -> Stat a -> a
 gunwightStatBonuses board cid AttackDice  = if adjacentAllies board cid /= Just [] then 1 else 0
 gunwightStatBonuses _     _   DefenseDice = 0
+gunwightStatBonuses _     _   FreeMove    = False

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]
@@ -101,3 +112,33 @@ basicActions =
 basicStatBonuses :: BoardState -> CharacterIdentifier -> Stat a -> a
 basicStatBonuses _     _   AttackDice  = 0
 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