{-|
Module : Diplomacy.Dislodgement
Description : Unit dislodgement.
Copyright : (c) Alexander Vieth, 2015
Licence : BSD3
Maintainer : aovieth@gmail.com
Stability : experimental
Portability : non-portable (GHC only)
-}
{-# LANGUAGE AutoDeriveTypeable #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
module Diplomacy.Dislodgement (
Dislodgement
, dislodgementAndOccupation
) where
import qualified Data.Map as M
import Diplomacy.Aligned
import Diplomacy.Unit
import Diplomacy.Zone
import Diplomacy.OrderObject
import Diplomacy.Phase
import Diplomacy.Occupation
import Diplomacy.OrderResolution
type Dislodgement = M.Map Zone (Aligned Unit)
-- | Use resolved Typical phase orders to compute the 'Dislodgement' and
-- 'Occupation' for the next (Retreat) phase.
dislodgementAndOccupation
:: M.Map Zone (Aligned Unit, SomeResolved OrderObject Typical)
-> (Dislodgement, Occupation)
dislodgementAndOccupation zonedResolvedOrders = (dislodgement, occupation)
where
currentOccupation :: Occupation
currentOccupation = M.map (\(a, _) -> a) zonedResolvedOrders
-- First, compute the occupation delta by checking for successful moves.
moveOccupation :: Occupation
stationaryOccupation :: Occupation
(moveOccupation, stationaryOccupation) = M.foldWithKey nextOccupationFold (M.empty, M.empty) currentOccupation
nextOccupationFold
:: Zone
-> Aligned Unit
-> (Occupation, Occupation)
-> (Occupation, Occupation)
nextOccupationFold zone aunit (move, stationary) = case M.lookup zone zonedResolvedOrders of
Just (_, SomeResolved (MoveObject pt, Nothing)) ->
(M.insert (Zone pt) aunit move, stationary)
_ ->
(move, M.insert zone aunit stationary)
-- The dislodgement is the left-biased intersection of the current
-- occupation with the change in occupation induced by successful
-- moves (moveOccupation), as these occupations have been upset by
-- the moves.
dislodgement :: Dislodgement
dislodgement = stationaryOccupation `M.intersection` moveOccupation
-- The next occupation is the left-biased union of the deltas with
-- the current occupation
occupation :: Occupation
occupation = moveOccupation `M.union` (stationaryOccupation `M.difference` dislodgement)