Make enumerateUnits a Traversal instad of just a Fold

Which happened to cancel out that potentialCoverDirections fed in its arguments
backwards

README.md

@@ -6,7 +6,6 @@ This is a work in progress engine for Maleghast, whose main goal currently inclu
 
 Currently missing core mechanics include:
 - Hazards
-- Pushing/Pulling
 - LoS blocking
 - Tyrants
 - Thralls
@@ -17,6 +16,7 @@ Currently missing core mechanics include:
 - Obliteration
 - Targetting walls
 - Corpses
+- Stepping
 - Most faction tags/tokens
 
 ## Building

app/Main.hs

@@ -3,8 +3,8 @@ 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.Carcass (gunwight)
 import GameLogic (buildChoiceTree, ChoiceTree(..), ChoiceTree'(..), makeChoice, ctTree)
 
 import Text.Read (readMaybe)

src/GameLogic.hs

@@ -18,7 +18,6 @@ module GameLogic
     ) where
 
 import GameModel
-import Units (computeStat)
 import Util (toMaybe, Never, (??), never)
 
 import Data.Maybe (fromMaybe, mapMaybe, isJust)
@@ -29,6 +28,16 @@ import Lens.Micro
 import Safe (atMay)
 
 import Debug.Trace
+import Mechanics (universalModifiers, globalHooks)
+import Data.Monoid (Any(getAny), getSum)
+
+-- | A version of `computeStat_` using `universalModifiers` as global modifiers
+computeStat :: BoardState -> CharacterIdentifier -> Stat a -> a
+computeStat = computeStat_ universalModifiers
+
+-- | A version of `runHooks_` using `globalHooks` as the global hooks
+runHooks :: Trigger -> BoardState -> BoardState
+runHooks = runHooks_ globalHooks
 
 data EngineState
   = PlayerChoice Player [Choice]
@@ -63,13 +72,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 +104,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" []
@@ -99,47 +141,73 @@ applyEffect StartTurn board = case (chooseCharacter board, chooseCharacter oppon
       if board ^. roundNumber == 6
         then board
         else nextRound board
-applyEffect (Event trigger) board = continue $ pushEffects (listHooks board trigger) board
+applyEffect (Event trigger) board = continue $ runHooks 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 = getAny $ computeStat board cid FreeMove
+    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)
@@ -171,7 +239,7 @@ applyEffect (ResolveAttack attacker attack defender) board = Roll actualDiceRoll
     attackerPosition = unitPosition board attacker
     defenderPosition = unitPosition board defender
     potentialCoverDirections =
-      usingBoardDimensions board identifyCardinalDirection <$> attackerPosition <*> defenderPosition
+      usingBoardDimensions board identifyCardinalDirection <$> defenderPosition <*> attackerPosition
     potentialCoverLocations =
       fromMaybe [] $
       (mapMaybe . offsetB board <$> defenderPosition) <*> potentialCoverDirections
@@ -180,7 +248,7 @@ applyEffect (ResolveAttack attacker attack defender) board = Roll actualDiceRoll
     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)
+    netDice = getSum $ attackerDieBonus - (defenderDieBonus + coverBonus)
     actualDiceRolled = fromIntegral $ if netDice <= 0 then 2 else netDice
     keepHighest = netDice > 0
     toHit = maybe 1 getDefense defender'

src/GameModel.hs

@@ -32,6 +32,15 @@ module GameModel
     , identifyCardinalDirection
     , adjacentPoints
     , distanceCardinal
+    , MovementSpecs(..)
+    , movVerbL
+    , movFreeL
+    , movMinimumL
+    , movAmountL
+    , movForcedL
+    , movSpendTokensL
+    , movEndMoveTriggerL
+    , movCompelledL
     , Effect(..)
     , Player(..)
     , PPair
@@ -47,9 +56,8 @@ module GameModel
     , movL
     , dfL
     , armL
-    , hooksL
+    , traitsL
     , actionsL
-    , statBonusL
     , instantiate
     , Character(..)
     , baseStats
@@ -85,7 +93,6 @@ module GameModel
     , isAlive
     , pushEffects
     , unitPosition
