{-|
Module      : Diplomacy.OrderResolution
Description : Definition of the resolution of orders (adjudication).
Copyright   : (c) Alexander Vieth, 2015
Licence     : BSD3
Maintainer  : aovieth@gmail.com
Stability   : experimental
Portability : non-portable (GHC only)
-}

{-# LANGUAGE AutoDeriveTypeable #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}

module Diplomacy.OrderResolution (

    Resolved
  , SomeResolved(..)
  , withSomeResolved

  , FailureReason(..)

  , Resolution

  , typicalResolution
  , retreatResolution
  , adjustResolution

  , typicalChange

  , ConvoyRoutes(..)
  , ConvoyRoute
  , convoyRoutes
  , successfulConvoyRoutes

  ) where

import Data.Typeable
import Data.Ord
import Data.List
import Data.Monoid
import Data.Either
import Data.Maybe
import Data.AtLeast
import Data.TypeNat.Nat
import Data.TypeNat.Vect
import Data.Functor.Identity
import Data.Traversable (sequenceA)
import qualified Data.Map as M
import qualified Data.Set as S
import Data.MapUtil
import Control.Monad
import Control.Applicative
import Diplomacy.GreatPower
import Diplomacy.Aligned
import Diplomacy.Unit
import Diplomacy.Phase
import Diplomacy.Subject
import Diplomacy.OrderType
import Diplomacy.OrderObject
import Diplomacy.Order
import Diplomacy.Province
import Diplomacy.Zone
import Diplomacy.Subject

type Resolution phase = M.Map Zone (Aligned Unit, SomeResolved OrderObject phase)

-- Left means assumed resolution, right means no resolution assumed.
type TypicalResolutionInput
    = M.Map Zone (Aligned Unit, Either (SomeResolved OrderObject Typical) (SomeOrderObject Typical))

-- We preserve the tagging of assumptions in the resolution output, to
-- facilitate the recursive "piling up" of assumptions.
type TypicalResolutionOutput
    = M.Map Zone (Aligned Unit, Either (SomeResolved OrderObject Typical) (SomeResolved OrderObject Typical))

-- Use an output as an input by dropping the resolutions of all non-assumptions.
preserveAssumptions :: TypicalResolutionOutput -> TypicalResolutionInput
preserveAssumptions = M.map makeInput
  where
    makeInput (aunit, x) = case x of
        Left y -> (aunit, Left y)
        Right (SomeResolved (x, _)) -> (aunit, Right $ SomeOrderObject x)

dropAssumptionTags :: TypicalResolutionOutput -> Resolution Typical
dropAssumptionTags = M.map dropTag
  where
    dropTag (aunit, x) = case x of
        Left y -> (aunit, y)
        Right y -> (aunit, y)

typicalResolutionAssuming
    :: TypicalResolutionInput
    -> TypicalResolutionOutput
typicalResolutionAssuming input =
    let resolution = M.mapWithKey (resolveOne resolution) input
    in  resolution
  where
    resolveOne
        :: TypicalResolutionOutput
        -> Zone
        -> (Aligned Unit, Either (SomeResolved OrderObject Typical) (SomeOrderObject Typical))
        -> (Aligned Unit, Either (SomeResolved OrderObject Typical) (SomeResolved OrderObject Typical))
    resolveOne resolution zone (aunit, x) = case x of
        Left y -> (aunit, Left y)
        Right y -> (aunit, Right (resolveSomeOrderTypical resolution zone (aunit, y)))

assumeNoOrder
    :: Zone
    -> TypicalResolutionInput
    -> TypicalResolutionInput
assumeNoOrder = M.alter (const Nothing)

assumeSucceeds
    :: Zone
    -> TypicalResolutionInput
    -> TypicalResolutionInput
assumeSucceeds zone = M.adjust makeSucceeds zone
  where
    makeSucceeds
        :: (Aligned Unit, Either (SomeResolved OrderObject Typical) (SomeOrderObject Typical))
        -> (Aligned Unit, Either (SomeResolved OrderObject Typical) (SomeOrderObject Typical))
    makeSucceeds (aunit, x) = case x of
        Left (SomeResolved (x, _)) -> (aunit, Left (SomeResolved (x, Nothing)))
        Right (SomeOrderObject x) -> (aunit, Left (SomeResolved (x, Nothing)))

noAssumptions
    :: M.Map Zone (Aligned Unit, SomeOrderObject Typical)
    -> TypicalResolutionInput
noAssumptions = M.map (\(x, y) -> (x, Right y))

data RequiresConvoy
    = RequiresConvoy
    | DoesNotRequireConvoy
    deriving (Show)

-- | First component indicates that there is a convoying 'Fleet' at this
--   'Zone', second component indicates whether something dislodged it, and if
--   so, who it was.
type ConvoyRoute = [(Zone, Maybe (Aligned Subject))]

data ConvoyRoutes = ConvoyRoutes {
      convoyRoutesParadox :: [ConvoyRoute]
    , convoyRoutesNonParadox :: [ConvoyRoute]
    }
    deriving (Show)

-- | Any move between non-adjacent provinces is deemed to require a
--   convoy, even if both provinces are inland. Order validation rules
--   out those cases though.
moveRequiresConvoy :: ProvinceTarget -> ProvinceTarget -> Bool
moveRequiresConvoy ptFrom ptTo = not (isSameOrAdjacent movingTo movingFrom)
  where
    movingTo = ptProvince ptFrom
    movingFrom = ptProvince ptTo

isConvoyMoveWithNoConvoyRoute :: MoveClassification -> Bool
isConvoyMoveWithNoConvoyRoute thisClassification = case thisClassification of
    NotHold RequiresConvoy theseConvoyRoutes _ _ -> null (successfulConvoyRoutes theseConvoyRoutes)
    _ -> False

-- | Description of an order's support (that order is unfortunately not a part
--   of this type or its values). Each entry in the list means a unit belonging
--   to some power at some place supports that implicit order.
type Supports = [Aligned Subject]

