diff --git a/Data/AtLeast.hs b/Data/AtLeast.hs new file mode 100644 --- /dev/null +++ b/Data/AtLeast.hs @@ -0,0 +1,88 @@ +{-| +Module : Data.AtLeast +Description : Lists of at least n elements. +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Data.AtLeast ( + + AtLeast(..) + + , fromList + , toList + , appendList + + , weaken + , maxima + + , head + + ) where + +import Prelude hiding (head) +import Data.List ((\\)) +import Data.Ord +import Data.TypeNat.Nat +import Data.TypeNat.Vect + +data AtLeast (n :: Nat) (t :: *) = AtLeast (Vect t n) [t] + +-- Equality ignores order of elements. +instance Eq t => Eq (AtLeast n t) where + (==) xs ys = case (toList xs) \\ (toList ys) of + [] -> True + _ -> False + +deriving instance Show t => Show (AtLeast n t) + +appendList :: AtLeast n t -> [t] -> AtLeast n t +appendList (AtLeast vect rest) xs = AtLeast vect (xs ++ rest) + +fromList :: [t] -> AtLeast Z t +fromList xs = AtLeast VNil xs + +toList :: AtLeast n t -> [t] +toList (AtLeast vs xs) = vectToList vs ++ xs + +head :: AtLeast One t -> t +head (AtLeast vs xs) = case (vs, xs) of + (VCons x _, _) -> x + +newtype Weaken t n = Weaken { + unWeaken :: AtLeast n t + } + +weaken1 :: AtLeast (S n) t -> AtLeast n t +weaken1 (AtLeast vs xs) = case vs of + VCons x rest -> AtLeast rest (x : xs) + +weaken :: forall n m t . LTE n m => AtLeast m t -> AtLeast n t +weaken = unWeaken . lteRecursion recurse . Weaken + where + recurse :: forall k . LTE n k => Weaken t (S k) -> Weaken t k + recurse (Weaken atLeast) = Weaken (weaken1 atLeast) + +maxima :: (t -> t -> Ordering) -> AtLeast One t -> AtLeast One t +maxima comparator (AtLeast vs xs) = case vs of + VCons x rest -> maxima' comparator (AtLeast (VCons x VNil) []) (vectToList rest ++ xs) + where + maxima' :: (t -> t -> Ordering) -> AtLeast One t -> [t] -> AtLeast One t + maxima' comparator acc rest = case rest of + [] -> acc + (x : rest) -> case comparator (head acc) x of + GT -> maxima' comparator acc rest + EQ -> maxima' comparator (appendList acc [x]) rest + LT -> maxima' comparator (AtLeast (VCons x VNil) []) rest diff --git a/Data/MapUtil.hs b/Data/MapUtil.hs new file mode 100644 --- /dev/null +++ b/Data/MapUtil.hs @@ -0,0 +1,35 @@ +{-| +Module : Data.MapUtil +Description : Definition of lookupWithKey +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} + +module Data.MapUtil ( + + lookupWithKey + + ) where + +import qualified Data.Map as M +import qualified Data.Set as S + +-- | Lookup a key in a map and get back the actual key as well. Useful when +-- the key Eq instance is not quite so sharp. +lookupWithKey + :: Ord k + => k + -> M.Map k v + -> Maybe (k, v) +lookupWithKey k m = + let v = M.lookup k m + keys = M.keysSet m + -- keys `S.intersection` S.singleton k is empty iff v is Nothing, so + -- this won't be undefined. + k' = head (S.elems (keys `S.intersection` S.singleton k)) + in fmap (\x -> (k', x)) v diff --git a/Diplomacy/Aligned.hs b/Diplomacy/Aligned.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/Aligned.hs @@ -0,0 +1,44 @@ +{-| +Module : Diplomacy.Aligned +Description : Align a value to a 'GreatPower'. +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Diplomacy.Aligned ( + + Aligned + , align + , alignedThing + , alignedGreatPower + + ) where + +import Diplomacy.GreatPower + +-- | Something aligned to a @GreatPower@. +data Aligned t where + Aligned :: t -> GreatPower -> Aligned t + +deriving instance Eq t => Eq (Aligned t) +deriving instance Ord t => Ord (Aligned t) +deriving instance Show t => Show (Aligned t) + +instance Functor Aligned where + fmap f (Aligned x y) = Aligned (f x) y + +align :: t -> GreatPower -> Aligned t +align = Aligned + +alignedThing :: Aligned t -> t +alignedThing (Aligned x _) = x + +alignedGreatPower :: Aligned t -> GreatPower +alignedGreatPower (Aligned _ x) = x diff --git a/Diplomacy/Control.hs b/Diplomacy/Control.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/Control.hs @@ -0,0 +1,38 @@ +{-| +Module : Diplomacy.Control +Description : Definition of control of provinces. +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} + +module Diplomacy.Control ( + + Control + + , emptyControl + , control + , controller + + ) where + +import qualified Data.Map as M +import Diplomacy.Province +import Diplomacy.GreatPower + +-- | Indicates which GreatPower most recently had a unit on a given Province +-- at the beginning of an adjust phase. +type Control = M.Map Province GreatPower + +emptyControl :: Control +emptyControl = M.empty + +control :: Province -> Maybe GreatPower -> Control -> Control +control pr mgp = M.alter (const mgp) pr + +controller :: Province -> Control -> Maybe GreatPower +controller = M.lookup diff --git a/Diplomacy/Dislodgement.hs b/Diplomacy/Dislodgement.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/Dislodgement.hs @@ -0,0 +1,70 @@ +{-| +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) diff --git a/Diplomacy/Game.hs b/Diplomacy/Game.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/Game.hs @@ -0,0 +1,868 @@ +{-| +Module : Diplomacy.Game +Description : State of a Diplomacy game. +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} + +module Diplomacy.Game ( + + Game(..) + , Round(..) + , RoundStatus(..) + , Status(..) + , TypicalRound(..) + , RetreatRound(..) + , AdjustRound(..) + , NextRound + , RoundPhase + , RoundOrderConstructor + , roundToInt + , nextRound + , prevRound + + , gameZonedOrders + , gameZonedResolvedOrders + , gameOccupation + , gameDislodged + , gameControl + , gameTurn + , gameRound + , gameSeason + , issueOrders + , resolve + , continue + , newGame + , showGame + + ) where + +import Control.Applicative +import qualified Data.Map as M +import qualified Data.Set as S +import Data.List (sortBy, intersperse) +import Diplomacy.Turn +import Diplomacy.Season +import Diplomacy.GreatPower +import Diplomacy.Aligned +import Diplomacy.Unit +import Diplomacy.Order +import Diplomacy.OrderObject +import Diplomacy.Phase +import Diplomacy.Province +import Diplomacy.Zone +import Diplomacy.Occupation +import Diplomacy.Dislodgement +import Diplomacy.Control +import Diplomacy.Subject +import Diplomacy.SupplyCentreDeficit +import Diplomacy.OrderResolution +import Diplomacy.OrderValidation + +data Round where + RoundOne :: Round + RoundTwo :: Round + RoundThree :: Round + RoundFour :: Round + RoundFive :: Round + +deriving instance Show Round +deriving instance Enum Round +deriving instance Bounded Round +deriving instance Eq Round +deriving instance Ord Round + +roundToInt :: Round -> Int +roundToInt = fromEnum + +nextRound :: Round -> Round +nextRound round = case round of + RoundOne -> RoundTwo + RoundTwo -> RoundThree + RoundThree -> RoundFour + RoundFour -> RoundFive + RoundFive -> RoundOne + +prevRound :: Round -> Round +prevRound round = case round of + RoundOne -> RoundFive + RoundTwo -> RoundOne + RoundThree -> RoundTwo + RoundFour -> RoundThree + RoundFive -> RoundFour + +data RoundStatus where + RoundUnresolved :: RoundStatus + RoundResolved :: RoundStatus + +deriving instance Show RoundStatus + +data Status (roundStatus :: RoundStatus) where + Unresolved :: Status RoundUnresolved + Resolved :: Status RoundResolved + +type family RoundOrderConstructor (roundStatus :: RoundStatus) :: Phase -> * where + RoundOrderConstructor RoundUnresolved = SomeOrderObject + RoundOrderConstructor RoundResolved = SomeResolved OrderObject + +data TypicalRound (round :: Round) where + TypicalRoundOne :: TypicalRound RoundOne + TypicalRoundTwo :: TypicalRound RoundThree + +deriving instance Show (TypicalRound round) + +nextRetreatRound :: TypicalRound round -> RetreatRound (NextRound round) +nextRetreatRound typicalRound = case typicalRound of + TypicalRoundOne -> RetreatRoundOne + TypicalRoundTwo -> RetreatRoundTwo + +data RetreatRound (round :: Round) where + RetreatRoundOne :: RetreatRound RoundTwo + RetreatRoundTwo :: RetreatRound RoundFour + +deriving instance Show (RetreatRound round) + +data AdjustRound (round :: Round) where + AdjustRound :: AdjustRound RoundFive + +deriving instance Show (AdjustRound round) + +type family NextRound (round :: Round) :: Round where + NextRound RoundOne = RoundTwo + NextRound RoundTwo = RoundThree + NextRound RoundThree = RoundFour + NextRound RoundFour = RoundFive + NextRound RoundFive = RoundOne + +type family RoundPhase (round :: Round) :: Phase where + RoundPhase RoundOne = Typical + RoundPhase RoundTwo = Retreat + RoundPhase RoundThree = Typical + RoundPhase RoundFour = Retreat + RoundPhase RoundFive = Adjust + +data Game (round :: Round) (roundStatus :: RoundStatus) where + + TypicalGame + :: TypicalRound round + -> Status roundStatus + -> Turn + -> M.Map Zone (Aligned Unit, RoundOrderConstructor roundStatus Typical) + -> Control + -> Game round roundStatus + + RetreatGame + :: RetreatRound round + -> Status roundStatus + -> Turn + -> Resolution Typical + -- Resolutions of the previous typical phase. + -> M.Map Zone (Aligned Unit, RoundOrderConstructor roundStatus Retreat) + -- Dislodged units, which have orders. + -> Occupation + -> Control + -> Game round roundStatus + + AdjustGame + :: AdjustRound round + -> Status roundStatus + -> Turn + -> M.Map Zone (Aligned Unit, RoundOrderConstructor roundStatus Adjust) + -> Control + -> Game round roundStatus + +newGame :: Game RoundOne RoundUnresolved +newGame = TypicalGame TypicalRoundOne Unresolved firstTurn zonedOrders thisControl + where + zonedOrders = M.mapWithKey giveDefaultOrder thisOccupation + + giveDefaultOrder + :: Zone + -> Aligned Unit + -> (Aligned Unit, SomeOrderObject Typical) + giveDefaultOrder zone aunit = (aunit, SomeOrderObject (MoveObject (zoneProvinceTarget zone))) + + thisOccupation = + + occupy (Normal London) (Just (align Fleet England)) + . occupy (Normal Edinburgh) (Just (align Fleet England)) + . occupy (Normal Liverpool) (Just (align Army England)) + + . occupy (Normal Brest) (Just (align Fleet France)) + . occupy (Normal Paris) (Just (align Army France)) + . occupy (Normal Marseilles) (Just (align Army France)) + + . occupy (Normal Venice) (Just (align Army Italy)) + . occupy (Normal Rome) (Just (align Army Italy)) + . occupy (Normal Naples) (Just (align Fleet Italy)) + + . occupy (Normal Kiel) (Just (align Fleet Germany)) + . occupy (Normal Berlin) (Just (align Army Germany)) + . occupy (Normal Munich) (Just (align Army Germany)) + + . occupy (Normal Vienna) (Just (align Army Austria)) + . occupy (Normal Budapest) (Just (align Army Austria)) + . occupy (Normal Trieste) (Just (align Fleet Austria)) + + . occupy (Normal Warsaw) (Just (align Army Russia)) + . occupy (Normal Moscow) (Just (align Army Russia)) + . occupy (Special StPetersburgSouth) (Just (align Fleet Russia)) + . occupy (Normal Sevastopol) (Just (align Fleet Russia)) + + . occupy (Normal Constantinople) (Just (align Army Turkey)) + . occupy (Normal Smyrna) (Just (align Army Turkey)) + . occupy (Normal Ankara) (Just (align Fleet Turkey)) + + $ emptyOccupation + + -- Initial control: everybody controls their home supply centres. + thisControl :: Control + thisControl = foldr (\(power, province) -> control province (Just power)) emptyControl controlList + where + controlList :: [(GreatPower, Province)] + controlList = [ (power, province) | power <- greatPowers, province <- filter (isHome power) supplyCentres ] + greatPowers :: [GreatPower] + greatPowers = [minBound..maxBound] + +showGame :: Game round roundStatus -> String +showGame game = concat . intersperse "\n" $ [ + showGameMetadata game + , "****" + , middle + , "****" + , showControl (gameControl game) + ] + where + middle = case game of + TypicalGame _ Unresolved _ _ _ -> showZonedOrders (gameZonedOrders game) + RetreatGame _ Unresolved _ _ _ _ _ -> showZonedOrders (gameZonedOrders game) + AdjustGame _ Unresolved _ _ _ -> showZonedOrders (gameZonedOrders game) + TypicalGame _ Resolved _ _ _ -> showZonedResolvedOrders (gameZonedResolvedOrders game) + RetreatGame _ Resolved _ _ _ _ _ -> showZonedResolvedOrders (gameZonedResolvedOrders game) + AdjustGame _ Resolved _ _ _ -> showZonedResolvedOrders (gameZonedResolvedOrders game) + +showGameMetadata :: Game round roundStatus -> String +showGameMetadata game = concat . intersperse "\n" $ [ + "Year: " ++ show year + , "Season: " ++ show season + , "Phase: " ++ show phase + ] + where + year = 1900 + turnToInt (gameTurn game) + season = gameSeason game + phase = gamePhase game + +showOccupation :: Occupation -> String +showOccupation = concat . intersperse "\n" . M.foldWithKey foldShowAlignedUnit [] + where + foldShowAlignedUnit zone aunit b = + concat [show provinceTarget, ": ", show greatPower, " ", show unit] : b + where + provinceTarget = zoneProvinceTarget zone + greatPower = alignedGreatPower aunit + unit = alignedThing aunit + +showZonedOrders :: M.Map Zone (Aligned Unit, SomeOrderObject phase) -> String +showZonedOrders = concat . intersperse "\n" . M.foldWithKey foldShowOrder [] + where + foldShowOrder zone (aunit, SomeOrderObject object) b = + concat [show provinceTarget, ": ", show greatPower, " ", show unit, " ", objectString] : b + where + provinceTarget = zoneProvinceTarget zone + greatPower = alignedGreatPower aunit + unit = alignedThing aunit + objectString = case object of + MoveObject pt -> + if pt == zoneProvinceTarget zone + then "hold" + else "move to " ++ show pt + SupportObject subj pt -> concat ["support ", show supportedUnit, " at ", show supportedPt, " into ", show pt] + where + supportedUnit = subjectUnit subj + supportedPt = subjectProvinceTarget subj + ConvoyObject subj pt -> concat ["convoy ", show convoyedUnit, " from ", show convoyedFrom, " to ", show pt] + where + convoyedUnit = subjectUnit subj + convoyedFrom = subjectProvinceTarget subj + SurrenderObject -> "surrender" + WithdrawObject pt -> "withdraw to " ++ show pt + DisbandObject -> "disband" + BuildObject -> "build" + ContinueObject -> "continue" + +showZonedResolvedOrders :: M.Map Zone (Aligned Unit, SomeResolved OrderObject phase) -> String +showZonedResolvedOrders = concat . intersperse "\n" . M.foldWithKey foldShowResolvedOrder [] + where + foldShowResolvedOrder + :: Zone + -> (Aligned Unit, SomeResolved OrderObject phase) + -> [String] + -> [String] + foldShowResolvedOrder zone (aunit, SomeResolved (object, resolution)) b = + concat [show provinceTarget, ": ", show greatPower, " ", show unit, " ", objectString, " ", resolutionString] : b + where + provinceTarget = zoneProvinceTarget zone + greatPower = alignedGreatPower aunit + unit = alignedThing aunit + objectString = case object of + MoveObject pt -> + if pt == zoneProvinceTarget zone + then "hold" + else "move to " ++ show pt + SupportObject subj pt -> concat ["support ", show supportedUnit, " at ", show supportedPt, " into ", show pt] + where + supportedUnit = subjectUnit subj + supportedPt = subjectProvinceTarget subj + ConvoyObject subj pt -> concat ["convoy ", show convoyedUnit, " from ", show convoyedFrom, " to ", show pt] + where + convoyedUnit = subjectUnit subj + convoyedFrom = subjectProvinceTarget subj + SurrenderObject -> "surrender" + WithdrawObject pt -> "withdraw to " ++ show pt + DisbandObject -> "disband" + BuildObject -> "build" + ContinueObject -> "continue" + resolutionString = case resolution of + Nothing -> "✓" + Just reason -> "✗ " ++ show reason + +showControl :: Control -> String +showControl = concat . intersperse "\n" . M.foldWithKey foldShowControl [] + where + foldShowControl province greatPower b = concat [show province, ": ", show greatPower] : b + +gameStatus :: Game round roundStatus -> Status roundStatus +gameStatus game = case game of + TypicalGame _ x _ _ _ -> x + RetreatGame _ x _ _ _ _ _ -> x + AdjustGame _ x _ _ _ -> x + +gameZonedOrders + :: Game round RoundUnresolved + -> M.Map Zone (Aligned Unit, SomeOrderObject (RoundPhase round)) +gameZonedOrders game = case game of + TypicalGame TypicalRoundOne _ _ x _ -> x + TypicalGame TypicalRoundTwo _ _ x _ -> x + RetreatGame RetreatRoundOne _ _ _ x _ _ -> x + RetreatGame RetreatRoundTwo _ _ _ x _ _ -> x + AdjustGame AdjustRound _ _ x _ -> x + +gameZonedResolvedOrders + :: Game round RoundResolved + -> M.Map Zone (Aligned Unit, SomeResolved OrderObject (RoundPhase round)) +gameZonedResolvedOrders game = case game of + TypicalGame TypicalRoundOne _ _ x _ -> x + TypicalGame TypicalRoundTwo _ _ x _ -> x + RetreatGame RetreatRoundOne _ _ _ x _ _ -> x + RetreatGame RetreatRoundTwo _ _ _ x _ _ -> x + AdjustGame AdjustRound _ _ x _ -> x + +gameOccupation :: Game round roundStatus -> Occupation +gameOccupation game = case game of + TypicalGame _ _ _ zonedOrders _ -> M.map fst zonedOrders + RetreatGame _ _ _ _ _ x _ -> x + AdjustGame _ Unresolved _ zonedOrders _ -> M.mapMaybe selectDisbandOrContinue zonedOrders + where + selectDisbandOrContinue :: (Aligned Unit, SomeOrderObject Adjust) -> Maybe (Aligned Unit) + selectDisbandOrContinue (aunit, SomeOrderObject object) = case object of + DisbandObject -> Just aunit + ContinueObject -> Just aunit + _ -> Nothing + AdjustGame _ Resolved _ zonedOrders _ -> M.mapMaybe selectBuildOrContinue zonedOrders + where + selectBuildOrContinue :: (Aligned Unit, SomeResolved OrderObject Adjust) -> Maybe (Aligned Unit) + selectBuildOrContinue (aunit, SomeResolved (object, _)) = case object of + BuildObject -> Just aunit + ContinueObject -> Just aunit + _ -> Nothing + +gameDislodged + :: (RoundPhase round ~ Retreat) + => Game round RoundUnresolved + -> M.Map Zone (Aligned Unit) +gameDislodged game = case game of + RetreatGame _ Unresolved _ _ zonedOrders _ _ -> M.map fst zonedOrders + +gameResolved + :: (RoundPhase round ~ Retreat) + => Game round RoundUnresolved + -> M.Map Zone (Aligned Unit, SomeResolved OrderObject Typical) +gameResolved game = case game of + RetreatGame _ _ _ x _ _ _ -> x + +gameControl :: Game round roundStatus -> Control +gameControl game = case game of + TypicalGame _ _ _ _ c -> c + RetreatGame _ _ _ _ _ _ c -> c + AdjustGame _ _ _ _ c -> c + +gameTurn :: Game round roundStatus -> Turn +gameTurn game = case game of + TypicalGame _ _ t _ _ -> t + RetreatGame _ _ t _ _ _ _ -> t + AdjustGame _ _ t _ _ -> t + +gameRound :: Game round roundStatus -> Round +gameRound game = case game of + TypicalGame TypicalRoundOne _ _ _ _ -> RoundOne + TypicalGame TypicalRoundTwo _ _ _ _ -> RoundThree + RetreatGame RetreatRoundOne _ _ _ _ _ _ -> RoundTwo + RetreatGame RetreatRoundTwo _ _ _ _ _ _ -> RoundFour + AdjustGame AdjustRound _ _ _ _ -> RoundFive + +gameSeason :: Game round roundStatus -> Season +gameSeason game = case game of + TypicalGame TypicalRoundOne _ _ _ _ -> Spring + RetreatGame RetreatRoundOne _ _ _ _ _ _ -> Spring + TypicalGame TypicalRoundTwo _ _ _ _ -> Fall + RetreatGame RetreatRoundTwo _ _ _ _ _ _ -> Fall + AdjustGame _ _ _ _ _ -> Winter + +gamePhase :: Game round roundStatus -> Phase +gamePhase game = case game of + TypicalGame _ _ _ _ _ -> Typical + RetreatGame _ _ _ _ _ _ _ -> Retreat + AdjustGame _ _ _ _ _ -> Adjust + + +-- Can only issue orders for one great power. +-- Must offer the ability to issue more than one order, else issuing +-- adjust phase orders would be impossible. +-- +-- TBD the return type. +-- There may be more than one invalid order given. We must associate each +-- order with the set of criteria which it fails to meet, and give back the +-- next game. If any order is invalid, no orders shall be issued. +-- Of course, for the adjust phase, things are slightly different. Not only +-- is each order associated with its set of invalid reasons, but the set itself +-- has a set of reasons! + +type family ValidateOrdersOutput (phase :: Phase) :: * where + ValidateOrdersOutput Typical = M.Map Zone (Aligned Unit, SomeOrderObject Typical, S.Set (SomeValidityCriterion Typical)) + ValidateOrdersOutput Retreat = M.Map Zone (Aligned Unit, SomeOrderObject Retreat, S.Set (SomeValidityCriterion Retreat)) + ValidateOrdersOutput Adjust = (M.Map Zone (Aligned Unit, SomeOrderObject Adjust, S.Set (SomeValidityCriterion Adjust)), M.Map GreatPower (S.Set AdjustSetValidityCriterion)) + +-- | The game given as the second component of the return value will differ +-- from the input game only if all orders are valid. +-- NB for adjust phase we wipe all build orders; that's because there's +-- no way to explicitly remove a build order by overwriting it with some +-- other order. +issueOrders + :: forall round . + M.Map Zone (Aligned Unit, SomeOrderObject (RoundPhase round)) + -> Game round RoundUnresolved + -> (ValidateOrdersOutput (RoundPhase round), Game round RoundUnresolved) +issueOrders orders game = + let nextGame = case game of + AdjustGame AdjustRound _ _ _ _ -> issueOrdersUnsafe orders (removeBuildOrders game) + _ -> issueOrdersUnsafe orders game + validation :: ValidateOrdersOutput (RoundPhase round) + allValid :: Bool + (validation, allValid) = case game of + TypicalGame TypicalRoundOne _ _ _ _ -> + let validation = validateOrders orders game + invalids = M.fold pickInvalids S.empty validation + in (validation, S.null invalids) + TypicalGame TypicalRoundTwo _ _ _ _ -> + let validation = validateOrders orders game + invalids = M.fold pickInvalids S.empty validation + in (validation, S.null invalids) + RetreatGame RetreatRoundOne _ _ _ _ _ _ -> + let validation = validateOrders orders game + invalids = M.fold pickInvalids S.empty validation + in (validation, S.null invalids) + RetreatGame RetreatRoundTwo _ _ _ _ _ _ -> + let validation = validateOrders orders game + invalids = M.fold pickInvalids S.empty validation + in (validation, S.null invalids) + AdjustGame AdjustRound _ _ _ _ -> + let validation = validateOrders orders game + invalids = M.fold pickInvalids S.empty (fst validation) + adjustSetInvalids = M.fold S.union S.empty (snd validation) + in (validation, S.null invalids && S.null adjustSetInvalids) + in if allValid + then (validation, nextGame) + else (validation, game) + where + pickInvalids + :: (Aligned Unit, SomeOrderObject phase, S.Set (SomeValidityCriterion phase)) + -> S.Set (SomeValidityCriterion phase) + -> S.Set (SomeValidityCriterion phase) + pickInvalids (_, _, x) = S.union x + +validateOrders + :: forall round . + M.Map Zone (Aligned Unit, SomeOrderObject (RoundPhase round)) + -> Game round RoundUnresolved + -> ValidateOrdersOutput (RoundPhase round) +validateOrders orders game = case game of + -- The form of validation depends upon the game phase: + -- - Typical and Retreat orders are validated independently, so we can + -- express validation as a fold. + -- - Adjust orders are validated independently and then ensemble. + TypicalGame TypicalRoundOne _ _ _ _ -> M.mapWithKey (validateOrderTypical game) orders + TypicalGame TypicalRoundTwo _ _ _ _ -> M.mapWithKey (validateOrderTypical game) orders + RetreatGame RetreatRoundOne _ _ _ _ _ _ -> M.mapWithKey (validateOrderRetreat game) orders + RetreatGame RetreatRoundTwo _ _ _ _ _ _ -> M.mapWithKey (validateOrderRetreat game) orders + AdjustGame AdjustRound _ _ _ _ -> + let independent = M.mapWithKey (validateOrderSubjectAdjust game) orders + ensemble = validateOrdersAdjust game orders + in (independent, ensemble) + where + + validateOrderTypical + :: forall round . + ( RoundPhase round ~ Typical ) + => Game round RoundUnresolved + -> Zone + -> (Aligned Unit, SomeOrderObject (RoundPhase round)) + -> (Aligned Unit, SomeOrderObject (RoundPhase round), S.Set (SomeValidityCriterion Typical)) + validateOrderTypical game zone (aunit, SomeOrderObject object) = + (aunit, SomeOrderObject object, validation) + where + validation = case object of + MoveObject _ -> analyze snd (S.singleton . SomeValidityCriterion . fst) S.empty S.union (moveVOC greatPower occupation) (Order (subject, object)) + SupportObject _ _ -> analyze snd (S.singleton . SomeValidityCriterion . fst) S.empty S.union (supportVOC greatPower occupation) (Order (subject, object)) + ConvoyObject _ _ -> analyze snd (S.singleton . SomeValidityCriterion . fst) S.empty S.union (convoyVOC greatPower occupation) (Order (subject, object)) + occupation = gameOccupation game + greatPower = alignedGreatPower aunit + unit = alignedThing aunit + subject = (unit, zoneProvinceTarget zone) + + validateOrderRetreat + :: forall round . + ( RoundPhase round ~ Retreat ) + => Game round RoundUnresolved + -> Zone + -> (Aligned Unit, SomeOrderObject (RoundPhase round)) + -> (Aligned Unit, SomeOrderObject (RoundPhase round), S.Set (SomeValidityCriterion Retreat)) + validateOrderRetreat game zone (aunit, SomeOrderObject object) = + (aunit, SomeOrderObject object, validation) + where + validation = case object of + SurrenderObject -> analyze snd (S.singleton . SomeValidityCriterion . fst) S.empty S.union (surrenderVOC greatPower dislodgement) (Order (subject, object)) + WithdrawObject _ -> analyze snd (S.singleton . SomeValidityCriterion . fst) S.empty S.union (withdrawVOC greatPower resolved) (Order (subject, object)) + occupation = gameOccupation game + resolved = gameResolved game + dislodgement = gameDislodged game + greatPower = alignedGreatPower aunit + unit = alignedThing aunit + subject = (unit, zoneProvinceTarget zone) + + -- The above two functions give us single-order validations for typical + -- and retreat phases... for adjust we need single-order validation and + -- also order-set validation. But then, the return value type of + -- validateOrders must surely depend upon the phase, no? We want to + -- associate each input order with its set of failed criteria, and then + -- associate the set itself with its failed criteria. So we'll want + -- a type family. + validateOrderSubjectAdjust + :: forall round . + ( RoundPhase round ~ Adjust ) + => Game round RoundUnresolved + -> Zone + -> (Aligned Unit, SomeOrderObject (RoundPhase round)) + -> (Aligned Unit, SomeOrderObject (RoundPhase round), S.Set (SomeValidityCriterion Adjust)) + validateOrderSubjectAdjust game zone (aunit, SomeOrderObject object) = + (aunit, SomeOrderObject object, validation) + where + validation = case object of + ContinueObject -> analyze snd (S.singleton . SomeValidityCriterion . fst) S.empty S.union (continueSubjectVOC greatPower occupation) subject + DisbandObject -> analyze snd (S.singleton . SomeValidityCriterion . fst) S.empty S.union (disbandSubjectVOC greatPower occupation) subject + BuildObject -> analyze snd (S.singleton . SomeValidityCriterion . fst) S.empty S.union (buildSubjectVOC greatPower occupation control) subject + occupation = gameOccupation game + control = gameControl game + greatPower = alignedGreatPower aunit + unit = alignedThing aunit + subject = (unit, zoneProvinceTarget zone) + + -- Here we partition the subjects by GreatPower, because each power's set of + -- adjust orders must be analyzed ensemble to determine whether it makes + -- sense (enough disbands/not too many builds for instance). + validateOrdersAdjust + :: forall round . + ( RoundPhase round ~ Adjust ) + => Game round RoundUnresolved + -> M.Map Zone (Aligned Unit, SomeOrderObject (RoundPhase round)) + -> M.Map GreatPower (S.Set AdjustSetValidityCriterion) + validateOrdersAdjust game orders = M.mapWithKey validation adjustSetsByGreatPower + where + validation + :: GreatPower + -> AdjustSubjects + -> S.Set AdjustSetValidityCriterion + validation greatPower subjects = analyze snd (S.singleton . fst) S.empty S.union (adjustSubjectsVOC greatPower occupation control subjects) subjects + adjustSetsByGreatPower :: M.Map GreatPower AdjustSubjects + adjustSetsByGreatPower = M.foldWithKey pickSubject M.empty orders + pickSubject + :: Zone + -> (Aligned Unit, SomeOrderObject (RoundPhase round)) + -> M.Map GreatPower AdjustSubjects + -> M.Map GreatPower AdjustSubjects + pickSubject zone (aunit, SomeOrderObject object) = case object of + ContinueObject -> M.alter (alterContinue subject) greatPower + BuildObject -> M.alter (alterBuild subject) greatPower + DisbandObject -> M.alter (alterDisband subject) greatPower + where + subject = (alignedThing aunit, zoneProvinceTarget zone) + greatPower = alignedGreatPower aunit + alterContinue + :: Subject + -> Maybe AdjustSubjects + -> Maybe AdjustSubjects + alterContinue subject x = Just $ case x of + Nothing -> AdjustSubjects S.empty S.empty (S.singleton subject) + Just x' -> x' { continueSubjects = S.insert subject (continueSubjects x') } + alterBuild + :: Subject + -> Maybe AdjustSubjects + -> Maybe AdjustSubjects + alterBuild subject x = Just $ case x of + Nothing -> AdjustSubjects (S.singleton subject) S.empty S.empty + Just x' -> x' { buildSubjects = S.insert subject (buildSubjects x') } + alterDisband + :: Subject + -> Maybe AdjustSubjects + -> Maybe AdjustSubjects + alterDisband subject x = Just $ case x of + Nothing -> AdjustSubjects S.empty (S.singleton subject) S.empty + Just x' -> x' { disbandSubjects = S.insert subject (disbandSubjects x') } + occupation = gameOccupation game + control = gameControl game + +-- | Issue orders without validating them. Do not use this with orders which +-- have not been validated! +issueOrdersUnsafe + :: forall round . + M.Map Zone (Aligned Unit, SomeOrderObject (RoundPhase round)) + -> Game round RoundUnresolved + -> Game round RoundUnresolved +issueOrdersUnsafe validOrders game = M.foldWithKey issueOrderUnsafe game validOrders + where + issueOrderUnsafe + :: forall round . + Zone + -> (Aligned Unit, SomeOrderObject (RoundPhase round)) + -> Game round RoundUnresolved + -> Game round RoundUnresolved + issueOrderUnsafe zone (aunit, someObject) game = case game of + TypicalGame TypicalRoundOne s t zonedOrders v -> TypicalGame TypicalRoundOne s t (insertOrder zonedOrders) v + TypicalGame TypicalRoundTwo s t zonedOrders v -> TypicalGame TypicalRoundTwo s t (insertOrder zonedOrders) v + RetreatGame RetreatRoundOne s t res zonedOrders o c -> RetreatGame RetreatRoundOne s t res (insertOrder zonedOrders) o c + RetreatGame RetreatRoundTwo s t res zonedOrders o c -> RetreatGame RetreatRoundTwo s t res (insertOrder zonedOrders) o c + AdjustGame AdjustRound s t zonedOrders c -> AdjustGame AdjustRound s t (insertOrder zonedOrders) c + where + insertOrder + :: M.Map Zone (Aligned Unit, SomeOrderObject (RoundPhase round)) + -> M.Map Zone (Aligned Unit, SomeOrderObject (RoundPhase round)) + insertOrder = M.alter (const (Just (aunit, someObject))) zone + +removeBuildOrders + :: (RoundPhase round ~ Adjust) + => Game round RoundUnresolved + -> Game round RoundUnresolved +removeBuildOrders game = case game of + AdjustGame AdjustRound s t zonedOrders c -> + let zonedOrders' = M.filter (not . isBuild) zonedOrders + in AdjustGame AdjustRound s t zonedOrders' c + where + isBuild :: (Aligned Unit, SomeOrderObject Adjust) -> Bool + isBuild (_, SomeOrderObject object) = case object of + BuildObject -> True + _ -> False + +resolve + :: Game round RoundUnresolved + -> Game round RoundResolved +resolve game = case game of + TypicalGame round _ turn zonedOrders control -> + TypicalGame round Resolved turn (typicalResolution zonedOrders) control + RetreatGame round _ turn previousResolution zonedOrders occupation control -> + RetreatGame round Resolved turn previousResolution (retreatResolution zonedOrders) occupation control + AdjustGame round _ turn zonedOrders control -> + AdjustGame round Resolved turn (adjustResolution zonedOrders) control + +continue + :: Game round RoundResolved + -> Game (NextRound round) RoundUnresolved +continue game = case game of + + TypicalGame round _ turn zonedResolvedOrders thisControl -> + RetreatGame (nextRetreatRound round) Unresolved turn zonedResolvedOrders nextZonedOrders occupation thisControl + where + -- Give every dislodged unit a surrender order. + nextZonedOrders :: M.Map Zone (Aligned Unit, SomeOrderObject Retreat) + nextZonedOrders = M.map giveDefaultRetreatOrder dislodgement + + giveDefaultRetreatOrder + :: Aligned Unit + -> (Aligned Unit, SomeOrderObject Retreat) + giveDefaultRetreatOrder aunit = (aunit, SomeOrderObject object) + where + object = SurrenderObject + + (dislodgement, occupation) = dislodgementAndOccupation zonedResolvedOrders + + RetreatGame RetreatRoundOne _ turn _ zonedResolvedOrders occupation thisControl -> + TypicalGame TypicalRoundTwo Unresolved turn nextZonedOrders thisControl + where + -- Give every occupier a hold order. + nextZonedOrders :: M.Map Zone (Aligned Unit, SomeOrderObject Typical) + nextZonedOrders = M.mapWithKey giveDefaultTypicalOrder nextOccupation + + giveDefaultTypicalOrder + :: Zone + -> Aligned Unit + -> (Aligned Unit, SomeOrderObject Typical) + giveDefaultTypicalOrder zone aunit = (aunit, SomeOrderObject object) + where + object = MoveObject (zoneProvinceTarget zone) + + -- Every dislodged unit which successfully withdraws is added to the + -- next occupation value; all others are forgotten. + nextOccupation :: Occupation + nextOccupation = M.foldWithKey occupationFold occupation zonedResolvedOrders + + occupationFold + :: Zone + -> (Aligned Unit, SomeResolved OrderObject Retreat) + -> Occupation + -> Occupation + occupationFold zone (aunit, SomeResolved (object, res)) = + case (object, res) of + (WithdrawObject withdrawingTo, Nothing) -> occupy withdrawingTo (Just aunit) + _ -> id + + RetreatGame RetreatRoundTwo _ turn _ zonedResolvedOrders occupation thisControl -> + AdjustGame AdjustRound Unresolved turn nextZonedOrders nextControl + where + nextZonedOrders :: M.Map Zone (Aligned Unit, SomeOrderObject Adjust) + nextZonedOrders = M.mapWithKey giveDefaultAdjustOrder nextOccupation + + -- This one is not so trivial... what IS the default adjust order? + -- It depends upon the deficit, and the distance of the unit from + -- its home supply centre! That's because our goal is to enforce that + -- the issued orders in a Game are always valid. So we can't just throw + -- a bunch of Continue objects onto the order set here; the great power + -- may need to disband some units! + -- NB a player need not have a deficit of 0; it's ok to have a negative + -- deficit, since the rule book states that a player may decline to + -- build a unit that she is entitled to. + -- + -- First, let's calculate the deficits for each great power. + -- Then, we'll order their units by minimum distance from home supply + -- centre. + -- Then, we give as many disband orders as the deficit if it's positive, + -- using the list order; other units get ContinueObject. + -- + -- Associate every country with a list of the zones it occupies, + -- ordered by distance from home supply centre. + -- + -- TODO must respect the rule "in case of a tie, fleets first, then + -- alphabetically by province". + zonesByDistance :: M.Map GreatPower [Zone] + zonesByDistance = + M.mapWithKey + (\k -> sortWith (distanceFromHomeSupplyCentre k . ptProvince . zoneProvinceTarget)) + (M.foldWithKey foldZonesByDistance M.empty occupation) + + sortWith f = sortBy (\x y -> f x `compare` f y) + + foldZonesByDistance + :: Zone + -> Aligned Unit + -> M.Map GreatPower [Zone] + -> M.Map GreatPower [Zone] + foldZonesByDistance zone aunit = M.alter alteration (alignedGreatPower aunit) + where + alteration m = case m of + Nothing -> Just [zone] + Just zs -> Just (zone : zs) + + disbands :: S.Set Zone + disbands = M.foldWithKey foldDisbands S.empty zonesByDistance + + foldDisbands + :: GreatPower + -> [Zone] + -> S.Set Zone + -> S.Set Zone + -- take behaves as we want it to with negative numbers. + foldDisbands greatPower zones = S.union (S.fromList (take deficit zones)) + where + deficit = supplyCentreDeficit greatPower nextOccupation nextControl + + giveDefaultAdjustOrder + :: Zone + -> Aligned Unit + -> (Aligned Unit, SomeOrderObject Adjust) + giveDefaultAdjustOrder zone aunit = case S.member zone disbands of + True -> (aunit, SomeOrderObject DisbandObject) + False -> (aunit, SomeOrderObject ContinueObject) + + -- Every dislodged unit which successfully withdraws is added to the + -- next occupation value; all others are forgotten. + nextOccupation :: Occupation + nextOccupation = M.foldWithKey occupationFold occupation zonedResolvedOrders + + occupationFold + :: Zone + -> (Aligned Unit, SomeResolved OrderObject Retreat) + -> Occupation + -> Occupation + occupationFold zone (aunit, SomeResolved (object, res)) = + case (object, res) of + (WithdrawObject withdrawingTo, Nothing) -> occupy withdrawingTo (Just aunit) + _ -> id + + -- Every unit in @nextOccupation@ takes control of the Province where it + -- lies. + nextControl :: Control + nextControl = M.foldWithKey controlFold thisControl nextOccupation + + controlFold + :: Zone + -> Aligned Unit + -> Control + -> Control + controlFold zone aunit = control (ptProvince (zoneProvinceTarget zone)) (Just (alignedGreatPower aunit)) + + AdjustGame AdjustRound _ turn zonedResolvedOrders thisControl -> + TypicalGame TypicalRoundOne Unresolved (nextTurn turn) nextZonedOrders thisControl + where + -- Give every occupier a hold order. + nextZonedOrders :: M.Map Zone (Aligned Unit, SomeOrderObject Typical) + nextZonedOrders = M.mapWithKey giveDefaultTypicalOrder nextOccupation + + giveDefaultTypicalOrder + :: Zone + -> Aligned Unit + -> (Aligned Unit, SomeOrderObject Typical) + giveDefaultTypicalOrder zone aunit = (aunit, SomeOrderObject object) + where + object = MoveObject (zoneProvinceTarget zone) + + -- Builds and continues become occupying units; disbands go away. + nextOccupation :: Occupation + nextOccupation = M.mapMaybe mapOccupation zonedResolvedOrders + + mapOccupation + :: (Aligned Unit, SomeResolved OrderObject Adjust) + -> Maybe (Aligned Unit) + mapOccupation (aunit, SomeResolved (object, resolution)) = + case (object, resolution) of + (DisbandObject, Nothing) -> Nothing + (BuildObject, Nothing) -> Just aunit + (ContinueObject, Nothing) -> Just aunit diff --git a/Diplomacy/GreatPower.hs b/Diplomacy/GreatPower.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/GreatPower.hs @@ -0,0 +1,35 @@ +{-| +Module : Diplomacy.GreatPower +Description : Definition of the great powers (countries). +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Diplomacy.GreatPower ( + + GreatPower(..) + + ) where + +data GreatPower where + England :: GreatPower + Germany :: GreatPower + France :: GreatPower + Italy :: GreatPower + Austria :: GreatPower + Russia :: GreatPower + Turkey :: GreatPower + +deriving instance Eq GreatPower +deriving instance Ord GreatPower +deriving instance Show GreatPower +deriving instance Read GreatPower +deriving instance Enum GreatPower +deriving instance Bounded GreatPower diff --git a/Diplomacy/Occupation.hs b/Diplomacy/Occupation.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/Occupation.hs @@ -0,0 +1,89 @@ +{-| +Module : Diplomacy.Occupation +Description : Definition of Zone/ProvinceTarget occupation. +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} + +module Diplomacy.Occupation ( + + Occupation + + , emptyOccupation + , occupy + , occupier + , provinceOccupier + , occupies + , unitOccupies + , occupied + , zoneOccupied + , allSubjects + + ) where + +import qualified Data.Map as M +import Data.MapUtil +import Data.Maybe (isJust) +import Diplomacy.Aligned +import Diplomacy.Unit +import Diplomacy.Province +import Diplomacy.Zone +import Diplomacy.Subject +import Diplomacy.GreatPower + +-- | Each Zone is occupied by at most one Aligned Unit, but the functions on +-- Occupation work with ProvinceTarget; the use of Zone as a key here is just +-- to guarantee that we don't have, for instance, units on both of Spain's +-- coasts simultaneously. +type Occupation = M.Map Zone (Aligned Unit) + +emptyOccupation :: Occupation +emptyOccupation = M.empty + +occupy :: ProvinceTarget -> Maybe (Aligned Unit) -> Occupation -> Occupation +occupy pt maunit = M.alter (const maunit) (Zone pt) + +-- | Must be careful with this one! We can't just lookup the Zone corresponding +-- to the ProvinceTarget; we must also check that the key matching that Zone, +-- if there is one in the map, is also ProvinceTarget-equal. +occupier :: ProvinceTarget -> Occupation -> Maybe (Aligned Unit) +occupier pt occupation = case lookupWithKey (Zone pt) occupation of + Just (zone, value) -> + if zoneProvinceTarget zone == pt + then Just value + else Nothing + _ -> Nothing + +provinceOccupier :: Province -> Occupation -> Maybe (Aligned Unit) +provinceOccupier pr occupation = case lookupWithKey (Zone (Normal pr)) occupation of + Just (zone, value) -> + if zoneProvinceTarget zone == Normal pr + then Just value + else Nothing + _ -> Nothing + +occupies :: Aligned Unit -> ProvinceTarget -> Occupation -> Bool +occupies aunit pt = (==) (Just aunit) . occupier pt + +unitOccupies :: Unit -> ProvinceTarget -> Occupation -> Bool +unitOccupies unit pt = (==) (Just unit) . fmap alignedThing . occupier pt + +occupied :: ProvinceTarget -> Occupation -> Bool +occupied pt = isJust . occupier pt + +zoneOccupied :: Zone -> Occupation -> Bool +zoneOccupied zone = isJust . M.lookup zone + +allSubjects :: Maybe GreatPower -> Occupation -> [Subject] +allSubjects maybeGreatPower = M.foldWithKey f [] + where + f zone aunit = + let subject = (alignedThing aunit, zoneProvinceTarget zone) + in if maybeGreatPower == Nothing || Just (alignedGreatPower aunit) == maybeGreatPower + then (:) subject + else id diff --git a/Diplomacy/Order.hs b/Diplomacy/Order.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/Order.hs @@ -0,0 +1,95 @@ +{-| +Module : Diplomacy.Order +Description : Definition of an order +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Diplomacy.Order ( + + Order(..) + + , SomeOrder(..) + + , orderSubject + , orderObject + + , isHold + , movingFrom + , movingTo + , supportsOrder + + ) where + +import Data.Coerce (coerce) +import Diplomacy.GreatPower +import Diplomacy.Aligned +import Diplomacy.Phase +import Diplomacy.Subject +import Diplomacy.OrderType +import Diplomacy.OrderObject +import Diplomacy.Province + +newtype Order (phase :: Phase) (order :: OrderType) = Order { + outOrder :: (Subject, OrderObject phase order) + } deriving (Eq, Ord, Show) + +coerce' :: Order phase order -> (Subject, OrderObject phase order) +coerce' = coerce + +orderSubject :: Order phase order -> Subject +orderSubject = fst . coerce' + +orderObject :: Order phase order -> OrderObject phase order +orderObject = snd . coerce' + +data SomeOrder phase where + SomeOrder :: Order phase order -> SomeOrder phase + +instance Eq (SomeOrder phase) where + SomeOrder o1 == SomeOrder o2 = case (orderObject o1, orderObject o2) of + (MoveObject _, MoveObject _) -> o1 == o2 + (SupportObject _ _, SupportObject _ _) -> o1 == o2 + (ConvoyObject _ _, ConvoyObject _ _) -> o1 == o2 + (SurrenderObject, SurrenderObject) -> o1 == o2 + (WithdrawObject _, WithdrawObject _) -> o1 == o2 + (DisbandObject, DisbandObject) -> o1 == o2 + (BuildObject, BuildObject) -> o1 == o2 + (ContinueObject, ContinueObject) -> o1 == o2 + _ -> False + +instance Ord (SomeOrder phase) where + SomeOrder o1 `compare` SomeOrder o2 = show o1 `compare` show o2 + +deriving instance Show (SomeOrder phase) + +isHold :: Order Typical Move -> Bool +isHold order = from == to + where + to = moveTarget . orderObject $ order + from = subjectProvinceTarget . orderSubject $ order + +movingFrom :: Order Typical Move -> ProvinceTarget +movingFrom = subjectProvinceTarget . orderSubject + +movingTo :: Order Typical Move -> ProvinceTarget +movingTo = moveTarget . orderObject + +supportsOrder :: OrderObject Typical Support -> SomeOrder Typical -> Bool +supportsOrder supportOrderObject (SomeOrder order) = + supportedSubject supportOrderObject == orderSubject order + && supportTarget supportOrderObject == orderDestination order + where + orderDestination :: Order Typical order -> ProvinceTarget + orderDestination order = case orderObject order of + MoveObject pt -> pt + SupportObject _ _ -> subjectProvinceTarget (orderSubject order) diff --git a/Diplomacy/OrderObject.hs b/Diplomacy/OrderObject.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/OrderObject.hs @@ -0,0 +1,124 @@ +{-| +Module : Diplomacy.OrderObject +Description : Definition of OrderObject, which describes what a Subject is to do. +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 KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Diplomacy.OrderObject ( + + OrderObject(..) + , orderObjectEqual + + , SomeOrderObject(..) + + , moveTarget + , supportedSubject + , supportTarget + , convoySubject + , convoyTarget + , withdrawTarget + + ) where + +import Diplomacy.Phase +import Diplomacy.Subject +import Diplomacy.OrderType +import Diplomacy.Province + +-- | The objective of an order. Together with an Subject and a GreatPower, +-- this makes a complete order. +data OrderObject (phase :: Phase) (order :: OrderType) where + + MoveObject :: ProvinceTarget -> OrderObject Typical Move + SupportObject + :: Subject + -> ProvinceTarget + -> OrderObject Typical Support + ConvoyObject + -- TODO later, would be cool if we could use type system extensions + -- to eliminate bogus convoys like convoys of fleets or convoys from/to + -- water provinces. + :: Subject + -> ProvinceTarget + -> OrderObject Typical Convoy + + WithdrawObject :: ProvinceTarget -> OrderObject Retreat Withdraw + SurrenderObject :: OrderObject Retreat Surrender + + DisbandObject :: OrderObject Adjust Disband + BuildObject :: OrderObject Adjust Build + ContinueObject :: OrderObject Adjust Continue + -- This is convenient because with it, every unit always has an + -- order in every phase. + +deriving instance Eq (OrderObject phase order) +deriving instance Show (OrderObject phase order) + +instance Ord (OrderObject phase order) where + x `compare` y = case (x, y) of + (MoveObject pt, MoveObject pt') -> pt `compare` pt' + (SupportObject subj pt, SupportObject subj' pt') -> (subj, pt) `compare` (subj, pt') + (ConvoyObject subj pt, ConvoyObject subj' pt') -> (subj, pt) `compare` (subj', pt') + (SurrenderObject, SurrenderObject) -> EQ + (WithdrawObject pt, WithdrawObject pt') -> pt `compare` pt' + (DisbandObject, DisbandObject) -> EQ + (BuildObject, BuildObject) -> EQ + (ContinueObject, ContinueObject) -> EQ + +orderObjectEqual :: OrderObject phase order -> OrderObject phase' order' -> Bool +orderObjectEqual object1 object2 = case (object1, object2) of + (MoveObject pt1, MoveObject pt2) -> pt1 == pt2 + (SupportObject subj1 pt1, SupportObject subj2 pt2) -> (subj1, pt1) == (subj2, pt2) + (ConvoyObject subj1 pt1, ConvoyObject subj2 pt2) -> (subj1, pt1) == (subj2, pt2) + (WithdrawObject pt1, WithdrawObject pt2) -> pt1 == pt2 + (SurrenderObject, SurrenderObject) -> True + (DisbandObject, DisbandObject) -> True + (BuildObject, BuildObject) -> True + (ContinueObject, ContinueObject) -> True + _ -> False + +moveTarget :: OrderObject Typical Move -> ProvinceTarget +moveTarget (MoveObject x) = x + +supportedSubject :: OrderObject Typical Support -> Subject +supportedSubject (SupportObject x _) = x + +supportTarget :: OrderObject Typical Support -> ProvinceTarget +supportTarget (SupportObject _ x) = x + +convoySubject :: OrderObject Typical Convoy -> Subject +convoySubject (ConvoyObject x _) = x + +convoyTarget :: OrderObject Typical Convoy -> ProvinceTarget +convoyTarget (ConvoyObject _ x) = x + +withdrawTarget :: OrderObject Retreat Withdraw -> ProvinceTarget +withdrawTarget (WithdrawObject x) = x + +data SomeOrderObject phase where + SomeOrderObject :: OrderObject phase order -> SomeOrderObject phase + +deriving instance Show (SomeOrderObject phase) + +{- +instance Eq (SomeOrderObject phase) where + (SomeOrderObject x) == (SomeOrderObject y) = case (x, y) of + (MoveObject _, MoveObject _) -> x == y + (SupportObject _ _, SupportObject _ _) -> x == y + (ConvoyObject _ _, ConvoyObject _ _) -> x == y + (SurrenderObject, SurrenderObject) -> x == y + (WithdrawObject _, WithdrawObject _) -> x == y + (DisbandObject, DisbandObject) -> x == y + (BuildObject, BuildObject) -> x == y + (ContinueObject, ContinueObject) -> x == y +-} diff --git a/Diplomacy/OrderResolution.hs b/Diplomacy/OrderResolution.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/OrderResolution.hs @@ -0,0 +1,1162 @@ +{-| +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 OR F MAt C . + 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 diff --git a/Diplomacy/OrderType.hs b/Diplomacy/OrderType.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/OrderType.hs @@ -0,0 +1,29 @@ +{-| +Module : Diplomacy.OrderType +Description : Definition of order types +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE GADTs #-} + +module Diplomacy.OrderType ( + + OrderType(..) + + ) where + +-- | Enumeration of types of orders. Useful when DataKinds is enabled. +data OrderType where + Move :: OrderType + Support :: OrderType + Convoy :: OrderType + Withdraw :: OrderType + Surrender :: OrderType + Disband :: OrderType + Build :: OrderType + Continue :: OrderType diff --git a/Diplomacy/OrderValidation.hs b/Diplomacy/OrderValidation.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/OrderValidation.hs @@ -0,0 +1,1048 @@ +{-| +Module : Diplomacy.OrderValidation +Description : Definition of order validation +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 TypeOperators #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module Diplomacy.OrderValidation ( + + ValidityCharacterization(..) + , ArgumentList(..) + + , ValidityCriterion(..) + , SomeValidityCriterion(..) + , AdjustSetValidityCriterion(..) + , ValidityTag + , AdjustSetValidityTag + + , synthesize + , analyze + + , moveVOC + , supportVOC + , convoyVOC + , surrenderVOC + , withdrawVOC + + , AdjustSubjects(..) + , disbandSubjectVOC + , buildSubjectVOC + , continueSubjectVOC + , adjustSubjectsVOC + + ) where + +import GHC.Exts (Constraint) +import Control.Monad +import Control.Applicative +import qualified Data.Map as M +import qualified Data.Set as S +import Data.MapUtil +import Data.AtLeast +import Data.Functor.Identity +import Data.Functor.Constant +import Data.Functor.Compose +import Data.List as L +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.ZonedSubject +import Diplomacy.Occupation +import Diplomacy.Dislodgement +import Diplomacy.Control +import Diplomacy.SupplyCentreDeficit +import Diplomacy.OrderResolution + +import Debug.Trace + +-- Each one of these constructors is associated with a set. +data ValidityCriterion (phase :: Phase) (order :: OrderType) where + + MoveValidSubject :: ValidityCriterion Typical Move + MoveUnitCanOccupy :: ValidityCriterion Typical Move + MoveReachable :: ValidityCriterion Typical Move + + SupportValidSubject :: ValidityCriterion Typical Support + SupporterAdjacent :: ValidityCriterion Typical Support + SupporterCanOccupy :: ValidityCriterion Typical Support + SupportedCanDoMove :: ValidityCriterion Typical Support + + ConvoyValidSubject :: ValidityCriterion Typical Convoy + ConvoyValidConvoySubject :: ValidityCriterion Typical Convoy + ConvoyValidConvoyTarget :: ValidityCriterion Typical Convoy + + SurrenderValidSubject :: ValidityCriterion Retreat Surrender + + WithdrawValidSubject :: ValidityCriterion Retreat Withdraw + WithdrawAdjacent :: ValidityCriterion Retreat Withdraw + WithdrawUnoccupiedZone :: ValidityCriterion Retreat Withdraw + WithdrawUncontestedZone :: ValidityCriterion Retreat Withdraw + WithdrawNotDislodgingZone :: ValidityCriterion Retreat Withdraw + + ContinueValidSubject :: ValidityCriterion Adjust Continue + DisbandValidSubject :: ValidityCriterion Adjust Disband + BuildValidSubject :: ValidityCriterion Adjust Build + +deriving instance Show (ValidityCriterion phase order) +deriving instance Eq (ValidityCriterion phase order) +deriving instance Ord (ValidityCriterion phase order) + +data SomeValidityCriterion (phase :: Phase) where + SomeValidityCriterion :: ValidityCriterion phase order -> SomeValidityCriterion phase + +instance Show (SomeValidityCriterion phase) where + show (SomeValidityCriterion vc) = case vc of + MoveValidSubject -> show vc + MoveUnitCanOccupy -> show vc + MoveReachable -> show vc + SupportValidSubject -> show vc + SupporterAdjacent -> show vc + SupporterCanOccupy -> show vc + SupportedCanDoMove -> show vc + ConvoyValidSubject -> show vc + ConvoyValidConvoySubject -> show vc + ConvoyValidConvoyTarget -> show vc + SurrenderValidSubject -> show vc + WithdrawValidSubject -> show vc + WithdrawAdjacent -> show vc + WithdrawUnoccupiedZone -> show vc + WithdrawUncontestedZone -> show vc + WithdrawNotDislodgingZone -> show vc + ContinueValidSubject -> show vc + DisbandValidSubject -> show vc + BuildValidSubject -> show vc + +instance Eq (SomeValidityCriterion phase) where + SomeValidityCriterion vc1 == SomeValidityCriterion vc2 = case (vc1, vc2) of + (MoveValidSubject, MoveValidSubject) -> True + (MoveUnitCanOccupy, MoveUnitCanOccupy) -> True + (MoveReachable, MoveReachable) -> True + (SupportValidSubject, SupportValidSubject) -> True + (SupporterAdjacent, SupporterAdjacent) -> True + (SupporterCanOccupy, SupporterCanOccupy) -> True + (SupportedCanDoMove, SupportedCanDoMove) -> True + (ConvoyValidSubject, ConvoyValidSubject) -> True + (ConvoyValidConvoySubject, ConvoyValidConvoySubject) -> True + (ConvoyValidConvoyTarget, ConvoyValidConvoyTarget) -> True + (SurrenderValidSubject, SurrenderValidSubject) -> True + (WithdrawValidSubject, WithdrawValidSubject) -> True + (WithdrawAdjacent, WithdrawAdjacent) -> True + (WithdrawUnoccupiedZone, WithdrawUnoccupiedZone) -> True + (WithdrawUncontestedZone, WithdrawUncontestedZone) -> True + (WithdrawNotDislodgingZone, WithdrawNotDislodgingZone) -> True + (ContinueValidSubject, ContinueValidSubject) -> True + (DisbandValidSubject, DisbandValidSubject) -> True + (BuildValidSubject, BuildValidSubject) -> True + _ -> False + +instance Ord (SomeValidityCriterion phase) where + SomeValidityCriterion vc1 `compare` SomeValidityCriterion vc2 = + show vc1 `compare` show vc2 + +data AdjustSetValidityCriterion where + RequiredNumberOfDisbands :: AdjustSetValidityCriterion + AdmissibleNumberOfBuilds :: AdjustSetValidityCriterion + OnlyContinues :: AdjustSetValidityCriterion + +deriving instance Eq AdjustSetValidityCriterion +deriving instance Ord AdjustSetValidityCriterion +deriving instance Show AdjustSetValidityCriterion + +-- | All ProvinceTargets which a unit can legally occupy. +unitCanOccupy :: Unit -> S.Set ProvinceTarget +unitCanOccupy unit = case unit of + Army -> S.map Normal . S.filter (not . isWater) $ S.fromList [minBound..maxBound] + Fleet -> S.fromList $ do + pr <- [minBound..maxBound] + guard (not (isInland pr)) + case provinceCoasts pr of + [] -> return $ Normal pr + xs -> fmap Special xs + +-- | All places to which a unit could possibly move (without regard for +-- occupation rules as specified by unitCanOccupy). +-- The Occupation parameter is needed to determine which convoys are possible. +-- If it's nothing, we don't consider convoy routes. +validMoveAdjacency :: Maybe Occupation -> Subject -> S.Set ProvinceTarget +validMoveAdjacency occupation subject = case subjectUnit subject of + Army -> case occupation of + Nothing -> S.fromList $ neighbours pt + Just o -> (S.fromList $ neighbours pt) `S.union` (S.map Normal (convoyTargets o pr)) + Fleet -> S.fromList $ do + n <- neighbours pt + let np = ptProvince n + let ppt = ptProvince pt + -- If we have two coastal places, we must guarantee that they have a + -- common coast. + guard (not (isCoastal np) || not (isCoastal ppt) || not (null (commonCoasts pt n))) + return n + where + pt = subjectProvinceTarget subject + pr = ptProvince pt + +convoyPaths :: Occupation -> Province -> [(Province, [Province])] +convoyPaths occupation pr = + filter ((/=) pr . fst) . fmap (\(x, y, z) -> (x, y : z)) . paths occupiedByFleet pickCoastal . pure $ pr + where + occupiedByFleet pr = case provinceOccupier pr occupation of + Just aunit -> alignedThing aunit == Fleet + _ -> False + pickCoastal pr = if isCoastal pr then Just pr else Nothing + +convoyTargets :: Occupation -> Province -> S.Set Province +convoyTargets occupation = S.fromList . fmap fst . convoyPaths occupation + +validMoveTargets + :: Maybe Occupation + -> Subject + -> S.Set ProvinceTarget +validMoveTargets maybeOccupation subject = + (validMoveAdjacency maybeOccupation subject) + `S.intersection` + (unitCanOccupy (subjectUnit subject)) + +-- | Valid support targets are any place where this subject could move without +-- a convoy (this excludes the subject's own province target), and such that +-- the common coast constraint is relaxed (a Fleet in Marseilles can support +-- into Spain NC for example). +validSupportTargets + :: Subject + -> S.Set ProvinceTarget +validSupportTargets subject = S.fromList $ do + x <- S.toList $ validMoveAdjacency Nothing subject + provinceTargetCluster x + +-- | Valid support targets depend upon the support subject AND its chosen +-- target! For example, if we choose to support into Brest, then a fleet +-- in the Tyrrhenian Sea cannot be the support subject. +validSupportSubjects + :: Occupation + -> Subject + -> ProvinceTarget + -> S.Set Subject +validSupportSubjects occupation subject target = M.foldWithKey f S.empty occupation + where + pt = subjectProvinceTarget subject + f zone aunit = + -- validMoveTargets will give us non-hold targets, so we explicitly + -- handle the case of a hold. + if target == zoneProvinceTarget zone + || S.member target (validMoveTargets (Just occupation) subject') + then S.insert subject' + else id + where + subject' = (alignedThing aunit, zoneProvinceTarget zone) + +-- | Subjects which could act as convoyers: fleets in water. +validConvoyers + :: Maybe GreatPower + -> Occupation + -> S.Set Subject +validConvoyers greatPower = M.foldWithKey f S.empty + where + f zone aunit = case unit of + Fleet -> if isWater (ptProvince pt) + && ( greatPower == Nothing + || greatPower == Just (alignedGreatPower aunit) + ) + then S.insert (unit, pt) + else id + _ -> id + where + pt = zoneProvinceTarget zone + unit = alignedThing aunit + +-- | Subjects which could be convoyed: armies on coasts. +validConvoySubjects + :: Occupation + -> S.Set Subject +validConvoySubjects = M.foldWithKey f S.empty + where + f zone aunit = if unit == Army && isCoastal (ptProvince pt) + then S.insert (unit, pt) + else id + where + unit = alignedThing aunit + pt = zoneProvinceTarget zone + +-- | Valid convoy destinations: those reachable by some path of fleets in +-- water which includes the convoyer subject, and initiates at the convoying +-- subject's province target. +validConvoyTargets + :: Occupation + -> Subject + -> Subject + -> S.Set ProvinceTarget +validConvoyTargets occupation subjectConvoyer subjectConvoyed = + let allConvoyPaths = convoyPaths occupation prConvoyed + convoyPathsWithThis = filter (elem prConvoyer . snd) allConvoyPaths + in S.fromList (fmap (Normal . fst) convoyPathsWithThis) + where + prConvoyer = ptProvince (subjectProvinceTarget subjectConvoyer) + prConvoyed = ptProvince (subjectProvinceTarget subjectConvoyed) + +-- Would be nice to have difference, to simulate "not". Then we could say +-- "not contested", "not attacking province" and "not occupied" and providing +-- those contested, attacking province, and occupied sets, rather than +-- providing their complements. +-- +-- Ok, so for withdraw, we wish to say +-- +-- subject : valid subject +-- target : valid unconvoyed move target +-- & not contested area +-- & not dislodging province (of subject's province target) +-- & not occupied province +setOfAllProvinceTargets :: S.Set ProvinceTarget +setOfAllProvinceTargets = S.fromList [minBound..maxBound] + +setOfAllZones :: S.Set Zone +setOfAllZones = S.map Zone setOfAllProvinceTargets + +zoneSetToProvinceTargetSet :: S.Set Zone -> S.Set ProvinceTarget +zoneSetToProvinceTargetSet = S.fold f S.empty + where + f zone = S.union (S.fromList (provinceTargetCluster (zoneProvinceTarget zone))) + +occupiedZones :: Occupation -> S.Set Zone +occupiedZones = S.map (Zone . snd) . S.fromList . allSubjects Nothing + +-- A zone is contested iff there is at least one bounced move order to it, and +-- no successful move order to it. +contestedZones + :: M.Map Zone (Aligned Unit, SomeResolved OrderObject Typical) + -> S.Set Zone +contestedZones = M.foldWithKey g S.empty . M.fold f M.empty + where + + f :: (Aligned Unit, SomeResolved OrderObject Typical) + -> M.Map Zone Bool + -> M.Map Zone Bool + f (aunit, SomeResolved (object, res)) = case object of + MoveObject pt -> case res of + Just (MoveBounced _) -> M.alter alteration (Zone pt) + _ -> id + where + alteration (Just bool) = case res of + Nothing -> Just False + _ -> Just bool + alteration Nothing = case res of + Nothing -> Just False + _ -> Just True + _ -> id + + g :: Zone -> Bool -> S.Set Zone -> S.Set Zone + g zone bool = case bool of + True -> S.insert zone + False -> id + +-- | The Zone, if any, which dislodged a unit in this Zone, without the +-- use of a convoy! +dislodgingZones + :: M.Map Zone (Aligned Unit, SomeResolved OrderObject Typical) + -> Zone + -> S.Set Zone +dislodgingZones resolved zone = M.foldWithKey f S.empty resolved + where + f :: Zone + -> (Aligned Unit, SomeResolved OrderObject Typical) + -> S.Set Zone + -> S.Set Zone + f zone' (aunit, SomeResolved (object, res)) = case object of + MoveObject pt -> + if Zone pt == zone + then case (routes, res) of + ([], Nothing) -> S.insert zone' + _ -> id + else id + where + routes = successfulConvoyRoutes (convoyRoutes resolved subject pt) + subject = (alignedThing aunit, zoneProvinceTarget zone') + _ -> id + +{- +data AdjustPhaseOrderSet where + AdjustPhaseOrderSet + :: Maybe (Either (S.Set (Order Adjust Build)) (S.Set (Order Adjust Disband))) + -> S.Set (Order Adjust Continue) + -> AdjustPhaseOrderSet + +validAdjustOrderSet + :: GreatPower + -> Occupation + -> Control + -> Maybe (Either (S.Set (Order Adjust Build)) (S.Set (Order Adjust Disband))) +validAdjustOrderSet greatPower occupation control + -- All possible sets of build orders: + | deficit < 0 = Just . Left $ allBuildOrderSets + | deficit > 0 = Just . Right $ allDisbandOrderSets + | otherwise = Nothing + where + deficit = supplyCentreDeficit greatPower occupation control + -- To construct all build order sets, we take all subsets of the home + -- supply centres of cardinality at most |deficit| and for each of these, + -- make a subject for each kind of unit which can occupy that place. Note + -- that in the case of special areas like St. Petersburg, we have 3 options! + allBuildOrderSets = flattenSet $ (S.map . S.map) (\s -> Order (s, BuildObject)) allBuildOrderSubjects + -- To construct all disband order sets, we take all subsets of this great + -- power's subjects of cardinality exactly deficit. + -- All subsets of the home supply centres, for each unit which can go + -- there. + allDisbandOrderSets = S.empty + -- New strategy: + -- We have all of the valid ProvinceTargets. + -- For each of these, get the set of all pairs with units which can go + -- there. + -- Now pick from this set of sets; all ways to pick one from each set + -- without going over |deficit| + --allBuildOrderSubjects :: S.Set (S.Set Subject) + --allBuildOrderSubjects = S.map (S.filter (\(unit, pt) -> S.member pt (unitCanOccupy unit))) . (S.map (setCartesianProduct (S.fromList [minBound..maxBound]))) $ allBuildOrderProvinceTargetSets + allBuildOrderSubjects :: S.Set (S.Set Subject) + allBuildOrderSubjects = foldr (\i -> S.union (pickSet i candidateSubjectSets)) S.empty [0..(abs deficit)] + --allBuildOrderSubjects = S.filter ((flip (<=)) (abs deficit) . S.size) (powerSet candidateSubjects) + --candidateSubjects :: S.Set Subject + --candidateSubjects = S.filter (\(unit, pt) -> S.member pt (unitCanOccupy unit)) ((setCartesianProduct (S.fromList [minBound..maxBound])) candidateSupplyCentreSet) + candidateSubjectSets :: S.Set (S.Set Subject) + candidateSubjectSets = S.map (\pt -> S.filter (\(unit, pt) -> S.member pt (unitCanOccupy unit)) (setCartesianProduct (S.fromList [minBound..maxBound]) (S.singleton pt))) candidateSupplyCentreSet +-} + +-- All continue order subjects which would make sense without any other orders +-- in context. +candidateContinueSubjects :: GreatPower -> Occupation -> S.Set Subject +candidateContinueSubjects greatPower = S.fromList . allSubjects (Just greatPower) + +-- All disband order subjects which would make sense without any other orders +-- in context. +candidateDisbandSubjects :: GreatPower -> Occupation -> S.Set Subject +candidateDisbandSubjects greatPower = S.fromList . allSubjects (Just greatPower) + +-- All build subjects which would make sense without any other adjust orders +-- in context: unoccupied home supply centre controlled by this great power +-- which the unit could legally occupy. +candidateBuildSubjects :: GreatPower -> Occupation -> Control -> S.Set Subject +candidateBuildSubjects greatPower occupation control = + let candidateTargets = S.fromList $ candidateSupplyCentreTargets greatPower occupation control + units :: S.Set Unit + units = S.fromList $ [minBound..maxBound] + candidateSubjects :: S.Set Subject + candidateSubjects = setCartesianProduct units candidateTargets + in S.filter (\(u, pt) -> pt `S.member` unitCanOccupy u) candidateSubjects + +candidateSupplyCentreTargets :: GreatPower -> Occupation -> Control -> [ProvinceTarget] +candidateSupplyCentreTargets greatPower occupation control = filter (not . (flip zoneOccupied) occupation . Zone) (controlledHomeSupplyCentreTargets greatPower control) + +controlledHomeSupplyCentreTargets :: GreatPower -> Control -> [ProvinceTarget] +controlledHomeSupplyCentreTargets greatPower control = (controlledHomeSupplyCentres greatPower control >>= provinceTargets) + +controlledHomeSupplyCentres :: GreatPower -> Control -> [Province] +controlledHomeSupplyCentres greatPower control = filter ((==) (Just greatPower) . (flip controller) control) (homeSupplyCentres greatPower) + +homeSupplyCentres :: GreatPower -> [Province] +homeSupplyCentres greatPower = filter (isHome greatPower) supplyCentres + +setCartesianProduct :: (Ord t, Ord s) => S.Set t -> S.Set s -> S.Set (t, s) +setCartesianProduct xs ys = S.foldr (\x -> S.union (S.map ((,) x) ys)) S.empty xs + +powerSet :: Ord a => S.Set a -> S.Set (S.Set a) +powerSet = S.fold powerSetFold (S.singleton (S.empty)) + where + powerSetFold :: Ord a => a -> S.Set (S.Set a) -> S.Set (S.Set a) + powerSetFold elem pset = S.union (S.map (S.insert elem) pset) pset + +flattenSet :: Ord a => S.Set (S.Set a) -> S.Set a +flattenSet = S.foldr S.union S.empty + +setComplement :: Ord a => S.Set a -> S.Set a -> S.Set a +setComplement relativeTo = S.filter (not . (flip S.member) relativeTo) + +-- Pick 1 thing from each of the sets to get a set of cardinality at most +-- n. +-- If there are m sets in the input set, you get a set of cardinality +-- at most m. +-- If n < 0 you get the empty set. +pickSet :: Ord a => Int -> S.Set (S.Set a) -> S.Set (S.Set a) +pickSet n sets + | n <= 0 = S.singleton S.empty + | otherwise = case S.size sets of + 0 -> S.empty + m -> let xs = S.findMin sets + xss = S.delete xs sets + in case S.size xs of + 0 -> pickSet n xss + l -> let rest = pickSet (n-1) xss + in S.map (\(y, ys) -> S.insert y ys) (setCartesianProduct xs rest) `S.union` pickSet n xss + +choose :: Ord a => Int -> S.Set a -> S.Set (S.Set a) +choose n set + | n <= 0 = S.singleton (S.empty) + | otherwise = case S.size set of + 0 -> S.empty + m -> let x = S.findMin set + withoutX = choose n (S.delete x set) + withX = S.map (S.insert x) (choose (n-1) (S.delete x set)) + in withX `S.union` withoutX + +newtype Intersection t = Intersection [t] +newtype Union t = Union [t] + +evalIntersection + :: t + -> (t -> t -> t) + -> Intersection t + -> t +evalIntersection empty intersect (Intersection is) = foldr intersect empty is + +evalUnion + :: t + -> (t -> t -> t) + -> Union t + -> t +evalUnion empty union (Union us) = foldr union empty us + +-- TBD better name, obviously. +-- No Functor superclass because, due to constraints on the element type, this +-- may not really be a Functor. +class SuitableFunctor (f :: * -> *) where + type SuitableFunctorConstraint f :: * -> Constraint + suitableEmpty :: f t + suitableUnion :: SuitableFunctorConstraint f t => f t -> f t -> f t + suitableIntersect :: SuitableFunctorConstraint f t => f t -> f t -> f t + suitableMember :: SuitableFunctorConstraint f t => t -> f t -> Bool + suitableFmap + :: ( SuitableFunctorConstraint f t + , SuitableFunctorConstraint f s + ) + => (t -> s) + -> f t + -> f s + suitablePure :: SuitableFunctorConstraint f t => t -> f t + -- Instead of <*> we offer bundle, which can be used with + -- suitableFmap and uncurry to emulate <*>. + suitableBundle + :: ( SuitableFunctorConstraint f t + , SuitableFunctorConstraint f s + ) + => f t + -> f s + -> f (t, s) + suitableJoin :: SuitableFunctorConstraint f t => f (f t) -> f t + suitableBind + :: ( SuitableFunctorConstraint f t + , SuitableFunctorConstraint f (f s) + , SuitableFunctorConstraint f s + ) + => f t + -> (t -> f s) + -> f s + suitableBind x k = suitableJoin (suitableFmap k x) + +instance SuitableFunctor [] where + type SuitableFunctorConstraint [] = Eq + suitableEmpty = [] + suitableUnion = union + suitableIntersect = intersect + suitableMember = elem + suitableFmap = fmap + suitableBundle = cartesianProduct + where + cartesianProduct :: (Eq a, Eq b) => [a] -> [b] -> [(a, b)] + cartesianProduct xs ys = foldr (\x -> suitableUnion (fmap ((,) x) ys)) suitableEmpty xs + suitablePure = pure + suitableJoin = join + +-- Shit, can't throw functions into a set! +-- Ok, so Ap is out; but can implement it with join instead. +instance SuitableFunctor S.Set where + type SuitableFunctorConstraint S.Set = Ord + suitableEmpty = S.empty + suitableUnion = S.union + suitableIntersect = S.intersection + suitableMember = S.member + suitableFmap = S.map + suitableBundle = setCartesianProduct + suitablePure = S.singleton + suitableJoin = S.foldr suitableUnion suitableEmpty + +-- Description of validity is here: given the prior arguments, produce a +-- tagged union of intersections for the next argument. +data ValidityCharacterization (g :: * -> *) (f :: * -> *) (k :: [*]) where + VCNil + :: ( SuitableFunctor f + ) + => ValidityCharacterization g f '[] + VCCons + :: ( SuitableFunctor f + , SuitableFunctorConstraint f t + ) + => (ArgumentList Identity Identity ts -> TaggedIntersectionOfUnions g f t) + -> ValidityCharacterization g f ts + -> ValidityCharacterization g f (t ': ts) + +validityCharacterizationTrans + :: (forall s . g s -> h s) + -> ValidityCharacterization g f ts + -> ValidityCharacterization h f ts +validityCharacterizationTrans natTrans vc = case vc of + VCNil -> VCNil + VCCons f rest -> VCCons (taggedIntersectionOfUnionsTrans natTrans . f) (validityCharacterizationTrans natTrans rest) + +-- Each thing which we intersect is endowed with a tag (the functor g). +type TaggedIntersectionOfUnions (g :: * -> *) (f :: * -> *) (t :: *) = Intersection (g (Union (f t))) + +taggedIntersectionOfUnionsTrans + :: (forall s . g s -> h s) + -> TaggedIntersectionOfUnions g f t + -> TaggedIntersectionOfUnions h f t +taggedIntersectionOfUnionsTrans trans iou = case iou of + Intersection is -> Intersection (fmap trans is) + +evalTaggedIntersectionOfUnions + :: ( SuitableFunctor f + , SuitableFunctorConstraint f t + ) + => (forall s . g s -> s) + -> TaggedIntersectionOfUnions g f t + -> f t +evalTaggedIntersectionOfUnions exitG (Intersection is) = + -- Must take special care here, since we have no identity under intersection. + -- This is unfortunate, but necessary if we want to admit [] and Set as + -- suitable functors! + case is of + [] -> suitableEmpty + [x] -> evalUnion suitableEmpty suitableUnion (exitG x) + x : xs -> suitableIntersect (evalUnion suitableEmpty suitableUnion (exitG x)) (evalTaggedIntersectionOfUnions exitG (Intersection xs)) + +checkTaggedIntersectionOfUnions + :: ( SuitableFunctor f + , SuitableFunctorConstraint f t + ) + => (forall s . g s -> s) + -> (forall s . g s -> r) + -> r + -> (r -> r -> r) + -> t + -> TaggedIntersectionOfUnions g f t + -> r +checkTaggedIntersectionOfUnions exitG inMonoid mempty mappend x (Intersection is) = + foldr (\xs b -> if suitableMember x (evalUnion suitableEmpty suitableUnion (exitG xs)) then b else mappend (inMonoid xs) b) mempty is + +data ArgumentList (g :: * -> *) (f :: * -> *) (k :: [*]) where + ALNil :: ArgumentList g f '[] + ALCons :: g (f t) -> ArgumentList g f ts -> ArgumentList g f (t ': ts) + +type family Every (c :: * -> Constraint) (ts :: [*]) :: Constraint where + Every c '[] = () + Every c (t ': ts) = (c t, Every c ts) + +instance Every Show ts => Show (ArgumentList Identity Identity ts) where + show al = case al of + ALNil -> "ALNil" + ALCons (Identity (Identity x)) rest -> "ALCons " ++ show x ++ " (" ++ show rest ++ ")" + +instance Every Eq ts => Eq (ArgumentList Identity Identity ts) where + x == y = case (x, y) of + (ALNil, ALNil) -> True + (ALCons (Identity (Identity x')) xs, ALCons (Identity (Identity y')) ys) -> x' == y' && xs == ys + +instance (Every Ord ts, Every Eq ts) => Ord (ArgumentList Identity Identity ts) where + x `compare` y = case (x, y) of + (ALNil, ALNil) -> EQ + (ALCons (Identity (Identity x')) xs, ALCons (Identity (Identity y')) ys) -> + case x' `compare` y' of + LT -> LT + GT -> GT + EQ -> xs `compare` ys + +argListTrans + :: (forall s . g s -> h s) + -> ArgumentList g f ts + -> ArgumentList h f ts +argListTrans natTrans argList = case argList of + ALNil -> ALNil + ALCons x rest -> ALCons (natTrans x) (argListTrans natTrans rest) + +argListTrans1 + :: Functor g + => (forall s . f s -> h s) + -> ArgumentList g f ts + -> ArgumentList g h ts +argListTrans1 natTrans argList = case argList of + ALNil -> ALNil + ALCons x rest -> ALCons (fmap natTrans x) (argListTrans1 natTrans rest) + +-- This function is to use the VCCons constructor functions to build an f +-- coontaining all argument lists. Obviously, the SuitableFunctor must be +-- capable of carrying ArgumentList Identity Identity ts +-- +-- No, we should never have to union or intersect on f's containing +-- ArgumentList values, right? +evalValidityCharacterization + :: ( SuitableFunctor f + , ValidityCharacterizationConstraint f ts + ) + => ValidityCharacterization Identity f ts + -> f (ArgumentList Identity Identity ts) +evalValidityCharacterization vc = case vc of + VCNil -> suitablePure ALNil + VCCons next rest -> + let rest' = evalValidityCharacterization rest + in suitableBind rest' $ \xs -> + suitableBind (evalTaggedIntersectionOfUnions runIdentity (next xs)) $ \y -> + suitablePure (ALCons (Identity (Identity y)) xs) + +type family ValidityCharacterizationConstraint (f :: * -> *) (ts :: [*]) :: Constraint where + ValidityCharacterizationConstraint f '[] = ( + SuitableFunctorConstraint f (ArgumentList Identity Identity '[]) + ) + ValidityCharacterizationConstraint f (t ': ts) = ( + SuitableFunctorConstraint f t + , SuitableFunctorConstraint f (f t) + , SuitableFunctorConstraint f (f (ArgumentList Identity Identity (t ': ts))) + , SuitableFunctorConstraint f (t, ArgumentList Identity Identity ts) + , SuitableFunctorConstraint f (ArgumentList Identity Identity (t ': ts)) + , SuitableFunctorConstraint f (ArgumentList Identity Identity ts) + , ValidityCharacterizationConstraint f ts + ) + +type Constructor ts t = ArgumentList Identity Identity ts -> t +type Deconstructor ts t = t -> ArgumentList Identity Identity ts + +-- | VOC is an acronym for Valid Order Characterization +type VOC g f ts t = (Constructor ts t, Deconstructor ts t, ValidityCharacterization g f ts) + +synthesize + :: ( SuitableFunctor f + , SuitableFunctorConstraint f (ArgumentList Identity Identity ts) + , SuitableFunctorConstraint f t + , ValidityCharacterizationConstraint f ts + ) + => (forall s . g s -> Identity s) + -> VOC g f ts t + -> f t +synthesize trans (cons, _, vc) = + let fArgList = evalValidityCharacterization (validityCharacterizationTrans trans vc) + in suitableFmap cons fArgList + +analyze + :: (forall s . g s -> s) + -> (forall s . g s -> r) + -> r + -> (r -> r -> r) + -> VOC g f ts t + -> t + -> r +analyze exitG inMonoid mempty mappend (_, uncons, vd) x = + -- We unconstruct into an argument list, and now we must compare its + -- members with the description + let challenge = uncons x + in analyze' exitG inMonoid mempty mappend challenge vd + where + analyze' + :: (forall s . g s -> s) + -> (forall s . g s -> r) + -> r + -> (r -> r -> r) + -> ArgumentList Identity Identity ts + -> ValidityCharacterization g f ts + -> r + analyze' exitG inMonoid mempty mappend challenge vd = case (challenge, vd) of + (ALNil, VCNil) -> mempty + (ALCons (Identity (Identity x)) rest, VCCons f rest') -> + let possibilities = f rest + -- So here we are. possibilities is an intersection of unions. + -- When evaluated (intersection taken) they give the set of all + -- valid arguments here. + -- BUT here we don't just take the intersection! No, we need + -- to check membership in EACH of the intersectands, and if we + -- find there's no membership, we must grab the tag and mappend + -- it. + here = checkTaggedIntersectionOfUnions + exitG + inMonoid + mempty + mappend + x + possibilities + there = analyze' exitG inMonoid mempty mappend rest rest' + in here `mappend` there + +-- Simple example case to see if things are working somewhat well. + +type ValidityTag phase order = (,) (ValidityCriterion phase order) + +type AdjustSetValidityTag = (,) (AdjustSetValidityCriterion) + +moveVOC + :: GreatPower + -> Occupation + -> VOC (ValidityTag Typical Move) S.Set '[ProvinceTarget, Subject] (Order Typical Move) +moveVOC greatPower occupation = (cons, uncons, vc) + where + vc :: ValidityCharacterization (ValidityTag Typical Move) S.Set '[ProvinceTarget, Subject] + vc = VCCons (\(ALCons (Identity (Identity subject)) ALNil) -> Intersection [ + (MoveUnitCanOccupy, Union [unitCanOccupy (subjectUnit subject)]) + , (MoveReachable, Union [S.singleton (subjectProvinceTarget subject), validMoveAdjacency (Just occupation) subject]) + ]) + . VCCons (\ALNil -> Intersection [(MoveValidSubject, Union [S.fromList (allSubjects (Just greatPower) occupation)])]) + $ VCNil + cons :: ArgumentList Identity Identity '[ProvinceTarget, Subject] -> Order Typical Move + cons argList = case argList of + ALCons (Identity (Identity pt)) (ALCons (Identity (Identity subject)) ALNil) -> + Order (subject, MoveObject pt) + uncons :: Order Typical Move -> ArgumentList Identity Identity '[ProvinceTarget, Subject] + uncons (Order (subject, MoveObject pt)) = + ALCons (return (return pt)) (ALCons (return (return subject)) ALNil) + +supportVOC + :: GreatPower + -> Occupation + -> VOC (ValidityTag Typical Support) S.Set '[Subject, ProvinceTarget, Subject] (Order Typical Support) +supportVOC greatPower occupation = (cons, uncons, vc) + where + vc :: ValidityCharacterization (ValidityTag Typical Support) S.Set '[Subject, ProvinceTarget, Subject] + vc = -- Given a subject for the supporter, and a target for the support, we + -- characterize every valid subject which can be supported. + VCCons (\(ALCons (Identity (Identity pt)) (ALCons (Identity (Identity subject1)) ALNil)) -> Intersection [ + (SupportedCanDoMove, Union [S.filter (/= subject1) (validSupportSubjects occupation subject1 pt)]) + ]) + -- Given a subject for the supporter, we check every place into which + -- that supporter could offer support; that's every place where it + -- could move without a convoy. + . VCCons (\(ALCons (Identity (Identity subject)) ALNil) -> Intersection [ + (SupporterCanOccupy, Union [unitCanOccupy (subjectUnit subject)]) + , (SupporterAdjacent, Union [validSupportTargets subject]) + ]) + . VCCons (\ALNil -> Intersection [(SupportValidSubject, Union [S.fromList (allSubjects (Just greatPower) occupation)])]) + $ VCNil + cons :: ArgumentList Identity Identity '[Subject, ProvinceTarget, Subject] -> Order Typical Support + cons argList = case argList of + ALCons (Identity (Identity subject2)) (ALCons (Identity (Identity pt)) (ALCons (Identity (Identity subject1)) ALNil)) -> + Order (subject1, SupportObject subject2 pt) + uncons :: Order Typical Support -> ArgumentList Identity Identity '[Subject, ProvinceTarget, Subject] + uncons order = case order of + Order (subject1, SupportObject subject2 pt) -> + ALCons (Identity (Identity subject2)) (ALCons (Identity (Identity pt)) (ALCons (Identity (Identity subject1)) ALNil)) + +convoyVOC + :: GreatPower + -> Occupation + -> VOC (ValidityTag Typical Convoy) S.Set '[ProvinceTarget, Subject, Subject] (Order Typical Convoy) +convoyVOC greatPower occupation = (cons, uncons, vc) + where + vc :: ValidityCharacterization (ValidityTag Typical Convoy) S.Set '[ProvinceTarget, Subject, Subject] + vc = VCCons (\(ALCons (Identity (Identity convoyed)) (ALCons (Identity (Identity convoyer)) ALNil)) -> Intersection [ + (ConvoyValidConvoyTarget, Union [validConvoyTargets occupation convoyer convoyed]) + ]) + . VCCons (\(ALCons (Identity (Identity subject)) ALNil) -> Intersection [ + (ConvoyValidConvoySubject, Union [validConvoySubjects occupation]) + ]) + . VCCons (\ALNil -> Intersection [ + (ConvoyValidSubject, Union [validConvoyers (Just greatPower) occupation]) + ]) + $ VCNil + cons :: ArgumentList Identity Identity '[ProvinceTarget, Subject, Subject] -> Order Typical Convoy + cons al = case al of + ALCons (Identity (Identity pt)) (ALCons (Identity (Identity convoyed)) (ALCons (Identity (Identity convoyer)) ALNil)) -> + Order (convoyer, ConvoyObject convoyed pt) + uncons :: Order Typical Convoy -> ArgumentList Identity Identity '[ProvinceTarget, Subject, Subject] + uncons order = case order of + Order (convoyer, ConvoyObject convoyed pt) -> + ALCons (Identity (Identity pt)) (ALCons (Identity (Identity convoyed)) (ALCons (Identity (Identity convoyer)) ALNil)) + +surrenderVOC + :: GreatPower + -> Dislodgement + -> VOC (ValidityTag Retreat Surrender) S.Set '[Subject] (Order Retreat Surrender) +surrenderVOC greatPower dislodgement = (cons, uncons, vc) + where + vc = VCCons (\ALNil -> Intersection [ + (SurrenderValidSubject, Union [S.fromList (allSubjects (Just greatPower) dislodgement)]) + ]) + $ VCNil + cons :: ArgumentList Identity Identity '[Subject] -> Order Retreat Surrender + cons al = case al of + ALCons (Identity (Identity subject)) ALNil -> + Order (subject, SurrenderObject) + uncons :: Order Retreat Surrender -> ArgumentList Identity Identity '[Subject] + uncons order = case order of + Order (subject, SurrenderObject) -> + ALCons (Identity (Identity subject)) ALNil + +withdrawVOC + :: GreatPower + -> M.Map Zone (Aligned Unit, SomeResolved OrderObject Typical) + -> VOC (ValidityTag Retreat Withdraw) S.Set '[ProvinceTarget, Subject] (Order Retreat Withdraw) +withdrawVOC greatPower resolved = (cons, uncons, vc) + where + (dislodgement, occupation) = dislodgementAndOccupation resolved + vc = VCCons (\(ALCons (Identity (Identity subject)) ALNil) -> Intersection [ + (WithdrawAdjacent, Union [validMoveTargets Nothing subject]) + , (WithdrawNotDislodgingZone, Union [zoneSetToProvinceTargetSet $ S.difference setOfAllZones (dislodgingZones resolved (Zone (subjectProvinceTarget subject)))]) + , (WithdrawUncontestedZone, Union [zoneSetToProvinceTargetSet $ S.difference setOfAllZones (contestedZones resolved)]) + , (WithdrawUnoccupiedZone, Union [zoneSetToProvinceTargetSet $ S.difference setOfAllZones (occupiedZones occupation)]) + ]) + . VCCons (\ALNil -> Intersection [ + (WithdrawValidSubject, Union [S.fromList (allSubjects (Just greatPower) dislodgement)]) + ]) + $ VCNil + cons :: ArgumentList Identity Identity '[ProvinceTarget, Subject] -> Order Retreat Withdraw + cons al = case al of + ALCons (Identity (Identity pt)) (ALCons (Identity (Identity subject)) ALNil) -> + Order (subject, WithdrawObject pt) + uncons :: Order Retreat Withdraw -> ArgumentList Identity Identity '[ProvinceTarget, Subject] + uncons order = case order of + Order (subject, WithdrawObject pt) -> + ALCons (Identity (Identity pt)) (ALCons (Identity (Identity subject)) ALNil) + +continueSubjectVOC + :: GreatPower + -> Occupation + -> VOC (ValidityTag Adjust Continue) S.Set '[Subject] Subject +continueSubjectVOC greatPower occupation = (cons, uncons, vc) + where + vc :: ValidityCharacterization (ValidityTag Adjust Continue) S.Set '[Subject] + vc = VCCons (\ALNil -> Intersection [(ContinueValidSubject, Union [candidateContinueSubjects greatPower occupation])]) + $ VCNil + cons :: ArgumentList Identity Identity '[Subject] -> Subject + cons al = case al of + ALCons (Identity (Identity subject)) ALNil -> subject + uncons :: Subject -> ArgumentList Identity Identity '[Subject] + uncons subject = + ALCons (Identity (Identity subject)) ALNil + +disbandSubjectVOC + :: GreatPower + -> Occupation + -> VOC (ValidityTag Adjust Disband) S.Set '[Subject] Subject +disbandSubjectVOC greatPower occupation = (cons, uncons, vc) + where + vc :: ValidityCharacterization (ValidityTag Adjust Disband) S.Set '[Subject] + vc = VCCons (\ALNil -> Intersection [(DisbandValidSubject, Union [candidateDisbandSubjects greatPower occupation])]) + $ VCNil + cons :: ArgumentList Identity Identity '[Subject] -> Subject + cons al = case al of + ALCons (Identity (Identity subject)) ALNil -> subject + uncons :: Subject -> ArgumentList Identity Identity '[Subject] + uncons subject = + ALCons (Identity (Identity subject)) ALNil + +-- Not a very useful factoring. Oh well, can make it sharper later if needed. +buildSubjectVOC + :: GreatPower + -> Occupation + -> Control + -> VOC (ValidityTag Adjust Build) S.Set '[Subject] Subject +buildSubjectVOC greatPower occupation control = (cons, uncons, vc) + where + vc :: ValidityCharacterization (ValidityTag Adjust Build) S.Set '[Subject] + vc = VCCons (\ALNil -> Intersection [(BuildValidSubject, Union [candidateBuildSubjects greatPower occupation control])]) + $ VCNil + cons :: ArgumentList Identity Identity '[Subject] -> Subject + cons al = case al of + ALCons (Identity (Identity subject)) ALNil -> subject + uncons :: Subject -> ArgumentList Identity Identity '[Subject] + uncons subject = + ALCons (Identity (Identity subject)) ALNil + +-- Next up: given the set of adjust orders (special datatype or really +-- a set of SomeOrder?) give the valid subsets. Special datatype. +data AdjustSubjects = AdjustSubjects { + buildSubjects :: S.Set Subject + , disbandSubjects :: S.Set Subject + , continueSubjects :: S.Set Subject + } + deriving (Eq, Ord, Show) + +-- Here we assume that all of the subjects are valid according to +-- the characterizations with the SAME occupation, control, and great power. +-- +-- Really though, what should be the output? Sets of SomeOrder are annoying, +-- because the Ord instance there is not trivial. Why not sets of +-- AdjustSubjects as we have here? +-- For 0 deficit, we give the singleton set of the AdjustSubjects in +-- which we make the build and disband sets empty. +-- For > 0 deficit, we take all deficit-element subsets of the disband +-- subjects, and for each of them we throw in the complement relative to +-- the continue subjects, and no build subjects. +-- For < 0 deficit, we take all (-deficit)-element or less subsets of the +-- build subjects, and for each of them we throw in the complement relative +-- to the continue subjects, and no disband subjects. +adjustSubjectsVOC + :: GreatPower + -> Occupation + -> Control + -> AdjustSubjects + -> VOC AdjustSetValidityTag S.Set '[AdjustSubjects] AdjustSubjects +adjustSubjectsVOC greatPower occupation control subjects = (cons, uncons, vc) + where + deficit = supplyCentreDeficit greatPower occupation control + vc :: ValidityCharacterization AdjustSetValidityTag S.Set '[AdjustSubjects] + vc = VCCons (\ALNil -> tiu) + $ VCNil + cons :: ArgumentList Identity Identity '[AdjustSubjects] -> AdjustSubjects + cons al = case al of + ALCons (Identity (Identity x)) ALNil -> x + uncons :: AdjustSubjects -> ArgumentList Identity Identity '[AdjustSubjects] + uncons x = + ALCons (Identity (Identity x)) ALNil + tiu :: TaggedIntersectionOfUnions AdjustSetValidityTag S.Set AdjustSubjects + tiu | deficit > 0 = let disbandSets = choose deficit disbands + pairs = S.map (\xs -> (xs, continues `S.difference` xs)) disbandSets + valids :: S.Set AdjustSubjects + valids = S.map (\(disbands, continues) -> AdjustSubjects S.empty disbands continues) pairs + in Intersection [(RequiredNumberOfDisbands, Union (fmap S.singleton (S.toList valids)))] + | deficit < 0 = let buildSetsUnzoned :: [S.Set (S.Set Subject)] + buildSetsUnzoned = fmap (\n -> choose n builds) [0..(-deficit)] + -- buildSetsUnzoned is not quite what we want; its + -- member sets may include subjects of the same + -- zone. A fleet in Marseilles and an army in + -- Marseilles, for instance. To remedy this, we + -- set-map each one to and from ZonedSubjectDull, + -- whose Eq/Ord instances ignore the unit and uses + -- zone-equality. Then, to rule out duplicate sets, + -- we do this again with the ZonedSubjectSharp + -- type, which uses zone-equality but does not + -- ignore the unit. This ensure that, for instance, + -- the sets {(Fleet, Marseilles)} and + -- {(Army, Marseilles)} can coexist in buildSets. + buildSets :: [S.Set (S.Set Subject)] + buildSets = + fmap + (S.map (S.map zonedSubjectSharp) . (S.map (S.map (ZonedSubjectSharp . zonedSubjectDull) . (S.map ZonedSubjectDull)))) + buildSetsUnzoned + pairs :: [S.Set (S.Set Subject, S.Set Subject)] + pairs = (fmap . S.map) (\xs -> (xs, continues `S.difference` xs)) buildSets + valids :: [S.Set AdjustSubjects] + valids = (fmap . S.map) (\(builds, continues) -> AdjustSubjects builds S.empty continues) pairs + in Intersection [(AdmissibleNumberOfBuilds, Union valids)] + | otherwise = Intersection [(OnlyContinues, Union [S.singleton (AdjustSubjects S.empty S.empty continues)])] + builds = buildSubjects subjects + disbands = disbandSubjects subjects + continues = continueSubjects subjects diff --git a/Diplomacy/Phase.hs b/Diplomacy/Phase.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/Phase.hs @@ -0,0 +1,30 @@ +{-| +Module : Diplomacy.Phase +Description : Definition of phases of play +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Diplomacy.Phase ( + + Phase(..) + + ) where + +data Phase where + Typical :: Phase + Retreat :: Phase + Adjust :: Phase + +deriving instance Show Phase +deriving instance Eq Phase +deriving instance Ord Phase +deriving instance Enum Phase +deriving instance Bounded Phase diff --git a/Diplomacy/Province.hs b/Diplomacy/Province.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/Province.hs @@ -0,0 +1,859 @@ +{-| +Module : Diplomacy.Province +Description : Definitions related to places on the diplomacy board. +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +module Diplomacy.Province ( + + Province(..) + + , adjacency + , adjacent + , isSameOrAdjacent + + , neighbours + , isSameOrNeighbour + , provinceCommonNeighbours + , provinceCommonCoasts + , commonNeighbours + , commonCoasts + + , ProvinceType(..) + , provinceType + , supplyCentre + , supplyCentres + + , isCoastal + , isInland + , isWater + + , country + , isHome + + , ProvinceCoast(..) + , pcProvince + , provinceCoasts + + , ProvinceTarget(..) + + , isNormal + , isSpecial + + , ptProvince + + , provinceTargets + , provinceTargetCluster + + , shortestPath + , distance + , distanceFromHomeSupplyCentre + + , parseProvince + , parseProvinceTarget + + , printProvince + , printProvinceTarget + + , paths + + ) where + +import Control.Monad (guard) +import Control.Applicative +import qualified Data.Set as S +import Data.String (fromString, IsString) +import Data.List (sort) +import Diplomacy.GreatPower +import Text.Parsec hiding ((<|>)) +import Text.Parsec.Text + +-- | Enumeration of the places on the diplomacy board. +data Province + = Bohemia + | Budapest + | Galicia + | Trieste + | Tyrolia + | Vienna + | Clyde + | Edinburgh + | Liverpool + | London + | Wales + | Yorkshire + | Brest + | Burgundy + | Gascony + | Marseilles + | Paris + | Picardy + | Berlin + | Kiel + | Munich + | Prussia + | Ruhr + | Silesia + | Apulia + | Naples + | Piedmont + | Rome + | Tuscany + | Venice + | Livonia + | Moscow + | Sevastopol + | StPetersburg + | Ukraine + | Warsaw + | Ankara + | Armenia + | Constantinople + | Smyrna + | Syria + | Albania + | Belgium + | Bulgaria + | Finland + | Greece + | Holland + | Norway + | NorthAfrica + | Portugal + | Rumania + | Serbia + | Spain + | Sweden + | Tunis + | Denmark + | AdriaticSea + | AegeanSea + | BalticSea + | BarentsSea + | BlackSea + | EasternMediterranean + | EnglishChannel + | GulfOfBothnia + | GulfOfLyon + | HeligolandBight + | IonianSea + | IrishSea + | MidAtlanticOcean + | NorthAtlanticOcean + | NorthSea + | NorwegianSea + | Skagerrak + | TyrrhenianSea + | WesternMediterranean + deriving (Eq, Ord, Enum, Bounded, Show) + +data ProvinceType = Inland | Water | Coastal + deriving (Eq, Ord, Enum, Bounded, Show) + +provinceType :: Province -> ProvinceType +provinceType Bohemia = Inland +provinceType Budapest = Inland +provinceType Galicia = Inland +provinceType Trieste = Coastal +provinceType Tyrolia = Inland +provinceType Vienna = Inland +provinceType Clyde = Coastal +provinceType Edinburgh = Coastal +provinceType Liverpool = Coastal +provinceType London = Coastal +provinceType Wales = Coastal +provinceType Yorkshire = Coastal +provinceType Brest = Coastal +provinceType Burgundy = Inland +provinceType Gascony = Coastal +provinceType Marseilles = Coastal +provinceType Paris = Inland +provinceType Picardy = Coastal +provinceType Berlin = Coastal +provinceType Kiel = Coastal +provinceType Munich = Inland +provinceType Prussia = Coastal +provinceType Ruhr = Inland +provinceType Silesia = Inland +provinceType Apulia = Coastal +provinceType Naples = Coastal +provinceType Piedmont = Coastal +provinceType Rome = Coastal +provinceType Tuscany = Coastal +provinceType Venice = Coastal +provinceType Livonia = Coastal +provinceType Moscow = Inland +provinceType Sevastopol = Coastal +provinceType StPetersburg = Coastal +provinceType Ukraine = Inland +provinceType Warsaw = Inland +provinceType Ankara = Coastal +provinceType Armenia = Coastal +provinceType Constantinople = Coastal +provinceType Smyrna = Coastal +provinceType Syria = Coastal +provinceType Albania = Coastal +provinceType Belgium = Coastal +provinceType Bulgaria = Coastal +provinceType Finland = Coastal +provinceType Greece = Coastal +provinceType Holland = Coastal +provinceType Norway = Coastal +provinceType NorthAfrica = Coastal +provinceType Portugal = Coastal +provinceType Rumania = Coastal +provinceType Serbia = Inland +provinceType Spain = Coastal +provinceType Sweden = Coastal +provinceType Tunis = Coastal +provinceType Denmark = Coastal +provinceType AdriaticSea = Water +provinceType AegeanSea = Water +provinceType BalticSea = Water +provinceType BarentsSea = Water +provinceType BlackSea = Water +provinceType EasternMediterranean = Water +provinceType EnglishChannel = Water +provinceType GulfOfBothnia = Water +provinceType GulfOfLyon = Water +provinceType HeligolandBight = Water +provinceType IonianSea = Water +provinceType IrishSea = Water +provinceType MidAtlanticOcean = Water +provinceType NorthAtlanticOcean = Water +provinceType NorthSea = Water +provinceType NorwegianSea = Water +provinceType Skagerrak = Water +provinceType TyrrhenianSea = Water +provinceType WesternMediterranean = Water + +-- | A Province @p@ is adjacent to (borders) all Provinces in @adjacency p@. +-- This is symmetric and antireflexive. +adjacency :: Province -> [Province] +adjacency Bohemia = [Munich, Tyrolia, Vienna, Silesia, Galicia] +adjacency Budapest = [Vienna, Galicia, Rumania, Serbia, Trieste] +adjacency Galicia = [Warsaw, Silesia, Ukraine, Rumania, Budapest, Vienna, Bohemia] +adjacency Trieste = [AdriaticSea, Venice, Tyrolia, Vienna, Budapest, Serbia, Albania] +adjacency Tyrolia = [Piedmont, Munich, Bohemia, Vienna, Trieste, Venice] +adjacency Vienna = [Trieste, Tyrolia, Bohemia, Galicia, Budapest] +adjacency Clyde = [NorthAtlanticOcean, NorwegianSea, Edinburgh, Liverpool] +adjacency Edinburgh = [Clyde, NorwegianSea, NorthSea, Yorkshire, Liverpool] +adjacency Liverpool = [NorthAtlanticOcean, IrishSea, Clyde, Edinburgh, Yorkshire, Wales] +adjacency London = [NorthSea, EnglishChannel, Wales, Yorkshire] +adjacency Wales = [IrishSea, EnglishChannel, London, Yorkshire, Liverpool] +adjacency Yorkshire = [Liverpool, Edinburgh, London, Wales, NorthSea] +adjacency Brest = [EnglishChannel, MidAtlanticOcean, Picardy, Paris, Gascony] +adjacency Burgundy = [Paris, Picardy, Belgium, Ruhr, Munich, Marseilles, Gascony] +adjacency Gascony = [MidAtlanticOcean, Spain, Brest, Paris, Burgundy, Marseilles] +adjacency Marseilles = [GulfOfLyon, Spain, Gascony, Burgundy, Piedmont] +adjacency Paris = [Brest, Picardy, Burgundy, Gascony] +adjacency Picardy = [EnglishChannel, Belgium, Burgundy, Paris, Brest] +adjacency Berlin = [BalticSea, Prussia, Silesia, Munich, Kiel] +adjacency Kiel = [HeligolandBight, Berlin, Munich, Ruhr, Holland, Denmark, BalticSea] +adjacency Munich = [Ruhr, Kiel, Berlin, Silesia, Bohemia, Tyrolia, Burgundy] +adjacency Prussia = [BalticSea, Livonia, Warsaw, Silesia, Berlin] +adjacency Ruhr = [Belgium, Holland, Kiel, Munich, Burgundy] +adjacency Silesia = [Munich, Berlin, Prussia, Warsaw, Galicia, Bohemia] +adjacency Apulia = [AdriaticSea, IonianSea, Naples, Rome, Venice] +adjacency Naples = [IonianSea, TyrrhenianSea, Apulia, Rome] +adjacency Piedmont = [Marseilles, Tyrolia, GulfOfLyon, Venice, Tuscany] +adjacency Rome = [TyrrhenianSea, Naples, Tuscany, Venice, Apulia] +adjacency Tuscany = [GulfOfLyon, Piedmont, Venice, Rome, TyrrhenianSea] +adjacency Venice = [Piedmont, Tyrolia, Trieste, AdriaticSea, Apulia, Tuscany, Rome] +adjacency Livonia = [BalticSea, GulfOfBothnia, StPetersburg, Moscow, Warsaw, Prussia] +adjacency Moscow = [StPetersburg, Sevastopol, Ukraine, Warsaw, Livonia] +adjacency Sevastopol = [Armenia, BlackSea, Rumania, Ukraine, Moscow] +adjacency StPetersburg = [BarentsSea, Moscow, Livonia, GulfOfBothnia, Finland, Norway] +adjacency Ukraine = [Moscow, Sevastopol, Rumania, Galicia, Warsaw] +adjacency Warsaw = [Prussia, Livonia, Moscow, Ukraine, Galicia, Silesia] +adjacency Ankara = [BlackSea, Armenia, Smyrna, Constantinople] +adjacency Armenia = [BlackSea, Sevastopol, Syria, Ankara, Smyrna] +adjacency Constantinople = [BlackSea, Ankara, Smyrna, Bulgaria, AegeanSea] +adjacency Smyrna = [EasternMediterranean, AegeanSea, Constantinople, Ankara, Armenia, Syria] +adjacency Syria = [Armenia, Smyrna, EasternMediterranean] +adjacency Albania = [AdriaticSea, Trieste, Serbia, Greece, IonianSea] +adjacency Belgium = [Holland, Ruhr, Burgundy, Picardy, EnglishChannel, NorthSea] +adjacency Bulgaria = [Rumania, BlackSea, Constantinople, AegeanSea, Greece, Serbia] +adjacency Finland = [StPetersburg, Sweden, Norway, GulfOfBothnia] +adjacency Greece = [IonianSea, AegeanSea, Albania, Serbia, Bulgaria] +adjacency Holland = [Belgium, NorthSea, Kiel, Ruhr, HeligolandBight] +adjacency Norway = [NorwegianSea, NorthSea, Sweden, Finland, Skagerrak, BarentsSea, StPetersburg] +adjacency NorthAfrica = [MidAtlanticOcean, WesternMediterranean, Tunis] +adjacency Portugal = [MidAtlanticOcean, Spain] +adjacency Rumania = [BlackSea, Bulgaria, Serbia, Budapest, Galicia, Ukraine, Sevastopol] +adjacency Serbia = [Trieste, Budapest, Rumania, Bulgaria, Greece, Albania] +adjacency Spain = [Portugal, MidAtlanticOcean, Gascony, GulfOfLyon, WesternMediterranean, Marseilles] +adjacency Sweden = [GulfOfBothnia, Finland, Norway, BalticSea, Skagerrak, Denmark] +adjacency Tunis = [NorthAfrica, WesternMediterranean, IonianSea, TyrrhenianSea] +adjacency Denmark = [BalticSea, Skagerrak, HeligolandBight, Kiel, NorthSea, Sweden] +adjacency AdriaticSea = [Trieste, Venice, Apulia, Albania, IonianSea] +adjacency AegeanSea = [Greece, Bulgaria, Constantinople, Smyrna, EasternMediterranean, IonianSea] +adjacency BalticSea = [Sweden, GulfOfBothnia, Livonia, Prussia, Berlin, Kiel, Denmark] +adjacency BarentsSea = [StPetersburg, Norway, NorwegianSea] +adjacency BlackSea = [Sevastopol, Armenia, Ankara, Constantinople, Bulgaria, Rumania] +adjacency EasternMediterranean = [Syria, IonianSea, AegeanSea, Smyrna] +adjacency EnglishChannel = [London, Belgium, Picardy, Brest, MidAtlanticOcean, IrishSea, Wales, NorthSea] +adjacency GulfOfBothnia = [Sweden, Finland, Livonia, StPetersburg, BalticSea] +adjacency GulfOfLyon = [Marseilles, Piedmont, Tuscany, TyrrhenianSea, WesternMediterranean, Spain] +adjacency HeligolandBight = [Denmark, Kiel, Holland, NorthSea] +adjacency IonianSea = [Tunis, TyrrhenianSea, Naples, Apulia, AdriaticSea, Greece, Albania, AegeanSea, EasternMediterranean] +adjacency IrishSea = [NorthAtlanticOcean, EnglishChannel, MidAtlanticOcean, Liverpool, Wales] +adjacency MidAtlanticOcean = [NorthAtlanticOcean, IrishSea, EnglishChannel, Brest, Gascony, Spain, Portugal, WesternMediterranean, NorthAfrica] +adjacency NorthAtlanticOcean = [NorwegianSea, Clyde, Liverpool, IrishSea, MidAtlanticOcean] +adjacency NorthSea = [NorwegianSea, Skagerrak, Denmark, HeligolandBight, Holland, Belgium, EnglishChannel, London, Yorkshire, Edinburgh, Norway] +adjacency NorwegianSea = [NorthAtlanticOcean, Norway, BarentsSea, NorthSea, Clyde, Edinburgh] +adjacency Skagerrak = [Norway, Sweden, Denmark, NorthSea] +adjacency TyrrhenianSea = [GulfOfLyon, WesternMediterranean, Tunis, Tuscany, Rome, Naples, IonianSea] +adjacency WesternMediterranean = [NorthAfrica, MidAtlanticOcean, GulfOfLyon, Spain, Tunis, TyrrhenianSea] + +adjacent :: Province -> Province -> Bool +adjacent prv0 prv1 = prv0 `elem` (adjacency prv1) + +isSameOrAdjacent :: Province -> Province -> Bool +isSameOrAdjacent prv0 prv1 = prv0 == prv1 || adjacent prv0 prv1 + +-- | Indicates whether a Province is a supply centre. +supplyCentre :: Province -> Bool +supplyCentre Norway = True +supplyCentre Sweden = True +supplyCentre Denmark = True +supplyCentre StPetersburg = True +supplyCentre Moscow = True +supplyCentre Sevastopol = True +supplyCentre Ankara = True +supplyCentre Smyrna = True +supplyCentre Constantinople = True +supplyCentre Rumania = True +supplyCentre Bulgaria = True +supplyCentre Greece = True +supplyCentre Serbia = True +supplyCentre Warsaw = True +supplyCentre Budapest = True +supplyCentre Vienna = True +supplyCentre Trieste = True +supplyCentre Berlin = True +supplyCentre Kiel = True +supplyCentre Munich = True +supplyCentre Venice = True +supplyCentre Rome = True +supplyCentre Naples = True +supplyCentre Tunis = True +supplyCentre Spain = True +supplyCentre Portugal = True +supplyCentre Marseilles = True +supplyCentre Paris = True +supplyCentre Brest = True +supplyCentre Belgium = True +supplyCentre Holland = True +supplyCentre London = True +supplyCentre Liverpool = True +supplyCentre Edinburgh = True +supplyCentre _ = False + +-- | All supply centres. +supplyCentres :: [Province] +supplyCentres = filter supplyCentre [minBound..maxBound] + +-- | Some provinces belong to a country. +-- This is useful in conjunction with supplyCentre to determine which +-- provinces can be used by a given country to build a unit. +-- It is distinct from the in-game notion of control. Although Brest +-- belongs to France, it may be controlled by some other power. +country :: Province -> Maybe GreatPower +country Bohemia = Just Austria +country Budapest = Just Austria +country Galicia = Just Austria +country Trieste = Just Austria +country Tyrolia = Just Austria +country Vienna = Just Austria +country Clyde = Just England +country Edinburgh = Just England +country Liverpool = Just England +country London = Just England +country Wales = Just England +country Yorkshire = Just England +country Brest = Just France +country Burgundy = Just France +country Gascony = Just France +country Marseilles = Just France +country Paris = Just France +country Picardy = Just France +country Berlin = Just Germany +country Kiel = Just Germany +country Munich = Just Germany +country Prussia = Just Germany +country Ruhr = Just Germany +country Silesia = Just Germany +country Apulia = Just Italy +country Naples = Just Italy +country Piedmont = Just Italy +country Rome = Just Italy +country Tuscany = Just Italy +country Venice = Just Italy +country Livonia = Just Russia +country Moscow = Just Russia +country Sevastopol = Just Russia +country StPetersburg = Just Russia +country Ukraine = Just Russia +country Warsaw = Just Russia +country Ankara = Just Turkey +country Armenia = Just Turkey +country Constantinople = Just Turkey +country Smyrna = Just Turkey +country Syria = Just Turkey +country Albania = Nothing +country Belgium = Nothing +country Bulgaria = Nothing +country Finland = Nothing +country Greece = Nothing +country Holland = Nothing +country Norway = Nothing +country NorthAfrica = Nothing +country Portugal = Nothing +country Rumania = Nothing +country Serbia = Nothing +country Spain = Nothing +country Sweden = Nothing +country Tunis = Nothing +country Denmark = Nothing +country AdriaticSea = Nothing +country AegeanSea = Nothing +country BalticSea = Nothing +country BarentsSea = Nothing +country BlackSea = Nothing +country EasternMediterranean = Nothing +country EnglishChannel = Nothing +country GulfOfBothnia = Nothing +country GulfOfLyon = Nothing +country HeligolandBight = Nothing +country IonianSea = Nothing +country IrishSea = Nothing +country MidAtlanticOcean = Nothing +country NorthAtlanticOcean = Nothing +country NorthSea = Nothing +country NorwegianSea = Nothing +country Skagerrak = Nothing +country TyrrhenianSea = Nothing +country WesternMediterranean = Nothing + +isHome :: GreatPower -> Province -> Bool +isHome c p = maybe False ((==) c) (country p) + +-- | These are the special coasts, for @Province@s which have more than one +-- coast. +data ProvinceCoast + = StPetersburgNorth + | StPetersburgSouth + | SpainNorth + | SpainSouth + | BulgariaEast + | BulgariaSouth + deriving (Eq, Ord, Enum, Bounded) + +instance Show ProvinceCoast where + show StPetersburgNorth = "StP NC" + show StPetersburgSouth = "StP SC" + show SpainNorth = "Spa NC" + show SpainSouth = "Spa SC" + show BulgariaEast = "Bul EC" + show BulgariaSouth = "Bul SC" + +-- | The @Province@ to which a @ProvinceCoast@ belongs. +pcProvince :: ProvinceCoast -> Province +pcProvince StPetersburgNorth = StPetersburg +pcProvince StPetersburgSouth = StPetersburg +pcProvince SpainNorth = Spain +pcProvince SpainSouth = Spain +pcProvince BulgariaEast = Bulgaria +pcProvince BulgariaSouth = Bulgaria + +-- | The @ProvinceCoast@s which belong to a @Province@. +provinceCoasts :: Province -> [ProvinceCoast] +provinceCoasts StPetersburg = [StPetersburgNorth, StPetersburgSouth] +provinceCoasts Spain = [SpainNorth, SpainSouth] +provinceCoasts Bulgaria = [BulgariaEast, BulgariaSouth] +provinceCoasts _ = [] + +-- | This type contains all places where some unit could be stationed. +data ProvinceTarget + = Normal Province + | Special ProvinceCoast + deriving (Eq, Ord) + +instance Show ProvinceTarget where + show (Normal province) = show province + show (Special provinceCoast) = show provinceCoast + +instance Enum ProvinceTarget where + fromEnum pt = case pt of + Normal pr -> fromEnum pr + Special pc -> fromEnum (maxBound :: Province) + fromEnum pc + toEnum n | n < fromEnum (minBound :: Province) = error "ProvinceTarget.toEnum : index too small." + | n <= fromEnum (maxBound :: Province) = Normal (toEnum n) + | n <= fromEnum (maxBound :: Province) + fromEnum (maxBound :: ProvinceCoast) + 1 = Special (toEnum (n - fromEnum (maxBound :: Province) - 1)) + | otherwise = error "ProvinceTarget.toEnum : index too large." + +instance Bounded ProvinceTarget where + minBound = Normal minBound + maxBound = Special maxBound + +isSpecial :: ProvinceTarget -> Bool +isSpecial (Special _) = True +isSpecial _ = False + +isNormal :: ProvinceTarget -> Bool +isNormal (Normal _) = True +isNormal _ = False + +-- | All @ProvinceTarget@s associated with a @Province@. For @Province@s with +-- 0 or 1 coast, @provinceTargets p = [Normal p]@. +provinceTargets :: Province -> [ProvinceTarget] +provinceTargets x = Normal x : (map Special (provinceCoasts x)) + +-- | All @ProvinceTarget@s which belong to the same @Province@ as this one. +provinceTargetCluster :: ProvinceTarget -> [ProvinceTarget] +provinceTargetCluster (Normal x) = provinceTargets x +provinceTargetCluster (Special c) = (Normal $ pcProvince c) : (map Special (provinceCoasts (pcProvince c))) + +ptProvince :: ProvinceTarget -> Province +ptProvince (Normal p) = p +ptProvince (Special c) = pcProvince c + +isCoastal :: Province -> Bool +isCoastal prv = case provinceType prv of + Coastal -> True + _ -> False + +isInland :: Province -> Bool +isInland prv = case provinceType prv of + Inland -> True + _ -> False + +isWater :: Province -> Bool +isWater prv = case provinceType prv of + Water -> True + _ -> False + +-- | True iff the given province should not be considered adjacent to the +-- given province coast, even though they are adjacent as provinces. +blacklist :: Province -> ProvinceTarget -> Bool +blacklist p (Special c) = coastBlacklist p c + where + coastBlacklist :: Province -> ProvinceCoast -> Bool + coastBlacklist WesternMediterranean SpainNorth = True + coastBlacklist GulfOfLyon SpainNorth = True + coastBlacklist Gascony SpainSouth = True + coastBlacklist Marseilles SpainNorth = True + -- NB MidAtlanticOcean to SpainSouth is fine! + coastBlacklist GulfOfBothnia StPetersburgNorth = True + coastBlacklist BarentsSea StPetersburgSouth = True + coastBlacklist BlackSea BulgariaSouth = True + coastBlacklist AegeanSea BulgariaEast = True + coastBlacklist _ _ = False +blacklist _ _ = False + +provinceCommonNeighbours :: Province -> Province -> [Province] +provinceCommonNeighbours province1 province2 = + [ x | x <- adjacency province1, y <- adjacency province2, x == y ] + +provinceCommonCoasts :: Province -> Province -> [Province] +provinceCommonCoasts province1 province2 = + filter isWater (provinceCommonNeighbours province1 province2) + +-- | This is like adjacency but for @ProvinceTargets@, +-- and takes into consideration the special cases of multi-coast @Province@s. +neighbours :: ProvinceTarget -> [ProvinceTarget] +neighbours pt1 = do + x <- adjacency (ptProvince pt1) + guard $ not (blacklist x pt1) + y <- provinceTargets x + guard $ not (blacklist (ptProvince pt1) y) + return y + +isSameOrNeighbour :: ProvinceTarget -> ProvinceTarget -> Bool +isSameOrNeighbour to from = to == from || elem to (neighbours from) + +commonNeighbours :: ProvinceTarget -> ProvinceTarget -> [ProvinceTarget] +commonNeighbours pt1 pt2 = + [ x | x <- neighbours pt1, y <- neighbours pt2, x == y ] + +-- | Common neighbours which are water provinces. +commonCoasts :: ProvinceTarget -> ProvinceTarget -> [ProvinceTarget] +commonCoasts pt1 pt2 = + filter (isWater . ptProvince) (commonNeighbours pt1 pt2) + +distance :: Province -> Province -> Int +distance pr1 pr2 = length (shortestPath pr1 pr2) + +shortestPath :: Province -> Province -> [Province] +shortestPath pr1 pr2 = + if pr1 == pr2 + then [] + else reverse $ shortestPath' pr2 (fmap pure (adjacency pr1)) + where + shortestPath' :: Province -> [[Province]] -> [Province] + shortestPath' pr paths = case select pr paths of + Just path -> path + Nothing -> shortestPath' pr (expand paths) + + expand :: [[Province]] -> [[Province]] + expand ps = do + t : ts <- ps + fmap (\x -> x : t : ts) (adjacency t) + + select :: Province -> [[Province]] -> Maybe [Province] + select p paths = foldr select Nothing paths + where + select path b = b <|> if elem p path then Just path else Nothing + +distanceFromHomeSupplyCentre :: GreatPower -> Province -> Int +distanceFromHomeSupplyCentre power province = head (sort distances) + where + distances = fmap (distance province) homeSupplyCentres + homeSupplyCentres = filter (isHome power) supplyCentres + +provinceStringRepresentation :: Province -> String +provinceStringRepresentation province = case province of + Denmark -> "Denmark" + Bohemia -> "Bohemia" + Budapest -> "Budapest" + Galicia -> "Galicia" + Trieste -> "Trieste" + Tyrolia -> "Tyrolia" + Vienna -> "Vienna" + Clyde -> "Clyde" + Edinburgh -> "Edinburgh" + Liverpool -> "Liverpool" + London -> "London" + Wales -> "Wales" + Yorkshire -> "Yorkshire" + Brest -> "Brest" + Burgundy -> "Burgundy" + Gascony -> "Gascony" + Marseilles -> "Marseilles" + Paris -> "Paris" + Picardy -> "Picardy" + Berlin -> "Berlin" + Kiel -> "Kiel" + Munich -> "Munich" + Prussia -> "Prussia" + Ruhr -> "Ruhr" + Silesia -> "Silesia" + Apulia -> "Apulia" + Naples -> "Naples" + Piedmont -> "Piedmont" + Rome -> "Rome" + Tuscany -> "Tuscany" + Venice -> "Venice" + Livonia -> "Livonia" + Moscow -> "Moscow" + Sevastopol -> "Sevastopol" + StPetersburg -> "St. Petersburg" + Ukraine -> "Ukraine" + Warsaw -> "Warsaw" + Ankara -> "Ankara" + Armenia -> "Armenia" + Constantinople -> "Constantinople" + Smyrna -> "Smyrna" + Syria -> "Syria" + Albania -> "Albania" + Belgium -> "Belgium" + Bulgaria -> "Bulgaria" + Finland -> "Finland" + Greece -> "Greece" + Holland -> "Holland" + Norway -> "Norway" + NorthAfrica -> "North Africa" + Portugal -> "Portugal" + Rumania -> "Rumania" + Serbia -> "Serbia" + Spain -> "Spain" + Sweden -> "Sweden" + Tunis -> "Tunis" + AdriaticSea -> "Adriatic Sea" + AegeanSea -> "Aegean Sea" + BalticSea -> "Baltic Sea" + BarentsSea -> "Barents Sea" + BlackSea -> "Black Sea" + EasternMediterranean -> "Eastern Mediterranean" + EnglishChannel -> "English Channel" + GulfOfBothnia -> "Gulf of Bothnia" + GulfOfLyon -> "Gulf of Lyon" + HeligolandBight -> "Heligoland Bight" + IonianSea -> "Ionian Sea" + IrishSea -> "Irish Sea" + MidAtlanticOcean -> "Mid-Atlantic Ocean" + NorthAtlanticOcean -> "North Atlantic Ocean" + NorthSea -> "North Sea" + NorwegianSea -> "Norwegian Sea" + Skagerrak -> "Skagerrak" + TyrrhenianSea -> "Tyrrhenian Sea" + WesternMediterranean -> "Western Mediterranean" + +provinceStringRepresentations :: Province -> (String, [String]) +provinceStringRepresentations pr = (principal, others) + where + principal = provinceStringRepresentation pr + others = case pr of + Liverpool -> ["Lvp"] + Livonia -> ["Lvn"] + StPetersburg -> ["StP"] + Norway -> ["Nwy"] + NorthAfrica -> ["NAf"] + GulfOfBothnia -> ["Bot"] + GulfOfLyon -> ["GoL"] + -- There are 2 accepted spellings of this one: + -- Heligoland + -- Helgoland + -- according to Wikipedia. + HeligolandBight -> ["Helgoland Bight", "Hel"] + MidAtlanticOcean -> ["Mao", "Mid", "Mid Atlantic Ocean"] + NorthAtlanticOcean -> ["NAt"] + NorthSea -> ["Nth"] + NorwegianSea -> ["Nrg"] + TyrrhenianSea -> ["Tyn"] + _ -> [take 3 principal] + +parseProvince :: Parser Province +parseProvince = choice (longParsers ++ shortParsers) + where + longParsers :: [Parser Province] + longParsers = fmap makeParser provinceLongReps + shortParsers :: [Parser Province] + shortParsers = fmap makeParser provinceShortReps + provinces :: [Province] + provinces = [minBound..maxBound] + provinceReps :: [(Province, String, [String])] + provinceReps = fmap reps provinces + provinceLongReps :: [(Province, String)] + provinceLongReps = fmap (\(pr, x, _) -> (pr, x)) provinceReps + provinceShortReps :: [(Province, String)] + provinceShortReps = provinceReps >>= \(pr, _, xs) -> fmap (\x -> (pr, x)) xs + reps :: Province -> (Province, String, [String]) + reps pr = let (s, ss) = provinceStringRepresentations pr + in (pr, s, ss) + makeParser :: (Province, String) -> Parser Province + makeParser (p, s) = try (string s) *> pure p + +provinceCoastStringRepresentations :: ProvinceCoast -> [String] +provinceCoastStringRepresentations pc = provinceReps >>= addSuffix + where + (principal, others) = provinceStringRepresentations (pcProvince pc) + provinceReps = principal : others + addSuffix str = [ + str ++ " " ++ suffix + , str ++ " (" ++ suffix ++ ")" + ] + suffix = provinceCoastStringSuffix pc + +provinceCoastStringSuffix :: ProvinceCoast -> String +provinceCoastStringSuffix pc = case pc of + StPetersburgNorth -> "NC" + StPetersburgSouth -> "SC" + SpainNorth -> "NC" + SpainSouth -> "SC" + BulgariaEast -> "EC" + BulgariaSouth -> "SC" + +parseCoast :: Parser ProvinceCoast +parseCoast = choice parsers + where + parsers :: [Parser ProvinceCoast] + parsers = fmap makeParser provinceCoastsWithReps + provinceCoasts = [minBound..maxBound] + provinceCoastsWithReps = fmap bundleReps provinceCoasts + bundleReps :: ProvinceCoast -> (ProvinceCoast, [String]) + bundleReps pc = let ss = provinceCoastStringRepresentations pc + in (pc, ss) + makeParser :: (ProvinceCoast, [String]) -> Parser ProvinceCoast + makeParser (pc, ss) = choice (fmap (try . string) ss) *> pure pc + +parseProvinceTarget :: Parser ProvinceTarget +parseProvinceTarget = try parseSpecial <|> parseNormal + where + parseNormal = Normal <$> parseProvince + parseSpecial = Special <$> parseCoast + +provinceTargetStringRepresentation :: ProvinceTarget -> String +provinceTargetStringRepresentation pt = case pt of + Normal p -> provinceStringRepresentation p + Special c -> head (provinceCoastStringRepresentations c) + +printProvinceTarget :: IsString a => ProvinceTarget -> a +printProvinceTarget = fromString . provinceTargetStringRepresentation + +printProvince :: IsString a => Province -> a +printProvince = fromString . provinceStringRepresentation + +-- | A search from a list of Provinces, via 1 or more adjacent Provinces which +-- satisfy some indicator, until another indicator is satisfied. +-- This gives simple paths from those Provinces, via Provinces which satisfy +-- the first indicator, to Provinces which satisfy the second indicator. +-- +-- Example use case: convoy paths from a given Province. +-- +-- @ +-- convoyPaths +-- :: Occupation +-- -> Province +-- -> [(Province, [Province])] +-- convoyPaths occupation convoyingFrom = +-- fmap +-- (\(x, y, zs) -> (x, y : zs)) +-- (paths (occupiedByFleet occupation) (coastalIndicator) [convoyingFrom]) +-- @ +-- +paths + :: (Province -> Bool) + -> (Province -> Maybe t) + -> [Province] + -> [(t, Province, [Province])] +paths indicatorA indicatorB seeds = paths' [] indicatorA indicatorB (fmap (\x -> (x, [])) seeds) + where + + paths' + :: [(t, Province, [Province])] + -> (Province -> Bool) + -> (Province -> Maybe t) + -> [(Province, [Province])] + -> [(t, Province, [Province])] + paths' found indicatorA indicatorB paths = + -- At each step we take the next vanguard, but we must have the previous + -- paths as well! Ok so why don't we just keep all of the paths? + let nextPaths = growPaths indicatorA paths + endpoints = takeEndpoints indicatorB nextPaths + found' = found ++ endpoints + in case nextPaths of + [] -> found' + _ -> paths' found' indicatorA indicatorB nextPaths + + growPaths + :: (Province -> Bool) + -> [(Province, [Province])] + -> [(Province, [Province])] + growPaths indicator paths = do + (first, theRest) <- paths + next <- adjacency first + let theRest' = first : theRest + guard (not (next `elem` theRest')) + guard (indicator next) + return (next, theRest') + + takeEndpoints + :: (Province -> Maybe t) + -> [(Province, [Province])] + -> [(t, Province, [Province])] + takeEndpoints indicator candidates = do + (first, rest) <- candidates + x <- adjacency first + case indicator x of + Just y -> return (y, first, rest) + Nothing -> empty diff --git a/Diplomacy/Season.hs b/Diplomacy/Season.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/Season.hs @@ -0,0 +1,20 @@ +{-| +Module : Diplomacy.Season +Description : Definition of the three seasons of Diplomacy. +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} + +module Diplomacy.Season ( + + Season(..) + + ) where + +data Season = Spring | Fall | Winter + deriving (Eq, Show) diff --git a/Diplomacy/Subject.hs b/Diplomacy/Subject.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/Subject.hs @@ -0,0 +1,41 @@ +{-| +Module : Diplomacy.Subject +Description : Definition of Subject +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} + +module Diplomacy.Subject ( + + Subject + , subjectUnit + , subjectProvinceTarget + + ) where + +import Diplomacy.Unit +import Diplomacy.Province + +-- | Description of a subject in a diplomacy game, like the subject of an order +-- for instance: +-- +-- a. F Bre - Eng +-- b. A Par S A Bre - Pic +-- +-- have subjects +-- +-- a. (Fleet, Normal Brest) +-- b. (Army, Normal Paris) +-- +type Subject = (Unit, ProvinceTarget) + +subjectUnit :: Subject -> Unit +subjectUnit (x, _) = x + +subjectProvinceTarget :: Subject -> ProvinceTarget +subjectProvinceTarget (_, x) = x diff --git a/Diplomacy/SupplyCentreDeficit.hs b/Diplomacy/SupplyCentreDeficit.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/SupplyCentreDeficit.hs @@ -0,0 +1,48 @@ +{-| +Module : Diplomacy.SupplyCentreDeficit +Description : Compute the supply centre deficit for a 'GreatPower'. +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} + +module Diplomacy.SupplyCentreDeficit ( + + SupplyCentreDeficit + + , supplyCentreDeficit + + ) where + +import qualified Data.Map as M +import Diplomacy.GreatPower +import Diplomacy.Occupation +import Diplomacy.Control +import Diplomacy.Province +import Diplomacy.Aligned +import Diplomacy.Unit + +type SupplyCentreDeficit = Int + +supplyCentreDeficit + :: GreatPower + -> Occupation + -> Control + -> SupplyCentreDeficit +supplyCentreDeficit greatPower occupation control = unitCount - supplyCentreCount + where + unitCount = M.fold unitCountFold 0 occupation + supplyCentreCount = M.foldWithKey supplyCentreCountFold 0 control + unitCountFold :: Aligned Unit -> Int -> Int + unitCountFold aunit + | alignedGreatPower aunit == greatPower = (+) 1 + | otherwise = id + supplyCentreCountFold :: Province -> GreatPower -> Int -> Int + supplyCentreCountFold pr greatPower' + | greatPower' == greatPower + && elem pr supplyCentres = (+) 1 + | otherwise = id diff --git a/Diplomacy/Turn.hs b/Diplomacy/Turn.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/Turn.hs @@ -0,0 +1,51 @@ +{-| +Module : Diplomacy.Turn +Description : Definition of a turn in a game of Diplomacy. +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Diplomacy.Turn ( + + Turn + , firstTurn + , nextTurn + , prevTurn + , turnToInt + , turnFromInt + + ) where + +import Data.TypeNat.Nat + +newtype Turn = Turn Nat + +deriving instance Eq Turn +deriving instance Ord Turn + +instance Show Turn where + show = show . turnToInt + +firstTurn = Turn Z + +nextTurn :: Turn -> Turn +nextTurn (Turn n) = Turn (S n) + +prevTurn :: Turn -> Maybe Turn +prevTurn (Turn Z) = Nothing +prevTurn (Turn (S n)) = Just (Turn n) + +turnToInt :: Turn -> Int +turnToInt (Turn Z) = 0 +turnToInt (Turn (S n)) = 1 + turnToInt (Turn n) + +turnFromInt :: Int -> Maybe Turn +turnFromInt i | i < 0 = Nothing + | i == 0 = Just firstTurn + | otherwise = fmap nextTurn (turnFromInt (i-1)) diff --git a/Diplomacy/Unit.hs b/Diplomacy/Unit.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/Unit.hs @@ -0,0 +1,51 @@ +{-| +Module : Diplomacy.Unit +Description : Definition of units (armies and fleets) +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Diplomacy.Unit ( + + Unit(..) + + , parseUnit + , printUnit + + ) where + +import Control.Applicative +import Data.String (IsString) +import Text.Parsec hiding ((<|>)) +import Text.Parsec.Text + +data Unit where + Army :: Unit + Fleet :: Unit + +deriving instance Eq Unit +deriving instance Ord Unit +deriving instance Show Unit +deriving instance Enum Unit +deriving instance Bounded Unit + +parseUnit :: Parser Unit +parseUnit = parseFleet <|> parseArmy + where + parseFleet :: Parser Unit + parseFleet = char 'F' *> pure Fleet + parseArmy :: Parser Unit + parseArmy = char 'A' *> pure Army + +printUnit :: IsString a => Unit -> a +printUnit unit = case unit of + Army -> "A" + Fleet -> "F" diff --git a/Diplomacy/Zone.hs b/Diplomacy/Zone.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/Zone.hs @@ -0,0 +1,47 @@ +{-| +Module : Diplomacy.Zone +Description : ProvinceTarget with different Eq, Ord instances. +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Diplomacy.Zone ( + + Zone(..) + + , zoneProvinceTarget + + ) where + +import Diplomacy.Province + +-- | A ProvinceTarget in which coasts of the same Province are equal. +-- This notion is useful because the rules of Diplomacy state that each +-- Zone is occupied by at most one unit, i.e. there cannot be a unit at +-- two coasts of the same Province. +newtype Zone = Zone ProvinceTarget + +deriving instance Show Zone + +instance Eq Zone where + Zone x == Zone y = case (x, y) of + (Normal p1, Normal p2) -> p1 == p2 + (Special c1, Special c2) -> pcProvince c1 == pcProvince c2 + (Normal p, Special c) -> p == pcProvince c + (Special c, Normal p) -> p == pcProvince c + +instance Ord Zone where + Zone x `compare` Zone y = case (x, y) of + (Normal p1, Normal p2) -> p1 `compare` p2 + (Special c1, Special c2) -> pcProvince c1 `compare` pcProvince c2 + (Normal p, Special c) -> p `compare` pcProvince c + (Special c, Normal p) -> pcProvince c `compare` p + +zoneProvinceTarget :: Zone -> ProvinceTarget +zoneProvinceTarget (Zone pt) = pt diff --git a/Diplomacy/ZonedSubject.hs b/Diplomacy/ZonedSubject.hs new file mode 100644 --- /dev/null +++ b/Diplomacy/ZonedSubject.hs @@ -0,0 +1,57 @@ +{-| +Module : Diplomacy.ZonedSubject +Description : Subject with different Eq, Ord instances. +Copyright : (c) Alexander Vieth, 2015 +Licence : BSD3 +Maintainer : aovieth@gmail.com +Stability : experimental +Portability : non-portable (GHC only) +-} + +{-# LANGUAGE AutoDeriveTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Diplomacy.ZonedSubject ( + + ZonedSubjectDull(..) + , ZonedSubjectSharp(..) + + , zonedSubjectDull + , zonedSubjectSharp + + ) where + +import Diplomacy.Subject +import Diplomacy.Zone + +newtype ZonedSubjectDull = ZonedSubjectDull Subject + +deriving instance Show ZonedSubjectDull + +instance Eq ZonedSubjectDull where + ZonedSubjectDull (_, pt1) == ZonedSubjectDull (_, pt2) = + Zone pt1 == Zone pt2 + +instance Ord ZonedSubjectDull where + ZonedSubjectDull (_, pt1) `compare` ZonedSubjectDull (_, pt2) = + Zone pt1 `compare` Zone pt2 + +zonedSubjectDull :: ZonedSubjectDull -> Subject +zonedSubjectDull (ZonedSubjectDull x) = x + +newtype ZonedSubjectSharp = ZonedSubjectSharp Subject + +deriving instance Show ZonedSubjectSharp + +instance Eq ZonedSubjectSharp where + ZonedSubjectSharp (u1, pt1) == ZonedSubjectSharp (u2, pt2) = + Zone pt1 == Zone pt2 && u1 == u2 + +instance Ord ZonedSubjectSharp where + ZonedSubjectSharp (u1, pt1) `compare` ZonedSubjectSharp (u2, pt2) = + case Zone pt1 `compare` Zone pt2 of + EQ -> u1 `compare` u2 + x -> x + +zonedSubjectSharp :: ZonedSubjectSharp -> Subject +zonedSubjectSharp (ZonedSubjectSharp x) = x diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Alexander Vieth + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexander Vieth nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,75 @@ +# Diplomacy + +These programs aspire to provide everything you need in order to talk about +the board game [Diplomacy](https://en.wikipedia.org/wiki/Diplomacy_%28game%29) +in Haskell. + +## State of the project + +Things look good. The order resolution component passes over 100 of the +[DATC](http://web.inter.nl.net/users/L.B.Kruijswijk/) test cases. +It probably passes more than that, but not every one of them has been +transcribed. + +## Components + +This project is organized into four parts: + +- The types and data for the fundamental language of the game. +- The characterizations of valid orders. +- The resolution of orders. +- The description of the state of a particular game. + +### Characterization of valid orders + +An order is defined to be any subject/object pair. For instance, the subject of +`A Ion S A Bre - Par` is `A Ion` (an army in the Ionian Sea) and the object is +`S A Bre - Par` (support the army in Brest as it moves into Paris). Not every +such order makes sense: that support order is invalid, not only because an +army cannot be in the Ionian Sea, but also because no unit in the Ionian Sea +can support a move into Paris. + +As far as I can tell, the characterization of valid orders is too intricate for +Haskell's type system, even with state of the art GHC-only extensions, to handle +well. Perhaps a language with full dependent types such as Idris is up to the +task, but in this project, we do order validation at the value level. However, +instead of giving indicator functions `Order phase orderType -> Bool` for +validity, we give more intricate descriptions of *why* an order is valid, in +the form of an intersection of unions of sets (corresponding to a conjunctive +normal form clause). By actually constructing the valid orders and their +components, we obtain not only a way to check validity (`analyze`) but also a +way to generate all valid orders (`synthesize`), which could be very useful +when implementing a user-facing client. + +An order of the typical or retreat phase is either valid or invalid, regardless +of the other orders issued. The mantra for these phases is that a valid order +would succeed if no other orders were issued. The situation is different for +the adjust phase, in which no order is valid on its own. Instead, the whole set +of orders for a given great power is either valid or invalid. This is due to +the deficit constraint: if a great power has more units than supply centres, +it must disband *exactly* the difference; if it has more supply centres than +units, it *may* build at most the magnitude of the difference. In this phase, +a valid *set* of orders would succeed regardless of the orders of the other +great powers (and in fact it *will* succeed, because adjust phase orders from +different great powers never conflict). + +### Resolution of orders + +In order to carry a game from one round to the next (for instance, to go +from a typical phase to a retreat phase), orders must be checked against one +another to determine which orders succeed, and which orders fail. This process +is known as *order resolution*, and it is defined distinctly for each phase. + +While the adjust phase is clearly the most simple to resolve (every valid order +succeeds), the typical phase resolution is far more complex than that of the +retreat phase. This typical phase resolver is the component which determines +which supports are cut, which convoys fail, which moves standoff or are +overpowered. It must also deal with the ambiguities in the rulebook, which +the DATC is very helpful in pointing out and characterizing via tests. + +## Thanks + +Much thanks to Lucas B. Kruijswijk for giving us the +[DATC](http://web.inter.nl.net/users/L.B.Kruijswijk/), from which +[many tests](AdjudicationTests.hs) were transcribed and consequently many bugs +discovered and fixed. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/diplomacy.cabal b/diplomacy.cabal new file mode 100644 --- /dev/null +++ b/diplomacy.cabal @@ -0,0 +1,70 @@ +-- Initial diplomacy.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: diplomacy +version: 0.1.0.0 +synopsis: The board game Diplomacy, spoken in Haskell +-- description: +homepage: https://github.com/avieth/diplomacy +license: BSD3 +license-file: LICENSE +author: Alexander Vieth +maintainer: aovieth@gmail.com +-- copyright: +-- category: +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + + +library + exposed-modules: Diplomacy.OrderObject + , Diplomacy.Zone + , Diplomacy.ZonedSubject + , Diplomacy.Turn + , Diplomacy.SupplyCentreDeficit + , Diplomacy.Order + , Diplomacy.Season + , Diplomacy.Control + , Diplomacy.OrderType + , Diplomacy.GreatPower + , Diplomacy.Occupation + , Diplomacy.Dislodgement + , Diplomacy.Aligned + , Diplomacy.OrderValidation + , Diplomacy.Province + , Diplomacy.Unit + , Diplomacy.OrderResolution + , Diplomacy.Phase + , Diplomacy.Game + , Diplomacy.Subject + , Data.MapUtil + , Data.AtLeast + -- other-modules: + other-extensions: GADTs + , AutoDeriveTypeable + , DataKinds + , ImpredicativeTypes + , MultiParamTypeClasses + , FlexibleInstances + , FlexibleContexts + , ScopedTypeVariables + , PolyKinds + , KindSignatures + , DeriveFunctor + , GeneralizedNewtypeDeriving + , StandaloneDeriving + , TypeFamilies + , OverloadedStrings + , RankNTypes + , PatternSynonyms + + build-depends: base >=4.7 && <4.8 + , containers >=0.5 && <0.6 + , transformers >=0.3 && <0.4 + , HUnit >=1.2 && <1.3 + , TypeNat >=0.4 && <0.5 + , parsec >= 3.1 && <3.2 + -- hs-source-dirs: + default-language: Haskell2010 +