diplomacy (empty) → 0.1.0.0
raw patch · 26 files changed
+5106/−0 lines, 26 filesdep +HUnitdep +TypeNatdep +basesetup-changed
Dependencies added: HUnit, TypeNat, base, containers, parsec, transformers
Files
- Data/AtLeast.hs +88/−0
- Data/MapUtil.hs +35/−0
- Diplomacy/Aligned.hs +44/−0
- Diplomacy/Control.hs +38/−0
- Diplomacy/Dislodgement.hs +70/−0
- Diplomacy/Game.hs +868/−0
- Diplomacy/GreatPower.hs +35/−0
- Diplomacy/Occupation.hs +89/−0
- Diplomacy/Order.hs +95/−0
- Diplomacy/OrderObject.hs +124/−0
- Diplomacy/OrderResolution.hs +1162/−0
- Diplomacy/OrderType.hs +29/−0
- Diplomacy/OrderValidation.hs +1048/−0
- Diplomacy/Phase.hs +30/−0
- Diplomacy/Province.hs +859/−0
- Diplomacy/Season.hs +20/−0
- Diplomacy/Subject.hs +41/−0
- Diplomacy/SupplyCentreDeficit.hs +48/−0
- Diplomacy/Turn.hs +51/−0
- Diplomacy/Unit.hs +51/−0
- Diplomacy/Zone.hs +47/−0
- Diplomacy/ZonedSubject.hs +57/−0
- LICENSE +30/−0
- README.md +75/−0
- Setup.hs +2/−0
- diplomacy.cabal +70/−0
+ Data/AtLeast.hs view
@@ -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
+ Data/MapUtil.hs view
@@ -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
+ Diplomacy/Aligned.hs view
@@ -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
+ Diplomacy/Control.hs view
@@ -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
+ Diplomacy/Dislodgement.hs view
@@ -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)
+ Diplomacy/Game.hs view
@@ -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
+ Diplomacy/GreatPower.hs view
@@ -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
+ Diplomacy/Occupation.hs view
@@ -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
+ Diplomacy/Order.hs view
@@ -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)
+ Diplomacy/OrderObject.hs view
@@ -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+-}
+ Diplomacy/OrderResolution.hs view
@@ -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 <anything> OR F MAt C <anything>.+ resolveSupport+ :: OrderObject Typical Support+ -> Maybe (FailureReason Typical Support)+ resolveSupport supportObject =+ supportVoid supportObject+ <|> supportCut supportObject+ <|> supportDislodged supportObject++ -- A support is Void if the supported order was not given.+ supportVoid+ :: OrderObject Typical Support+ -> Maybe (FailureReason Typical Support)+ supportVoid (SupportObject supportingSubject supportingTo) =+ case M.lookup supportingFrom (dropAssumptionTags resolution) of+ Nothing -> Just SupportVoid+ Just (aunit, SomeResolved (object, _)) ->+ if supportingUnit == alignedThing aunit+ && supportingTo == destination+ then Nothing+ else Just SupportVoid+ where+ destination = case object of+ MoveObject pt -> pt+ _ -> zoneProvinceTarget supportingFrom++ where++ supportingFrom :: Zone+ supportingFrom = Zone (snd supportingSubject)++ supportingUnit :: Unit+ supportingUnit = fst supportingSubject+++ -- Support is cut if there is a move into its territory issued by+ -- another great power, from a territory other than the one into which+ -- support is directed. If that move requires a convoy, then there must+ -- be at least one successful convoy route. To avoid nontermination+ -- which would arise from the classic convoy paradox:+ --+ -- France: Army Brest -> English Channel -> London.+ -- France: Fleet English Channel CONVOY Army Brest -> London. + --+ -- England: Fleet London SUPPORT Fleet Wales -> English Channel.+ -- England: Fleet Wales -> English Channel. + --+ -- we use the notion of convoy-independence. In this example, we would+ -- check whether the convoy route succeeds, which in-turn check whether+ -- the English move succeeds, which would ask whether the English+ -- support succeeds, which would in-turn ask whether the French+ -- move has a successful convoy route, and so on...+ --+ -- We could cut the loop by inspecting only the independent convoy+ -- routes, those routes such that their convoying fleets are not+ -- attacked by a move which is supported by this support. The next rule,+ -- convoyDislodged, is sensitive to this, because under this paradox+ -- resolution, it's possible for a dislodged unit to give support, i.e.+ -- when it was dislodged by a move which did not cut it.+ --+ -- Another option is to identify the moves which participate in these+ -- paradoxes and fail them (MoveConvoyParadox). But how does this hold+ -- up in case there's more than one convoy route? Aha, yes we would+ -- first have to ensure that none of the other routes are successful,+ -- and only then could we say it's MoveConvoyParadox. So, this amounts+ -- to 1. grabbing all convoy routes 2. isolating any paradoxical ones+ -- 3. checking whether any nonparadoxical one succeeds. Then+ --+ -- no successful nonparadoxical, at least one paradoxical -> MoveConvoyParadox+ -- no successful nonparadoxical, no paradoxical -> MoveNoConvoy+ -- successful nonparadoxical, _ -> Succeeds+ --+ -- Both of these strategies are explained here:+ -- http://diplom.org/Zine/F1999R/Debate/resolve.cgi+ supportCut+ :: OrderObject Typical Support+ -> Maybe (FailureReason Typical Support)+ supportCut (SupportObject supportingSubject supportingTo) =+ case filter issuedByOtherGreatPower offendingMoves of+ [] -> Nothing+ x : xs -> Just (SupportCut (AtLeast (VCons x VNil) xs))++ where++ issuedByOtherGreatPower :: Aligned Subject -> Bool+ issuedByOtherGreatPower x = alignedGreatPower aunit /= alignedGreatPower x++ supportingFrom :: Zone+ supportingFrom = zone++ offendingMoves :: [Aligned Subject]+ offendingMoves = M.elems (M.mapMaybeWithKey pickOffendingMove (dropAssumptionTags resolution))++ pickOffendingMove+ :: Zone+ -> (Aligned Unit, SomeResolved OrderObject Typical)+ -> Maybe (Aligned Subject)+ pickOffendingMove zone (aunit', SomeResolved (object, _)) =+ case object of+ MoveObject movingTo ->+ if Zone movingTo == supportingFrom+ && Zone supportingTo /= zone+ && not (isConvoyMoveWithNoConvoyRoute thisClassification)+ then Just $ align (alignedThing aunit', zoneProvinceTarget zone) (alignedGreatPower aunit')+ else Nothing+ where+ thisClassification = classify resolution zone (aunit', object)+ _ -> Nothing++ -- TODO TBD can't we remove this and the SupportDislodged constructor?+ -- SupportCut is sufficient.+ supportDislodged+ :: OrderObject Typical Support+ -> Maybe (FailureReason Typical Support)+ supportDislodged _ = case typicalChange (dropAssumptionTags resolution) zone of+ Nothing -> Nothing+ Just dislodger -> Just (SupportDislodged dislodger)++ -- ******+ -- CONVOY+ -- ******+ --+ -- There are two reasons to fail a convoy:+ --+ -- ConvoyVoid : the complementary move order was not given.+ -- For instance, F Eng C A Bre -> Wal cannot succeed unless some+ -- great power issues A Bre -> Wal. If no such order is issued, we+ -- say that the convoy order is void.+ --+ -- ConvoyNoRoute : there is no route of undisrupted convoy orders+ -- from the convoy source to convoy terminus. Note that this+ -- includes two possibilities: no route or exists, or every route+ -- which does exist has been cut (some member of the route dislodged).+ --+ resolveConvoy+ :: OrderObject Typical Convoy+ -> Maybe (FailureReason Typical Convoy)+ resolveConvoy convoyObject =+ convoyVoid convoyObject+ <|> convoyNoRoute convoyObject++ convoyVoid+ :: OrderObject Typical Convoy+ -> Maybe (FailureReason Typical Convoy)+ convoyVoid (ConvoyObject subject target) =+ if isVoidConvoy (dropAssumptionTags resolution) subject target+ then Just ConvoyVoid+ else Nothing++ -- Route cut in case every convoy route which this convoy order+ -- participates in has at laest one of its convoyers dislodged.+ convoyNoRoute+ :: OrderObject Typical Convoy+ -> Maybe (FailureReason Typical Convoy)+ convoyNoRoute (ConvoyObject convoyingSubject convoyingTo) =+ case routesParticipatedIn of+ [] -> Just ConvoyNoRoute+ _ -> fmap ConvoyRouteCut cuttingSet++ where++ routes :: [[(Zone, Maybe (Aligned Subject))]]+ routes = rawConvoyRoutes (dropAssumptionTags resolution) convoyingSubject convoyingTo++ routesParticipatedIn :: [[(Zone, Maybe (Aligned Subject))]]+ routesParticipatedIn = filter participates routes+ where+ participates = any (\(z, _) -> z == zone)++ cuttingSet :: Maybe [(Zone, Aligned Subject)]+ cuttingSet | length cutRoutes == length routesParticipatedIn = Just (nub (concat cutRoutes))+ | otherwise = Nothing++ cutRoutes :: [[(Zone, Aligned Subject)]]+ cutRoutes = filter (not . null) (fmap cutRoute routesParticipatedIn)++ cutRoute+ :: [(Zone, Maybe (Aligned Subject))]+ -> [(Zone, Aligned Subject)]+ cutRoute = mapMaybe pickCutRoute++ pickCutRoute+ :: (Zone, Maybe (Aligned Subject))+ -> Maybe (Zone, Aligned Subject)+ pickCutRoute (z, m) = fmap ((,) z) m++ in thisResolution++-- | Changes to a board as the result of a typical phase.+-- @Nothing@ means no change, @Just pt@ means the unit belonging to the great+-- power now lies the input 'Zone', and used to lie at the given+-- 'ProvinceTarget' @pt@.+typicalChange :: Resolution Typical -> Zone -> Maybe (Aligned Subject)+typicalChange res zone = M.foldWithKey folder Nothing res+ where+ folder+ :: Zone+ -> (Aligned Unit, SomeResolved OrderObject Typical)+ -> Maybe (Aligned Subject)+ -> Maybe (Aligned Subject)+ folder zone' (aunit, SomeResolved (object, resolution)) b = case object of+ MoveObject movingTo ->+ -- Rule out moves that don't offend this zone, and moves that are+ -- holds at this zone.+ if Zone movingTo /= zone+ || Zone movingTo == zone'+ then b+ else case resolution of+ Nothing -> let power = alignedGreatPower aunit+ unit = alignedThing aunit+ subj = align (unit, zoneProvinceTarget zone') power+ in Just subj+ _ -> b+ _ -> b++-- | Resolution for the Typical phase.+typicalResolution+ :: M.Map Zone (Aligned Unit, SomeOrderObject Typical)+ -> Resolution Typical+typicalResolution = dropAssumptionTags . typicalResolutionAssuming . noAssumptions++-- | Resolution for the Retreat phase.+retreatResolution+ :: M.Map Zone (Aligned Unit, SomeOrderObject Retreat)+ -> Resolution Retreat+retreatResolution zonedOrders = M.mapWithKey (resolveRetreat zonedWithdraws) zonedOrders+ where+ -- At each Zone we have a list of the zones from which a withdraw attempt+ -- is made.+ zonedWithdraws :: M.Map Zone [Aligned Subject]+ zonedWithdraws = M.foldWithKey folder M.empty zonedOrders+ where+ folder+ :: Zone+ -> (Aligned Unit, SomeOrderObject Retreat)+ -> M.Map Zone [Aligned Subject]+ -> M.Map Zone [Aligned Subject]+ folder zone (aunit, SomeOrderObject object) b = case object of+ WithdrawObject withdrawingTo -> M.alter alteration (Zone withdrawingTo) b+ where+ subject = align (alignedThing aunit, zoneProvinceTarget zone) (alignedGreatPower aunit)+ alteration x = case x of+ Nothing -> Just [subject]+ Just ys -> Just (subject : ys)+ _ -> b+ resolveRetreat+ :: M.Map Zone [Aligned Subject]+ -> Zone+ -> (Aligned Unit, SomeOrderObject Retreat)+ -> (Aligned Unit, SomeResolved OrderObject Retreat)+ resolveRetreat zonedWithdraws zone (aunit, SomeOrderObject object) = case object of+ SurrenderObject -> (aunit, SomeResolved (object, Nothing))+ WithdrawObject _ -> (aunit, SomeResolved (object, resolution))+ where+ resolution :: Maybe (FailureReason Retreat Withdraw)+ resolution = case fmap (filter (/= thisSubject)) (M.lookup (Zone (withdrawTarget object)) zonedWithdraws) of+ Just [] -> Nothing+ Just (x : xs) -> Just (WithdrawCollision (AtLeast (VCons x VNil) xs))+ _ -> Nothing+ where+ thisSubject = align (alignedThing aunit, zoneProvinceTarget zone) (alignedGreatPower aunit)++-- | Resolution for the Adjust phase.+adjustResolution+ :: M.Map Zone (Aligned Unit, SomeOrderObject Adjust)+ -> Resolution Adjust+adjustResolution = M.map (\(aunit, SomeOrderObject object) -> (aunit, SomeResolved (object, Nothing)))++type Resolved (k :: Phase -> OrderType -> *) (phase :: Phase) (order :: OrderType) =+ (k phase order, Maybe (FailureReason phase order))++data SomeResolved (k :: Phase -> OrderType -> *) phase where+ SomeResolved :: Resolved k phase order -> SomeResolved k phase++deriving instance Show (SomeResolved OrderObject phase)+deriving instance Show (SomeResolved Order phase)++instance Eq (SomeResolved OrderObject phase) where+ SomeResolved (object1, res1) == SomeResolved (object2, res2) =+ object1 `orderObjectEqual` object2+ && case (res1, res2) of+ (Just r1, Just r2) -> failureReasonEqual r1 r2+ (Nothing, Nothing) -> True+ _ -> False++withSomeResolved+ :: (forall order . Resolved k phase order -> t) -> SomeResolved k phase -> t+withSomeResolved f term = case term of+ SomeResolved x -> f x++-- | Enumeration of reasons why an order could not succeed.+data FailureReason (phase :: Phase) (order :: OrderType) where++ MoveOverpowered :: AtLeast One (Aligned Subject) -> FailureReason Typical Move++ MoveBounced :: AtLeast One (Aligned Subject) -> FailureReason Typical Move++ -- The move would dislodge the player's own unit.+ -- TBD the rules are ambigious for games where one player controls many+ -- great powers. Is it ok for a player's unit to dislodge a unit which+ -- belongs to a different great power which he controls? We allow it.+ MoveFriendlyDislodge :: Unit -> FailureReason Typical Move++ MoveNoConvoy :: FailureReason Typical Move++ MoveConvoyParadox :: FailureReason Typical Move++ -- The supported unit did not give an order consistent with the support+ -- order.+ SupportVoid :: FailureReason Typical Support++ -- The supporting unit was attacked from a province other than the one+ -- into which the support was directed.+ SupportCut :: AtLeast One (Aligned Subject) -> FailureReason Typical Support++ -- The supporting unit was overpowered by a move from the province into+ -- which the support was directed.+ SupportDislodged :: Aligned Subject -> FailureReason Typical Support++ ConvoyVoid :: FailureReason Typical Convoy++ ConvoyNoRoute :: FailureReason Typical Convoy++ ConvoyRouteCut :: [(Zone, Aligned Subject)] -> FailureReason Typical Convoy++ -- The unit withdraws into the same province as some other unit(s).+ WithdrawCollision :: AtLeast One (Aligned Subject) -> FailureReason Retreat Withdraw++ -- Surrender orders and adjust phase orders can never fail; if they're+ -- valid, they succeed!++deriving instance Show (FailureReason phase order)+deriving instance Eq (FailureReason phase order)++failureReasonEqual+ :: FailureReason phase order+ -> FailureReason phase' order'+ -> Bool+failureReasonEqual r1 r2 = case (r1, r2) of+ (MoveOverpowered x, MoveOverpowered y) -> x == y+ (MoveBounced x, MoveBounced y) -> x == y+ (MoveFriendlyDislodge x, MoveFriendlyDislodge y) -> x == y+ (MoveNoConvoy, MoveNoConvoy) -> True+ (MoveConvoyParadox, MoveConvoyParadox) -> True+ (SupportVoid, SupportVoid) -> True+ (SupportCut x, SupportCut y) -> x == y+ (SupportDislodged x, SupportDislodged y) -> x == y+ (ConvoyVoid, ConvoyVoid) -> True+ (ConvoyNoRoute, ConvoyNoRoute) -> True+ (ConvoyRouteCut x, ConvoyRouteCut y) -> x == y+ (WithdrawCollision x, WithdrawCollision y) -> x == y+ _ -> False
+ Diplomacy/OrderType.hs view
@@ -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
+ Diplomacy/OrderValidation.hs view
@@ -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
+ Diplomacy/Phase.hs view
@@ -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
+ Diplomacy/Province.hs view
@@ -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
+ Diplomacy/Season.hs view
@@ -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)
+ Diplomacy/Subject.hs view
@@ -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
+ Diplomacy/SupplyCentreDeficit.hs view
@@ -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
+ Diplomacy/Turn.hs view
@@ -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))
+ Diplomacy/Unit.hs view
@@ -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"
+ Diplomacy/Zone.hs view
@@ -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
+ Diplomacy/ZonedSubject.hs view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ diplomacy.cabal view
@@ -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+