-- | Given a Subject and a ProvinceTarget, meaning Subject attempting to move to
--   that ProvinceTarget (or support/convoy/hold in case it's the same as the
--   Subject's), calculate the supporters of that order.
support :: TypicalResolutionOutput -> Subject -> ProvinceTarget -> Supports
support resolution subject goingTo = M.foldWithKey selector [] (dropAssumptionTags resolution)
  where
    selector
        :: Zone
        -> (Aligned Unit, SomeResolved OrderObject Typical)
        -> [Aligned Subject]
        -> [Aligned Subject]
    selector zone (aunit, SomeResolved (object, thisResolution)) b = case object of
        SupportObject supportSubject supportTo ->
            if    supportSubject /= subject
               || supportTo /= goingTo
            then b
            else case thisResolution of
                Nothing -> align (alignedThing aunit, zoneProvinceTarget zone) (alignedGreatPower aunit) : b
                _ -> b
        _ -> b

foreignSupport
    :: TypicalResolutionOutput
    -> GreatPower
    -> Subject
    -> ProvinceTarget
    -> Supports
foreignSupport resolution power subject goingTo =
    filter isForeignSupport (support resolution subject goingTo)
  where
    isForeignSupport asubj = alignedGreatPower asubj /= power

-- TODO should be able to do this with only the classification, no? The issue
-- is that the classification doesn't contain the zone or great power for which
-- it's relevant :(
isMoveDislodgedFromAttackedZone
    :: TypicalResolutionOutput
    -> Zone
    -> (Aligned Unit, OrderObject Typical Move)
    -> Bool
isMoveDislodgedFromAttackedZone resolution zoneFrom (aunit, object) = case thisClassification of
    Hold _ -> False
    NotHold _ _ _ thisIncumbant -> case thisIncumbant of
        -- How to decide this? It strikes me as a little complex...
        -- It must be
        --
        --   1. a foreign order (no self-dislodge).
        --   2. a have more foreign support than this order.
        --
        -- Should abstract this later, as I'm sure it will come up
        -- again!
        ComplementaryMove WouldSucceed asubj target ->
            let opposingSupports = foreignSupport resolution (alignedGreatPower aunit) (alignedThing asubj) target
                thisSupports = support resolution (alignedThing aunit, zoneProvinceTarget zoneFrom) (zoneProvinceTarget zoneTo)
            in     alignedGreatPower aunit /= alignedGreatPower asubj
                && length opposingSupports > length thisSupports
        _ -> False
  where
    thisClassification = classify resolution zoneFrom (aunit, object)
    zoneTo = Zone (moveTarget object)


-- | Relative to a Zone (given only by context, unfortunately). Each entry means
--   there is a move from that zone by that unit belonging to that great power
--   against the implicit Zone.
type CompetingMoves = [(Aligned Subject, ProvinceTarget)]

-- | Get the competing moves (enough information to reconstruct them) against
--   a move from one zone to another. Yes, they're only moves; a hold, support,
--   or convoy at the target zone is not included.
competingMoves
    :: TypicalResolutionOutput
    -> Zone
    -> Zone
    -> CompetingMoves
competingMoves resolution zoneFrom zoneTo = M.foldWithKey selector [] (dropAssumptionTags resolution')
  where
    -- It is ESSENTIAL that we forget about the order at THIS zone when we
    -- compute the competing moves. If we don't, the program may not terminate.
    -- For example:
    --
    --   1. F North Sea -> Holland
    --   2. F Holland -> North Sea
    --   3. F Norwegian Sea -> North Sea
    --   4. F Ruhr -> Holland
    --
    -- To compute the competing moves for 4, we must classify 1 to get the
    -- incumbant, so we must resolve 2, which requires classifying 3, which
    -- in turn demands that we resolve 1, of which 4 is a competing move!
    resolution' = M.delete zoneFrom resolution
    selector
        :: Zone
        -> (Aligned Unit, SomeResolved OrderObject Typical)
        -> CompetingMoves
        -> CompetingMoves
    selector zone (aunit, SomeResolved (object, _)) b = case object of
        MoveObject movingTo ->
            if    zone == zoneFrom
               || Zone movingTo /= zoneTo
               || isConvoyMoveWithNoConvoyRoute thisClassification
               -- A dislodged unit cannot cause a standoff in the province
               -- from which it was dislodged.
               || isMoveDislodgedFromAttackedZone resolution' zone (aunit, object)
            then b
            else let subject = (alignedThing aunit, zoneProvinceTarget zone)
                     asubject = align subject (alignedGreatPower aunit)
                 in  (asubject, movingTo) : b
          where
            thisClassification = classify resolution' zone (aunit, object)
        _ -> b

data WouldSucceed
    = WouldSucceed
    | WouldNotSucceed
    deriving (Show)

data Incumbant
    = ComplementaryMove WouldSucceed (Aligned Subject) ProvinceTarget
    -- ^ Only if the move succeeds in the absence of its complement.
    --   The ProvinceTarget in the subject is from where the complement moves,
    --   and the other ProvinceTarget is to where the complementary move
    --   wishes to go. These are necessary due to the coarseness of Zone
    --   Eq.
    --
    --   This notion is useful because in the case of complementary moves,
    --   support of both moves must be compared against each-other, as though
    --   one unit must advance through the opposite advance of the other.
    --   Compare at returning moves, in which the returning unit cannot have
    --   any support for its return.
    | ReturningMove (Aligned Subject) ProvinceTarget
    -- ^ Only if the move fails (could be complementary).
    | Stationary (Aligned Subject)
    -- ^ Here we give a subject because the ProvinceTarget is NOT implicit.
    --   For instance, if we know that Zone (Special SpainSouth) is stationary,
    --   we don't know whether that thing is stationary at
    --       Special SpainSouth
    --       Special SpainNorth
    --       Normal Spain
    --   It could be any of these.
    | NoIncumbant
    deriving (Show)

incumbant
    :: TypicalResolutionOutput
    -> Zone
    -> Zone
    -> Incumbant
incumbant resolution zoneFrom zoneTo = case lookupWithKey zoneTo resolution' of
    -- We lookupWithKey because the actual ProvinceTarget where the incumbant
    -- lies may not be ProvinceTarget-equal with the ProvinceTarget in the
    -- Zone which we used to index the map!
    Just (zoneTo', (aunit, SomeResolved (object, res))) -> case object of
        MoveObject pt ->
            if Zone pt == zoneTo
            then Stationary (align (alignedThing aunit, zoneProvinceTarget zoneTo') (alignedGreatPower aunit))
            else if Zone pt == zoneFrom
            -- It's a move back against zoneFrom. If it succeeds (in the absence
            -- of any move at zoneFrom) then we call it complementary; the
            -- actual resolution of the move at zoneFrom may change this
            -- outcome! If it fails, we'll just treat it like a returning move.
            then case res of
                Nothing -> ComplementaryMove WouldSucceed (align (alignedThing aunit, zoneProvinceTarget zoneTo') (alignedGreatPower aunit)) pt
                Just _ -> ComplementaryMove WouldNotSucceed (align (alignedThing aunit, zoneProvinceTarget zoneTo') (alignedGreatPower aunit)) pt
            else case res of
                Nothing -> NoIncumbant
                Just _ -> ReturningMove (align (alignedThing aunit, pt) (alignedGreatPower aunit)) (zoneProvinceTarget zoneTo')
        _ -> Stationary (align (alignedThing aunit, zoneProvinceTarget zoneTo') (alignedGreatPower aunit))
    _ -> NoIncumbant
  where
    resolutionThisSucceeds = typicalResolutionAssuming (assumeSucceeds zoneFrom (preserveAssumptions resolution))
    resolution' = dropAssumptionTags resolutionThisSucceeds

data MoveClassification
    = Hold CompetingMoves
    | NotHold RequiresConvoy ConvoyRoutes CompetingMoves Incumbant
    deriving (Show)

classify
    :: TypicalResolutionOutput
    -> Zone
    -> (Aligned Unit, OrderObject Typical Move)
    -> MoveClassification
classify resolution zone (aunit, MoveObject movingTo) =
    if zone == Zone movingTo
    then Hold (holdCompetingMoves resolution zone (Zone movingTo))
    else let power = alignedGreatPower aunit
             unit = alignedThing aunit
             pt = zoneProvinceTarget zone
             asubject = align (unit, pt) power
         in  classifyNonHold resolution asubject movingTo
  where

    -- TBD should we here calculate supports of the competing move, using the
    -- alignment to eliminate non-foreign support and non-foreign moves?!
    -- Yeah, why not?
    -- In non hold we would do this for competing moves, but for the incumbant
    -- if there is one.
    holdCompetingMoves
        :: TypicalResolutionOutput
        -> Zone
        -> Zone
        -> CompetingMoves
    holdCompetingMoves resolution zoneFrom zoneTo = theseCompetingMoves
      where
        theseCompetingMoves = competingMoves resolution zoneFrom zoneTo

    classifyNonHold
        :: TypicalResolutionOutput
        -> Aligned Subject
        -> ProvinceTarget
        -> MoveClassification
    classifyNonHold resolution asubject pt =
        NotHold thisRequiresConvoy theseConvoyRoutes theseCompetingMoves thisIncumbant
      where
        thisRequiresConvoy =
            if moveRequiresConvoy (zoneProvinceTarget zoneFrom) (zoneProvinceTarget zoneTo)
            then RequiresConvoy
            else DoesNotRequireConvoy
        theseConvoyRoutes = convoyRoutes (dropAssumptionTags resolution) (alignedThing asubject) pt 
        -- TODO Tuesday: compute the competing moves, here and in the
        -- Hold case. This will involve gathering them from the resolution,
        -- classifying them, and using the convoy routes and incumbant fields
        -- in order to determine whether they take part in the list (no
        -- convoy routes but requies a convoy means it's out; a complementary
        -- incumbant which dislodges it means it's out)
        theseCompetingMoves = competingMoves resolution zoneFrom zoneTo
        thisIncumbant = incumbant resolution zoneFrom zoneTo
        zoneFrom = Zone (subjectProvinceTarget (alignedThing asubject))
        zoneTo = Zone pt

-- | All convoy routes which connect the subject to the given ProvinceTarget.
--   Each element of a route gives its zone (zone of the convoying fleet which
--   composese the route) as well as an indication of whether it was
--   dislodged (Just means it was dislodged by that subject).
rawConvoyRoutes
    :: Resolution Typical
    -> Subject
    -> ProvinceTarget
    -> [ConvoyRoute]
rawConvoyRoutes resolution (unit, ptFrom) ptTo =
    (fmap . fmap) tagWithChange routes
  where
    
    -- We knock off the last element of the third parameter, because it is the
    -- Province where the convoy began (the coastal one).
    routes :: [[Province]]
    routes = fmap (\(_, y, ys) -> y : init ys) discoveredPaths

    discoveredPaths :: [((), Province, [Province])]
    discoveredPaths = paths ((flip S.member) viableConvoyProvinces) (\p -> if p == ptProvince ptTo then Just () else Nothing) [ptProvince ptFrom]

    tagWithChange :: Province -> (Zone, Maybe (Aligned Subject))
    tagWithChange pr = (Zone (Normal pr), typicalChange resolution (Zone (Normal pr)))

    viableConvoyProvinces :: S.Set Province
    viableConvoyProvinces = S.fromList (fmap (ptProvince . zoneProvinceTarget) (M.keys (M.filter isViableConvoy resolution)))

    isViableConvoy
        :: (Aligned Unit, SomeResolved OrderObject Typical)
        -> Bool
    isViableConvoy (aunit, SomeResolved (object, _)) = case object of
        ConvoyObject (unit', convoyingFrom) convoyingTo ->
               unit == unit'
            && ptFrom == convoyingFrom
            && ptTo == convoyingTo
        _ -> False

convoyRoutes
    :: Resolution Typical
    -> Subject
    -> ProvinceTarget
    -> ConvoyRoutes
convoyRoutes resolution subject pt =
    let routes = rawConvoyRoutes resolution subject pt
        (paradox, nonParadox) = partition (isParadoxRoute resolution pt . fmap fst) routes
    in  ConvoyRoutes paradox nonParadox

-- | A void convoy is one for which there is no matching move order.
isVoidConvoy
    :: Resolution Typical
    -> Subject
    -> ProvinceTarget
    -> Bool
isVoidConvoy resolution subject convoyingTo = case M.lookup convoyingFrom resolution of
    Nothing -> True
    Just (aunit, SomeResolved (MoveObject movingTo, _)) ->
           convoyingUnit /= alignedThing aunit
        || convoyingTo /= movingTo
  where
    convoyingFrom :: Zone
    convoyingFrom = Zone (snd subject)
    convoyingUnit :: Unit
    convoyingUnit = fst subject

-- | Identify convoy routes which are paradox-inducing; those routes whose
--   success is contingent upon the success of the move which they convoy!
--   This accounts for simple paradox routes as well as the so-called
--   second order paradoxes.
isParadoxRoute
    :: Resolution Typical
    -> ProvinceTarget -- ^ The destination of the route.
    -> [Zone] -- ^ The zones in the route.
    -> Bool
isParadoxRoute resolution destination convoyZones = case M.lookup (Zone destination) resolution of
    -- First we check the order at the destination of the route.
    -- If it's not a support then we know there's no paradox, but if it is a
    -- support then we must check whether it threatens a certain kind of
    -- convoying fleet.
    Just (_, SomeResolved (SupportObject _ supportTarget, _)) ->
        if any ((==) (Zone supportTarget)) convoyZones
        -- This support threatens a fleet in the parameter convoy zones. That's
        -- enough to decide that we have a paradox route...
        then True
        -- ... but even if it doesn't threaten a zone in @convoyZones@, we must
        -- make more checks, to account for the second order paradoxes!
        -- It could threaten another convoying fleet which attacks a support
        -- which threatens one of the zones in @convoyZones@, and so on
        -- recursively.
        else case M.lookup (Zone supportTarget) resolution of
            -- There's a convoying fleet at the support target.
            -- If it's a void convoy, we're done.
            -- Otherwise, we get all of the raw routes for that convoying
            -- fleet's subject and destination, and identify all of those which
            -- are threatened by this support. We resolve the others, and if
            -- none are successful, we recurse.
            Just (_, SomeResolved (ConvoyObject convoySubject convoyTarget, _)) ->
                let nextRoutes = rawConvoyRoutes resolution convoySubject convoyTarget
                    (maybeParadoxical, others) = partition (any ((==) (Zone supportTarget)) . fmap fst) nextRoutes
                    successfulOthers = filter isSuccessfulConvoyRoute others
                in    not (isVoidConvoy resolution convoySubject convoyTarget)
                   && null successfulOthers
                   -- Here we're careful to delete the destination zone, so that
                   -- we don't get nontermination.
                   && isParadoxRoute (M.delete (Zone destination) resolution) convoyTarget convoyZones
            _ -> False
    _ -> False

-- | Initial characterization of a support order which cannot be cut by a
--   convoyed move to the given Zone. That's to say, if there is any such
--   support, it will turn up in this. However it must also support an attack
--   against a convoying fleet in some route.
paradoxInducingSupport
    :: TypicalResolutionOutput
    -> Zone -- ^ The destination of a convoy route.
    -> Maybe (OrderObject Typical Support)
paradoxInducingSupport resolution zone =
    case M.lookup zone (dropAssumptionTags resolution) of
        Just (aunit, SomeResolved (s@(SupportObject _ _), _)) -> Just s
        _ -> Nothing

-- | If Just, then any convoy route which includes this Zone is a paradox route
paradoxInducingConvoyZone
    :: TypicalResolutionOutput
    -> Zone -- ^ Destination of convoy.
    -> Maybe Zone
paradoxInducingConvoyZone resolution =
    fmap (Zone . supportTarget) . paradoxInducingSupport resolution

-- | These are always non-paradox routes.
successfulConvoyRoutes :: ConvoyRoutes -> [ConvoyRoute]
successfulConvoyRoutes = filter isSuccessfulConvoyRoute . convoyRoutesNonParadox

isSuccessfulConvoyRoute :: ConvoyRoute -> Bool
isSuccessfulConvoyRoute = all (isNothing . snd)

resolveSomeOrderTypical
    :: TypicalResolutionOutput
    -> Zone
    -> (Aligned Unit, SomeOrderObject Typical)
    -> SomeResolved OrderObject Typical
resolveSomeOrderTypical resolution zone (aunit, SomeOrderObject object) =

    let thisResolution :: SomeResolved OrderObject Typical
        thisResolution = case object of
            MoveObject _ -> SomeResolved (object, resolveMove object)
            SupportObject _ _ -> SomeResolved (object, resolveSupport object)
            ConvoyObject _ _ -> SomeResolved (object, resolveConvoy object)

        -- ****
        -- MOVE
        -- ****
        --
        -- There are _ reasons to fail a move:
        --
        --   MoveNoConvoy : the move requires a convoy, there is no paradox
        --   convoy route, and there's no suitable path of successful convoys
        --   for it.
        --   MoveConvoyParadox : the move requires a convoy, there is a paradox
        --   convoy route, and all non-paradox convoy routes fail.
        --   MoveOverpowered : there is some other move of strictly greater
        --   support into this move's target.
        --   MoveBounced : this move is not a hold, and it is not a dominator
        --   at its target.
        --   MoveFriendlyDislodge : the move would dislodge a friendly unit.
        resolveMove :: OrderObject Typical Move -> Maybe (FailureReason Typical Move)
        resolveMove moveObject = case classify resolution zone (aunit, moveObject) of

            -- A hold is easy: it fails iff there is a foreign move with more
            -- foreign support than it.
            Hold theseCompetingMoves -> case dominator of
                Nothing -> Nothing
                Just (x, ss) ->
                    if length ss <= length thisSupports
                    then Nothing
                    -- TBD HoldOverpowered failure reason?
                    else Just (MoveOverpowered (AtLeast (VCons x VNil) []))
              where
                dominator = case sortedOpposingSupports of
                    [] -> Nothing
                    [x] -> Just x
                    x : y : _ -> if length (snd x) > length (snd y)
                                 then Just x
                                 else Nothing
                sortedOpposingSupports = sortBy comparator opposingSupports
                comparator :: (Aligned Subject, Supports) -> (Aligned Subject, Supports) -> Ordering
                comparator (_, xs) (_, ys) = Down (length xs) `compare` Down (length ys)
                opposingSupports :: [(Aligned Subject, Supports)]
                opposingSupports = fmap (\x -> (fst x, calculateOpposingSupports x)) foreignCompetingMoves
                calculateOpposingSupports :: (Aligned Subject, ProvinceTarget) -> Supports
                calculateOpposingSupports (asubj, pt) = foreignSupport resolution (alignedGreatPower aunit) (alignedThing asubj) pt
                foreignCompetingMoves :: CompetingMoves
                foreignCompetingMoves = filter (\(asubj, _) -> alignedGreatPower asubj /= alignedGreatPower aunit) theseCompetingMoves
                thisSupports :: Supports
                thisSupports = support resolution (alignedThing aunit, zoneProvinceTarget zone) (zoneProvinceTarget zone)


            -- For a non hold:
            --
            --   1. check if it doesn't have the required convoy.
            --   2. check if it bounces off/is overpowered by the competing moves.
            --   3. check if it bounces off/is overpowered by the incumbant.
            NotHold requiresConvoy theseConvoyRoutes theseCompetingMoves thisIncumbant ->
                case (checkConvoy, checkCompeting, checkIncumbant) of
                    -- We play with the order here, so that a move overpowered
                    -- is always preferred over a move bounced.
                    (Nothing, x@(Just (MoveBounced _)), y@(Just (MoveOverpowered _))) -> y
                    (Nothing, x@(Just (MoveBounced _)), y@(Just (MoveBounced _))) -> y
                    (Nothing, x@(Just (MoveOverpowered _)), y@(Just (MoveBounced _))) -> x
                    (Nothing, x@(Just (MoveOverpowered _)), y@(Just (MoveOverpowered _))) -> y
                    (x, y, z) -> x <|> y <|> z
              where

                checkConvoy = case requiresConvoy of
                    RequiresConvoy ->
                        if    null (successfulConvoyRoutes theseConvoyRoutes)
                        then if null (convoyRoutesParadox theseConvoyRoutes)
                             then Just MoveNoConvoy
                             else Just MoveConvoyParadox
                        else Nothing
                    _ -> Nothing

                -- For competing moves here, we don't care about foriegn orders
                -- or supports, it's all the same.
                checkCompeting = case sortedOpposingSupports of
                    [] -> Nothing
                    ((x, ss) : xs) ->
                        if length ss == length thisSupports
                        then Just (MoveBounced (AtLeast (VCons x VNil) equallySupported))
                        else if length ss > length thisSupports
                        then Just (MoveOverpowered (AtLeast (VCons x VNil) equallySupported))
                        else Nothing
                      where
                        equallySupported = fmap fst (filter (\(x, ss') -> length ss' == length ss) xs)
                  where
                    sortedOpposingSupports = sortBy comparator opposingSupports
                    comparator :: (Aligned Subject, Supports) -> (Aligned Subject, Supports) -> Ordering
                    comparator (_, xs) (_, ys) = Down (length xs) `compare` Down (length ys)
                    opposingSupports :: [(Aligned Subject, Supports)]
                    opposingSupports = fmap (\x -> (fst x, calculateOpposingSupports x)) theseCompetingMoves
                    calculateOpposingSupports :: (Aligned Subject, ProvinceTarget) -> Supports
                    calculateOpposingSupports (asubj, pt) = support resolution (alignedThing asubj) pt
                    thisSupports :: Supports
                    thisSupports = support resolution (alignedThing aunit, zoneProvinceTarget zone) (moveTarget moveObject)


                checkIncumbant = case thisIncumbant of

                    NoIncumbant -> Nothing

                    -- Stationary: fail if this move (which threatens to
                    -- dislodge the stationary unit) does not dominate the
                    -- zone WITHOUT support from the stationary unit's great
                    -- power, or if that unit is not foreign
                    -- (MoveFiendlyDislodge).
                    Stationary asubj -> case sortedOpposingSupports of
                        [] -> Nothing -- Actually impossible.
                        ((x, ss) : xs) ->
                            if length ss == length thisSupports
                            then Just (MoveBounced (AtLeast (VCons x VNil) equallySupported))
                            else if length ss > length thisSupports
                            then Just (MoveOverpowered (AtLeast (VCons x VNil) equallySupported))
                            else if opposingPower == thisPower
                            then Just (MoveFriendlyDislodge (alignedThing aunit))
                            else Nothing
                          where
                            equallySupported = fmap fst (filter (\(x, ss') -> length ss' == length ss) xs)
                      where
                        thisSupports :: Supports
                        thisSupports = foreignSupport resolution opposingPower (alignedThing aunit, zoneProvinceTarget zone) (moveTarget moveObject)
                        sortedOpposingSupports = sortBy comparator opposingSupports
                        comparator :: (Aligned Subject, Supports) -> (Aligned Subject, Supports) -> Ordering
                        comparator (_, xs) (_, ys) = Down (length xs) `compare` Down (length ys)
                        opposingSupports :: [(Aligned Subject, Supports)]
                        opposingSupports = fmap (\x -> (fst x, calculateOpposingSupports x)) theseCompetingMovesWithStationary
                        calculateOpposingSupports :: (Aligned Subject, ProvinceTarget) -> Supports
                        calculateOpposingSupports (asubj, pt) = support resolution (alignedThing asubj) pt
                        theseCompetingMovesWithStationary = (asubj, subjectProvinceTarget thisSubject) : theseCompetingMoves
                        opposingSubject = alignedThing asubj
                        opposingPower = alignedGreatPower asubj
                        thisPower = alignedGreatPower aunit
                        thisSubject = alignedThing asubj

                    -- Returning: fail if this move (which threatens to
                    -- dislodge the returning unit) does not dominate the
                    -- zone WITHOUT support from the returning unit's great
                    -- power, or if that unit is not foreign
                    -- (MoveFiendlyDislodge).
                    ReturningMove asubj pt -> case sortedOpposingSupports of
                        [] -> Nothing -- Actually impossible
                        ((x, ss) : xs) ->
                            if length ss == length thisSupports
                            then Just (MoveBounced (AtLeast (VCons x VNil) equallySupported))
                            else if length ss > length thisSupports
                            then Just (MoveOverpowered (AtLeast (VCons x VNil) equallySupported))
                            else if opposingPower == thisPower
                            then Just (MoveFriendlyDislodge (subjectUnit (alignedThing asubj)))
                            else Nothing
                          where
                            equallySupported = fmap fst (filter (\(x, ss') -> length ss' == length ss) xs)
                      where
                        thisSupports :: Supports
                        thisSupports = foreignSupport resolution (alignedGreatPower asubj) (alignedThing aunit, zoneProvinceTarget zone) (moveTarget moveObject)
                        -- We add the returning move with no supports, making
                        -- it look like it was a hold, so that if a move bounces
                        -- off a returning move, it's indicated by the origin
                        -- of the returning move, rather than its destination.
                        sortedOpposingSupports = sortBy comparator ((align (opposingUnit, pt) opposingPower, []) : opposingSupports)
                        comparator :: (Aligned Subject, Supports) -> (Aligned Subject, Supports) -> Ordering
                        comparator (_, xs) (_, ys) = Down (length xs) `compare` Down (length ys)
                        opposingSupports :: [(Aligned Subject, Supports)]
                        opposingSupports = fmap (\x -> (fst x, calculateOpposingSupports x)) theseCompetingMoves
                        calculateOpposingSupports :: (Aligned Subject, ProvinceTarget) -> Supports
                        calculateOpposingSupports (asubj, pt) = support resolution (alignedThing asubj) pt
                        opposingSubject = alignedThing asubj
                        opposingUnit = subjectUnit opposingSubject
                        opposingPower = alignedGreatPower asubj
                        thisPower = alignedGreatPower aunit

                    -- Complementary where the other would not succeed even
                    -- without this one.
                    -- HERE AS WELL we must check that without supports friendly
                    -- to the complementary, this move would still dominate!
                    ComplementaryMove WouldNotSucceed asubj target -> case sortedOpposingSupports of
                        [] -> Nothing -- Impossible
                        ((x, ss) : xs) ->
                            if length ss > length thisSupports && opposingPower /= thisPower
                            then Just (MoveOverpowered (AtLeast (VCons x VNil) equallySupported))
                            else if length thisSupports > length ss && opposingPower == thisPower
                            then Just (MoveFriendlyDislodge opposingUnit)
                            else if length ss == length thisSupports
                            then Just (MoveBounced (AtLeast (VCons x VNil) equallySupported))
                            else Nothing
                          where
                            equallySupported = fmap fst (filter (\(x, ss') -> length ss' == length ss) xs)
                      where
                        sortedOpposingSupports = sortBy comparator ((asubj, complementarySupports) : opposingSupports)
                        comparator :: (Aligned Subject, Supports) -> (Aligned Subject, Supports) -> Ordering
                        comparator (_, xs) (_, ys) = Down (length xs) `compare` Down (length ys)
                        opposingSupports :: [(Aligned Subject, Supports)]
                        opposingSupports = fmap (\x -> (fst x, calculateOpposingSupports x)) theseCompetingMoves
                        calculateOpposingSupports :: (Aligned Subject, ProvinceTarget) -> Supports
                        calculateOpposingSupports (asubj, pt) = support resolution (alignedThing asubj) pt
                        complementarySupports :: Supports
                        complementarySupports = foreignSupport resolution thisPower opposingSubject target
                        thisSupports :: Supports
                        thisSupports = foreignSupport resolution opposingPower (alignedThing aunit, zoneProvinceTarget zone) (moveTarget moveObject)
                        opposingPower = alignedGreatPower asubj
                        opposingSubject = alignedThing asubj
                        opposingUnit = subjectUnit opposingSubject
                        thisPower = alignedGreatPower aunit


                    -- Complementary where the other would succeed without
                    -- this one.
                    -- HERE AS WELL we must check that without supports friendly
                    -- to the complementary, this move would still dominate!
                    ComplementaryMove WouldSucceed asubj target ->
                        if     not (null opposingSuccessfulConvoyRoutes)
                            || not (null thisSuccessfulConvoyRoutes)
                        then Nothing
                        else case sortedOpposingSupports of
                            [] -> Nothing -- Impossible
                            ((x, ss) : xs) ->
                                if length ss > length thisSupports && opposingPower /= thisPower
                                then Just (MoveOverpowered (AtLeast (VCons x VNil) equallySupported))
                                else if length thisSupports > length ss && opposingPower == thisPower
                                then Just (MoveFriendlyDislodge opposingUnit)
                                else if    length ss == length thisSupports
                                then Just (MoveBounced (AtLeast (VCons x VNil) equallySupported))
                                else Nothing
                              where
                                equallySupported = fmap fst (filter (\(x, ss') -> length ss' == length ss) xs)
                      where
                        sortedOpposingSupports = sortBy comparator ((asubj, complementarySupports) : opposingSupports)
                        comparator :: (Aligned Subject, Supports) -> (Aligned Subject, Supports) -> Ordering
                        comparator (_, xs) (_, ys) = Down (length xs) `compare` Down (length ys)
                        opposingSupports :: [(Aligned Subject, Supports)]
                        opposingSupports = fmap (\x -> (fst x, calculateOpposingSupports x)) theseCompetingMoves
                        calculateOpposingSupports :: (Aligned Subject, ProvinceTarget) -> Supports
                        calculateOpposingSupports (asubj, pt) = support resolution (alignedThing asubj) pt
                        complementarySupports :: Supports
                        complementarySupports = foreignSupport resolution thisPower opposingSubject target
                        thisSupports :: Supports
                        thisSupports = foreignSupport resolution opposingPower (alignedThing aunit, zoneProvinceTarget zone) (moveTarget moveObject)
                        opposingSuccessfulConvoyRoutes :: [ConvoyRoute]
                        opposingSuccessfulConvoyRoutes = successfulConvoyRoutes opposingConvoyRoutes
                        thisSuccessfulConvoyRoutes :: [ConvoyRoute]
                        thisSuccessfulConvoyRoutes = successfulConvoyRoutes theseConvoyRoutes
                        opposingConvoyRoutes :: ConvoyRoutes
                        opposingConvoyRoutes = convoyRoutes (dropAssumptionTags resolution) opposingSubject target
                        opposingPower = alignedGreatPower asubj
                        opposingSubject = alignedThing asubj
                        opposingUnit = subjectUnit opposingSubject
                        thisPower = alignedGreatPower aunit

        -- *******
        -- SUPPORT
        -- *******
        --
        -- There are three reasons to fail a support:
        --
        --   SupportVoid : the complementary order was not given.
        --   For instance, F Eng S F MAt -> Bre cannot succeed unless
        --   some great power issues F MAt -> Bre. Similarly,
        --   F Eng S F MAt -> MAt cannot success unless some great power
        --   issues F MAt Hold OR F MAt S <anything> OR F MAt C <anything>.
        resolveSupport
            :: OrderObject Typical Support
            -> Maybe (FailureReason Typical Support)
        resolveSupport supportObject =
                supportVoid supportObject
            <|> supportCut supportObject
            <|> supportDislodged supportObject

        -- A support is Void if the supported order was not given.
        supportVoid
            :: OrderObject Typical Support
            -> Maybe (FailureReason Typical Support)
        supportVoid (SupportObject supportingSubject supportingTo) =
            case M.lookup supportingFrom (dropAssumptionTags resolution) of
                Nothing -> Just SupportVoid
                Just (aunit, SomeResolved (object, _)) ->
                    if    supportingUnit == alignedThing aunit
                       && supportingTo == destination
                    then Nothing
                    else Just SupportVoid
                  where
                    destination = case object of
                        MoveObject pt -> pt
                        _ -> zoneProvinceTarget supportingFrom

          where

            supportingFrom :: Zone
            supportingFrom = Zone (snd supportingSubject)

            supportingUnit :: Unit
            supportingUnit = fst supportingSubject


        -- Support is cut if there is a move into its territory issued by
        -- another great power, from a territory other than the one into which
        -- support is directed. If that move requires a convoy, then there must
        -- be at least one successful convoy route. To avoid nontermination
        -- which would arise from the classic convoy paradox:
        --
        --   France: Army Brest -> English Channel -> London.
        --   France: Fleet English Channel CONVOY Army Brest -> London. 
        --
        --   England: Fleet London SUPPORT Fleet Wales -> English Channel.
        --   England: Fleet Wales -> English Channel. 
        --
        -- we use the notion of convoy-independence. In this example, we would
        -- check whether the convoy route succeeds, which in-turn check whether
        -- the English move succeeds, which would ask whether the English
        -- support succeeds, which would in-turn ask whether the French
        -- move has a successful convoy route, and so on...
        --
        -- We could cut the loop by inspecting only the independent convoy
        -- routes, those routes such that their convoying fleets are not
        -- attacked by a move which is supported by this support. The next rule,
        -- convoyDislodged, is sensitive to this, because under this paradox
        -- resolution, it's possible for a dislodged unit to give support, i.e.
        -- when it was dislodged by a move which did not cut it.
        --
        -- Another option is to identify the moves which participate in these
        -- paradoxes and fail them (MoveConvoyParadox). But how does this hold
        -- up in case there's more than one convoy route? Aha, yes we would
        -- first have to ensure that none of the other routes are successful,
        -- and only then could we say it's MoveConvoyParadox. So, this amounts
        -- to 1. grabbing all convoy routes 2. isolating any paradoxical ones
        -- 3. checking whether any nonparadoxical one succeeds. Then
        --
        --     no successful nonparadoxical, at least one paradoxical -> MoveConvoyParadox
        --     no successful nonparadoxical, no paradoxical -> MoveNoConvoy
        --     successful nonparadoxical, _ -> Succeeds
        --
        -- Both of these strategies are explained here:
        -- http://diplom.org/Zine/F1999R/Debate/resolve.cgi
        supportCut
            :: OrderObject Typical Support
            -> Maybe (FailureReason Typical Support)
        supportCut (SupportObject supportingSubject supportingTo) =
            case filter issuedByOtherGreatPower offendingMoves of
                [] -> Nothing
                x : xs -> Just (SupportCut (AtLeast (VCons x VNil) xs))

          where

            issuedByOtherGreatPower :: Aligned Subject -> Bool
            issuedByOtherGreatPower x = alignedGreatPower aunit /= alignedGreatPower x

            supportingFrom :: Zone
            supportingFrom = zone

            offendingMoves :: [Aligned Subject]
            offendingMoves = M.elems (M.mapMaybeWithKey pickOffendingMove (dropAssumptionTags resolution))

            pickOffendingMove
                :: Zone
                -> (Aligned Unit, SomeResolved OrderObject Typical)
                -> Maybe (Aligned Subject)
            pickOffendingMove zone (aunit', SomeResolved (object, _)) =
                case object of
                    MoveObject movingTo ->
                        if    Zone movingTo == supportingFrom
                           && Zone supportingTo /= zone
                           && not (isConvoyMoveWithNoConvoyRoute thisClassification)
                        then Just $ align (alignedThing aunit', zoneProvinceTarget zone) (alignedGreatPower aunit')
                        else Nothing
                      where
                        thisClassification = classify resolution zone (aunit', object)
                    _ -> Nothing

        -- TODO TBD can't we remove this and the SupportDislodged constructor?
        -- SupportCut is sufficient.
        supportDislodged
            :: OrderObject Typical Support
            -> Maybe (FailureReason Typical Support)
        supportDislodged _ = case typicalChange (dropAssumptionTags resolution) zone of
            Nothing -> Nothing
            Just dislodger -> Just (SupportDislodged dislodger)

        -- ******
        -- CONVOY
        -- ******
        --
        -- There are two reasons to fail a convoy:
        --
        --   ConvoyVoid : the complementary move order was not given.
        --   For instance, F Eng C A Bre -> Wal cannot succeed unless some
        --   great power issues A Bre -> Wal. If no such order is issued, we
        --   say that the convoy order is void.
        --
        --   ConvoyNoRoute : there is no route of undisrupted convoy orders
        --   from the convoy source to convoy terminus. Note that this
        --   includes two possibilities: no route or exists, or every route
        --   which does exist has been cut (some member of the route dislodged).
        --
        resolveConvoy
            :: OrderObject Typical Convoy
            -> Maybe (FailureReason Typical Convoy)
        resolveConvoy convoyObject =
                convoyVoid convoyObject
            <|> convoyNoRoute convoyObject

        convoyVoid
            :: OrderObject Typical Convoy
            -> Maybe (FailureReason Typical Convoy)
        convoyVoid (ConvoyObject subject target) =
            if isVoidConvoy (dropAssumptionTags resolution) subject target
            then Just ConvoyVoid
            else Nothing

        -- Route cut in case every convoy route which this convoy order
        -- participates in has at laest one of its convoyers dislodged.
        convoyNoRoute
            :: OrderObject Typical Convoy
            -> Maybe (FailureReason Typical Convoy)
        convoyNoRoute (ConvoyObject convoyingSubject convoyingTo) =
            case routesParticipatedIn of
                [] -> Just ConvoyNoRoute
                _ -> fmap ConvoyRouteCut cuttingSet

          where

            routes :: [[(Zone, Maybe (Aligned Subject))]]
            routes = rawConvoyRoutes (dropAssumptionTags resolution) convoyingSubject convoyingTo

            routesParticipatedIn :: [[(Zone, Maybe (Aligned Subject))]]
            routesParticipatedIn = filter participates routes
              where
                participates = any (\(z, _) -> z == zone)

            cuttingSet :: Maybe [(Zone, Aligned Subject)]
            cuttingSet | length cutRoutes == length routesParticipatedIn = Just (nub (concat cutRoutes))
                       | otherwise = Nothing

            cutRoutes :: [[(Zone, Aligned Subject)]]
            cutRoutes = filter (not . null) (fmap cutRoute routesParticipatedIn)

            cutRoute
                :: [(Zone, Maybe (Aligned Subject))]
                -> [(Zone, Aligned Subject)]
            cutRoute = mapMaybe pickCutRoute

            pickCutRoute
                :: (Zone, Maybe (Aligned Subject))
                -> Maybe (Zone, Aligned Subject)
            pickCutRoute (z, m) = fmap ((,) z) m

    in  thisResolution

-- | Changes to a board as the result of a typical phase.
--   @Nothing@ means no change, @Just pt@ means the unit belonging to the great
--   power now lies the input 'Zone', and used to lie at the given
--   'ProvinceTarget' @pt@.
typicalChange :: Resolution Typical -> Zone -> Maybe (Aligned Subject)
typicalChange res zone = M.foldWithKey folder Nothing res
  where
    folder
        :: Zone
        -> (Aligned Unit, SomeResolved OrderObject Typical)
        -> Maybe (Aligned Subject)
        -> Maybe (Aligned Subject)
    folder zone' (aunit, SomeResolved (object, resolution)) b = case object of
        MoveObject movingTo ->
            -- Rule out moves that don't offend this zone, and moves that are
            -- holds at this zone.
            if    Zone movingTo /= zone
               || Zone movingTo == zone'
            then b
            else case resolution of
                     Nothing -> let power = alignedGreatPower aunit
                                    unit = alignedThing aunit
                                    subj = align (unit, zoneProvinceTarget zone') power
                                in  Just subj
                     _ -> b
        _ -> b

-- | Resolution for the Typical phase.
typicalResolution
    :: M.Map Zone (Aligned Unit, SomeOrderObject Typical)
    -> Resolution Typical
typicalResolution = dropAssumptionTags . typicalResolutionAssuming . noAssumptions

-- | Resolution for the Retreat phase.
retreatResolution
    :: M.Map Zone (Aligned Unit, SomeOrderObject Retreat)
    -> Resolution Retreat
retreatResolution zonedOrders = M.mapWithKey (resolveRetreat zonedWithdraws) zonedOrders
  where
    -- At each Zone we have a list of the zones from which a withdraw attempt
    -- is made.
    zonedWithdraws :: M.Map Zone [Aligned Subject]
    zonedWithdraws = M.foldWithKey folder M.empty zonedOrders
      where
        folder
            :: Zone
            -> (Aligned Unit, SomeOrderObject Retreat)
            -> M.Map Zone [Aligned Subject]
            -> M.Map Zone [Aligned Subject]
        folder zone (aunit, SomeOrderObject object) b = case object of
            WithdrawObject withdrawingTo -> M.alter alteration (Zone withdrawingTo) b
              where
                subject = align (alignedThing aunit, zoneProvinceTarget zone) (alignedGreatPower aunit)
                alteration x = case x of
                    Nothing -> Just [subject]
                    Just ys -> Just (subject : ys)
            _ -> b
    resolveRetreat
        :: M.Map Zone [Aligned Subject]
        -> Zone
        -> (Aligned Unit, SomeOrderObject Retreat)
        -> (Aligned Unit, SomeResolved OrderObject Retreat)
    resolveRetreat zonedWithdraws zone (aunit, SomeOrderObject object) = case object of
        SurrenderObject -> (aunit, SomeResolved (object, Nothing))
        WithdrawObject _ -> (aunit, SomeResolved (object, resolution))
          where
            resolution :: Maybe (FailureReason Retreat Withdraw)
            resolution = case fmap (filter (/= thisSubject)) (M.lookup (Zone (withdrawTarget object)) zonedWithdraws) of
                Just [] -> Nothing
                Just (x : xs) -> Just (WithdrawCollision (AtLeast (VCons x VNil) xs))
                _ -> Nothing
      where
        thisSubject = align (alignedThing aunit, zoneProvinceTarget zone) (alignedGreatPower aunit)

-- | Resolution for the Adjust phase.
adjustResolution
    :: M.Map Zone (Aligned Unit, SomeOrderObject Adjust)
    -> Resolution Adjust
adjustResolution = M.map (\(aunit, SomeOrderObject object) -> (aunit, SomeResolved (object, Nothing)))

type Resolved (k :: Phase -> OrderType -> *) (phase :: Phase) (order :: OrderType) =
    (k phase order, Maybe (FailureReason phase order))

data SomeResolved (k :: Phase -> OrderType -> *) phase where
    SomeResolved :: Resolved k phase order -> SomeResolved k phase

deriving instance Show (SomeResolved OrderObject phase)
deriving instance Show (SomeResolved Order phase)

instance Eq (SomeResolved OrderObject phase) where
    SomeResolved (object1, res1) == SomeResolved (object2, res2) =
           object1 `orderObjectEqual` object2
        && case (res1, res2) of
               (Just r1, Just r2) -> failureReasonEqual r1 r2
               (Nothing, Nothing) -> True
               _ -> False

withSomeResolved
  :: (forall order . Resolved k phase order -> t) -> SomeResolved k phase -> t
withSomeResolved f term = case term of
    SomeResolved x -> f x

-- | Enumeration of reasons why an order could not succeed.
data FailureReason (phase :: Phase) (order :: OrderType) where

    MoveOverpowered :: AtLeast One (Aligned Subject) -> FailureReason Typical Move

    MoveBounced :: AtLeast One (Aligned Subject) -> FailureReason Typical Move

    -- The move would dislodge the player's own unit.
    -- TBD the rules are ambigious for games where one player controls many
    -- great powers. Is it ok for a player's unit to dislodge a unit which
    -- belongs to a different great power which he controls? We allow it.
    MoveFriendlyDislodge :: Unit -> FailureReason Typical Move

    MoveNoConvoy :: FailureReason Typical Move

    MoveConvoyParadox :: FailureReason Typical Move

    -- The supported unit did not give an order consistent with the support
    -- order.
    SupportVoid :: FailureReason Typical Support

    -- The supporting unit was attacked from a province other than the one
    -- into which the support was directed.
    SupportCut :: AtLeast One (Aligned Subject) -> FailureReason Typical Support

    -- The supporting unit was overpowered by a move from the province into
    -- which the support was directed.
    SupportDislodged :: Aligned Subject -> FailureReason Typical Support

    ConvoyVoid :: FailureReason Typical Convoy

    ConvoyNoRoute :: FailureReason Typical Convoy

    ConvoyRouteCut :: [(Zone, Aligned Subject)] ->  FailureReason Typical Convoy

    -- The unit withdraws into the same province as some other unit(s).
    WithdrawCollision :: AtLeast One (Aligned Subject) -> FailureReason Retreat Withdraw

    -- Surrender orders and adjust phase orders can never fail; if they're
    -- valid, they succeed!

deriving instance Show (FailureReason phase order)
deriving instance Eq (FailureReason phase order)

failureReasonEqual
    :: FailureReason phase order
    -> FailureReason phase' order'
    -> Bool
failureReasonEqual r1 r2 = case (r1, r2) of
    (MoveOverpowered x, MoveOverpowered y) -> x == y
    (MoveBounced x, MoveBounced y) -> x == y
    (MoveFriendlyDislodge x, MoveFriendlyDislodge y) -> x == y
    (MoveNoConvoy, MoveNoConvoy) -> True
    (MoveConvoyParadox, MoveConvoyParadox) -> True
    (SupportVoid, SupportVoid) -> True
    (SupportCut x, SupportCut y) -> x == y
    (SupportDislodged x, SupportDislodged y) -> x == y
    (ConvoyVoid, ConvoyVoid) -> True
    (ConvoyNoRoute, ConvoyNoRoute) -> True
    (ConvoyRouteCut x, ConvoyRouteCut y) -> x == y
    (WithdrawCollision x, WithdrawCollision y) -> x == y
    _ -> False