-    , listHooks
     , terrainAt
     , characterAt
     , adjacentUnits
@@ -113,13 +120,30 @@ module GameModel
     , newBoard
     , characterHandle
     , renderCharacterHandle
+    , ForcedMoveType(..)
+    , flipDirection
+    , ProtoMovementSpecs(..)
+    , basicMove
+    , forcedMove
+    , allStatsAreMonoids
+    , HasMonoidInstance
+    , Hook(..)
+    , hookTriggerL
+    , hookEffectL
+    , Modifier(..)
+    , Trait(..)
+    , traitNameL
+    , traitHooksL
+    , traitModifiersL
+    , computeStat_
+    , runHooks_
     ) where
 
 import Util (toMaybe, dup, secondClassLensNames, (??))
 
-import Control.Applicative (liftA2, Alternative (..))
+import Control.Applicative (Alternative (..))
 import Control.Arrow ((>>>), Arrow (second))
-import Control.Monad (join, mfilter)
+import Control.Monad (join, mfilter, zipWithM)
 import Data.Ix (inRange)
 import Data.List (intersperse, elemIndex)
 import Data.List.NonEmpty as NonEmpty (cons, NonEmpty, singleton)
@@ -127,7 +151,7 @@ import Data.Maybe (mapMaybe, catMaybes)
 import Numeric.Natural (Natural)
 import Safe (headMay)
 import Lens.Micro
-import Data.Monoid (First)
+import Data.Monoid (Sum, Any)
 import Lens.Micro.TH (makeLenses, makeLensesWith, generateUpdateableOptics)
 import Lens.Micro.Extras (preview)
 import Data.Data ((:~:)(..))
@@ -277,6 +301,7 @@ data Trigger
   | TookDamage CharacterIdentifier
   | Died CharacterIdentifier Point
   | EndMove CharacterIdentifier
+  deriving (Eq, Show)
 
 data OrthagonalDirection
   = North
@@ -288,6 +313,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)
@@ -303,12 +334,12 @@ identifyCardinalDirection w _ from to = northOrSouth ++ eastOrWest
     (fromX, fromY) = coordinates w from
     (toX, toY) = coordinates w to
     northOrSouth
-      | fromY > toY = [South]
-      | fromY < toY = [North]
+      | fromY < toY = [South]
+      | fromY > toY = [North]
       | otherwise   = [     ]
     eastOrWest
-      | fromX > toX = [East]
-      | fromX < toX = [West]
+      | fromX < toX = [East]
+      | fromX > toX = [West]
       | otherwise   = [    ]
 
 cardinalDirections :: [[OrthagonalDirection]]
@@ -331,6 +362,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 +379,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 +446,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 +454,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
 
@@ -439,8 +529,22 @@ otherPlayer Max = Min
 otherPlayer Min = Max
 
 data Stat a where
-  AttackDice  :: Stat Int
-  DefenseDice :: Stat Int
+  AttackDice  :: Stat (Sum Int)
+  DefenseDice :: Stat (Sum Int)
+  FreeMove    :: Stat Any
+
+statEq :: Stat a -> Stat b -> Maybe (a :~: b)
+statEq AttackDice  AttackDice  = Just Refl
+statEq DefenseDice DefenseDice = Just Refl
+statEq FreeMove    FreeMove    = Just Refl
+statEq _           _           = Nothing
+
+data HasMonoidInstance a = forall m. Monoid m => HasMonoidInstance (a :~: m)
+
+allStatsAreMonoids :: Stat a -> HasMonoidInstance a
+allStatsAreMonoids AttackDice  = HasMonoidInstance Refl
+allStatsAreMonoids DefenseDice = HasMonoidInstance Refl
+allStatsAreMonoids FreeMove    = HasMonoidInstance Refl
 
 data BaseStats = BaseStats
   { name        :: String
@@ -448,9 +552,36 @@ data BaseStats = BaseStats
   , mov         :: Natural
   , df          :: DieFace
   , arm         :: Armor
-  , hooks       :: BoardState -> CharacterIdentifier -> Trigger -> [Effect]
+  , traits      :: [Trait]
   , actions     :: [CharacterIdentifier -> Choice]
-  , statBonus   :: forall a. BoardState -> CharacterIdentifier -> Stat a -> a
+  }
+
+-- | Some effect which is activated by some trigger event
+data Hook h = Hook
+  { hookTrigger :: Trigger -- ^ The trigger which should activate this effect
+  -- | What this effect does.  Recieves board & this character's CID
+  , hookEffect  :: BoardState -> h
+  }
+
+-- | A modifier which conditionally affects thet value of some stat for a unit
+data Modifier = forall a. Monoid a => Modifier
+  { modifierStat   :: Stat a -- ^ Which stat this modifier effects
+  -- | What the effects of this modifier are
+  , modifierEffect :: BoardState -> CharacterIdentifier -> a
+  }
+
+queryModifier :: BoardState -> CharacterIdentifier -> Stat a -> Modifier -> a
+queryModifier board cid queryStat (Modifier {..}) = case queryStat `statEq` modifierStat of
+  Just Refl -> modifierEffect board cid
+  Nothing -> case allStatsAreMonoids queryStat of HasMonoidInstance Refl -> mempty
+
+-- | A passive trait on a unit
+-- Can affect a unit or surrounding units by directly and conditionally modifying that
+-- units stats, or by running certain 'Effect's on a given trigger
+data Trait = Trait
+  { traitName      :: String -- ^ The name of this trait, e.g. "Formation"
+  , traitHooks     :: [Hook (CharacterIdentifier -> [Effect])] -- ^ Any hooks which this trait needs
+  , traitModifiers :: [Modifier] -- ^ Any modifiers this trait imposes
   }
 
 instance Show BaseStats where
@@ -562,6 +693,12 @@ makeLenses ''BoardState
 
 makeLensesWith (secondClassLensNames & generateUpdateableOptics .~ False) ''BaseStats
 
+makeLensesWith secondClassLensNames ''MovementSpecs
+
+makeLensesWith secondClassLensNames ''Hook
+
+makeLensesWith secondClassLensNames ''Trait
+
 instantiate :: BaseStats -> Character
 instantiate stats = Character stats False noTokens & tokenCount . ofToken Health .~ hp stats
 
@@ -578,10 +715,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
@@ -599,6 +736,40 @@ untapped = not . _movedThisRound
 untap :: Character -> Character
 untap = movedThisRound .~ False
 
+-- | Compute a stat for a unit by accumulating the modifiers for the stat in all places
+--
+-- This includes so called global modifiers, but in order to keep game rules seperate from
+-- the model, global modifiers must be provided as the first argument.
+computeStat_ :: [Modifier] -> BoardState -> CharacterIdentifier -> Stat a -> a
+computeStat_ globalModifiers board cid stat = case allStatsAreMonoids stat of
+  HasMonoidInstance Refl ->
+    let
+      queryStatsL = each . to (queryModifier board cid stat)
+      globalBonus = globalModifiers ^. queryStatsL
+      traitBonus = board ^. ixCharacter cid . baseStats . traitsL . each . traitModifiersL . queryStatsL
+    in globalBonus <> traitBonus
+
+-- | Activate all of the relevant hooks on the board
+--
+-- Searches through all hooks in traits and global hooks, accumulates all their effects,
+-- then adds all the resulting effects to the effect stack.  Similar to `computeStat_`,
+-- this is additionall searches so called global hooks, but only recognizes global hooks
+-- passed as an argument.
+runHooks_ :: [Hook [Effect]] -> Trigger -> BoardState -> BoardState
+runHooks_ globalHooks trigger board = board <++ characterEffects  <++ globalEffects
+  where
+    filterActivatedL :: Traversal' (Hook a) (Hook a)
+    filterActivatedL = filtered ((==trigger) . hookTrigger)
+    unitHooksL :: SimpleFold Character (BoardState -> CharacterIdentifier -> [Effect])
+    unitHooksL = baseStats . traitsL . each . traitHooksL . each . filterActivatedL . hookEffectL
+    charRunHooks :: (CharacterIdentifier, Character) -> [Effect]
+    charRunHooks (cid, c) =
+      (c ^. unitHooksL) board cid
+    characterEffects :: [Effect]
+    characterEffects = board ^. enumerateUnits . to charRunHooks
+    globalEffects :: [Effect]
+    globalEffects = (globalHooks ^. each . filterActivatedL . hookEffectL) board
+
 instance Show BoardState where
   show board = join (intersperse "\n" showTiles) ++ '\n':showRound  ++ "\n" ++ showCharacters
     where
@@ -767,16 +938,26 @@ cidsInRange board range locus = board ^.. inner
 ofPlayer :: Player -> Traversal' CharacterIdentifier CharacterIdentifier
 ofPlayer player = filtered (owner >>> (== player))
 
-lookupCIDs :: Monoid r => [CharacterIdentifier] -> Getting r BoardState (CharacterIdentifier, Character)
-lookupCIDs chars = to lookupCIDs' . each
+-- | A traversal over pairs in the form (`CharacterIdentifier`, `Character`)
+--
+-- On modifying these pairs:  Modifications to the `Character` will be applied to the
+-- original character, but __changes to the `CharacterIdentifier` will be completely
+-- ignored__.  This means you /cannot/ use this traversal to change the order of
+-- characters, switch characters between players, or anything like that.
+enumerateUnits :: Traversal' BoardState (CharacterIdentifier, Character)
+enumerateUnits = enumerateUnits'
   where
-    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
+    enumerateUnits' :: forall f. Applicative f
+                   => ((CharacterIdentifier, Character) -> f (CharacterIdentifier, Character))
+                   -> BoardState -> f BoardState
+    enumerateUnits' f = characters fCharacters
+      where
+        fUnit :: Player -> Int -> Character -> f Character
+        fUnit player indx c = snd <$> f ((player, indx), c)
+        fRoster :: Player -> [Character] -> f [Character]
+        fRoster player roster = zipWithM (fUnit player) [0..] roster
+        fCharacters :: PPair [Character] -> f (PPair [Character])
+        fCharacters (PPair p1 p2) = PPair <$> fRoster Min p1 <*> fRoster Max p2
 
 untappedUnits :: SimpleFold BoardState CharacterIdentifier
 untappedUnits = enumerateUnits . filtered (untapped . snd) . _1
@@ -797,12 +978,6 @@ unitPosition (BoardState {_tiles}) cid = headMay $ catMaybes $ zipWith aux [0..]
       | 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

src/Mechanics.hs

@@ -0,0 +1,32 @@
+module Mechanics
+  ( universalModifiers
+  , globalHooks
+  )
+  where
+
+import GameModel
+  (BoardState, CharacterIdentifier, Modifier (..), Stat (..), isElevated, Hook, Effect)
+
+import Data.Monoid (Sum)
+
+universalModifiers :: [Modifier]
+universalModifiers =
+  [ elevationBonus AttackDice
+  , elevationBonus DefenseDice
+  , attackDiceBase
+  ]
+
+elevationBonus :: Stat (Sum Int) -> Modifier
+elevationBonus modifierStat = Modifier {..}
+  where
+    modifierEffect :: BoardState -> CharacterIdentifier -> Sum Int
+    modifierEffect board cid = if isElevated board cid then 1 else 0
+
+attackDiceBase :: Modifier
+attackDiceBase = Modifier {..}
+  where
+    modifierStat = AttackDice
+    modifierEffect = const $ const 1
+
+globalHooks :: [Hook [Effect]]
+globalHooks = []

src/Units.hs

@@ -1,70 +0,0 @@
-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

src/Units/Carcass.hs

@@ -15,11 +15,13 @@ import GameModel
   , Stat(..)
   , Token(..)
   , Trigger(..)
+  , Trait(..)
+  , Modifier(..)
   )
-import Units
+import Units.Components
   ( AttackT(..)
   , anyTarget
-  , buildAttack
+  , buildAttack, inflictTokens, push
   )
 
 gunwight :: BaseStats
@@ -29,17 +31,10 @@ gunwight = BaseStats
   , mov       = 2
   , df        = 4
   , arm       = NoArmor
-  , hooks     = gunwightHooks
   , actions   = gunwightActions
-  , statBonus = gunwightStatBonuses
+  , traits    = [formation]
   }
 
-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
@@ -49,11 +44,30 @@ gunwightActions =
     , tMelee           = False
     , tDamageType      = Unblockable
     , tDamageAmount    = 2
-    , tHeadshotEffects = [InflictTokens VitalVulnr (-1)]
+    , tHeadshotEffects = [inflictTokens VitalVulnr (-1)]
     , tStandardEffects = []
     }
+  , buildAttack $ AttackT
+    { tName            = "Baton"
+    , tRange           = (1, 1)
+    , tValidTargets    = anyTarget
+    , tMelee           = True
+    , tDamageType      = BasicDamage
+    , tDamageAmount    = 0
+    , tStandardEffects = [push 1]
+    , tHeadshotEffects = []
+    }
   ]
 
-gunwightStatBonuses :: BoardState -> CharacterIdentifier -> Stat a -> a
-gunwightStatBonuses board cid AttackDice  = if adjacentAllies board cid /= Just [] then 1 else 0
-gunwightStatBonuses _     _   DefenseDice = 0
+formation :: Trait
+formation = Trait
+  { traitName = "Formation"
+  , traitHooks = []
+  , traitModifiers = [formationModifier]
+  }
+  where
+    formationF board cid = if adjacentAllies board cid /= Just [] then 1 else 0
+    formationModifier = Modifier
+      { modifierStat = AttackDice
+      , modifierEffect = formationF
+      }

src/Units/Components.hs

@@ -0,0 +1,80 @@
+module Units.Components
+  ( AttackT(..)
+  , ProtoEffect
+  , anyTarget
+  , buildAttack
+  , SelfAbilityT(..)
+  , mkSelfAbility
+  , inflictTokens
+  , push
+  , pull
+  )
+  where
+
+import GameModel
+  ( Attack(..)
+  , BoardState
+  , CharacterIdentifier
+  , Choice
+  , DamageType
+  , Effect(..)
+  , mkChoice, Token, forcedMove, ForcedMoveType (..), owner
+  )
+
+import Numeric.Natural (Natural)
+
+-------------------------
+-- Attacks & Abilities --
+-------------------------
+
+data AttackT = AttackT
+  { tName            :: String
+  , tRange           :: (Natural, Natural)
+  , tValidTargets    :: BoardState -> CharacterIdentifier -> Bool
+  , tMelee           :: Bool
+  , tDamageType      :: DamageType
+  , tDamageAmount    :: Natural
+  , tHeadshotEffects :: [ProtoEffect]
+  , tStandardEffects :: [ProtoEffect]
+  }
+
+anyTarget :: BoardState -> CharacterIdentifier -> Bool
+anyTarget = const $ const True
+
+buildAttack :: AttackT -> CharacterIdentifier -> Choice
+buildAttack (AttackT {..}) attacker = mkChoice tName [targetEffect]
+  where
+    attackDetails target = Attack
+      ((sequence $ sequence tHeadshotEffects attacker) target)
+      tMelee
+      ((sequence $ sequence tStandardEffects attacker) target)
+      tDamageType
+      tDamageAmount
+    attackEffect target = [ResolveAttack attacker (attackDetails target) target]
+    targetEffect = Target attacker tRange tValidTargets attackEffect
+
+data SelfAbilityT = SelfAbilityT
+  { tName    :: String
+  , tEffects :: [ProtoEffect]
+  }
+
+mkSelfAbility :: SelfAbilityT -> CharacterIdentifier -> Choice
+mkSelfAbility (SelfAbilityT {..}) cid = mkChoice tName (sequence (sequence tEffects cid) cid)
+
+-----------------------------
+--------- Effects -----------
+-----------------------------
+
+type ProtoEffect = CharacterIdentifier -> CharacterIdentifier -> Effect
+
+inflictTokens :: Num n => Token n -> n -> ProtoEffect
+inflictTokens tokenType tokenCount _ = InflictTokens tokenType tokenCount
+
+genericShift :: ForcedMoveType -> Natural -> ProtoEffect
+genericShift fmType amount puller = forcedMove fmType amount (owner puller) (Left puller)
+
+push :: Natural -> ProtoEffect
+push = genericShift Push
+
+pull :: Natural -> ProtoEffect
+pull = genericShift Pull

src/Units/Debug.hs

@@ -4,24 +4,20 @@ module Units.Debug
   where
 
 import GameModel
-  ( adjacentAllies
-  , Armor(..)
+  ( Armor(..)
   , BaseStats(..)
-  , BoardState
   , CharacterIdentifier
   , Choice
   , DamageType(..)
-  , Effect(..)
-  , Stat(..)
   , Token(..)
-  , Trigger(..)
   )
-import Units
+
+import Units.Components
   ( AttackT(..)
   , anyTarget
   , buildAttack
   , SelfAbilityT(..)
-  , mkSelfAbility
+  , mkSelfAbility, inflictTokens, pull, push
   )
 
 basic :: BaseStats
@@ -31,17 +27,10 @@ basic = BaseStats
   , mov       = 4
   , df        = 4
   , arm       = NoArmor
-  , hooks     = basicHooks
   , actions   = basicActions
-  , statBonus = basicStatBonuses
+  , traits    = []
   }
 
-basicHooks :: BoardState -> CharacterIdentifier -> Trigger -> [Effect]
-basicHooks _     _   TurnStart = []
-basicHooks _     _   (TookDamage _) = []
-basicHooks _     _   (Died _ _) = []
-basicHooks _     _   (EndMove _) = []
-
 basicActions :: [CharacterIdentifier -> Choice]
 basicActions =
   [ buildAttack $ AttackT
@@ -62,7 +51,7 @@ basicActions =
     , tDamageType      = BasicDamage
     , tDamageAmount    = 0
     , tHeadshotEffects = []
-    , tStandardEffects = [InflictTokens VitalVulnr (-1)]
+    , tStandardEffects = [inflictTokens VitalVulnr (-1)]
     }
   , buildAttack $ AttackT
     { tName            = "Slime"
@@ -72,7 +61,7 @@ basicActions =
     , tDamageType      = BasicDamage
     , tDamageAmount    = 0
     , tHeadshotEffects = []
-    , tStandardEffects = [InflictTokens SpeedSlow (-1)]
+    , tStandardEffects = [inflictTokens SpeedSlow (-1)]
     }
   , buildAttack $ AttackT
     { tName            = "Nerf"
@@ -82,22 +71,38 @@ basicActions =
     , tDamageType      = BasicDamage
     , tDamageAmount    = 0
     , tHeadshotEffects = []
-    , tStandardEffects = [InflictTokens StrWeak (-1)]
+    , tStandardEffects = [inflictTokens StrWeak (-1)]
+    }
+  , buildAttack $ AttackT
+    { tName            = "Yoink"
+    , tRange           = (1, 4)
+    , tValidTargets    = anyTarget
+    , tMelee           = False
+    , tDamageType      = BasicDamage
+    , tDamageAmount    = 0
+    , tHeadshotEffects = []
+    , tStandardEffects = [pull 3]
+    }
+  , buildAttack $ AttackT
+    { tName            = "Yeet"
+    , tRange           = (1, 4)
+    , tValidTargets    = anyTarget
+    , tMelee           = False
+    , tDamageType      = BasicDamage
+    , tDamageAmount    = 0
+    , tHeadshotEffects = []
+    , tStandardEffects = [push 3]
     }
   , mkSelfAbility $ SelfAbilityT
     { tName            = "Calcify"
-    , tEffects         = [InflictTokens VitalVulnr 1]
+    , tEffects         = [inflictTokens VitalVulnr 1]
     }
   , mkSelfAbility $ SelfAbilityT
     { tName            = "Zoomify"
-    , tEffects         = [InflictTokens SpeedSlow 1]
+    , tEffects         = [inflictTokens SpeedSlow 1]
     }
   , mkSelfAbility $ SelfAbilityT
     { tName            = "Get String"
-    , tEffects         = [InflictTokens StrWeak 1]
+    , tEffects         = [inflictTokens StrWeak 1]
     }
-  ]
-
-basicStatBonuses :: BoardState -> CharacterIdentifier -> Stat a -> a
-basicStatBonuses _     _   AttackDice  = 0
-basicStatBonuses _     _   DefenseDice = 0
+  ]