├── cabal.project ├── Setup.hs ├── test └── adjudication │ └── Main.hs ├── src ├── Diplomacy │ ├── Season.hs │ ├── OrderType.hs │ ├── Subject.hs │ ├── Control.hs │ ├── GreatPower.hs │ ├── Phase.hs │ ├── Aligned.hs │ ├── Turn.hs │ ├── Unit.hs │ ├── SupplyCentreDeficit.hs │ ├── Zone.hs │ ├── ZonedSubject.hs │ ├── Dislodgement.hs │ ├── Occupation.hs │ ├── OrderObject.hs │ ├── Order.hs │ ├── SVGMap.hs │ ├── Province.hs │ ├── Game.hs │ └── OrderValidation.hs └── Data │ ├── MapUtil.hs │ └── AtLeast.hs ├── LICENSE ├── Example.hs ├── diplomacy.cabal └── README.md /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./diplomacy.cabal 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/adjudication/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import AdjudicationTests (tests) 4 | import Test.HUnit.Text (runTestTTAndExit) 5 | 6 | main :: IO () 7 | main = runTestTTAndExit tests 8 | -------------------------------------------------------------------------------- /src/Diplomacy/Season.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.Season 3 | Description : Definition of the three seasons of Diplomacy. 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | module Diplomacy.Season ( 12 | 13 | Season(..) 14 | 15 | ) where 16 | 17 | data Season = Spring | Fall | Winter 18 | deriving (Eq, Show) 19 | -------------------------------------------------------------------------------- /src/Diplomacy/OrderType.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.OrderType 3 | Description : Definition of order types 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | {-# LANGUAGE GADTs #-} 12 | 13 | module Diplomacy.OrderType ( 14 | 15 | OrderType(..) 16 | 17 | ) where 18 | 19 | -- | Enumeration of types of orders. Useful when DataKinds is enabled. 20 | data OrderType where 21 | Move :: OrderType 22 | Support :: OrderType 23 | Convoy :: OrderType 24 | Withdraw :: OrderType 25 | Surrender :: OrderType 26 | Disband :: OrderType 27 | Build :: OrderType 28 | Continue :: OrderType 29 | -------------------------------------------------------------------------------- /src/Diplomacy/Subject.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.Subject 3 | Description : Definition of Subject 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | module Diplomacy.Subject ( 12 | 13 | Subject 14 | , subjectUnit 15 | , subjectProvinceTarget 16 | 17 | ) where 18 | 19 | import Diplomacy.Unit 20 | import Diplomacy.Province 21 | 22 | -- | Description of a subject in a diplomacy game, like the subject of an order 23 | -- for instance: 24 | -- 25 | -- a. F Bre - Eng 26 | -- b. A Par S A Bre - Pic 27 | -- 28 | -- have subjects 29 | -- 30 | -- a. (Fleet, Normal Brest) 31 | -- b. (Army, Normal Paris) 32 | -- 33 | type Subject = (Unit, ProvinceTarget) 34 | 35 | subjectUnit :: Subject -> Unit 36 | subjectUnit (x, _) = x 37 | 38 | subjectProvinceTarget :: Subject -> ProvinceTarget 39 | subjectProvinceTarget (_, x) = x 40 | -------------------------------------------------------------------------------- /src/Diplomacy/Control.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.Control 3 | Description : Definition of control of provinces. 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | module Diplomacy.Control ( 12 | 13 | Control 14 | 15 | , emptyControl 16 | , control 17 | , controller 18 | 19 | ) where 20 | 21 | import qualified Data.Map as M 22 | import Diplomacy.Province 23 | import Diplomacy.GreatPower 24 | 25 | -- | Indicates which GreatPower most recently had a unit on a given Province 26 | -- at the beginning of an adjust phase. 27 | type Control = M.Map Province GreatPower 28 | 29 | emptyControl :: Control 30 | emptyControl = M.empty 31 | 32 | control :: Province -> Maybe GreatPower -> Control -> Control 33 | control pr mgp = M.alter (const mgp) pr 34 | 35 | controller :: Province -> Control -> Maybe GreatPower 36 | controller = M.lookup 37 | -------------------------------------------------------------------------------- /src/Diplomacy/GreatPower.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.GreatPower 3 | Description : Definition of the great powers (countries). 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE StandaloneDeriving #-} 13 | 14 | module Diplomacy.GreatPower ( 15 | 16 | GreatPower(..) 17 | , allGreatPowers 18 | 19 | ) where 20 | 21 | data GreatPower where 22 | England :: GreatPower 23 | Germany :: GreatPower 24 | France :: GreatPower 25 | Italy :: GreatPower 26 | Austria :: GreatPower 27 | Russia :: GreatPower 28 | Turkey :: GreatPower 29 | 30 | deriving instance Eq GreatPower 31 | deriving instance Ord GreatPower 32 | deriving instance Show GreatPower 33 | deriving instance Read GreatPower 34 | deriving instance Enum GreatPower 35 | deriving instance Bounded GreatPower 36 | 37 | allGreatPowers :: [GreatPower] 38 | allGreatPowers = [minBound..maxBound] 39 | -------------------------------------------------------------------------------- /src/Diplomacy/Phase.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.Phase 3 | Description : Definition of phases of play 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE KindSignatures #-} 14 | {-# LANGUAGE StandaloneDeriving #-} 15 | 16 | module Diplomacy.Phase ( 17 | 18 | Phase(..) 19 | , IsPhase(..) 20 | 21 | ) where 22 | 23 | data Phase where 24 | Typical :: Phase 25 | Retreat :: Phase 26 | Adjust :: Phase 27 | 28 | deriving instance Show Phase 29 | deriving instance Eq Phase 30 | deriving instance Ord Phase 31 | deriving instance Enum Phase 32 | deriving instance Bounded Phase 33 | 34 | data IsPhase (phase :: Phase) where 35 | IsTypicalPhase :: IsPhase 'Typical 36 | IsRetreatPhase :: IsPhase 'Retreat 37 | IsAdjustPhase :: IsPhase 'Adjust 38 | 39 | instance Show (IsPhase phase) where 40 | show IsTypicalPhase = show Typical 41 | show IsRetreatPhase = show Retreat 42 | show IsAdjustPhase = show Adjust 43 | -------------------------------------------------------------------------------- /src/Diplomacy/Aligned.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.Aligned 3 | Description : Align a value to a 'GreatPower'. 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE StandaloneDeriving #-} 13 | 14 | module Diplomacy.Aligned ( 15 | 16 | Aligned 17 | , align 18 | , alignedThing 19 | , alignedGreatPower 20 | 21 | ) where 22 | 23 | import Diplomacy.GreatPower 24 | 25 | -- | Something aligned to a @GreatPower@. 26 | data Aligned t where 27 | Aligned :: t -> GreatPower -> Aligned t 28 | 29 | deriving instance Eq t => Eq (Aligned t) 30 | deriving instance Ord t => Ord (Aligned t) 31 | deriving instance Show t => Show (Aligned t) 32 | 33 | instance Functor Aligned where 34 | fmap f (Aligned x y) = Aligned (f x) y 35 | 36 | align :: t -> GreatPower -> Aligned t 37 | align = Aligned 38 | 39 | alignedThing :: Aligned t -> t 40 | alignedThing (Aligned x _) = x 41 | 42 | alignedGreatPower :: Aligned t -> GreatPower 43 | alignedGreatPower (Aligned _ x) = x 44 | -------------------------------------------------------------------------------- /src/Diplomacy/Turn.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.Turn 3 | Description : Definition of a turn in a game of Diplomacy. 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | 13 | module Diplomacy.Turn ( 14 | 15 | Turn (..) 16 | , firstTurn 17 | , nextTurn 18 | , prevTurn 19 | , turnToInt 20 | , turnFromInt 21 | 22 | ) where 23 | 24 | import Numeric.Natural 25 | 26 | newtype Turn = Turn Natural 27 | 28 | deriving instance Eq Turn 29 | deriving instance Ord Turn 30 | 31 | instance Show Turn where 32 | show = show . turnToInt 33 | 34 | firstTurn = Turn 0 35 | 36 | nextTurn :: Turn -> Turn 37 | nextTurn (Turn n) = Turn (n + 1) 38 | 39 | prevTurn :: Turn -> Maybe Turn 40 | prevTurn (Turn 0) = Nothing 41 | prevTurn (Turn n) = Just (Turn (n - 1)) 42 | 43 | turnToInt :: Turn -> Int 44 | turnToInt (Turn n) = fromIntegral n 45 | 46 | turnFromInt :: Int -> Maybe Turn 47 | turnFromInt i | i < 0 = Nothing 48 | | otherwise = Just (Turn (fromIntegral i)) 49 | -------------------------------------------------------------------------------- /src/Data/MapUtil.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Data.MapUtil 3 | Description : Definition of lookupWithKey 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | module Data.MapUtil ( 12 | 13 | lookupWithKey 14 | 15 | ) where 16 | 17 | import qualified Data.Map as M 18 | import qualified Data.Set as S 19 | 20 | -- | Lookup a key in a map and get back the actual key as well. Useful when 21 | -- the key Eq instance is not quite so sharp, i.e. when k ~ Zone and we 22 | -- have a special zone which matches a normal zone, we want to get back the 23 | -- zone that was in the map, not the zone that was used to lookup. 24 | lookupWithKey 25 | :: Ord k 26 | => k 27 | -> M.Map k v 28 | -> Maybe (k, v) 29 | lookupWithKey k m = 30 | let v = M.lookup k m 31 | keys = M.keysSet m 32 | -- keys `S.intersection` S.singleton k is empty iff v is Nothing, so 33 | -- this won't be undefined. 34 | -- 35 | -- NB: the point is that intersection biases to the left, so that 36 | -- k' is not necessarily the same as k. 37 | k' = head (S.elems (keys `S.intersection` S.singleton k)) 38 | in fmap (\x -> (k', x)) v 39 | -------------------------------------------------------------------------------- /src/Diplomacy/Unit.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.Unit 3 | Description : Definition of units (armies and fleets) 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE StandaloneDeriving #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | 15 | module Diplomacy.Unit ( 16 | 17 | Unit(..) 18 | 19 | , parseUnit 20 | , printUnit 21 | 22 | ) where 23 | 24 | import Control.Applicative 25 | import Data.String (IsString) 26 | import Text.Parsec hiding ((<|>)) 27 | import Text.Parsec.Text 28 | 29 | data Unit where 30 | Army :: Unit 31 | Fleet :: Unit 32 | 33 | deriving instance Eq Unit 34 | deriving instance Ord Unit 35 | deriving instance Show Unit 36 | deriving instance Enum Unit 37 | deriving instance Bounded Unit 38 | 39 | parseUnit :: Parser Unit 40 | parseUnit = parseFleet <|> parseArmy 41 | where 42 | parseFleet :: Parser Unit 43 | parseFleet = (char 'F' <|> char 'f') *> pure Fleet 44 | parseArmy :: Parser Unit 45 | parseArmy = (char 'A' <|> char 'a') *> pure Army 46 | 47 | printUnit :: IsString a => Unit -> a 48 | printUnit unit = case unit of 49 | Army -> "A" 50 | Fleet -> "F" 51 | -------------------------------------------------------------------------------- /src/Diplomacy/SupplyCentreDeficit.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.SupplyCentreDeficit 3 | Description : Compute the supply centre deficit for a 'GreatPower'. 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | module Diplomacy.SupplyCentreDeficit ( 12 | 13 | SupplyCentreDeficit 14 | 15 | , supplyCentreDeficit 16 | 17 | ) where 18 | 19 | import qualified Data.Map as M 20 | import Diplomacy.GreatPower 21 | import Diplomacy.Occupation 22 | import Diplomacy.Control 23 | import Diplomacy.Province 24 | import Diplomacy.Aligned 25 | import Diplomacy.Unit 26 | 27 | type SupplyCentreDeficit = Int 28 | 29 | supplyCentreDeficit 30 | :: GreatPower 31 | -> Occupation 32 | -> Control 33 | -> SupplyCentreDeficit 34 | supplyCentreDeficit greatPower occupation control = unitCount - supplyCentreCount 35 | where 36 | unitCount = M.foldr unitCountFold 0 occupation 37 | supplyCentreCount = M.foldrWithKey supplyCentreCountFold 0 control 38 | unitCountFold :: Aligned Unit -> Int -> Int 39 | unitCountFold aunit 40 | | alignedGreatPower aunit == greatPower = (+) 1 41 | | otherwise = id 42 | supplyCentreCountFold :: Province -> GreatPower -> Int -> Int 43 | supplyCentreCountFold pr greatPower' 44 | | greatPower' == greatPower 45 | && elem pr supplyCentres = (+) 1 46 | | otherwise = id 47 | -------------------------------------------------------------------------------- /src/Diplomacy/Zone.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.Zone 3 | Description : ProvinceTarget with different Eq, Ord instances. 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | 13 | module Diplomacy.Zone ( 14 | 15 | Zone(..) 16 | 17 | , zoneProvinceTarget 18 | 19 | ) where 20 | 21 | import Diplomacy.Province 22 | 23 | -- | A ProvinceTarget in which coasts of the same Province are equal. 24 | -- This notion is useful because the rules of Diplomacy state that each 25 | -- Zone is occupied by at most one unit, i.e. there cannot be a unit at 26 | -- two coasts of the same Province. 27 | newtype Zone = Zone ProvinceTarget 28 | 29 | deriving instance Show Zone 30 | 31 | instance Eq Zone where 32 | Zone x == Zone y = case (x, y) of 33 | (Normal p1, Normal p2) -> p1 == p2 34 | (Special c1, Special c2) -> pcProvince c1 == pcProvince c2 35 | (Normal p, Special c) -> p == pcProvince c 36 | (Special c, Normal p) -> p == pcProvince c 37 | 38 | instance Ord Zone where 39 | Zone x `compare` Zone y = case (x, y) of 40 | (Normal p1, Normal p2) -> p1 `compare` p2 41 | (Special c1, Special c2) -> pcProvince c1 `compare` pcProvince c2 42 | (Normal p, Special c) -> p `compare` pcProvince c 43 | (Special c, Normal p) -> pcProvince c `compare` p 44 | 45 | zoneProvinceTarget :: Zone -> ProvinceTarget 46 | zoneProvinceTarget (Zone pt) = pt 47 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Alexander Vieth 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alexander Vieth nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/Diplomacy/ZonedSubject.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.ZonedSubject 3 | Description : Subject with different Eq, Ord instances. 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | 13 | module Diplomacy.ZonedSubject ( 14 | 15 | ZonedSubjectDull(..) 16 | , ZonedSubjectSharp(..) 17 | 18 | , zonedSubjectDull 19 | , zonedSubjectSharp 20 | 21 | ) where 22 | 23 | import Diplomacy.Subject 24 | import Diplomacy.Zone 25 | 26 | newtype ZonedSubjectDull = ZonedSubjectDull Subject 27 | 28 | deriving instance Show ZonedSubjectDull 29 | 30 | instance Eq ZonedSubjectDull where 31 | ZonedSubjectDull (_, pt1) == ZonedSubjectDull (_, pt2) = 32 | Zone pt1 == Zone pt2 33 | 34 | instance Ord ZonedSubjectDull where 35 | ZonedSubjectDull (_, pt1) `compare` ZonedSubjectDull (_, pt2) = 36 | Zone pt1 `compare` Zone pt2 37 | 38 | zonedSubjectDull :: ZonedSubjectDull -> Subject 39 | zonedSubjectDull (ZonedSubjectDull x) = x 40 | 41 | newtype ZonedSubjectSharp = ZonedSubjectSharp Subject 42 | 43 | deriving instance Show ZonedSubjectSharp 44 | 45 | instance Eq ZonedSubjectSharp where 46 | ZonedSubjectSharp (u1, pt1) == ZonedSubjectSharp (u2, pt2) = 47 | Zone pt1 == Zone pt2 && u1 == u2 48 | 49 | instance Ord ZonedSubjectSharp where 50 | ZonedSubjectSharp (u1, pt1) `compare` ZonedSubjectSharp (u2, pt2) = 51 | case Zone pt1 `compare` Zone pt2 of 52 | EQ -> u1 `compare` u2 53 | x -> x 54 | 55 | zonedSubjectSharp :: ZonedSubjectSharp -> Subject 56 | zonedSubjectSharp (ZonedSubjectSharp x) = x 57 | -------------------------------------------------------------------------------- /Example.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.Map as M 2 | import Diplomacy.Unit 3 | import Diplomacy.Province 4 | import Diplomacy.Zone 5 | import Diplomacy.OrderObject 6 | import Diplomacy.GreatPower 7 | import Diplomacy.Aligned 8 | import Diplomacy.Game 9 | 10 | -- Orders for first Typical Phase (first round). 11 | firstOrders = M.fromList [ 12 | (Zone (Normal London), (align Fleet England, SomeOrderObject (MoveObject (Normal EnglishChannel)))) 13 | , (Zone (Normal Edinburgh), (align Fleet England, SomeOrderObject (MoveObject (Normal NorthSea)))) 14 | , (Zone (Special StPetersburgSouth), (align Fleet Russia, SomeOrderObject (MoveObject (Normal GulfOfBothnia)))) 15 | , (Zone (Normal Marseilles), (align Army France, SomeOrderObject (MoveObject (Normal Piedmont)))) 16 | ] 17 | 18 | -- Orders for second Typical phase (third round). 19 | secondOrders = M.fromList [ 20 | (Zone (Normal Piedmont), (align Army France, SomeOrderObject (MoveObject (Normal Venice)))) 21 | , (Zone (Normal Trieste), (align Fleet Austria, SomeOrderObject (SupportObject (Army, Normal Piedmont) (Normal Venice)))) 22 | ] 23 | 24 | -- Orders for second Retreat phase (fourth round). 25 | thirdOrders = M.fromList [ 26 | (Zone (Normal Venice), (align Army Italy, SomeOrderObject (WithdrawObject (Normal Tuscany)))) 27 | ] 28 | 29 | main = do 30 | let game0 = snd (issueOrders firstOrders newGame) 31 | putStrLn (showGame game0) 32 | putStrLn "\nPress any key to see next typical phase.\n" 33 | getChar 34 | let game1 = snd (issueOrders secondOrders (continue . resolve . continue . resolve $ game0)) 35 | putStrLn (showGame game1) 36 | putStrLn "\nPress any key to see the next retreat phase." 37 | putStrLn "Note that the Italian army in Venice is dislodged and retreats to Tuscany.\n" 38 | getChar 39 | let game2 = snd (issueOrders thirdOrders (continue . resolve $ game1)) 40 | putStrLn (showGame game2) 41 | -------------------------------------------------------------------------------- /src/Diplomacy/Dislodgement.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.Dislodgement 3 | Description : Unit dislodgement. 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | {-# LANGUAGE DataKinds #-} 12 | {-# LANGUAGE GADTs #-} 13 | 14 | module Diplomacy.Dislodgement ( 15 | 16 | Dislodgement 17 | 18 | , dislodgementAndOccupation 19 | 20 | ) where 21 | 22 | import qualified Data.Map as M 23 | import Diplomacy.Aligned 24 | import Diplomacy.Unit 25 | import Diplomacy.Zone 26 | import Diplomacy.OrderObject 27 | import Diplomacy.Phase 28 | import Diplomacy.Occupation 29 | import Diplomacy.OrderResolution 30 | 31 | type Dislodgement = M.Map Zone (Aligned Unit) 32 | 33 | -- | Use resolved Typical phase orders to compute the 'Dislodgement' and 34 | -- 'Occupation' for the next (Retreat) phase. 35 | dislodgementAndOccupation 36 | :: M.Map Zone (Aligned Unit, SomeResolved OrderObject Typical) 37 | -> (Dislodgement, Occupation) 38 | dislodgementAndOccupation zonedResolvedOrders = (dislodgement, occupation) 39 | where 40 | 41 | currentOccupation :: Occupation 42 | currentOccupation = M.map (\(a, _) -> a) zonedResolvedOrders 43 | 44 | -- First, compute the occupation delta by checking for successful moves. 45 | moveOccupation :: Occupation 46 | stationaryOccupation :: Occupation 47 | (moveOccupation, stationaryOccupation) = M.foldrWithKey nextOccupationFold (M.empty, M.empty) currentOccupation 48 | nextOccupationFold 49 | :: Zone 50 | -> Aligned Unit 51 | -> (Occupation, Occupation) 52 | -> (Occupation, Occupation) 53 | nextOccupationFold zone aunit (move, stationary) = case M.lookup zone zonedResolvedOrders of 54 | Just (_, SomeResolved (MoveObject pt, Nothing)) -> 55 | (M.insert (Zone pt) aunit move, stationary) 56 | _ -> 57 | (move, M.insert zone aunit stationary) 58 | 59 | -- The dislodgement is the left-biased intersection of the current 60 | -- occupation with the change in occupation induced by successful 61 | -- moves (moveOccupation), as these occupations have been upset by 62 | -- the moves. 63 | dislodgement :: Dislodgement 64 | dislodgement = stationaryOccupation `M.intersection` moveOccupation 65 | 66 | -- The next occupation is the left-biased union of the deltas with 67 | -- the current occupation 68 | occupation :: Occupation 69 | occupation = moveOccupation `M.union` (stationaryOccupation `M.difference` dislodgement) 70 | -------------------------------------------------------------------------------- /src/Data/AtLeast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Data.AtLeast 3 | Description : Lists of at least n elements. 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE DataKinds #-} 14 | {-# LANGUAGE PatternSynonyms #-} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | {-# LANGUAGE FlexibleContexts #-} 17 | {-# LANGUAGE StandaloneDeriving #-} 18 | 19 | module Data.AtLeast ( 20 | 21 | AtLeast(..) 22 | 23 | , fromList 24 | , toList 25 | , appendList 26 | 27 | , weaken 28 | , maxima 29 | 30 | , head 31 | 32 | ) where 33 | 34 | import Prelude hiding (head) 35 | import Data.List ((\\)) 36 | import Data.Ord 37 | import Data.TypeNat.Nat 38 | import Data.TypeNat.Vect 39 | 40 | data AtLeast (n :: Nat) (t :: *) = AtLeast (Vect n t) [t] 41 | 42 | -- Equality ignores order of elements. 43 | instance Eq t => Eq (AtLeast n t) where 44 | (==) xs ys = case (toList xs) \\ (toList ys) of 45 | [] -> True 46 | _ -> False 47 | 48 | deriving instance Show t => Show (AtLeast n t) 49 | 50 | appendList :: AtLeast n t -> [t] -> AtLeast n t 51 | appendList (AtLeast vect rest) xs = AtLeast vect (xs ++ rest) 52 | 53 | fromList :: [t] -> AtLeast Z t 54 | fromList xs = AtLeast VNil xs 55 | 56 | toList :: AtLeast n t -> [t] 57 | toList (AtLeast vs xs) = vectToList vs ++ xs 58 | 59 | head :: AtLeast One t -> t 60 | head (AtLeast vs xs) = case (vs, xs) of 61 | (VCons x _, _) -> x 62 | 63 | newtype Weaken t n = Weaken { 64 | unWeaken :: AtLeast n t 65 | } 66 | 67 | weaken1 :: AtLeast (S n) t -> AtLeast n t 68 | weaken1 (AtLeast vs xs) = case vs of 69 | VCons x rest -> AtLeast rest (x : xs) 70 | 71 | weaken :: forall n m t . LTE n m => AtLeast m t -> AtLeast n t 72 | weaken = unWeaken . lteRecursion recurse . Weaken 73 | where 74 | recurse :: forall k . LTE n k => Weaken t (S k) -> Weaken t k 75 | recurse (Weaken atLeast) = Weaken (weaken1 atLeast) 76 | 77 | maxima :: (t -> t -> Ordering) -> AtLeast One t -> AtLeast One t 78 | maxima comparator (AtLeast vs xs) = case vs of 79 | VCons x rest -> maxima' comparator (AtLeast (VCons x VNil) []) (vectToList rest ++ xs) 80 | where 81 | maxima' :: (t -> t -> Ordering) -> AtLeast One t -> [t] -> AtLeast One t 82 | maxima' comparator acc rest = case rest of 83 | [] -> acc 84 | (x : rest) -> case comparator (head acc) x of 85 | GT -> maxima' comparator acc rest 86 | EQ -> maxima' comparator (appendList acc [x]) rest 87 | LT -> maxima' comparator (AtLeast (VCons x VNil) []) rest 88 | -------------------------------------------------------------------------------- /src/Diplomacy/Occupation.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.Occupation 3 | Description : Definition of Zone/ProvinceTarget occupation. 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | module Diplomacy.Occupation ( 12 | 13 | Occupation 14 | 15 | , emptyOccupation 16 | , occupy 17 | , occupier 18 | , provinceOccupier 19 | , occupies 20 | , unitOccupies 21 | , occupied 22 | , zoneOccupied 23 | , allSubjects 24 | 25 | ) where 26 | 27 | import qualified Data.Map as M 28 | import Data.MapUtil 29 | import Data.Maybe (isJust) 30 | import Diplomacy.Aligned 31 | import Diplomacy.Unit 32 | import Diplomacy.Province 33 | import Diplomacy.Zone 34 | import Diplomacy.Subject 35 | import Diplomacy.GreatPower 36 | 37 | -- | Each Zone is occupied by at most one Aligned Unit, but the functions on 38 | -- Occupation work with ProvinceTarget; the use of Zone as a key here is just 39 | -- to guarantee that we don't have, for instance, units on both of Spain's 40 | -- coasts simultaneously. 41 | type Occupation = M.Map Zone (Aligned Unit) 42 | 43 | emptyOccupation :: Occupation 44 | emptyOccupation = M.empty 45 | 46 | occupy :: ProvinceTarget -> Maybe (Aligned Unit) -> Occupation -> Occupation 47 | occupy pt maunit = M.alter (const maunit) (Zone pt) 48 | 49 | -- | Must be careful with this one! We can't just lookup the Zone corresponding 50 | -- to the ProvinceTarget; we must also check that the key matching that Zone, 51 | -- if there is one in the map, is also ProvinceTarget-equal. 52 | occupier :: ProvinceTarget -> Occupation -> Maybe (Aligned Unit) 53 | occupier pt occupation = case lookupWithKey (Zone pt) occupation of 54 | Just (zone, value) -> 55 | if zoneProvinceTarget zone == pt 56 | then Just value 57 | else Nothing 58 | _ -> Nothing 59 | 60 | provinceOccupier :: Province -> Occupation -> Maybe (Aligned Unit) 61 | provinceOccupier pr occupation = case lookupWithKey (Zone (Normal pr)) occupation of 62 | Just (zone, value) -> 63 | if zoneProvinceTarget zone == Normal pr 64 | then Just value 65 | else Nothing 66 | _ -> Nothing 67 | 68 | occupies :: Aligned Unit -> ProvinceTarget -> Occupation -> Bool 69 | occupies aunit pt = (==) (Just aunit) . occupier pt 70 | 71 | unitOccupies :: Unit -> ProvinceTarget -> Occupation -> Bool 72 | unitOccupies unit pt = (==) (Just unit) . fmap alignedThing . occupier pt 73 | 74 | occupied :: ProvinceTarget -> Occupation -> Bool 75 | occupied pt = isJust . occupier pt 76 | 77 | zoneOccupied :: Zone -> Occupation -> Bool 78 | zoneOccupied zone = isJust . M.lookup zone 79 | 80 | allSubjects :: Maybe GreatPower -> Occupation -> [Subject] 81 | allSubjects maybeGreatPower = M.foldrWithKey f [] 82 | where 83 | f zone aunit = 84 | let subject = (alignedThing aunit, zoneProvinceTarget zone) 85 | in if maybeGreatPower == Nothing || Just (alignedGreatPower aunit) == maybeGreatPower 86 | then (:) subject 87 | else id 88 | -------------------------------------------------------------------------------- /diplomacy.cabal: -------------------------------------------------------------------------------- 1 | -- Initial diplomacy.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: diplomacy 5 | version: 0.2.0.1 6 | synopsis: Diplomacy board game 7 | description: The board game Diplomacy, spoken in Haskell 8 | homepage: https://github.com/avieth/diplomacy 9 | license: BSD3 10 | license-file: LICENSE 11 | author: Alexander Vieth 12 | maintainer: aovieth@gmail.com 13 | copyright: BSD3 14 | category: Games 15 | build-type: Simple 16 | extra-source-files: README.md 17 | cabal-version: >=1.10 18 | 19 | source-repository head 20 | type: git 21 | location: http://github.com/avieth/diplomacy.git 22 | 23 | library 24 | exposed-modules: Diplomacy.OrderObject 25 | , Diplomacy.Zone 26 | , Diplomacy.ZonedSubject 27 | , Diplomacy.Turn 28 | , Diplomacy.SupplyCentreDeficit 29 | , Diplomacy.Order 30 | , Diplomacy.Season 31 | , Diplomacy.Control 32 | , Diplomacy.OrderType 33 | , Diplomacy.GreatPower 34 | , Diplomacy.Occupation 35 | , Diplomacy.Dislodgement 36 | , Diplomacy.Aligned 37 | , Diplomacy.OrderValidation 38 | , Diplomacy.Province 39 | , Diplomacy.Unit 40 | , Diplomacy.OrderResolution 41 | , Diplomacy.Phase 42 | , Diplomacy.Game 43 | , Diplomacy.Subject 44 | , Data.MapUtil 45 | , Data.AtLeast 46 | other-extensions: GADTs 47 | , DataKinds 48 | , ImpredicativeTypes 49 | , MultiParamTypeClasses 50 | , FlexibleInstances 51 | , FlexibleContexts 52 | , ScopedTypeVariables 53 | , PolyKinds 54 | , KindSignatures 55 | , DeriveFunctor 56 | , GeneralizedNewtypeDeriving 57 | , StandaloneDeriving 58 | , TypeFamilies 59 | , OverloadedStrings 60 | , RankNTypes 61 | , PatternSynonyms 62 | 63 | build-depends: base >=4.7 && <5 64 | , containers >=0.5 && <0.7 65 | , transformers >=0.3 && <0.6 66 | , text 67 | , TypeNat >=0.5 && <0.6 68 | , parsec >= 3.1 && <3.2 69 | hs-source-dirs: ./src 70 | default-language: Haskell2010 71 | 72 | test-suite adjudication 73 | type: exitcode-stdio-1.0 74 | main-is: Main.hs 75 | hs-source-dirs: ./test/adjudication 76 | other-modules: AdjudicationTests 77 | build-depends: base 78 | , diplomacy 79 | , HUnit 80 | , TypeNat 81 | , containers 82 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Diplomacy 2 | 3 | These programs aspire to provide everything you need in order to talk about 4 | the board game [Diplomacy](https://en.wikipedia.org/wiki/Diplomacy_%28game%29) 5 | in Haskell. 6 | 7 | ## State of the project 8 | 9 | Things look good. The order resolution component passes over 100 of the 10 | [DATC](http://web.inter.nl.net/users/L.B.Kruijswijk/) test cases. 11 | It probably passes more than that, but not every one of them has been 12 | transcribed. 13 | 14 | ## Components 15 | 16 | This project is organized into four parts: 17 | 18 | - The types and data for the fundamental language of the game. 19 | - The characterizations of valid orders. 20 | - The resolution of orders. 21 | - The description of the state of a particular game. 22 | 23 | ### Characterization of valid orders 24 | 25 | An order is defined to be any subject/object pair. For instance, the subject of 26 | `A Ion S A Bre - Par` is `A Ion` (an army in the Ionian Sea) and the object is 27 | `S A Bre - Par` (support the army in Brest as it moves into Paris). Not every 28 | such order makes sense: that support order is invalid, not only because an 29 | army cannot be in the Ionian Sea, but also because no unit in the Ionian Sea 30 | can support a move into Paris. 31 | 32 | As far as I can tell, the characterization of valid orders is too intricate for 33 | Haskell's type system, even with state of the art GHC-only extensions, to handle 34 | well. Perhaps a language with full dependent types such as Idris is up to the 35 | task, but in this project, we do order validation at the value level. However, 36 | instead of giving indicator functions `Order phase orderType -> Bool` for 37 | validity, we give more intricate descriptions of *why* an order is valid, in 38 | the form of an intersection of unions of sets (corresponding to a conjunctive 39 | normal form clause). By actually constructing the valid orders and their 40 | components, we obtain not only a way to check validity (`analyze`) but also a 41 | way to generate all valid orders (`synthesize`), which could be very useful 42 | when implementing a user-facing client. 43 | 44 | An order of the typical or retreat phase is either valid or invalid, regardless 45 | of the other orders issued. The mantra for these phases is that a valid order 46 | would succeed if no other orders were issued. The situation is different for 47 | the adjust phase, in which no order is valid on its own. Instead, the whole set 48 | of orders for a given great power is either valid or invalid. This is due to 49 | the deficit constraint: if a great power has more units than supply centres, 50 | it must disband *exactly* the difference; if it has more supply centres than 51 | units, it *may* build at most the magnitude of the difference. In this phase, 52 | a valid *set* of orders would succeed regardless of the orders of the other 53 | great powers (and in fact it *will* succeed, because adjust phase orders from 54 | different great powers never conflict). 55 | 56 | ### Resolution of orders 57 | 58 | In order to carry a game from one round to the next (for instance, to go 59 | from a typical phase to a retreat phase), orders must be checked against one 60 | another to determine which orders succeed, and which orders fail. This process 61 | is known as *order resolution*, and it is defined distinctly for each phase. 62 | 63 | While the adjust phase is clearly the most simple to resolve (every valid order 64 | succeeds), the typical phase resolution is far more complex than that of the 65 | retreat phase. This typical phase resolver is the component which determines 66 | which supports are cut, which convoys fail, which moves standoff or are 67 | overpowered. It must also deal with the ambiguities in the rulebook, which 68 | the DATC is very helpful in pointing out and characterizing via tests. 69 | 70 | ## Thanks 71 | 72 | Much thanks to Lucas B. Kruijswijk for giving us the 73 | [DATC](http://web.inter.nl.net/users/L.B.Kruijswijk/), from which 74 | [many tests](AdjudicationTests.hs) were transcribed and consequently many bugs 75 | discovered and fixed. 76 | -------------------------------------------------------------------------------- /src/Diplomacy/OrderObject.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.OrderObject 3 | Description : Definition of OrderObject, which describes what a Subject is to do. 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE KindSignatures #-} 14 | {-# LANGUAGE StandaloneDeriving #-} 15 | 16 | module Diplomacy.OrderObject ( 17 | 18 | OrderObject(..) 19 | , orderObjectEqual 20 | 21 | , SomeOrderObject(..) 22 | 23 | , moveTarget 24 | , supportedSubject 25 | , supportTarget 26 | , convoySubject 27 | , convoyTarget 28 | , withdrawTarget 29 | 30 | ) where 31 | 32 | import Diplomacy.Phase 33 | import Diplomacy.Subject 34 | import Diplomacy.OrderType 35 | import Diplomacy.Province 36 | 37 | -- | The objective of an order. Together with an Subject and a GreatPower, 38 | -- this makes a complete order. 39 | data OrderObject (phase :: Phase) (order :: OrderType) where 40 | 41 | MoveObject :: ProvinceTarget -> OrderObject Typical Move 42 | SupportObject 43 | :: Subject 44 | -> ProvinceTarget 45 | -> OrderObject Typical Support 46 | ConvoyObject 47 | -- TODO later, would be cool if we could use type system extensions 48 | -- to eliminate bogus convoys like convoys of fleets or convoys from/to 49 | -- water provinces. 50 | :: Subject 51 | -> ProvinceTarget 52 | -> OrderObject Typical Convoy 53 | 54 | WithdrawObject :: ProvinceTarget -> OrderObject Retreat Withdraw 55 | SurrenderObject :: OrderObject Retreat Surrender 56 | 57 | -- Adjust phase is a bit weird because the BuildObject is for units which 58 | -- don't actually exist. You can undo a Disband by giving a Continue, but 59 | -- you can't undo a Build by giving anything. 60 | -- FIXME we could probably do better, by having build orders held in 61 | -- a separate structure. For now, a game server implementation can require 62 | -- that all build orders be given in a batch, clearing any previous ones. 63 | BuildObject :: OrderObject Adjust Build 64 | DisbandObject :: OrderObject Adjust Disband 65 | -- | This is convenient because with it, every unit always has an 66 | -- order in every phase. 67 | ContinueObject :: OrderObject Adjust Continue 68 | 69 | deriving instance Eq (OrderObject phase order) 70 | deriving instance Show (OrderObject phase order) 71 | 72 | instance Ord (OrderObject phase order) where 73 | x `compare` y = case (x, y) of 74 | (MoveObject pt, MoveObject pt') -> pt `compare` pt' 75 | (SupportObject subj pt, SupportObject subj' pt') -> (subj, pt) `compare` (subj, pt') 76 | (ConvoyObject subj pt, ConvoyObject subj' pt') -> (subj, pt) `compare` (subj', pt') 77 | (SurrenderObject, SurrenderObject) -> EQ 78 | (WithdrawObject pt, WithdrawObject pt') -> pt `compare` pt' 79 | (DisbandObject, DisbandObject) -> EQ 80 | (BuildObject, BuildObject) -> EQ 81 | (ContinueObject, ContinueObject) -> EQ 82 | 83 | orderObjectEqual :: OrderObject phase order -> OrderObject phase' order' -> Bool 84 | orderObjectEqual object1 object2 = case (object1, object2) of 85 | (MoveObject pt1, MoveObject pt2) -> pt1 == pt2 86 | (SupportObject subj1 pt1, SupportObject subj2 pt2) -> (subj1, pt1) == (subj2, pt2) 87 | (ConvoyObject subj1 pt1, ConvoyObject subj2 pt2) -> (subj1, pt1) == (subj2, pt2) 88 | (WithdrawObject pt1, WithdrawObject pt2) -> pt1 == pt2 89 | (SurrenderObject, SurrenderObject) -> True 90 | (DisbandObject, DisbandObject) -> True 91 | (BuildObject, BuildObject) -> True 92 | (ContinueObject, ContinueObject) -> True 93 | _ -> False 94 | 95 | moveTarget :: OrderObject Typical Move -> ProvinceTarget 96 | moveTarget (MoveObject x) = x 97 | 98 | supportedSubject :: OrderObject Typical Support -> Subject 99 | supportedSubject (SupportObject x _) = x 100 | 101 | supportTarget :: OrderObject Typical Support -> ProvinceTarget 102 | supportTarget (SupportObject _ x) = x 103 | 104 | convoySubject :: OrderObject Typical Convoy -> Subject 105 | convoySubject (ConvoyObject x _) = x 106 | 107 | convoyTarget :: OrderObject Typical Convoy -> ProvinceTarget 108 | convoyTarget (ConvoyObject _ x) = x 109 | 110 | withdrawTarget :: OrderObject Retreat Withdraw -> ProvinceTarget 111 | withdrawTarget (WithdrawObject x) = x 112 | 113 | data SomeOrderObject phase where 114 | SomeOrderObject :: OrderObject phase order -> SomeOrderObject phase 115 | 116 | deriving instance Show (SomeOrderObject phase) 117 | 118 | {- 119 | instance Eq (SomeOrderObject phase) where 120 | (SomeOrderObject x) == (SomeOrderObject y) = case (x, y) of 121 | (MoveObject _, MoveObject _) -> x == y 122 | (SupportObject _ _, SupportObject _ _) -> x == y 123 | (ConvoyObject _ _, ConvoyObject _ _) -> x == y 124 | (SurrenderObject, SurrenderObject) -> x == y 125 | (WithdrawObject _, WithdrawObject _) -> x == y 126 | (DisbandObject, DisbandObject) -> x == y 127 | (BuildObject, BuildObject) -> x == y 128 | (ContinueObject, ContinueObject) -> x == y 129 | -} 130 | -------------------------------------------------------------------------------- /src/Diplomacy/Order.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.Order 3 | Description : Definition of an order 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | {-# LANGUAGE DataKinds #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE GADTs #-} 14 | {-# LANGUAGE StandaloneDeriving #-} 15 | {-# LANGUAGE OverloadedStrings #-} 16 | 17 | module Diplomacy.Order ( 18 | 19 | Order(..) 20 | 21 | , SomeOrder(..) 22 | , move 23 | , hold 24 | , support 25 | , convoy 26 | , surrender 27 | , retreat 28 | , build 29 | , disband 30 | , continue 31 | 32 | , orderSubject 33 | , orderObject 34 | 35 | , isHold 36 | , movingFrom 37 | , movingTo 38 | , supportsOrder 39 | 40 | , printSomeOrder 41 | , parseSomeOrder 42 | , printSubject 43 | , parseSubject 44 | , printObject 45 | , parseObject 46 | 47 | ) where 48 | 49 | import Data.Coerce (coerce) 50 | import Diplomacy.GreatPower 51 | import Diplomacy.Aligned 52 | import Diplomacy.Phase 53 | import Diplomacy.Subject 54 | import Diplomacy.OrderType 55 | import Diplomacy.OrderObject 56 | import Diplomacy.Province 57 | import Diplomacy.Unit 58 | import Data.Text as T 59 | import Text.Parsec 60 | import Text.Parsec.Text 61 | 62 | newtype Order (phase :: Phase) (order :: OrderType) = Order { 63 | outOrder :: (Subject, OrderObject phase order) 64 | } deriving (Eq, Ord, Show) 65 | 66 | coerce' :: Order phase order -> (Subject, OrderObject phase order) 67 | coerce' = coerce 68 | 69 | orderSubject :: Order phase order -> Subject 70 | orderSubject = fst . coerce' 71 | 72 | orderObject :: Order phase order -> OrderObject phase order 73 | orderObject = snd . coerce' 74 | 75 | data SomeOrder phase where 76 | SomeOrder :: Order phase order -> SomeOrder phase 77 | 78 | instance Eq (SomeOrder phase) where 79 | SomeOrder o1 == SomeOrder o2 = case (orderObject o1, orderObject o2) of 80 | (MoveObject _, MoveObject _) -> o1 == o2 81 | (SupportObject _ _, SupportObject _ _) -> o1 == o2 82 | (ConvoyObject _ _, ConvoyObject _ _) -> o1 == o2 83 | (SurrenderObject, SurrenderObject) -> o1 == o2 84 | (WithdrawObject _, WithdrawObject _) -> o1 == o2 85 | (DisbandObject, DisbandObject) -> o1 == o2 86 | (BuildObject, BuildObject) -> o1 == o2 87 | (ContinueObject, ContinueObject) -> o1 == o2 88 | _ -> False 89 | 90 | instance Ord (SomeOrder phase) where 91 | SomeOrder o1 `compare` SomeOrder o2 = show o1 `compare` show o2 92 | 93 | deriving instance Show (SomeOrder phase) 94 | 95 | move :: Unit -> ProvinceTarget -> ProvinceTarget -> SomeOrder Typical 96 | move unit from target = SomeOrder (Order ((unit, from), MoveObject target)) 97 | 98 | hold :: Unit -> ProvinceTarget -> SomeOrder Typical 99 | hold unit at = move unit at at 100 | 101 | support :: Unit -> ProvinceTarget -> Unit -> ProvinceTarget -> ProvinceTarget -> SomeOrder Typical 102 | support unit at unit' at' target = SomeOrder (Order ((unit, at), SupportObject (unit', at') target)) 103 | 104 | convoy :: Unit -> ProvinceTarget -> Unit -> ProvinceTarget -> ProvinceTarget -> SomeOrder Typical 105 | convoy unit at unit' at' target = SomeOrder (Order ((unit, at), ConvoyObject (unit', at') target)) 106 | 107 | surrender :: Unit -> ProvinceTarget -> SomeOrder Retreat 108 | surrender unit at = SomeOrder (Order ((unit, at), SurrenderObject)) 109 | 110 | retreat :: Unit -> ProvinceTarget -> ProvinceTarget -> SomeOrder Retreat 111 | retreat unit at target = SomeOrder (Order ((unit, at), WithdrawObject target)) 112 | 113 | build :: Unit -> ProvinceTarget -> SomeOrder Adjust 114 | build unit at = SomeOrder (Order ((unit, at), BuildObject)) 115 | 116 | disband :: Unit -> ProvinceTarget -> SomeOrder Adjust 117 | disband unit at = SomeOrder (Order ((unit, at), DisbandObject)) 118 | 119 | continue :: Unit -> ProvinceTarget -> SomeOrder Adjust 120 | continue unit at = SomeOrder (Order ((unit, at), ContinueObject)) 121 | 122 | isHold :: Order Typical Move -> Bool 123 | isHold order = from == to 124 | where 125 | to = moveTarget . orderObject $ order 126 | from = subjectProvinceTarget . orderSubject $ order 127 | 128 | movingFrom :: Order Typical Move -> ProvinceTarget 129 | movingFrom = subjectProvinceTarget . orderSubject 130 | 131 | movingTo :: Order Typical Move -> ProvinceTarget 132 | movingTo = moveTarget . orderObject 133 | 134 | supportsOrder :: OrderObject Typical Support -> SomeOrder Typical -> Bool 135 | supportsOrder supportOrderObject (SomeOrder order) = 136 | supportedSubject supportOrderObject == orderSubject order 137 | && supportTarget supportOrderObject == orderDestination order 138 | where 139 | orderDestination :: Order Typical order -> ProvinceTarget 140 | orderDestination order = case orderObject order of 141 | MoveObject pt -> pt 142 | SupportObject _ _ -> subjectProvinceTarget (orderSubject order) 143 | 144 | -- | 145 | -- = Printing/parsing 146 | -- 147 | -- Aims to be the typical board-game text representation of an order. 148 | 149 | printSomeOrder :: SomeOrder phase -> T.Text 150 | printSomeOrder (SomeOrder order) = T.concat [ 151 | printSubject (orderSubject order) 152 | , " " 153 | , printObject (SomeOrderObject (orderObject order)) 154 | ] 155 | 156 | parseSomeOrder :: IsPhase phase -> Parser (SomeOrder phase) 157 | parseSomeOrder IsTypicalPhase = parseSomeOrderTypical 158 | parseSomeOrder IsRetreatPhase = parseSomeOrderRetreat 159 | parseSomeOrder IsAdjustPhase = parseSomeOrderAdjust 160 | 161 | parseSomeOrderTypical :: Parser (SomeOrder Typical) 162 | parseSomeOrderTypical = do 163 | subject <- parseSubject 164 | spaces 165 | SomeOrderObject object <- parseObjectTypical 166 | return $ SomeOrder (Order (subject, object)) 167 | 168 | parseSomeOrderRetreat :: Parser (SomeOrder Retreat) 169 | parseSomeOrderRetreat = do 170 | subject <- parseSubject 171 | spaces 172 | SomeOrderObject object <- parseObjectRetreat 173 | return $ SomeOrder (Order (subject, object)) 174 | 175 | parseSomeOrderAdjust :: Parser (SomeOrder Adjust) 176 | parseSomeOrderAdjust = do 177 | subject <- parseSubject 178 | spaces 179 | SomeOrderObject object <- parseObjectAdjust 180 | return $ SomeOrder (Order (subject, object)) 181 | 182 | printSubject :: Subject -> T.Text 183 | printSubject (unit, pt) = T.concat [ 184 | printUnit unit 185 | , " " 186 | , printProvinceTarget pt 187 | ] 188 | 189 | parseSubject :: Parser Subject 190 | parseSubject = do 191 | unit <- parseUnit 192 | spaces 193 | pt <- parseProvinceTarget 194 | return (unit, pt) 195 | 196 | printObject :: SomeOrderObject phase -> T.Text 197 | printObject (SomeOrderObject object) = case object of 198 | MoveObject _ -> printMove object 199 | SupportObject _ _ -> printSupport object 200 | ConvoyObject _ _ -> printConvoy object 201 | SurrenderObject -> printSurrender object 202 | WithdrawObject _ -> printWithdraw object 203 | DisbandObject -> printDisband object 204 | BuildObject -> printBuild object 205 | ContinueObject -> printContinue object 206 | 207 | parseObject :: IsPhase phase -> Parser (SomeOrderObject phase) 208 | parseObject IsTypicalPhase = parseObjectTypical 209 | parseObject IsRetreatPhase = parseObjectRetreat 210 | parseObject IsAdjustPhase = parseObjectAdjust 211 | 212 | parseObjectTypical :: Parser (SomeOrderObject Typical) 213 | parseObjectTypical = 214 | (SomeOrderObject <$> try parseMove) 215 | <|> (SomeOrderObject <$> try parseSupport) 216 | <|> (SomeOrderObject <$> try parseConvoy) 217 | 218 | parseObjectRetreat :: Parser (SomeOrderObject Retreat) 219 | parseObjectRetreat = 220 | (SomeOrderObject <$> try parseSurrender) 221 | <|> (SomeOrderObject <$> try parseWithdraw) 222 | 223 | parseObjectAdjust :: Parser (SomeOrderObject Adjust) 224 | parseObjectAdjust = 225 | (SomeOrderObject <$> try parseDisband) 226 | <|> (SomeOrderObject <$> try parseBuild) 227 | <|> (SomeOrderObject <$> try parseContinue) 228 | 229 | printMove :: OrderObject Typical Move -> T.Text 230 | printMove (MoveObject pt) = T.concat ["- ", printProvinceTarget pt] 231 | 232 | parseMove :: Parser (OrderObject Typical Move) 233 | parseMove = do 234 | char '-' 235 | spaces 236 | pt <- parseProvinceTarget 237 | return $ MoveObject pt 238 | 239 | printSupport :: OrderObject Typical Support -> T.Text 240 | printSupport (SupportObject subj pt) = 241 | if subjectProvinceTarget subj == pt 242 | then T.concat ["S ", printSubject subj] 243 | else T.concat ["S ", printSubject subj, " - ", printProvinceTarget pt] 244 | 245 | parseSupport :: Parser (OrderObject Typical Support) 246 | parseSupport = do 247 | (char 'S' <|> char 's') 248 | spaces 249 | subject <- parseSubject 250 | target <- Text.Parsec.option (subjectProvinceTarget subject) (try rest) 251 | return $ SupportObject subject target 252 | where 253 | rest = do 254 | spaces 255 | char '-' 256 | spaces 257 | parseProvinceTarget 258 | 259 | printConvoy :: OrderObject Typical Convoy -> T.Text 260 | printConvoy (ConvoyObject subj pt) = T.concat ["C ", printSubject subj, " - ", printProvinceTarget pt] 261 | 262 | parseConvoy :: Parser (OrderObject Typical Convoy) 263 | parseConvoy = do 264 | (char 'C' <|> char 'c') 265 | spaces 266 | subject <- parseSubject 267 | spaces 268 | char '-' 269 | spaces 270 | target <- parseProvinceTarget 271 | return $ ConvoyObject subject target 272 | 273 | printSurrender :: OrderObject Retreat Surrender -> T.Text 274 | printSurrender SurrenderObject = "Surrender" 275 | 276 | parseSurrender :: Parser (OrderObject Retreat Surrender) 277 | parseSurrender = do 278 | string "Surrender" 279 | return $ SurrenderObject 280 | 281 | printWithdraw :: OrderObject Retreat Withdraw -> T.Text 282 | printWithdraw (WithdrawObject pt) = T.concat ["- ", printProvinceTarget pt] 283 | 284 | parseWithdraw :: Parser (OrderObject Retreat Withdraw) 285 | parseWithdraw = do 286 | char '-' 287 | spaces 288 | pt <- parseProvinceTarget 289 | return $ WithdrawObject pt 290 | 291 | printDisband :: OrderObject Adjust Disband -> T.Text 292 | printDisband DisbandObject = "Disband" 293 | 294 | parseDisband :: Parser (OrderObject Adjust Disband) 295 | parseDisband = do 296 | string "Disband" 297 | return $ DisbandObject 298 | 299 | printBuild :: OrderObject Adjust Build -> T.Text 300 | printBuild BuildObject = "Build" 301 | 302 | parseBuild :: Parser (OrderObject Adjust Build) 303 | parseBuild = do 304 | string "Build" 305 | return $ BuildObject 306 | 307 | printContinue :: OrderObject Adjust Continue -> T.Text 308 | printContinue ContinueObject = "Continue" 309 | 310 | parseContinue :: Parser (OrderObject Adjust Continue) 311 | parseContinue = do 312 | string "Continue" 313 | return $ ContinueObject 314 | -------------------------------------------------------------------------------- /src/Diplomacy/SVGMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- Diplomacy board renderer to SVG. 4 | -- Inspired by and largely copied from the SVG image here: 5 | -- http://upload.wikimedia.org/wikipedia/commons/a/a3/Diplomacy.svg 6 | 7 | import Text.Blaze.Svg11 ((!)) 8 | import qualified Text.Blaze.Svg11 as S 9 | import qualified Text.Blaze.Svg11.Attributes as A 10 | import Text.Blaze.Svg.Renderer.Pretty (renderSvg) 11 | import Text.Blaze.Internal (stringValue) 12 | 13 | import Control.Monad (forM_) 14 | import Data.List ((\\)) 15 | 16 | import Diplomacy.Board 17 | import Diplomacy.Country 18 | import Diplomacy.PlayerCount 19 | import Diplomacy.Province 20 | import Diplomacy.Unit 21 | 22 | svgMap :: Board a -> String 23 | svgMap = renderSvg . preamble . svgBoard 24 | 25 | svgBoard :: Board a -> S.Svg 26 | svgBoard board = do 27 | forM_ (fixOrder properProvinceTargets) (provinceGroup board) 28 | forM_ (supplyCentres) (supplyCentreIcon) 29 | forM_ (occupiedProvinceTargets board) (uncurry unitIcon) 30 | -- TODO Siwtzerland 31 | 32 | -- | We reorder because the drawing method uses a hack: the north sea must 33 | -- be drawn as soon as possible, but not after the norwegian sea is drawn! 34 | fixOrder :: [ProvinceTarget] -> [ProvinceTarget] 35 | fixOrder pts = Normal NorwegianSea : Normal NorthSea : (pts \\ [Normal NorthSea, Normal NorwegianSea]) 36 | 37 | preamble :: S.Svg -> S.Svg 38 | preamble = S.docTypeSvg ! A.version "1.0" ! A.viewbox "0 0 610 560" 39 | 40 | countryColour Austria = "#FF0000"; 41 | countryColour UnitedKingdom = "#0000FF" 42 | countryColour France = "#00FFFF" 43 | countryColour Germany = "#808080" 44 | countryColour Italy = "#00FF00" 45 | countryColour Russia = "#008000" 46 | countryColour Ottoman = "#FFFF00" 47 | 48 | provinceStyle b p = 49 | if isWater p 50 | then stringValue $ "fill: #99CCFF; stroke: black;" 51 | else stringValue $ "fill:" ++ colour ++ "; stroke:black;" 52 | where colour = maybe "#FFFFDD" countryColour (controllerOf b p) 53 | 54 | provinceGroup :: Board a -> ProvinceTarget -> S.Svg 55 | provinceGroup b p = S.g $ do 56 | provinceElement p ! A.style (provinceStyle b pr) 57 | provinceExtras p 58 | -- ^ Some provinces have extra overlays. 59 | provinceText pr ! A.style "font-size:7px; font-family:Arial,Helvetica,sans-serif;" 60 | 61 | where pr = ptProvince p 62 | 63 | unitIcon :: ProvinceTarget -> AlignedUnit -> S.Svg 64 | unitIcon pt au = 65 | if isFleet u 66 | then fleetIcon pt (alignedCountry au) 67 | else armyIcon pt (alignedCountry au) 68 | where u = alignedUnit au 69 | 70 | fleetIcon :: ProvinceTarget -> Country -> S.Svg 71 | fleetIcon pt c = S.text_ "F" ! A.transform (unitTransform pt) -- ! A.style "fill: #000000; stroke:" ++ (countryColour c) ++ ";" 72 | 73 | armyIcon :: ProvinceTarget -> Country -> S.Svg 74 | armyIcon pt c = S.text_ "A" ! A.transform (unitTransform pt) -- ! A.style "fill: #000000; stroke:" ++ (countryColour c) ++ ";" 75 | 76 | unitTransform c = case c of 77 | (Normal Ankara) -> S.translate 482 496 78 | (Normal Belgium) -> S.translate 186 305 79 | (Normal Berlin) -> S.translate 281 298 80 | (Normal Brest) -> S.translate 106 322 81 | (Normal Budapest) -> S.translate 326 376 82 | (Normal Bulgaria) -> S.translate 377 444 83 | (Normal Constantinople) -> S.translate 429 460 84 | (Normal Denmark) -> S.translate 272 252 85 | (Normal Edinburgh) -> S.translate 154 219 86 | (Normal Greece) -> S.translate 378 507 87 | (Normal Holland) -> S.translate 205 284 88 | (Normal Kiel) -> S.translate 254 278 89 | (Normal Liverpool) -> S.translate 144 257 90 | (Normal London) -> S.translate 162 290 91 | (Normal Marseilles) -> S.translate 186 417 92 | (Normal Moscow) -> S.translate 481 234 93 | (Normal Munich) -> S.translate 258 359 94 | (Normal Naples) -> S.translate 278 469 95 | (Normal Norway) -> S.translate 270 187 96 | (Normal Paris) -> S.translate 173 334 97 | (Normal Portugal) -> S.translate 15 434 98 | (Normal Rome) -> S.translate 252 443 99 | (Normal Rumania) -> S.translate 402 413 100 | (Normal Serbia) -> S.translate 343 419 101 | (Normal Sevastopol) -> S.translate 483 396 102 | (Normal Smyrna) -> S.translate 424 502 103 | (Normal Spain) -> S.translate 80 432 104 | (Normal StPetersburg) -> S.translate 418 187 105 | (Normal Sweden) -> S.translate 323 196 106 | (Normal Trieste) -> S.translate 284 396 107 | (Normal Tunis) -> S.translate 220 529 108 | (Normal Venice) -> S.translate 261 397 109 | (Normal Vienna) -> S.translate 301 363 110 | (Normal Warsaw) -> S.translate 346 302 111 | (Special StPetersburgWest) -> S.translate 418 187 112 | x -> error (show x) 113 | 114 | supplyCentreIcon :: Province -> S.Svg 115 | supplyCentreIcon p = S.g ! A.transform t $ do 116 | S.circle ! A.r "2" 117 | S.circle ! A.r "3.5" ! A.style "fill : transparent; stroke : black;" 118 | where t = case p of 119 | Ankara -> S.translate 482 496 120 | Belgium -> S.translate 186 305 121 | Berlin -> S.translate 281 298 122 | Brest -> S.translate 106 322 123 | Budapest -> S.translate 326 376 124 | Bulgaria -> S.translate 377 444 125 | Constantinople -> S.translate 429 460 126 | Denmark -> S.translate 272 252 127 | Edinburgh -> S.translate 154 219 128 | Greece -> S.translate 378 507 129 | Holland -> S.translate 205 284 130 | Kiel -> S.translate 254 278 131 | Liverpool -> S.translate 144 257 132 | London -> S.translate 162 290 133 | Marseilles -> S.translate 186 417 134 | Moscow -> S.translate 481 234 135 | Munich -> S.translate 258 359 136 | Naples -> S.translate 278 469 137 | Norway -> S.translate 270 187 138 | Paris -> S.translate 173 334 139 | Portugal -> S.translate 15 434 140 | Rome -> S.translate 252 443 141 | Rumania -> S.translate 402 413 142 | Serbia -> S.translate 343 419 143 | Sevastopol -> S.translate 483 396 144 | Smyrna -> S.translate 424 502 145 | Spain -> S.translate 80 432 146 | StPetersburg -> S.translate 418 187 147 | Sweden -> S.translate 323 196 148 | Trieste -> S.translate 284 396 149 | Tunis -> S.translate 220 529 150 | Venice -> S.translate 261 397 151 | Vienna -> S.translate 301 363 152 | Warsaw -> S.translate 346 302 153 | x -> error "supplyCentreIcon must only be applied to supplyCentres" 154 | 155 | provinceText :: Province -> S.Svg 156 | provinceText NorwegianSea = S.text_ "NWG" ! A.x "220" ! A.y "70" 157 | provinceText NorthSea = S.text_ "NTH" ! A.x "190" ! A.y "230" 158 | provinceText AdriaticSea = S.text_ "ADR" ! A.x "308" ! A.y "460" 159 | provinceText AegeanSea = S.text_ "AEG" ! A.x "392" ! A.y "510" 160 | provinceText Albania = S.text_ "ALB" ! A.x "333" ! A.y "460" 161 | provinceText Ankara = S.text_ "ANK" ! A.x "510" ! A.y "455" 162 | provinceText Apulia = S.text_ "APU" ! A.x "291" ! A.y "470" 163 | provinceText Armenia = S.text_ "ARM" ! A.x "585" ! A.y "467" 164 | provinceText BalticSea = S.text_ "BAL" ! A.x "308" ! A.y "260" 165 | provinceText BarentsSea = S.text_ "BAR" ! A.x "440" ! A.y "15" 166 | provinceText Belgium = S.text_ "BEL" ! A.x "192" ! A.y "321" 167 | provinceText Berlin = S.text_ "BER" ! A.x "272" ! A.y "292" 168 | provinceText BlackSea = S.text_ "BLA" ! A.x "500" ! A.y "418" 169 | provinceText Bohemia = S.text_ "BOH" ! A.x "283" ! A.y "347" 170 | provinceText Brest = S.text_ "BRE" ! A.x "130" ! A.y "354" 171 | provinceText Budapest = S.text_ "BUD" ! A.x "350" ! A.y "390" 172 | provinceText Bulgaria = S.text_ "BUL" ! A.x "395" ! A.y "443" 173 | provinceText Burgundy = S.text_ "BUR" ! A.x "185" ! A.y "371" 174 | provinceText Clyde = S.text_ "CLY" ! A.x "133" ! A.y "201" 175 | provinceText Constantinople = S.text_ "CON" ! A.x "435" ! A.y "483" 176 | provinceText Denmark = S.text_ "DEN" ! A.x "250" ! A.y "235" 177 | provinceText EasternMediterranean = S.text_ "EAS" ! A.x "455" ! A.y "550" 178 | provinceText Edinburgh = S.text_ "EDI" ! A.x "152" ! A.y "202" 179 | provinceText EnglishChannel = S.text_ "ENG" ! A.x "134" ! A.y "306" 180 | provinceText Finland = S.text_ "FIN" ! A.x "375" ! A.y "160" 181 | provinceText Galacia = S.text_ "GAL" ! A.x "355" ! A.y "343" 182 | provinceText Gascony = S.text_ "GAS" ! A.x "130" ! A.y "400" 183 | provinceText Greece = S.text_ "GRE" ! A.x "352" ! A.y "490" 184 | provinceText GulfOfLyon = S.text_ "LYO" ! A.x "170" ! A.y "457" 185 | provinceText GulfOfBothnia = S.text_ "BOT" ! A.x "328" ! A.y "175" 186 | provinceText HelgolandBright = S.text_ "HEL" ! A.x "220" ! A.y "265" 187 | provinceText Holland = S.text_ "HOL" ! A.x "210" ! A.y "290" 188 | provinceText IonianSea = S.text_ "ION" ! A.x "315" ! A.y "520" 189 | provinceText IrishSea = S.text_ "IRI" ! A.x "95" ! A.y "270" 190 | provinceText Kiel = S.text_ "KIE" ! A.x "237" ! A.y "285" 191 | provinceText Liverpool = S.text_ "LVP" ! A.x "138" ! A.y "230" 192 | provinceText Livonia = S.text_ "LVN" ! A.x "380" ! A.y "260" 193 | provinceText London = S.text_ "LON" ! A.x "160" ! A.y "280" 194 | provinceText Marseilles = S.text_ "MAR" ! A.x "173" ! A.y "412" 195 | provinceText MidAtlanticOcean = S.text_ "MAO" ! A.x "50" ! A.y "355" 196 | provinceText Moscow = S.text_ "MOS" ! A.x "460" ! A.y "265" 197 | provinceText Munich = S.text_ "MUN" ! A.x "235" ! A.y "360" 198 | provinceText Naples = S.text_ "NAP" ! A.x "293" ! A.y "493" 199 | provinceText NorthAtlanticOcean = S.text_ "NAO" ! A.x "65" ! A.y "120" 200 | provinceText NorthAfrica = S.text_ "NAF" ! A.x "130" ! A.y "536" 201 | provinceText Norway = S.text_ "NWY" ! A.x "250" ! A.y "175" 202 | provinceText Paris = S.text_ "PAR" ! A.x "155" ! A.y "358" 203 | provinceText Picardy = S.text_ "PIC" ! A.x "168" ! A.y "326" 204 | provinceText Piedmont = S.text_ "PIE" ! A.x "215" ! A.y "408" 205 | provinceText Portugal = S.text_ "POR" ! A.x "22" ! A.y "440" 206 | provinceText Prussia = S.text_ "PRU" ! A.x "335" ! A.y "283" 207 | provinceText Rome = S.text_ "ROM" ! A.x "257" ! A.y "452" 208 | provinceText Ruhr = S.text_ "RUH" ! A.x "215" ! A.y "330" 209 | provinceText Rumania = S.text_ "RUM" ! A.x "410" ! A.y "415" 210 | provinceText Serbia = S.text_ "SER" ! A.x "350" ! A.y "450" 211 | provinceText Sevastopol = S.text_ "SEV" ! A.x "540" ! A.y "350" 212 | provinceText Silesia = S.text_ "SIL" ! A.x "304" ! A.y "325" 213 | provinceText Skagerrak = S.text_ "SKA" ! A.x "255" ! A.y "220" 214 | provinceText Smyrna = S.text_ "SMY" ! A.x "460" ! A.y "510" 215 | provinceText Spain = S.text_ "SPA" ! A.x "85" ! A.y "450" 216 | provinceText StPetersburg = S.text_ "STP" ! A.x "460" ! A.y "149" 217 | provinceText Sweden = S.text_ "SWE" ! A.x "300" ! A.y "170" 218 | provinceText Syria = S.text_ "SYR" ! A.x "570" ! A.y "535" 219 | provinceText Trieste = S.text_ "TRI" ! A.x "305" ! A.y "425" 220 | provinceText Tunis = S.text_ "TUN" ! A.x "210" ! A.y "555" 221 | provinceText Tuscany = S.text_ "TUS" ! A.x "240" ! A.y "425" 222 | provinceText Tyrolia = S.text_ "TYR" ! A.x "255" ! A.y "380" 223 | provinceText TyrrhenianSea = S.text_ "TYS" ! A.x "245" ! A.y "495" 224 | provinceText Ukraine = S.text_ "UKR" ! A.x "420" ! A.y "340" 225 | provinceText Venice = S.text_ "VEN" ! A.x "245" ! A.y "407" 226 | provinceText Vienna = S.text_ "VIE" ! A.x "307" ! A.y "370" 227 | provinceText Wales = S.text_ "WAL" ! A.x "130" ! A.y "275" 228 | provinceText Warsaw = S.text_ "WAR" ! A.x "355" ! A.y "304" 229 | provinceText WesternMediterranean = S.text_ "WES" ! A.x "160" ! A.y "491" 230 | provinceText Yorkshire = S.text_ "YOR" ! A.x "155" ! A.y "254" 231 | 232 | provinceElement :: ProvinceTarget -> S.Svg 233 | provinceElement (Normal NorwegianSea) = S.polygon ! A.points "362,33 357,39 343,44 324,54 320,64 310,75 309,84 303,86 292,111 277,132 269,134 264,142 258,141 236,154 198,154 171,181 171,197 158,193 152,194 154,188 161,185 162,181 148,177 148,0 362,0" 234 | provinceElement (Normal NorthSea) = S.path ! A.d "M171,197 L171,181 A27,27 0,0,1 198,154 L241,154 L241,224 L248,224 L245,237 L211,237 L211,301 L173,301 L165,293 L140,197Z" 235 | provinceElement (Normal AdriaticSea) = S.polygon ! A.points "322,480 297,456 300,453 290,453 278,443 272,424 260,417 261,401 270,398 276,399 275,403 278,410 282,401 286,402 289,418 306,436 331,454 331,477 335,480" 236 | provinceElement (Normal AegeanSea) = S.polygon ! A.points "376,537 371,520 378,521 377,513 386,516 385,509 370,494 371,491 378,494 368,483 371,477 379,484 382,483 381,477 386,478 380,472 392,472 400,468 408,470 410,473 414,475 410,482 409,487 417,486 417,489 420,495 417,498 417,507 423,510 427,524 435,523 435,530 416,549 412,547 387,546 383,544" 237 | provinceElement (Normal Albania) = S.polygon ! A.points "331,454 331,477 335,480 339,487 350,477 350,471 346,466 346,452 337,446 330,445" 238 | provinceElement (Normal Ankara) = S.polygon ! A.points "555,438 551,437 520,441 514,438 511,440 502,433 481,438 470,447 464,457 468,461 468,479 466,491 473,491 490,480 501,482 508,480 531,460 546,462 555,460 557,449" 239 | provinceElement (Normal Apulia) = S.polygon ! A.points "304,484 310,480 318,485 322,485 322,480 297,456 300,453 290,453 278,443 274,447 279,451 280,455 279,458 293,481" 240 | provinceElement (Normal Armenia) = S.polygon ! A.points "609,493 584,478 563,479 562,471 556,467 555,460 557,449 555,438 570,427 589,442 594,439 603,441 609,440" 241 | provinceElement (Normal BalticSea) = S.polygon ! A.points "266,255 271,260 278,254 277,250 280,248 279,243 282,253 289,254 294,245 305,244 312,229 311,220 359,220 349,229 347,243 347,248 348,254 344,262 337,264 334,273 328,274 326,265 314,266 307,273 294,275 286,274 287,267 280,266 266,275 261,274 260,269 256,266 256,263 254,255" 242 | provinceElement (Normal BarentsSea) = S.polygon ! A.points "540 0 535,9 530,6 517,19 516,33 513,38 513,23 507,20 505,26 499,33 492,48 495,58 488,60 479,57 477,55 481,50 473,43 466,45 472,62 478,66 478,74 472,72 468,74 457,91 469,100 467,106 462,109 444,101 442,110 447,115 454,119 452,122 434,118 426,103 426,94 414,88 412,83 445,84 457,79 459,66 453,61 417,47 405,49 401,45 397,48 391,47 395,41 394,38 384,33 382,40 380,33 377,31 374,38 371,33 366,42 366,33 362,33 362,0" 243 | provinceElement (Normal Belgium) = S.polygon ! A.points "191,299 194,303 206,306 205,311 208,315 210,326 205,331 192,323 184,315 169,311 173,301" 244 | provinceElement (Normal Berlin) = S.polygon ! A.points "294,275 286,274 287,267 280,266 266,275 266,283 262,287 264,293 261,296 263,310 288,305 296,300 297,296 292,290" 245 | provinceElement (Normal BlackSea) = S.polygon ! A.points "440,458 430,455 426,450 422,441 425,427 429,426 430,423 432,409 439,404 438,397 446,378 459,375 461,377 459,379 465,383 476,381 478,383 472,385 468,392 477,396 477,401 486,404 488,397 494,396 497,392 507,389 506,384 494,387 485,378 503,364 526,351 527,354 514,365 517,371 520,371 515,384 511,383 510,386 517,393 528,394 554,406 567,408 573,417 570,427 555,438 551,437 520,441 514,438 511,440 502,433 481,438 470,447 464,457 442,460" 246 | provinceElement (Normal Bohemia) = S.polygon ! A.points "281,356 276,346 268,343 264,329 266,325 278,326 288,321 297,322 311,334 314,332 321,339 322,347 316,348 303,346 295,349 292,357" 247 | provinceElement (Normal Brest) = S.polygon ! A.points "150,319 144,318 142,312 136,310 136,326 124,323 122,318 102,317 100,322 103,328 109,329 123,344 122,350 123,357 128,363 146,365 146,337 148,329" 248 | provinceElement (Normal Budapest) = S.polygon ! A.points "394,376 395,382 401,385 406,396 401,402 387,402 367,406 365,412 360,413 342,410 338,412 335,410 332,410 323,408 321,398 311,394 308,383 311,375 322,370 335,354 337,350 350,347 360,351 368,353 377,360 378,363 384,365" 249 | provinceElement (Special BulgariaEast) = S.polyline ! A.points "413,464 412,454 420,451 426,450 422,441 425,427 429,426 430,423 422,420 410,420 404,422 398,427 390,425 382,427 375,423 370,425 367,421 365,425 368,433 371,438" 250 | provinceElement (Special BulgariaSouth) = S.polyline ! A.points "371,438 366,439 371,456 365,461 369,464 376,464 388,460 392,472 400,468 408,470 413,464 412,454" 251 | provinceElement (Normal Burgundy) = S.polygon ! A.points "192,323 205,331 204,338 211,346 213,352 209,363 208,367 194,382 178,381 178,390 173,396 168,395 163,387 165,383 158,380 156,374 165,365 185,344 188,332" 252 | provinceElement (Normal Clyde) = S.polygon ! A.points "138,214 130,208 129,197 139,189 140,182 148,177 162,181 161,185 154,188 152,194 146,200 144,213" 253 | provinceElement (Normal Constantinople) = S.polygon ! A.points "408,470 410,473 414,475 410,482 409,487 417,486 417,489 423,487 432,493 452,495 466,491 468,479 468,461 464,457 442,460 440,458 430,455 426,450 420,451 412,454 413,464" 254 | provinceElement (Normal Denmark) = S.polygon ! A.points "279,243 275,242 269,243 266,240 267,234 266,221 263,223 248,224 245,237 243,247 244,254 254,255 266,255 271,260 278,254 277,250 280,248" 255 | provinceElement (Normal EasternMediterranean) = S.polygon ! A.points "435,530 441,526 447,528 453,534 464,531 466,521 475,520 485,528 491,530 505,526 511,514 520,517 527,508 530,509 525,518 526,530 532,535 528,559 400,559 400,554 414,552 416,549" 256 | provinceElement (Normal Edinburgh) = S.polygon ! A.points "152,194 158,193 171,197 170,202 165,210 158,214 151,215 157,216 161,218 163,226 155,228 145,217 144,213 146,200" 257 | provinceElement (Normal EnglishChannel) = S.polygon ! A.points "173,301 169,311 153,315 155,320 150,319 144,318 142,312 136,310 136,326 124,323 122,318 102,317 88,303 100,291 110,292 120,295 124,291 134,294 147,295 160,298 168,296" 258 | provinceElement (Normal Finland) = S.polygon ! A.points "362,107 368,108 372,120 366,121 359,136 345,151 347,160 350,165 348,178 349,184 357,186 365,191 384,185 402,177 412,161 410,152 414,147 410,130 402,118 401,110 392,92 393,73 387,68 388,61 386,58 388,54 379,48 370,49 369,61 355,62 346,54 342,61 356,71" 259 | provinceElement (Normal Galacia) = S.polygon ! A.points "333,330 341,330 344,332 353,327 356,323 361,324 367,329 374,327 379,324 383,327 385,332 399,338 404,354 403,360 404,371 394,376 384,365 378,363 377,360 368,353 360,351 350,347 337,350 329,346 322,347 321,339 322,347 321,339 325,340 329,338" 260 | provinceElement (Normal Gascony) = S.polygon ! A.points "128,363 121,382 122,384 112,399 113,407 123,412 134,417 135,414 142,417 149,403 157,397 168,395 163,387 165,383 158,380 156,374 149,372 146,365" 261 | provinceElement (Normal Greece) = S.polygon ! A.points "339,487 346,498 350,498 347,500 352,508 367,507 371,511 355,510 350,514 357,521 359,533 360,528 367,536 368,531 376,537 371,520 378,521 377,513 386,516 385,509 370,494 371,491 378,494 368,483 371,477 379,484 382,483 381,477 386,478 380,472 392,472 388,460 376,464 369,464 361,467 356,471 350,471 350,477" 262 | provinceElement (Normal GulfOfLyon) = S.polygon ! A.points "115,469 110,461 124,444 131,439 146,438 157,432 158,425 158,418 169,412 176,417 188,422 198,421 211,416 222,410 233,415 238,431 224,431 221,434 211,436 213,451 218,454 218,458 214,461 206,462 205,466 154,466 148,463 142,469" 263 | provinceElement (Normal GulfOfBothnia) = S.polygon ! A.points "311,220 314,209 322,206 328,203 331,193 326,183 320,182 321,161 330,146 343,138 351,128 347,121 349,112 355,104 362,107 368,108 372,120 366,121 359,136 345,151 347,160 350,165 348,178 349,184 357,186 365,191 384,185 402,177 403,183 411,184 414,187 408,187 400,192 399,197 387,196 371,198 369,202 365,204 368,210 372,213 373,221 377,227 373,229 366,228 359,220" 264 | provinceElement (Normal HelgolandBright) = S.polygon ! A.points "245,237 243,247 244,254 243,257 245,263 244,270 244,273 235,277 234,274 230,273 226,275 211,274 211,237" 265 | provinceElement (Normal Holland) = S.polygon ! A.points "226,275 227,280 225,292 220,298 215,297 213,302 210,313 208,315 205,311 206,306 194,303 191,299 198,289 205,276 205,279 207,279 211,274" 266 | provinceElement (Normal IonianSea) = S.polygon ! A.points "289,511 290,514 295,515 308,500 311,491 304,484 310,480 318,485 322,485 322,480 335,480 339,487 346,498 350,498 347,500 352,508 367,507 371,511 355,510 350,514 357,521 359,533 360,528 367,536 368,531 376,537 383,544 380,547 383,550 400,554 400,559 232,559 234,551 232,544 225,535 231,531 236,524 247,513 258,519 273,531 281,532 282,521 285,513 285,511" 267 | provinceElement (Normal IrishSea) = S.polygon ! A.points "100,291 112,287 122,281 130,282 127,276 119,272 116,272 115,265 128,262 126,256 121,257 132,250 135,250 139,240 136,229 130,227 120,227 110,232 109,246 98,259 87,257 70,261 58,273 88,303" 268 | provinceElement (Normal Kiel) = S.polygon ! A.points "244,254 243,257 245,263 244,270 244,273 235,277 234,274 230,273 226,275 227,280 225,292 220,298 215,297 213,302 232,308 241,316 243,322 263,310 261,296 264,293 262,287 266,283 266,275 261,274 260,269 256,266 256,263 254,255" 269 | provinceElement (Normal Liverpool) = S.polygon ! A.points "128,262 126,256 121,257 132,250 135,250 139,240 136,229 130,227 130,223 138,217 138,214 144,213 145,217 155,228 155,239 151,248 150,264 143,262" 270 | provinceElement (Normal Livonia) = S.polygon ! A.points "369,202 365,204 368,210 372,213 373,221 377,227 373,229 366,228 359,220 349,229 347,243 354,251 356,261 362,260 367,265 365,281 372,283 379,290 389,285 392,278 404,275 405,239 409,228 405,217 394,205 382,206 372,205" 271 | provinceElement (Normal London) = S.polygon ! A.points "166,269 168,270 171,268 177,270 178,274 176,283 165,293 172,294 168,296 160,298 147,295 145,281 150,277 153,271" 272 | provinceElement (Normal Marseilles) = S.polygon ! A.points "142,417 149,403 157,397 168,395 173,396 178,390 178,381 194,382 197,385 203,379 207,386 204,390 207,396 201,399 204,402 203,410 211,416 198,421 188,422 176,417 169,412 158,418 158,425 154,427" 273 | provinceElement (Normal MidAtlanticOcean) = S.polygon ! A.points "102,317 100,322 103,328 109,329 123,344 122,350 123,357 128,363 121,382 122,384 112,399 101,396 96,397 72,384 59,381 54,375 48,374 46,378 39,375 33,381 35,384 32,396 30,406 17,427 14,427 10,433 13,440 15,441 12,450 13,454 8,462 19,469 27,468 33,475 34,484 37,490 37,495 33,496 17,518 0,520 0,273 58,273" 274 | provinceElement (Normal Moscow) = S.polygon ! A.points "609,117 598,132 573,143 564,159 534,164 515,169 489,184 476,183 458,194 456,207 457,210 451,213 447,209 439,211 428,225 421,229 409,228 405,239 404,275 392,278 389,285 379,290 386,309 390,306 456,292 468,295 477,289 494,295 505,280 516,286 526,287 533,283 549,284 554,304 564,305 569,321 597,330 609,330" 275 | provinceElement (Normal Munich) = S.polygon ! A.points "234,366 243,370 246,369 250,371 267,368 271,370 269,362 275,362 281,356 276,346 268,343 264,329 266,325 278,326 288,321 284,314 288,305 263,310 243,322 237,322 219,344 211,346 213,352 209,363 222,365 225,362 232,363" 276 | provinceElement (Normal Naples) = S.polygon ! A.points "271,464 276,474 290,487 294,502 289,511 290,514 295,515 308,500 311,491 304,484 293,481 279,458" 277 | provinceElement (Normal NorthAtlanticOcean) = S.polygon ! A.points "70,261 64,250 67,242 71,245 81,234 74,228 80,225 78,218 82,217 89,220 94,220 95,218 94,216 97,216 101,212 110,212 119,217 120,227 130,227 130,223 138,217 138,214 130,208 129,197 139,189 140,182 148,177 148,0 0,0 0,273 58,273" 278 | provinceElement (Normal NorthAfrica) = S.polygon ! A.points "203,520 179,515 169,518 150,511 117,509 106,511 99,515 89,512 84,518 79,520 68,516 68,511 64,514 46,509 42,502 41,494 37,495 33,496 17,518 0,520 0,559 195,559 197,527" 279 | provinceElement (Normal Norway) = S.polygon ! A.points "397,48 391,47 395,41 394,38 384,33 382,40 380,33 377,31 374,38 371,33 366,42 366,33 362,33 357,39 343,44 324,54 320,64 310,75 309,84 303,86 292,111 277,132 269,134 264,142 258,141 236,154 237,160 233,167 231,180 233,186 229,192 231,201 241,209 246,210 266,201 270,193 275,203 279,204 287,177 285,170 290,164 292,133 301,132 300,126 309,115 308,104 311,101 324,71 332,74 330,64 341,65 342,61 346,54 355,62 369,61 370,49 379,48 388,54 386,58 388,61" 280 | provinceElement (Normal Paris) = S.polygon ! A.points "146,365 149,372 156,374 165,365 185,344 188,332 172,328 165,331 159,331 148,329 146,337" 281 | provinceElement (Normal Picardy) = S.polygon ! A.points "169,311 153,315 155,320 150,319 148,329 159,331 165,331 172,328 188,332 192,323 184,315" 282 | provinceElement (Normal Piedmont) = S.polygon ! A.points "207,386 204,390 207,396 201,399 204,402 203,410 211,416 222,410 233,415 236,411 233,404 246,392 243,388 229,385 227,390 221,385 213,387" 283 | provinceElement (Normal Portugal) = S.polygon ! A.points "32,396 30,406 17,427 14,427 10,433 13,440 15,441 12,450 13,454 8,462 19,469 27,468 36,457 34,447 40,441 37,431 42,432 52,412 61,411 62,407 55,400 42,399 43,395" 284 | provinceElement (Normal Prussia) = S.polygon ! A.points "347,243 347,248 348,254 344,262 337,264 334,273 328,274 326,265 314,266 307,273 294,275 292,290 297,296 296,300 320,303 324,299 326,292 341,287 345,289 359,286 365,281 367,265 362,260 356,261 354,251" 285 | provinceElement (Normal Rome) = S.polygon ! A.points "247,442 248,447 256,458 271,464 279,458 280,455 279,451 274,447 263,434 250,438" 286 | provinceElement (Normal Ruhr) = S.polygon ! A.points "213,302 210,313 208,315 210,326 205,331 204,338 211,346 219,344 237,322 243,322 241,316 232,308" 287 | provinceElement (Normal Rumania) = S.polygon ! A.points "403,360 404,371 394,376 395,382 401,385 406,396 401,402 387,402 367,406 365,412 367,421 370,425 375,423 382,427 390,425 398,427 404,422 410,420 422,420 430,423 432,409 439,404 438,397 427,399 422,382 423,376 414,372 411,361" 288 | provinceElement (Normal Serbia) = S.polygon ! A.points "365,412 360,413 342,410 338,412 335,410 332,410 330,416 331,424 327,429 330,437 337,446 346,452 346,466 350,471 356,471 361,467 369,464 365,461 371,456 366,439 371,438 368,433 365,425 367,421" 289 | provinceElement (Normal Sevastopol) = S.polygon ! A.points "438,397 446,378 459,375 461,377 459,379 465,383 476,381 478,383 472,385 468,392 477,396 477,401 486,404 488,397 494,396 497,392 507,389 506,384 494,387 485,378 503,364 526,351 527,354 514,365 517,371 520,371 515,384 511,383 510,386 517,393 528,394 554,406 567,408 573,417 570,427 589,442 594,439 603,441 609,440 609,330 597,330 569,321 564,305 554,304 549,284 533,283 526,287 516,286 505,280 494,295 477,289 468,295 470,303 466,307 460,345 445,350 434,360 432,372 423,376 422,382 427,399" 290 | provinceElement (Normal Silesia) = S.polygon ! A.points "288,321 297,322 311,334 314,332 321,339 325,340 329,338 333,330 326,327 323,322 320,303 296,300 288,305 284,314" 291 | provinceElement (Normal Skagerrak) = S.polygon ! A.points "241,209 246,210 266,201 270,193 275,203 277,218 276,224 282,236 279,240 279,243 275,242 269,243 266,240 267,234 266,221 263,223 248,224 241,224" 292 | provinceElement (Normal Smyrna) = S.polygon ! A.points "417,489 420,495 417,498 417,507 423,510 427,524 435,523 435,530 441,526 447,528 453,534 464,531 466,521 475,520 485,528 491,530 505,526 511,514 520,517 527,508 530,509 536,494 545,486 555,484 563,479 562,471 556,467 555,460 546,462 531,460 508,480 501,482 490,480 473,491 466,491 452,495 432,493 423,487" 293 | provinceElement (Special SpainNorth) = S.polyline ! A.points "134,417 123,412 113,407 112,399 101,396 96,397 72,384 59,381 54,375 48,374 46,378 39,375 33,381 35,384 32,396 43,395 42,399 55,400 62,407 61,411 52,412 42,432 37,431 40,441" 294 | provinceElement (Special SpainSouth) = S.polyline ! A.points "40,441 34,447 36,457 27,468 33,475 34,484 37,490 47,488 52,489 60,486 78,491 83,494 86,485 90,483 98,484 107,474 113,473 115,469 110,461 124,444 131,439 146,438 157,432 158,425 154,427 142,417 135,414 134,417 123,412" 295 | provinceElement (Special StPetersburgNorth) = S.polyline ! A.points "534,164 564,159 573,143 598,132 609,117 609,0 540 0 535,9 530,6 517,19 516,33 513,38 513,23 507,20 505,26 499,33 492,48 495,58 488,60 479,57 477,55 481,50 473,43 466,45 472,62 478,66 478,74 472,72 468,74 457,91 469,100 467,106 462,109 444,101 442,110 447,115 454,119 452,122 434,118 426,103 426,94 414,88 412,83 445,84 457,79 459,66 453,61 417,47 405,49 401,45 397,48 388,61 387,68 393,73 392,92 401,110 402,118 410,130 414,147" 296 | provinceElement (Special StPetersburgWest) = S.polyline ! A.points "414,147 410,152 412,161 402,177 403,183 411,184 414,187 408,187 400,192 399,197 387,196 371,198 369,202 372,205 382,206 394,205 405,217 409,228 421,229 428,225 439,211 447,209 451,213 457,210 456,207 458,194 476,183 489,184 515,169 534,164 564,159" 297 | provinceElement (Normal Sweden) = S.polygon ! A.points "275,203 277,218 276,224 282,236 279,240 279,243 282,253 289,254 294,245 305,244 312,229 311,220 314,209 322,206 328,203 331,193 326,183 320,182 321,161 330,146 343,138 351,128 347,121 349,112 355,104 362,107 356,71 342,61 341,65 330,64 332,74 324,71 311,101 308,104 309,115 300,126 301,132 292,133 290,164 285,170 287,177 279,204" 298 | provinceElement (Normal Syria) = S.polygon ! A.points "530,509 536,494 545,486 555,484 563,479 584,478 609,493 609,559 528,559 532,535 526,530 525,518" 299 | provinceElement (Normal Trieste) = S.polygon ! A.points "276,399 275,403 278,410 282,401 286,402 289,418 306,436 331,454 330,445 337,446 330,437 327,429 331,424 330,416 332,410 323,408 321,398 311,394 308,383 299,385 294,380 289,385 276,386 279,389" 300 | provinceElement (Normal Tunis) = S.polygon ! A.points "232,559 234,551 232,544 225,535 231,531 236,524 233,523 224,527 223,518 218,516 212,517 208,521 203,520 197,527 195,559" 301 | provinceElement (Normal Tuscany) = S.polygon ! A.points "233,415 238,431 247,442 250,438 263,434 253,418 246,416 240,415 236,411" 302 | provinceElement (Normal Tyrolia) = S.polygon ! A.points "234,366 243,370 246,369 250,371 267,368 271,370 269,362 275,362 281,356 292,357 295,362 294,380 289,385 276,386 268,385 259,388 255,394 250,397 246,392 243,388 245,384 241,378 234,374" 303 | provinceElement (Normal TyrrhenianSea) = S.polygon ! A.points "238,431 247,442 248,447 256,458 271,464 276,474 290,487 294,502 289,511 285,511 285,508 276,510 263,510 257,507 252,508 247,513 236,524 233,523 224,527 223,518 218,516 218,490 220,490 224,468 222,458 218,458 218,454 223,450 225,444 225,436 224,431" 304 | provinceElement (Normal Ukraine) = S.polygon ! A.points "383,327 385,332 399,338 404,354 403,360 411,361 414,372 423,376 432,372 434,360 445,350 460,345 466,307 470,303 468,295 456,292 390,306 386,309" 305 | provinceElement (Normal Venice) = S.polygon ! A.points "278,443 272,424 260,417 261,401 270,398 276,399 279,389 276,386 268,385 259,388 255,394 250,397 246,392 233,404 236,411 240,415 246,416 253,418 263,434 274,447" 306 | provinceElement (Normal Vienna) = S.polygon ! A.points "292,357 295,349 303,346 316,348 322,347 329,346 337,350 335,354 322,370 311,375 308,383 299,385 294,380 295,362" 307 | provinceElement (Normal Wales) = S.polygon ! A.points "100,291 112,287 122,281 130,282 127,276 119,272 116,272 115,265 128,262 143,262 150,264 153,271 150,277 145,281 147,295 134,294 124,291 120,295 110,292" 308 | provinceElement (Normal Warsaw) = S.polygon ! A.points "333,330 326,327 323,322 320,303 324,299 326,292 341,287 345,289 359,286 365,281 372,283 379,290 386,309 383,327 379,324 374,327 367,329 361,324 356,323 353,327 344,332 341,330" 309 | provinceElement (Normal WesternMediterranean) = S.polygon ! A.points "37,490 47,488 52,489 60,486 78,491 83,494 86,485 90,483 98,484 107,474 113,473 115,469 142,469 150,471 154,466 205,466 206,476 204,485 208,492 212,492 217,489 218,490 218,516 212,517 208,521 203,520 179,515 169,518 150,511 117,509 106,511 99,515 89,512 84,518 79,520 68,516 68,511 64,514 46,509 42,502 41,494 37,495" 310 | provinceElement (Normal Yorkshire) = S.polygon ! A.points "163,226 163,239 168,246 170,252 169,265 166,269 153,271 150,264 151,248 155,239 155,228" 311 | provinceElement x = error "provinceElement must only be applied to output of properProvinceTargets" 312 | 313 | provinceExtras (Normal Constantinople) = S.polygon ! A.points "414,475 421,467 435,463 440,458 442,460 439,463 448,464 425,475" ! A.style "fill:#99CCFF; stroke:black;" 314 | provinceExtras (Normal Denmark) = S.polygon ! A.points "269,243 268,246 263,247 266,255 254,255 257,247 266,240" ! A.style "fill:#99CCFF; stroke:black;" 315 | provinceExtras _ = return () 316 | 317 | main = putStrLn $ svgMap (initialBoard Seven) 318 | -------------------------------------------------------------------------------- /src/Diplomacy/Province.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.Province 3 | Description : Definitions related to places on the diplomacy board. 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | {-# LANGUAGE DataKinds #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | 14 | module Diplomacy.Province ( 15 | 16 | Province(..) 17 | 18 | , adjacency 19 | , adjacent 20 | , isSameOrAdjacent 21 | 22 | , neighbours 23 | , isSameOrNeighbour 24 | , provinceCommonNeighbours 25 | , provinceCommonCoasts 26 | , commonNeighbours 27 | , commonCoasts 28 | 29 | , ProvinceType(..) 30 | , provinceType 31 | , supplyCentre 32 | , supplyCentres 33 | 34 | , isCoastal 35 | , isInland 36 | , isWater 37 | 38 | , country 39 | , isHome 40 | 41 | , ProvinceCoast(..) 42 | , pcProvince 43 | , provinceCoasts 44 | 45 | , ProvinceTarget(..) 46 | , region 47 | , coast 48 | 49 | , isNormal 50 | , isSpecial 51 | 52 | , ptProvince 53 | 54 | , provinceTargets 55 | , provinceTargetCluster 56 | 57 | , shortestPath 58 | , distance 59 | , distanceFromHomeSupplyCentre 60 | 61 | , parseProvince 62 | , parseProvinceTarget 63 | 64 | , printProvince 65 | , printProvinceTarget 66 | 67 | , paths 68 | 69 | ) where 70 | 71 | import Control.Monad (guard) 72 | import Control.Applicative 73 | import qualified Data.Set as S 74 | import Data.String (fromString, IsString) 75 | import Data.List (sort) 76 | import Data.Char (toUpper, toLower) 77 | import Diplomacy.GreatPower 78 | import Text.Parsec hiding ((<|>)) 79 | import Text.Parsec.Text 80 | 81 | -- | Enumeration of the places on the diplomacy board. 82 | data Province 83 | = Bohemia 84 | | Budapest 85 | | Galicia 86 | | Trieste 87 | | Tyrolia 88 | | Vienna 89 | | Clyde 90 | | Edinburgh 91 | | Liverpool 92 | | London 93 | | Wales 94 | | Yorkshire 95 | | Brest 96 | | Burgundy 97 | | Gascony 98 | | Marseilles 99 | | Paris 100 | | Picardy 101 | | Berlin 102 | | Kiel 103 | | Munich 104 | | Prussia 105 | | Ruhr 106 | | Silesia 107 | | Apulia 108 | | Naples 109 | | Piedmont 110 | | Rome 111 | | Tuscany 112 | | Venice 113 | | Livonia 114 | | Moscow 115 | | Sevastopol 116 | | StPetersburg 117 | | Ukraine 118 | | Warsaw 119 | | Ankara 120 | | Armenia 121 | | Constantinople 122 | | Smyrna 123 | | Syria 124 | | Albania 125 | | Belgium 126 | | Bulgaria 127 | | Finland 128 | | Greece 129 | | Holland 130 | | Norway 131 | | NorthAfrica 132 | | Portugal 133 | | Rumania 134 | | Serbia 135 | | Spain 136 | | Sweden 137 | | Tunis 138 | | Denmark 139 | | AdriaticSea 140 | | AegeanSea 141 | | BalticSea 142 | | BarentsSea 143 | | BlackSea 144 | | EasternMediterranean 145 | | EnglishChannel 146 | | GulfOfBothnia 147 | | GulfOfLyon 148 | | HeligolandBight 149 | | IonianSea 150 | | IrishSea 151 | | MidAtlanticOcean 152 | | NorthAtlanticOcean 153 | | NorthSea 154 | | NorwegianSea 155 | | Skagerrak 156 | | TyrrhenianSea 157 | | WesternMediterranean 158 | deriving (Eq, Ord, Enum, Bounded, Show) 159 | 160 | data ProvinceType = Inland | Water | Coastal 161 | deriving (Eq, Ord, Enum, Bounded, Show) 162 | 163 | provinceType :: Province -> ProvinceType 164 | provinceType Bohemia = Inland 165 | provinceType Budapest = Inland 166 | provinceType Galicia = Inland 167 | provinceType Trieste = Coastal 168 | provinceType Tyrolia = Inland 169 | provinceType Vienna = Inland 170 | provinceType Clyde = Coastal 171 | provinceType Edinburgh = Coastal 172 | provinceType Liverpool = Coastal 173 | provinceType London = Coastal 174 | provinceType Wales = Coastal 175 | provinceType Yorkshire = Coastal 176 | provinceType Brest = Coastal 177 | provinceType Burgundy = Inland 178 | provinceType Gascony = Coastal 179 | provinceType Marseilles = Coastal 180 | provinceType Paris = Inland 181 | provinceType Picardy = Coastal 182 | provinceType Berlin = Coastal 183 | provinceType Kiel = Coastal 184 | provinceType Munich = Inland 185 | provinceType Prussia = Coastal 186 | provinceType Ruhr = Inland 187 | provinceType Silesia = Inland 188 | provinceType Apulia = Coastal 189 | provinceType Naples = Coastal 190 | provinceType Piedmont = Coastal 191 | provinceType Rome = Coastal 192 | provinceType Tuscany = Coastal 193 | provinceType Venice = Coastal 194 | provinceType Livonia = Coastal 195 | provinceType Moscow = Inland 196 | provinceType Sevastopol = Coastal 197 | provinceType StPetersburg = Coastal 198 | provinceType Ukraine = Inland 199 | provinceType Warsaw = Inland 200 | provinceType Ankara = Coastal 201 | provinceType Armenia = Coastal 202 | provinceType Constantinople = Coastal 203 | provinceType Smyrna = Coastal 204 | provinceType Syria = Coastal 205 | provinceType Albania = Coastal 206 | provinceType Belgium = Coastal 207 | provinceType Bulgaria = Coastal 208 | provinceType Finland = Coastal 209 | provinceType Greece = Coastal 210 | provinceType Holland = Coastal 211 | provinceType Norway = Coastal 212 | provinceType NorthAfrica = Coastal 213 | provinceType Portugal = Coastal 214 | provinceType Rumania = Coastal 215 | provinceType Serbia = Inland 216 | provinceType Spain = Coastal 217 | provinceType Sweden = Coastal 218 | provinceType Tunis = Coastal 219 | provinceType Denmark = Coastal 220 | provinceType AdriaticSea = Water 221 | provinceType AegeanSea = Water 222 | provinceType BalticSea = Water 223 | provinceType BarentsSea = Water 224 | provinceType BlackSea = Water 225 | provinceType EasternMediterranean = Water 226 | provinceType EnglishChannel = Water 227 | provinceType GulfOfBothnia = Water 228 | provinceType GulfOfLyon = Water 229 | provinceType HeligolandBight = Water 230 | provinceType IonianSea = Water 231 | provinceType IrishSea = Water 232 | provinceType MidAtlanticOcean = Water 233 | provinceType NorthAtlanticOcean = Water 234 | provinceType NorthSea = Water 235 | provinceType NorwegianSea = Water 236 | provinceType Skagerrak = Water 237 | provinceType TyrrhenianSea = Water 238 | provinceType WesternMediterranean = Water 239 | 240 | -- | A Province @p@ is adjacent to (borders) all Provinces in @adjacency p@. 241 | -- This is symmetric and antireflexive. 242 | adjacency :: Province -> [Province] 243 | adjacency Bohemia = [Munich, Tyrolia, Vienna, Silesia, Galicia] 244 | adjacency Budapest = [Vienna, Galicia, Rumania, Serbia, Trieste] 245 | adjacency Galicia = [Warsaw, Silesia, Ukraine, Rumania, Budapest, Vienna, Bohemia] 246 | adjacency Trieste = [AdriaticSea, Venice, Tyrolia, Vienna, Budapest, Serbia, Albania] 247 | adjacency Tyrolia = [Piedmont, Munich, Bohemia, Vienna, Trieste, Venice] 248 | adjacency Vienna = [Trieste, Tyrolia, Bohemia, Galicia, Budapest] 249 | adjacency Clyde = [NorthAtlanticOcean, NorwegianSea, Edinburgh, Liverpool] 250 | adjacency Edinburgh = [Clyde, NorwegianSea, NorthSea, Yorkshire, Liverpool] 251 | adjacency Liverpool = [NorthAtlanticOcean, IrishSea, Clyde, Edinburgh, Yorkshire, Wales] 252 | adjacency London = [NorthSea, EnglishChannel, Wales, Yorkshire] 253 | adjacency Wales = [IrishSea, EnglishChannel, London, Yorkshire, Liverpool] 254 | adjacency Yorkshire = [Liverpool, Edinburgh, London, Wales, NorthSea] 255 | adjacency Brest = [EnglishChannel, MidAtlanticOcean, Picardy, Paris, Gascony] 256 | adjacency Burgundy = [Paris, Picardy, Belgium, Ruhr, Munich, Marseilles, Gascony] 257 | adjacency Gascony = [MidAtlanticOcean, Spain, Brest, Paris, Burgundy, Marseilles] 258 | adjacency Marseilles = [GulfOfLyon, Spain, Gascony, Burgundy, Piedmont] 259 | adjacency Paris = [Brest, Picardy, Burgundy, Gascony] 260 | adjacency Picardy = [EnglishChannel, Belgium, Burgundy, Paris, Brest] 261 | adjacency Berlin = [BalticSea, Prussia, Silesia, Munich, Kiel] 262 | adjacency Kiel = [HeligolandBight, Berlin, Munich, Ruhr, Holland, Denmark, BalticSea] 263 | adjacency Munich = [Ruhr, Kiel, Berlin, Silesia, Bohemia, Tyrolia, Burgundy] 264 | adjacency Prussia = [BalticSea, Livonia, Warsaw, Silesia, Berlin] 265 | adjacency Ruhr = [Belgium, Holland, Kiel, Munich, Burgundy] 266 | adjacency Silesia = [Munich, Berlin, Prussia, Warsaw, Galicia, Bohemia] 267 | adjacency Apulia = [AdriaticSea, IonianSea, Naples, Rome, Venice] 268 | adjacency Naples = [IonianSea, TyrrhenianSea, Apulia, Rome] 269 | adjacency Piedmont = [Marseilles, Tyrolia, GulfOfLyon, Venice, Tuscany] 270 | adjacency Rome = [TyrrhenianSea, Naples, Tuscany, Venice, Apulia] 271 | adjacency Tuscany = [GulfOfLyon, Piedmont, Venice, Rome, TyrrhenianSea] 272 | adjacency Venice = [Piedmont, Tyrolia, Trieste, AdriaticSea, Apulia, Tuscany, Rome] 273 | adjacency Livonia = [BalticSea, GulfOfBothnia, StPetersburg, Moscow, Warsaw, Prussia] 274 | adjacency Moscow = [StPetersburg, Sevastopol, Ukraine, Warsaw, Livonia] 275 | adjacency Sevastopol = [Armenia, BlackSea, Rumania, Ukraine, Moscow] 276 | adjacency StPetersburg = [BarentsSea, Moscow, Livonia, GulfOfBothnia, Finland, Norway] 277 | adjacency Ukraine = [Moscow, Sevastopol, Rumania, Galicia, Warsaw] 278 | adjacency Warsaw = [Prussia, Livonia, Moscow, Ukraine, Galicia, Silesia] 279 | adjacency Ankara = [BlackSea, Armenia, Smyrna, Constantinople] 280 | adjacency Armenia = [BlackSea, Sevastopol, Syria, Ankara, Smyrna] 281 | adjacency Constantinople = [BlackSea, Ankara, Smyrna, Bulgaria, AegeanSea] 282 | adjacency Smyrna = [EasternMediterranean, AegeanSea, Constantinople, Ankara, Armenia, Syria] 283 | adjacency Syria = [Armenia, Smyrna, EasternMediterranean] 284 | adjacency Albania = [AdriaticSea, Trieste, Serbia, Greece, IonianSea] 285 | adjacency Belgium = [Holland, Ruhr, Burgundy, Picardy, EnglishChannel, NorthSea] 286 | adjacency Bulgaria = [Rumania, BlackSea, Constantinople, AegeanSea, Greece, Serbia] 287 | adjacency Finland = [StPetersburg, Sweden, Norway, GulfOfBothnia] 288 | adjacency Greece = [IonianSea, AegeanSea, Albania, Serbia, Bulgaria] 289 | adjacency Holland = [Belgium, NorthSea, Kiel, Ruhr, HeligolandBight] 290 | adjacency Norway = [NorwegianSea, NorthSea, Sweden, Finland, Skagerrak, BarentsSea, StPetersburg] 291 | adjacency NorthAfrica = [MidAtlanticOcean, WesternMediterranean, Tunis] 292 | adjacency Portugal = [MidAtlanticOcean, Spain] 293 | adjacency Rumania = [BlackSea, Bulgaria, Serbia, Budapest, Galicia, Ukraine, Sevastopol] 294 | adjacency Serbia = [Trieste, Budapest, Rumania, Bulgaria, Greece, Albania] 295 | adjacency Spain = [Portugal, MidAtlanticOcean, Gascony, GulfOfLyon, WesternMediterranean, Marseilles] 296 | adjacency Sweden = [GulfOfBothnia, Finland, Norway, BalticSea, Skagerrak, Denmark] 297 | adjacency Tunis = [NorthAfrica, WesternMediterranean, IonianSea, TyrrhenianSea] 298 | adjacency Denmark = [BalticSea, Skagerrak, HeligolandBight, Kiel, NorthSea, Sweden] 299 | adjacency AdriaticSea = [Trieste, Venice, Apulia, Albania, IonianSea] 300 | adjacency AegeanSea = [Greece, Bulgaria, Constantinople, Smyrna, EasternMediterranean, IonianSea] 301 | adjacency BalticSea = [Sweden, GulfOfBothnia, Livonia, Prussia, Berlin, Kiel, Denmark] 302 | adjacency BarentsSea = [StPetersburg, Norway, NorwegianSea] 303 | adjacency BlackSea = [Sevastopol, Armenia, Ankara, Constantinople, Bulgaria, Rumania] 304 | adjacency EasternMediterranean = [Syria, IonianSea, AegeanSea, Smyrna] 305 | adjacency EnglishChannel = [London, Belgium, Picardy, Brest, MidAtlanticOcean, IrishSea, Wales, NorthSea] 306 | adjacency GulfOfBothnia = [Sweden, Finland, Livonia, StPetersburg, BalticSea] 307 | adjacency GulfOfLyon = [Marseilles, Piedmont, Tuscany, TyrrhenianSea, WesternMediterranean, Spain] 308 | adjacency HeligolandBight = [Denmark, Kiel, Holland, NorthSea] 309 | adjacency IonianSea = [Tunis, TyrrhenianSea, Naples, Apulia, AdriaticSea, Greece, Albania, AegeanSea, EasternMediterranean] 310 | adjacency IrishSea = [NorthAtlanticOcean, EnglishChannel, MidAtlanticOcean, Liverpool, Wales] 311 | adjacency MidAtlanticOcean = [NorthAtlanticOcean, IrishSea, EnglishChannel, Brest, Gascony, Spain, Portugal, WesternMediterranean, NorthAfrica] 312 | adjacency NorthAtlanticOcean = [NorwegianSea, Clyde, Liverpool, IrishSea, MidAtlanticOcean] 313 | adjacency NorthSea = [NorwegianSea, Skagerrak, Denmark, HeligolandBight, Holland, Belgium, EnglishChannel, London, Yorkshire, Edinburgh, Norway] 314 | adjacency NorwegianSea = [NorthAtlanticOcean, Norway, BarentsSea, NorthSea, Clyde, Edinburgh] 315 | adjacency Skagerrak = [Norway, Sweden, Denmark, NorthSea] 316 | adjacency TyrrhenianSea = [GulfOfLyon, WesternMediterranean, Tunis, Tuscany, Rome, Naples, IonianSea] 317 | adjacency WesternMediterranean = [NorthAfrica, MidAtlanticOcean, GulfOfLyon, Spain, Tunis, TyrrhenianSea] 318 | 319 | adjacent :: Province -> Province -> Bool 320 | adjacent prv0 prv1 = prv0 `elem` (adjacency prv1) 321 | 322 | isSameOrAdjacent :: Province -> Province -> Bool 323 | isSameOrAdjacent prv0 prv1 = prv0 == prv1 || adjacent prv0 prv1 324 | 325 | -- | Indicates whether a Province is a supply centre. 326 | supplyCentre :: Province -> Bool 327 | supplyCentre Norway = True 328 | supplyCentre Sweden = True 329 | supplyCentre Denmark = True 330 | supplyCentre StPetersburg = True 331 | supplyCentre Moscow = True 332 | supplyCentre Sevastopol = True 333 | supplyCentre Ankara = True 334 | supplyCentre Smyrna = True 335 | supplyCentre Constantinople = True 336 | supplyCentre Rumania = True 337 | supplyCentre Bulgaria = True 338 | supplyCentre Greece = True 339 | supplyCentre Serbia = True 340 | supplyCentre Warsaw = True 341 | supplyCentre Budapest = True 342 | supplyCentre Vienna = True 343 | supplyCentre Trieste = True 344 | supplyCentre Berlin = True 345 | supplyCentre Kiel = True 346 | supplyCentre Munich = True 347 | supplyCentre Venice = True 348 | supplyCentre Rome = True 349 | supplyCentre Naples = True 350 | supplyCentre Tunis = True 351 | supplyCentre Spain = True 352 | supplyCentre Portugal = True 353 | supplyCentre Marseilles = True 354 | supplyCentre Paris = True 355 | supplyCentre Brest = True 356 | supplyCentre Belgium = True 357 | supplyCentre Holland = True 358 | supplyCentre London = True 359 | supplyCentre Liverpool = True 360 | supplyCentre Edinburgh = True 361 | supplyCentre _ = False 362 | 363 | -- | All supply centres. 364 | supplyCentres :: [Province] 365 | supplyCentres = filter supplyCentre [minBound..maxBound] 366 | 367 | -- | Some provinces belong to a country. 368 | -- This is useful in conjunction with supplyCentre to determine which 369 | -- provinces can be used by a given country to build a unit. 370 | -- It is distinct from the in-game notion of control. Although Brest 371 | -- belongs to France, it may be controlled by some other power. 372 | country :: Province -> Maybe GreatPower 373 | country Bohemia = Just Austria 374 | country Budapest = Just Austria 375 | country Galicia = Just Austria 376 | country Trieste = Just Austria 377 | country Tyrolia = Just Austria 378 | country Vienna = Just Austria 379 | country Clyde = Just England 380 | country Edinburgh = Just England 381 | country Liverpool = Just England 382 | country London = Just England 383 | country Wales = Just England 384 | country Yorkshire = Just England 385 | country Brest = Just France 386 | country Burgundy = Just France 387 | country Gascony = Just France 388 | country Marseilles = Just France 389 | country Paris = Just France 390 | country Picardy = Just France 391 | country Berlin = Just Germany 392 | country Kiel = Just Germany 393 | country Munich = Just Germany 394 | country Prussia = Just Germany 395 | country Ruhr = Just Germany 396 | country Silesia = Just Germany 397 | country Apulia = Just Italy 398 | country Naples = Just Italy 399 | country Piedmont = Just Italy 400 | country Rome = Just Italy 401 | country Tuscany = Just Italy 402 | country Venice = Just Italy 403 | country Livonia = Just Russia 404 | country Moscow = Just Russia 405 | country Sevastopol = Just Russia 406 | country StPetersburg = Just Russia 407 | country Ukraine = Just Russia 408 | country Warsaw = Just Russia 409 | country Ankara = Just Turkey 410 | country Armenia = Just Turkey 411 | country Constantinople = Just Turkey 412 | country Smyrna = Just Turkey 413 | country Syria = Just Turkey 414 | country Albania = Nothing 415 | country Belgium = Nothing 416 | country Bulgaria = Nothing 417 | country Finland = Nothing 418 | country Greece = Nothing 419 | country Holland = Nothing 420 | country Norway = Nothing 421 | country NorthAfrica = Nothing 422 | country Portugal = Nothing 423 | country Rumania = Nothing 424 | country Serbia = Nothing 425 | country Spain = Nothing 426 | country Sweden = Nothing 427 | country Tunis = Nothing 428 | country Denmark = Nothing 429 | country AdriaticSea = Nothing 430 | country AegeanSea = Nothing 431 | country BalticSea = Nothing 432 | country BarentsSea = Nothing 433 | country BlackSea = Nothing 434 | country EasternMediterranean = Nothing 435 | country EnglishChannel = Nothing 436 | country GulfOfBothnia = Nothing 437 | country GulfOfLyon = Nothing 438 | country HeligolandBight = Nothing 439 | country IonianSea = Nothing 440 | country IrishSea = Nothing 441 | country MidAtlanticOcean = Nothing 442 | country NorthAtlanticOcean = Nothing 443 | country NorthSea = Nothing 444 | country NorwegianSea = Nothing 445 | country Skagerrak = Nothing 446 | country TyrrhenianSea = Nothing 447 | country WesternMediterranean = Nothing 448 | 449 | isHome :: GreatPower -> Province -> Bool 450 | isHome c p = maybe False ((==) c) (country p) 451 | 452 | -- | These are the special coasts, for @Province@s which have more than one 453 | -- coast. 454 | data ProvinceCoast 455 | = StPetersburgNorth 456 | | StPetersburgSouth 457 | | SpainNorth 458 | | SpainSouth 459 | | BulgariaEast 460 | | BulgariaSouth 461 | deriving (Eq, Ord, Enum, Bounded) 462 | 463 | instance Show ProvinceCoast where 464 | show StPetersburgNorth = "StP NC" 465 | show StPetersburgSouth = "StP SC" 466 | show SpainNorth = "Spa NC" 467 | show SpainSouth = "Spa SC" 468 | show BulgariaEast = "Bul EC" 469 | show BulgariaSouth = "Bul SC" 470 | 471 | -- | The @Province@ to which a @ProvinceCoast@ belongs. 472 | pcProvince :: ProvinceCoast -> Province 473 | pcProvince StPetersburgNorth = StPetersburg 474 | pcProvince StPetersburgSouth = StPetersburg 475 | pcProvince SpainNorth = Spain 476 | pcProvince SpainSouth = Spain 477 | pcProvince BulgariaEast = Bulgaria 478 | pcProvince BulgariaSouth = Bulgaria 479 | 480 | -- | The @ProvinceCoast@s which belong to a @Province@. 481 | provinceCoasts :: Province -> [ProvinceCoast] 482 | provinceCoasts StPetersburg = [StPetersburgNorth, StPetersburgSouth] 483 | provinceCoasts Spain = [SpainNorth, SpainSouth] 484 | provinceCoasts Bulgaria = [BulgariaEast, BulgariaSouth] 485 | provinceCoasts _ = [] 486 | 487 | -- | This type contains all places where some unit could be stationed. 488 | data ProvinceTarget 489 | = Normal Province 490 | | Special ProvinceCoast 491 | deriving (Eq, Ord) 492 | 493 | instance Show ProvinceTarget where 494 | show (Normal province) = show province 495 | show (Special provinceCoast) = show provinceCoast 496 | 497 | instance Enum ProvinceTarget where 498 | fromEnum pt = case pt of 499 | Normal pr -> fromEnum pr 500 | Special pc -> fromEnum (maxBound :: Province) + fromEnum pc 501 | toEnum n | n < fromEnum (minBound :: Province) = error "ProvinceTarget.toEnum : index too small." 502 | | n <= fromEnum (maxBound :: Province) = Normal (toEnum n) 503 | | n <= fromEnum (maxBound :: Province) + fromEnum (maxBound :: ProvinceCoast) + 1 = Special (toEnum (n - fromEnum (maxBound :: Province) - 1)) 504 | | otherwise = error "ProvinceTarget.toEnum : index too large." 505 | 506 | instance Bounded ProvinceTarget where 507 | minBound = Normal minBound 508 | maxBound = Special maxBound 509 | 510 | region :: Province -> ProvinceTarget 511 | region = Normal 512 | 513 | coast :: ProvinceCoast -> ProvinceTarget 514 | coast = Special 515 | 516 | isSpecial :: ProvinceTarget -> Bool 517 | isSpecial (Special _) = True 518 | isSpecial _ = False 519 | 520 | isNormal :: ProvinceTarget -> Bool 521 | isNormal (Normal _) = True 522 | isNormal _ = False 523 | 524 | -- | All @ProvinceTarget@s associated with a @Province@. For @Province@s with 525 | -- 0 or 1 coast, @provinceTargets p = [Normal p]@. 526 | provinceTargets :: Province -> [ProvinceTarget] 527 | provinceTargets x = Normal x : (map Special (provinceCoasts x)) 528 | 529 | -- | All @ProvinceTarget@s which belong to the same @Province@ as this one. 530 | provinceTargetCluster :: ProvinceTarget -> [ProvinceTarget] 531 | provinceTargetCluster (Normal x) = provinceTargets x 532 | provinceTargetCluster (Special c) = (Normal $ pcProvince c) : (map Special (provinceCoasts (pcProvince c))) 533 | 534 | ptProvince :: ProvinceTarget -> Province 535 | ptProvince (Normal p) = p 536 | ptProvince (Special c) = pcProvince c 537 | 538 | isCoastal :: Province -> Bool 539 | isCoastal prv = case provinceType prv of 540 | Coastal -> True 541 | _ -> False 542 | 543 | isInland :: Province -> Bool 544 | isInland prv = case provinceType prv of 545 | Inland -> True 546 | _ -> False 547 | 548 | isWater :: Province -> Bool 549 | isWater prv = case provinceType prv of 550 | Water -> True 551 | _ -> False 552 | 553 | -- | True iff the given province should not be considered adjacent to the 554 | -- given province coast, even though they are adjacent as provinces. 555 | blacklist :: Province -> ProvinceTarget -> Bool 556 | blacklist p (Special c) = coastBlacklist p c 557 | where 558 | coastBlacklist :: Province -> ProvinceCoast -> Bool 559 | coastBlacklist WesternMediterranean SpainNorth = True 560 | coastBlacklist GulfOfLyon SpainNorth = True 561 | coastBlacklist Gascony SpainSouth = True 562 | coastBlacklist Marseilles SpainNorth = True 563 | -- NB MidAtlanticOcean to SpainSouth is fine! 564 | coastBlacklist GulfOfBothnia StPetersburgNorth = True 565 | coastBlacklist BarentsSea StPetersburgSouth = True 566 | coastBlacklist BlackSea BulgariaSouth = True 567 | coastBlacklist AegeanSea BulgariaEast = True 568 | coastBlacklist _ _ = False 569 | blacklist _ _ = False 570 | 571 | provinceCommonNeighbours :: Province -> Province -> [Province] 572 | provinceCommonNeighbours province1 province2 = 573 | [ x | x <- adjacency province1, y <- adjacency province2, x == y ] 574 | 575 | provinceCommonCoasts :: Province -> Province -> [Province] 576 | provinceCommonCoasts province1 province2 = 577 | filter isWater (provinceCommonNeighbours province1 province2) 578 | 579 | -- | This is like adjacency but for @ProvinceTargets@, 580 | -- and takes into consideration the special cases of multi-coast @Province@s. 581 | neighbours :: ProvinceTarget -> [ProvinceTarget] 582 | neighbours pt1 = do 583 | x <- adjacency (ptProvince pt1) 584 | guard $ not (blacklist x pt1) 585 | y <- provinceTargets x 586 | guard $ not (blacklist (ptProvince pt1) y) 587 | return y 588 | 589 | isSameOrNeighbour :: ProvinceTarget -> ProvinceTarget -> Bool 590 | isSameOrNeighbour to from = to == from || elem to (neighbours from) 591 | 592 | commonNeighbours :: ProvinceTarget -> ProvinceTarget -> [ProvinceTarget] 593 | commonNeighbours pt1 pt2 = 594 | [ x | x <- neighbours pt1, y <- neighbours pt2, x == y ] 595 | 596 | -- | Common neighbours which are water provinces. 597 | commonCoasts :: ProvinceTarget -> ProvinceTarget -> [ProvinceTarget] 598 | commonCoasts pt1 pt2 = 599 | filter (isWater . ptProvince) (commonNeighbours pt1 pt2) 600 | 601 | distance :: Province -> Province -> Int 602 | distance pr1 pr2 = length (shortestPath pr1 pr2) 603 | 604 | shortestPath :: Province -> Province -> [Province] 605 | shortestPath pr1 pr2 = 606 | if pr1 == pr2 607 | then [] 608 | else reverse $ shortestPath' pr2 (fmap pure (adjacency pr1)) 609 | where 610 | shortestPath' :: Province -> [[Province]] -> [Province] 611 | shortestPath' pr paths = case select pr paths of 612 | Just path -> path 613 | Nothing -> shortestPath' pr (expand paths) 614 | 615 | expand :: [[Province]] -> [[Province]] 616 | expand ps = do 617 | t : ts <- ps 618 | fmap (\x -> x : t : ts) (adjacency t) 619 | 620 | select :: Province -> [[Province]] -> Maybe [Province] 621 | select p paths = foldr select Nothing paths 622 | where 623 | select path b = b <|> if elem p path then Just path else Nothing 624 | 625 | distanceFromHomeSupplyCentre :: GreatPower -> Province -> Int 626 | distanceFromHomeSupplyCentre power province = head (sort distances) 627 | where 628 | distances = fmap (distance province) homeSupplyCentres 629 | homeSupplyCentres = filter (isHome power) supplyCentres 630 | 631 | provinceStringRepresentation :: Province -> String 632 | provinceStringRepresentation province = case province of 633 | Denmark -> "Denmark" 634 | Bohemia -> "Bohemia" 635 | Budapest -> "Budapest" 636 | Galicia -> "Galicia" 637 | Trieste -> "Trieste" 638 | Tyrolia -> "Tyrolia" 639 | Vienna -> "Vienna" 640 | Clyde -> "Clyde" 641 | Edinburgh -> "Edinburgh" 642 | Liverpool -> "Liverpool" 643 | London -> "London" 644 | Wales -> "Wales" 645 | Yorkshire -> "Yorkshire" 646 | Brest -> "Brest" 647 | Burgundy -> "Burgundy" 648 | Gascony -> "Gascony" 649 | Marseilles -> "Marseilles" 650 | Paris -> "Paris" 651 | Picardy -> "Picardy" 652 | Berlin -> "Berlin" 653 | Kiel -> "Kiel" 654 | Munich -> "Munich" 655 | Prussia -> "Prussia" 656 | Ruhr -> "Ruhr" 657 | Silesia -> "Silesia" 658 | Apulia -> "Apulia" 659 | Naples -> "Naples" 660 | Piedmont -> "Piedmont" 661 | Rome -> "Rome" 662 | Tuscany -> "Tuscany" 663 | Venice -> "Venice" 664 | Livonia -> "Livonia" 665 | Moscow -> "Moscow" 666 | Sevastopol -> "Sevastopol" 667 | StPetersburg -> "St. Petersburg" 668 | Ukraine -> "Ukraine" 669 | Warsaw -> "Warsaw" 670 | Ankara -> "Ankara" 671 | Armenia -> "Armenia" 672 | Constantinople -> "Constantinople" 673 | Smyrna -> "Smyrna" 674 | Syria -> "Syria" 675 | Albania -> "Albania" 676 | Belgium -> "Belgium" 677 | Bulgaria -> "Bulgaria" 678 | Finland -> "Finland" 679 | Greece -> "Greece" 680 | Holland -> "Holland" 681 | Norway -> "Norway" 682 | NorthAfrica -> "North Africa" 683 | Portugal -> "Portugal" 684 | Rumania -> "Rumania" 685 | Serbia -> "Serbia" 686 | Spain -> "Spain" 687 | Sweden -> "Sweden" 688 | Tunis -> "Tunis" 689 | AdriaticSea -> "Adriatic Sea" 690 | AegeanSea -> "Aegean Sea" 691 | BalticSea -> "Baltic Sea" 692 | BarentsSea -> "Barents Sea" 693 | BlackSea -> "Black Sea" 694 | EasternMediterranean -> "Eastern Mediterranean" 695 | EnglishChannel -> "English Channel" 696 | GulfOfBothnia -> "Gulf of Bothnia" 697 | GulfOfLyon -> "Gulf of Lyon" 698 | HeligolandBight -> "Heligoland Bight" 699 | IonianSea -> "Ionian Sea" 700 | IrishSea -> "Irish Sea" 701 | MidAtlanticOcean -> "Mid-Atlantic Ocean" 702 | NorthAtlanticOcean -> "North Atlantic Ocean" 703 | NorthSea -> "North Sea" 704 | NorwegianSea -> "Norwegian Sea" 705 | Skagerrak -> "Skagerrak" 706 | TyrrhenianSea -> "Tyrrhenian Sea" 707 | WesternMediterranean -> "Western Mediterranean" 708 | 709 | provinceStringRepresentations :: Province -> (String, [String]) 710 | provinceStringRepresentations pr = (principal, others) 711 | where 712 | principal = provinceStringRepresentation pr 713 | others = case pr of 714 | Liverpool -> ["Lvp"] 715 | Livonia -> ["Lvn"] 716 | StPetersburg -> ["StP"] 717 | Norway -> ["Nwy"] 718 | NorthAfrica -> ["NAf"] 719 | GulfOfBothnia -> ["Bot"] 720 | GulfOfLyon -> ["GoL"] 721 | -- There are 2 accepted spellings of this one: 722 | -- Heligoland 723 | -- Helgoland 724 | -- according to Wikipedia. 725 | HeligolandBight -> ["Helgoland Bight", "Hel"] 726 | MidAtlanticOcean -> ["Mao", "Mid", "Mid Atlantic Ocean"] 727 | NorthAtlanticOcean -> ["NAt"] 728 | NorthSea -> ["Nth"] 729 | NorwegianSea -> ["Nrg"] 730 | TyrrhenianSea -> ["Tyn"] 731 | _ -> [take 3 principal] 732 | 733 | parseProvince :: Parser Province 734 | parseProvince = choice (longParsers ++ shortParsers) 735 | where 736 | longParsers :: [Parser Province] 737 | longParsers = fmap makeParser provinceLongReps 738 | shortParsers :: [Parser Province] 739 | shortParsers = fmap makeParser provinceShortReps 740 | provinces :: [Province] 741 | provinces = [minBound..maxBound] 742 | provinceReps :: [(Province, String, [String])] 743 | provinceReps = fmap reps provinces 744 | provinceLongReps :: [(Province, String)] 745 | provinceLongReps = fmap (\(pr, x, _) -> (pr, x)) provinceReps 746 | provinceShortReps :: [(Province, String)] 747 | provinceShortReps = provinceReps >>= \(pr, _, xs) -> fmap (\x -> (pr, x)) xs 748 | reps :: Province -> (Province, String, [String]) 749 | reps pr = let (s, ss) = provinceStringRepresentations pr 750 | in (pr, s, ss) 751 | makeParser :: (Province, String) -> Parser Province 752 | makeParser (p, s) = try (ciString s) *> pure p 753 | 754 | provinceCoastStringRepresentations :: ProvinceCoast -> [String] 755 | provinceCoastStringRepresentations pc = provinceReps >>= addSuffix 756 | where 757 | (principal, others) = provinceStringRepresentations (pcProvince pc) 758 | provinceReps = principal : others 759 | addSuffix str = [ 760 | str ++ " " ++ suffix 761 | , str ++ " (" ++ suffix ++ ")" 762 | ] 763 | suffix = provinceCoastStringSuffix pc 764 | 765 | provinceCoastStringSuffix :: ProvinceCoast -> String 766 | provinceCoastStringSuffix pc = case pc of 767 | StPetersburgNorth -> "NC" 768 | StPetersburgSouth -> "SC" 769 | SpainNorth -> "NC" 770 | SpainSouth -> "SC" 771 | BulgariaEast -> "EC" 772 | BulgariaSouth -> "SC" 773 | 774 | parseCoast :: Parser ProvinceCoast 775 | parseCoast = choice parsers 776 | where 777 | parsers :: [Parser ProvinceCoast] 778 | parsers = fmap makeParser provinceCoastsWithReps 779 | provinceCoasts = [minBound..maxBound] 780 | provinceCoastsWithReps = fmap bundleReps provinceCoasts 781 | bundleReps :: ProvinceCoast -> (ProvinceCoast, [String]) 782 | bundleReps pc = let ss = provinceCoastStringRepresentations pc 783 | in (pc, ss) 784 | makeParser :: (ProvinceCoast, [String]) -> Parser ProvinceCoast 785 | makeParser (pc, ss) = choice (fmap (try . ciString) ss) *> pure pc 786 | 787 | parseProvinceTarget :: Parser ProvinceTarget 788 | parseProvinceTarget = try parseSpecial <|> parseNormal 789 | where 790 | parseNormal = Normal <$> parseProvince 791 | parseSpecial = Special <$> parseCoast 792 | 793 | provinceTargetStringRepresentation :: ProvinceTarget -> String 794 | provinceTargetStringRepresentation pt = case pt of 795 | Normal p -> provinceStringRepresentation p 796 | Special c -> head (provinceCoastStringRepresentations c) 797 | 798 | printProvinceTarget :: IsString a => ProvinceTarget -> a 799 | printProvinceTarget = fromString . provinceTargetStringRepresentation 800 | 801 | printProvince :: IsString a => Province -> a 802 | printProvince = fromString . provinceStringRepresentation 803 | 804 | -- | A search from a list of Provinces, via 1 or more adjacent Provinces which 805 | -- satisfy some indicator, until another indicator is satisfied. 806 | -- This gives simple paths from those Provinces, via Provinces which satisfy 807 | -- the first indicator, to Provinces which satisfy the second indicator. 808 | -- 809 | -- Example use case: convoy paths from a given Province. 810 | -- 811 | -- @ 812 | -- convoyPaths 813 | -- :: Occupation 814 | -- -> Province 815 | -- -> [(Province, [Province])] 816 | -- convoyPaths occupation convoyingFrom = 817 | -- fmap 818 | -- (\(x, y, zs) -> (x, y : zs)) 819 | -- (paths (occupiedByFleet occupation) (coastalIndicator) [convoyingFrom]) 820 | -- @ 821 | -- 822 | paths 823 | :: (Province -> Bool) 824 | -> (Province -> Maybe t) 825 | -> [Province] 826 | -> [(t, Province, [Province])] 827 | paths indicatorA indicatorB seeds = paths' [] indicatorA indicatorB (fmap (\x -> (x, [])) seeds) 828 | where 829 | 830 | paths' 831 | :: [(t, Province, [Province])] 832 | -> (Province -> Bool) 833 | -> (Province -> Maybe t) 834 | -> [(Province, [Province])] 835 | -> [(t, Province, [Province])] 836 | paths' found indicatorA indicatorB paths = 837 | -- At each step we take the next vanguard, but we must have the previous 838 | -- paths as well! Ok so why don't we just keep all of the paths? 839 | let nextPaths = growPaths indicatorA paths 840 | endpoints = takeEndpoints indicatorB nextPaths 841 | found' = found ++ endpoints 842 | in case nextPaths of 843 | [] -> found' 844 | _ -> paths' found' indicatorA indicatorB nextPaths 845 | 846 | growPaths 847 | :: (Province -> Bool) 848 | -> [(Province, [Province])] 849 | -> [(Province, [Province])] 850 | growPaths indicator paths = do 851 | (first, theRest) <- paths 852 | next <- adjacency first 853 | let theRest' = first : theRest 854 | guard (not (next `elem` theRest')) 855 | guard (indicator next) 856 | return (next, theRest') 857 | 858 | takeEndpoints 859 | :: (Province -> Maybe t) 860 | -> [(Province, [Province])] 861 | -> [(t, Province, [Province])] 862 | takeEndpoints indicator candidates = do 863 | (first, rest) <- candidates 864 | x <- adjacency first 865 | case indicator x of 866 | Just y -> return (y, first, rest) 867 | Nothing -> empty 868 | 869 | -- case-insensitive string parser. 870 | ciString :: String -> Parser String 871 | ciString = mapM ciChar 872 | 873 | ciChar :: Char -> Parser Char 874 | ciChar c = char (toLower c) <|> char (toUpper c) 875 | -------------------------------------------------------------------------------- /src/Diplomacy/Game.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.Game 3 | Description : State of a Diplomacy game. 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | {-# LANGUAGE KindSignatures #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE GADTs #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE ScopedTypeVariables #-} 16 | {-# LANGUAGE StandaloneDeriving #-} 17 | {-# LANGUAGE FlexibleContexts #-} 18 | 19 | module Diplomacy.Game ( 20 | 21 | Game(..) 22 | , Round(..) 23 | , RoundStatus(..) 24 | , Status(..) 25 | , TypicalRound(..) 26 | , RetreatRound(..) 27 | , AdjustRound(..) 28 | , NextRound 29 | , RoundPhase 30 | , RoundOrderConstructor 31 | , ValidateOrdersOutput 32 | , roundToInt 33 | , nextRound 34 | , prevRound 35 | 36 | , gameZonedOrders 37 | , gameZonedResolvedOrders 38 | , gameOccupation 39 | , gameDislodged 40 | , gameControl 41 | , gameTurn 42 | , gameRound 43 | , gameSeason 44 | , issueOrders 45 | , removeBuildOrders 46 | , resolve 47 | , continue 48 | , newGame 49 | , showGame 50 | , greatPowerAssignments 51 | 52 | ) where 53 | 54 | import Control.Applicative 55 | import qualified Data.Map as M 56 | import qualified Data.Set as S 57 | import Data.List (sortBy, intersperse) 58 | import Diplomacy.Turn 59 | import Diplomacy.Season 60 | import Diplomacy.GreatPower 61 | import Diplomacy.Aligned 62 | import Diplomacy.Unit 63 | import Diplomacy.Order hiding (continue) 64 | import Diplomacy.OrderObject 65 | import Diplomacy.Phase 66 | import Diplomacy.Province 67 | import Diplomacy.Zone 68 | import Diplomacy.Occupation 69 | import Diplomacy.Dislodgement 70 | import Diplomacy.Control 71 | import Diplomacy.Subject 72 | import Diplomacy.SupplyCentreDeficit 73 | import Diplomacy.OrderResolution 74 | import Diplomacy.OrderValidation 75 | 76 | -- | A Turn consists of 5 rounds. 77 | data Round where 78 | -- Typical 79 | RoundOne :: Round 80 | -- Retreat 81 | RoundTwo :: Round 82 | -- Typical 83 | RoundThree :: Round 84 | -- Retreat 85 | RoundFour :: Round 86 | -- Adjust 87 | RoundFive :: Round 88 | 89 | deriving instance Show Round 90 | deriving instance Enum Round 91 | deriving instance Bounded Round 92 | deriving instance Eq Round 93 | deriving instance Ord Round 94 | 95 | roundToInt :: Round -> Int 96 | roundToInt = fromEnum 97 | 98 | nextRound :: Round -> Round 99 | nextRound round = case round of 100 | RoundOne -> RoundTwo 101 | RoundTwo -> RoundThree 102 | RoundThree -> RoundFour 103 | RoundFour -> RoundFive 104 | RoundFive -> RoundOne 105 | 106 | prevRound :: Round -> Round 107 | prevRound round = case round of 108 | RoundOne -> RoundFive 109 | RoundTwo -> RoundOne 110 | RoundThree -> RoundTwo 111 | RoundFour -> RoundThree 112 | RoundFive -> RoundFour 113 | 114 | data RoundStatus where 115 | RoundUnresolved :: RoundStatus 116 | RoundResolved :: RoundStatus 117 | 118 | deriving instance Show RoundStatus 119 | 120 | data Status (roundStatus :: RoundStatus) where 121 | Unresolved :: Status RoundUnresolved 122 | Resolved :: Status RoundResolved 123 | 124 | type family RoundOrderConstructor (roundStatus :: RoundStatus) :: Phase -> * where 125 | RoundOrderConstructor RoundUnresolved = SomeOrderObject 126 | RoundOrderConstructor RoundResolved = SomeResolved OrderObject 127 | 128 | -- | Rounds 1 and 3 are Typical. 129 | data TypicalRound (round :: Round) where 130 | TypicalRoundOne :: TypicalRound RoundOne 131 | TypicalRoundTwo :: TypicalRound RoundThree 132 | 133 | deriving instance Show (TypicalRound round) 134 | 135 | nextRetreatRound :: TypicalRound round -> RetreatRound (NextRound round) 136 | nextRetreatRound typicalRound = case typicalRound of 137 | TypicalRoundOne -> RetreatRoundOne 138 | TypicalRoundTwo -> RetreatRoundTwo 139 | 140 | -- | Rounds 2 and 4 are Retreat 141 | data RetreatRound (round :: Round) where 142 | RetreatRoundOne :: RetreatRound RoundTwo 143 | RetreatRoundTwo :: RetreatRound RoundFour 144 | 145 | deriving instance Show (RetreatRound round) 146 | 147 | -- | Round 5 is Adjust. 148 | data AdjustRound (round :: Round) where 149 | AdjustRound :: AdjustRound RoundFive 150 | 151 | deriving instance Show (AdjustRound round) 152 | 153 | type family NextRound (round :: Round) :: Round where 154 | NextRound RoundOne = RoundTwo 155 | NextRound RoundTwo = RoundThree 156 | NextRound RoundThree = RoundFour 157 | NextRound RoundFour = RoundFive 158 | NextRound RoundFive = RoundOne 159 | 160 | type family RoundPhase (round :: Round) :: Phase where 161 | RoundPhase RoundOne = Typical 162 | RoundPhase RoundTwo = Retreat 163 | RoundPhase RoundThree = Typical 164 | RoundPhase RoundFour = Retreat 165 | RoundPhase RoundFive = Adjust 166 | 167 | data Game (round :: Round) (roundStatus :: RoundStatus) where 168 | 169 | TypicalGame 170 | :: TypicalRound round 171 | -> Status roundStatus 172 | -> Turn 173 | -> M.Map Zone (Aligned Unit, RoundOrderConstructor roundStatus Typical) 174 | -> Control 175 | -> Game round roundStatus 176 | 177 | RetreatGame 178 | :: RetreatRound round 179 | -> Status roundStatus 180 | -> Turn 181 | -> Resolution Typical 182 | -- Resolutions of the previous typical phase. 183 | -> M.Map Zone (Aligned Unit, RoundOrderConstructor roundStatus Retreat) 184 | -- Dislodged units, which have orders. 185 | -> Occupation 186 | -> Control 187 | -> Game round roundStatus 188 | 189 | AdjustGame 190 | :: AdjustRound round 191 | -> Status roundStatus 192 | -> Turn 193 | -> M.Map Zone (Aligned Unit, RoundOrderConstructor roundStatus Adjust) 194 | -> Control 195 | -> Game round roundStatus 196 | 197 | 198 | -- | Depending on the number of players, we assign the great powers in different 199 | -- ways. If the list is too short (fewer than 3) or too long (more than 7) then 200 | -- Nothing is given. If Just is given, then the resulintg list is the same size 201 | -- as the given list; each provided set is non-empty. 202 | greatPowerAssignments :: [(S.Set GreatPower -> player)] -> Maybe [player] 203 | greatPowerAssignments players = case players of 204 | 205 | -- Full game: each player controls one power. 206 | [p1,p2,p3,p4,p5,p6,p7] -> Just 207 | [ (p1 $ S.singleton England) 208 | , (p2 $ S.singleton Austria) 209 | , (p3 $ S.singleton France) 210 | , (p4 $ S.singleton Turkey) 211 | , (p5 $ S.singleton Russia) 212 | , (p6 $ S.singleton Italy) 213 | , (p7 $ S.singleton Germany) 214 | ] 215 | 216 | -- Italy is not used. 217 | [p1,p2,p3,p4,p5,p6] -> Just 218 | [ (p1 $ S.singleton England) 219 | , (p2 $ S.singleton Austria) 220 | , (p3 $ S.singleton France) 221 | , (p4 $ S.singleton Turkey) 222 | , (p5 $ S.singleton Russia) 223 | , (p6 $ S.singleton Italy) 224 | ] 225 | 226 | -- Germany and Italy are not used. 227 | [p1,p2,p3,p4,p5] -> Just 228 | [ (p1 $ S.singleton England) 229 | , (p2 $ S.singleton Austria) 230 | , (p3 $ S.singleton France) 231 | , (p4 $ S.singleton Turkey) 232 | , (p5 $ S.singleton Russia) 233 | ] 234 | 235 | -- England is solo, other players each get 2 powers. 236 | [p1,p2,p3,p4] -> Just 237 | [ (p1 $ S.singleton England) 238 | , (p2 $ S.fromList [Austria, France]) 239 | , (p3 $ S.fromList [Germany, Turkey]) 240 | , (p4 $ S.fromList [Italy, Russia]) 241 | ] 242 | 243 | -- England/Gemrany/Austria vs. Russia/Italy vs. France/Turkey 244 | [p1,p2,p3] -> Just 245 | [ (p1 $ S.fromList [England, Germany, Austria]) 246 | , (p2 $ S.fromList [Russia, Italy]) 247 | , (p3 $ S.fromList [France, Turkey]) 248 | ] 249 | 250 | -- Cannot play. 251 | _ -> Nothing 252 | 253 | newGame :: Game RoundOne RoundUnresolved 254 | newGame = TypicalGame TypicalRoundOne Unresolved firstTurn zonedOrders thisControl 255 | where 256 | zonedOrders = M.mapWithKey giveDefaultOrder thisOccupation 257 | 258 | giveDefaultOrder 259 | :: Zone 260 | -> Aligned Unit 261 | -> (Aligned Unit, SomeOrderObject Typical) 262 | giveDefaultOrder zone aunit = (aunit, SomeOrderObject (MoveObject (zoneProvinceTarget zone))) 263 | 264 | thisOccupation = 265 | 266 | occupy (Normal London) (Just (align Fleet England)) 267 | . occupy (Normal Edinburgh) (Just (align Fleet England)) 268 | . occupy (Normal Liverpool) (Just (align Army England)) 269 | 270 | . occupy (Normal Brest) (Just (align Fleet France)) 271 | . occupy (Normal Paris) (Just (align Army France)) 272 | . occupy (Normal Marseilles) (Just (align Army France)) 273 | 274 | . occupy (Normal Venice) (Just (align Army Italy)) 275 | . occupy (Normal Rome) (Just (align Army Italy)) 276 | . occupy (Normal Naples) (Just (align Fleet Italy)) 277 | 278 | . occupy (Normal Kiel) (Just (align Fleet Germany)) 279 | . occupy (Normal Berlin) (Just (align Army Germany)) 280 | . occupy (Normal Munich) (Just (align Army Germany)) 281 | 282 | . occupy (Normal Vienna) (Just (align Army Austria)) 283 | . occupy (Normal Budapest) (Just (align Army Austria)) 284 | . occupy (Normal Trieste) (Just (align Fleet Austria)) 285 | 286 | . occupy (Normal Warsaw) (Just (align Army Russia)) 287 | . occupy (Normal Moscow) (Just (align Army Russia)) 288 | . occupy (Special StPetersburgSouth) (Just (align Fleet Russia)) 289 | . occupy (Normal Sevastopol) (Just (align Fleet Russia)) 290 | 291 | . occupy (Normal Constantinople) (Just (align Army Turkey)) 292 | . occupy (Normal Smyrna) (Just (align Army Turkey)) 293 | . occupy (Normal Ankara) (Just (align Fleet Turkey)) 294 | 295 | $ emptyOccupation 296 | 297 | -- Initial control: everybody controls their home supply centres. 298 | thisControl :: Control 299 | thisControl = foldr (\(power, province) -> control province (Just power)) emptyControl controlList 300 | where 301 | controlList :: [(GreatPower, Province)] 302 | controlList = [ (power, province) | power <- greatPowers, province <- filter (isHome power) supplyCentres ] 303 | greatPowers :: [GreatPower] 304 | greatPowers = [minBound..maxBound] 305 | 306 | showGame :: Game round roundStatus -> String 307 | showGame game = concat . intersperse "\n" $ [ 308 | showGameMetadata game 309 | , "****" 310 | , middle 311 | , "****" 312 | , showControl (gameControl game) 313 | ] 314 | where 315 | middle = case game of 316 | TypicalGame _ Unresolved _ _ _ -> showZonedOrders (gameZonedOrders game) 317 | RetreatGame _ Unresolved _ _ _ _ _ -> showZonedOrders (gameZonedOrders game) 318 | AdjustGame _ Unresolved _ _ _ -> showZonedOrders (gameZonedOrders game) 319 | TypicalGame _ Resolved _ _ _ -> showZonedResolvedOrders (gameZonedResolvedOrders game) 320 | RetreatGame _ Resolved _ _ _ _ _ -> showZonedResolvedOrders (gameZonedResolvedOrders game) 321 | AdjustGame _ Resolved _ _ _ -> showZonedResolvedOrders (gameZonedResolvedOrders game) 322 | 323 | showGameMetadata :: Game round roundStatus -> String 324 | showGameMetadata game = concat . intersperse "\n" $ [ 325 | "Year: " ++ show year 326 | , "Season: " ++ show season 327 | , "Phase: " ++ show phase 328 | ] 329 | where 330 | year = 1900 + turnToInt (gameTurn game) 331 | season = gameSeason game 332 | phase = gamePhase game 333 | 334 | showOccupation :: Occupation -> String 335 | showOccupation = concat . intersperse "\n" . M.foldrWithKey foldShowAlignedUnit [] 336 | where 337 | foldShowAlignedUnit zone aunit b = 338 | concat [show provinceTarget, ": ", show greatPower, " ", show unit] : b 339 | where 340 | provinceTarget = zoneProvinceTarget zone 341 | greatPower = alignedGreatPower aunit 342 | unit = alignedThing aunit 343 | 344 | showZonedOrders :: M.Map Zone (Aligned Unit, SomeOrderObject phase) -> String 345 | showZonedOrders = concat . intersperse "\n" . M.foldrWithKey foldShowOrder [] 346 | where 347 | foldShowOrder zone (aunit, SomeOrderObject object) b = 348 | concat [show provinceTarget, ": ", show greatPower, " ", show unit, " ", objectString] : b 349 | where 350 | provinceTarget = zoneProvinceTarget zone 351 | greatPower = alignedGreatPower aunit 352 | unit = alignedThing aunit 353 | objectString = case object of 354 | MoveObject pt -> 355 | if pt == zoneProvinceTarget zone 356 | then "hold" 357 | else "move to " ++ show pt 358 | SupportObject subj pt -> concat ["support ", show supportedUnit, " at ", show supportedPt, " into ", show pt] 359 | where 360 | supportedUnit = subjectUnit subj 361 | supportedPt = subjectProvinceTarget subj 362 | ConvoyObject subj pt -> concat ["convoy ", show convoyedUnit, " from ", show convoyedFrom, " to ", show pt] 363 | where 364 | convoyedUnit = subjectUnit subj 365 | convoyedFrom = subjectProvinceTarget subj 366 | SurrenderObject -> "surrender" 367 | WithdrawObject pt -> "withdraw to " ++ show pt 368 | DisbandObject -> "disband" 369 | BuildObject -> "build" 370 | ContinueObject -> "continue" 371 | 372 | showZonedResolvedOrders :: M.Map Zone (Aligned Unit, SomeResolved OrderObject phase) -> String 373 | showZonedResolvedOrders = concat . intersperse "\n" . M.foldrWithKey foldShowResolvedOrder [] 374 | where 375 | foldShowResolvedOrder 376 | :: Zone 377 | -> (Aligned Unit, SomeResolved OrderObject phase) 378 | -> [String] 379 | -> [String] 380 | foldShowResolvedOrder zone (aunit, SomeResolved (object, resolution)) b = 381 | concat [show provinceTarget, ": ", show greatPower, " ", show unit, " ", objectString, " ", resolutionString] : b 382 | where 383 | provinceTarget = zoneProvinceTarget zone 384 | greatPower = alignedGreatPower aunit 385 | unit = alignedThing aunit 386 | objectString = case object of 387 | MoveObject pt -> 388 | if pt == zoneProvinceTarget zone 389 | then "hold" 390 | else "move to " ++ show pt 391 | SupportObject subj pt -> concat ["support ", show supportedUnit, " at ", show supportedPt, " into ", show pt] 392 | where 393 | supportedUnit = subjectUnit subj 394 | supportedPt = subjectProvinceTarget subj 395 | ConvoyObject subj pt -> concat ["convoy ", show convoyedUnit, " from ", show convoyedFrom, " to ", show pt] 396 | where 397 | convoyedUnit = subjectUnit subj 398 | convoyedFrom = subjectProvinceTarget subj 399 | SurrenderObject -> "surrender" 400 | WithdrawObject pt -> "withdraw to " ++ show pt 401 | DisbandObject -> "disband" 402 | BuildObject -> "build" 403 | ContinueObject -> "continue" 404 | resolutionString = case resolution of 405 | Nothing -> "✓" 406 | Just reason -> "✗ " ++ show reason 407 | 408 | showControl :: Control -> String 409 | showControl = concat . intersperse "\n" . M.foldrWithKey foldShowControl [] 410 | where 411 | foldShowControl province greatPower b = concat [show province, ": ", show greatPower] : b 412 | 413 | gameStatus :: Game round roundStatus -> Status roundStatus 414 | gameStatus game = case game of 415 | TypicalGame _ x _ _ _ -> x 416 | RetreatGame _ x _ _ _ _ _ -> x 417 | AdjustGame _ x _ _ _ -> x 418 | 419 | gameZonedOrders 420 | :: Game round RoundUnresolved 421 | -> M.Map Zone (Aligned Unit, SomeOrderObject (RoundPhase round)) 422 | gameZonedOrders game = case game of 423 | TypicalGame TypicalRoundOne _ _ x _ -> x 424 | TypicalGame TypicalRoundTwo _ _ x _ -> x 425 | RetreatGame RetreatRoundOne _ _ _ x _ _ -> x 426 | RetreatGame RetreatRoundTwo _ _ _ x _ _ -> x 427 | AdjustGame AdjustRound _ _ x _ -> x 428 | 429 | gameZonedResolvedOrders 430 | :: Game round RoundResolved 431 | -> M.Map Zone (Aligned Unit, SomeResolved OrderObject (RoundPhase round)) 432 | gameZonedResolvedOrders game = case game of 433 | TypicalGame TypicalRoundOne _ _ x _ -> x 434 | TypicalGame TypicalRoundTwo _ _ x _ -> x 435 | RetreatGame RetreatRoundOne _ _ _ x _ _ -> x 436 | RetreatGame RetreatRoundTwo _ _ _ x _ _ -> x 437 | AdjustGame AdjustRound _ _ x _ -> x 438 | 439 | gameOccupation :: Game round roundStatus -> Occupation 440 | gameOccupation game = case game of 441 | TypicalGame _ _ _ zonedOrders _ -> M.map fst zonedOrders 442 | RetreatGame _ _ _ _ _ x _ -> x 443 | AdjustGame _ Unresolved _ zonedOrders _ -> M.mapMaybe selectDisbandOrContinue zonedOrders 444 | where 445 | selectDisbandOrContinue :: (Aligned Unit, SomeOrderObject Adjust) -> Maybe (Aligned Unit) 446 | selectDisbandOrContinue (aunit, SomeOrderObject object) = case object of 447 | DisbandObject -> Just aunit 448 | ContinueObject -> Just aunit 449 | _ -> Nothing 450 | AdjustGame _ Resolved _ zonedOrders _ -> M.mapMaybe selectBuildOrContinue zonedOrders 451 | where 452 | selectBuildOrContinue :: (Aligned Unit, SomeResolved OrderObject Adjust) -> Maybe (Aligned Unit) 453 | selectBuildOrContinue (aunit, SomeResolved (object, _)) = case object of 454 | BuildObject -> Just aunit 455 | ContinueObject -> Just aunit 456 | _ -> Nothing 457 | 458 | gameDislodged 459 | :: (RoundPhase round ~ Retreat) 460 | => Game round RoundUnresolved 461 | -> M.Map Zone (Aligned Unit) 462 | gameDislodged game = case game of 463 | RetreatGame _ Unresolved _ _ zonedOrders _ _ -> M.map fst zonedOrders 464 | 465 | gameResolved 466 | :: (RoundPhase round ~ Retreat) 467 | => Game round RoundUnresolved 468 | -> M.Map Zone (Aligned Unit, SomeResolved OrderObject Typical) 469 | gameResolved game = case game of 470 | RetreatGame _ _ _ x _ _ _ -> x 471 | 472 | gameControl :: Game round roundStatus -> Control 473 | gameControl game = case game of 474 | TypicalGame _ _ _ _ c -> c 475 | RetreatGame _ _ _ _ _ _ c -> c 476 | AdjustGame _ _ _ _ c -> c 477 | 478 | gameTurn :: Game round roundStatus -> Turn 479 | gameTurn game = case game of 480 | TypicalGame _ _ t _ _ -> t 481 | RetreatGame _ _ t _ _ _ _ -> t 482 | AdjustGame _ _ t _ _ -> t 483 | 484 | gameRound :: Game round roundStatus -> Round 485 | gameRound game = case game of 486 | TypicalGame TypicalRoundOne _ _ _ _ -> RoundOne 487 | TypicalGame TypicalRoundTwo _ _ _ _ -> RoundThree 488 | RetreatGame RetreatRoundOne _ _ _ _ _ _ -> RoundTwo 489 | RetreatGame RetreatRoundTwo _ _ _ _ _ _ -> RoundFour 490 | AdjustGame AdjustRound _ _ _ _ -> RoundFive 491 | 492 | gameSeason :: Game round roundStatus -> Season 493 | gameSeason game = case game of 494 | TypicalGame TypicalRoundOne _ _ _ _ -> Spring 495 | RetreatGame RetreatRoundOne _ _ _ _ _ _ -> Spring 496 | TypicalGame TypicalRoundTwo _ _ _ _ -> Fall 497 | RetreatGame RetreatRoundTwo _ _ _ _ _ _ -> Fall 498 | AdjustGame _ _ _ _ _ -> Winter 499 | 500 | gamePhase :: Game round roundStatus -> Phase 501 | gamePhase game = case game of 502 | TypicalGame _ _ _ _ _ -> Typical 503 | RetreatGame _ _ _ _ _ _ _ -> Retreat 504 | AdjustGame _ _ _ _ _ -> Adjust 505 | 506 | 507 | -- Can only issue orders for one great power. 508 | -- Must offer the ability to issue more than one order, else issuing 509 | -- adjust phase orders would be impossible. 510 | -- 511 | -- TBD the return type. 512 | -- There may be more than one invalid order given. We must associate each 513 | -- order with the set of criteria which it fails to meet, and give back the 514 | -- next game. If any order is invalid, no orders shall be issued. 515 | -- Of course, for the adjust phase, things are slightly different. Not only 516 | -- is each order associated with its set of invalid reasons, but the set itself 517 | -- has a set of reasons! 518 | 519 | type family ValidateOrdersOutput (phase :: Phase) :: * where 520 | ValidateOrdersOutput Typical = M.Map Zone (Aligned Unit, SomeOrderObject Typical, S.Set (SomeValidityCriterion Typical)) 521 | ValidateOrdersOutput Retreat = M.Map Zone (Aligned Unit, SomeOrderObject Retreat, S.Set (SomeValidityCriterion Retreat)) 522 | ValidateOrdersOutput Adjust = (M.Map Zone (Aligned Unit, SomeOrderObject Adjust, S.Set (SomeValidityCriterion Adjust)), M.Map GreatPower (S.Set AdjustSetValidityCriterion)) 523 | 524 | -- | The game given as the second component of the return value will differ 525 | -- from the input game only if all orders are valid. 526 | -- 527 | -- NB for adjust phase we wipe all build orders for every great power with 528 | -- at least one order appearing in the input order set; that's because there's 529 | -- no way to explicitly remove a build order by overwriting it with some 530 | -- other order. This is due to the way we represent build orders: they are 531 | -- in the game map alongside a unit which doesn't really exist yet. Removing 532 | -- this order involves removing that entry in the map. 533 | issueOrders 534 | :: forall round . 535 | M.Map Zone (Aligned Unit, SomeOrderObject (RoundPhase round)) 536 | -> Game round RoundUnresolved 537 | -> (ValidateOrdersOutput (RoundPhase round), Game round RoundUnresolved) 538 | issueOrders orders game = 539 | let nextGame = case game of 540 | AdjustGame AdjustRound _ _ _ _ -> issueOrdersUnsafe orders (removeBuildOrders greatPowers game) 541 | where 542 | -- All great powers who have an order in the orders set. 543 | greatPowers :: S.Set GreatPower 544 | greatPowers = M.foldr pickGreatPower S.empty orders 545 | pickGreatPower :: (Aligned Unit, t) -> S.Set GreatPower -> S.Set GreatPower 546 | pickGreatPower (aunit, _) = S.insert (alignedGreatPower aunit) 547 | _ -> issueOrdersUnsafe orders game 548 | validation :: ValidateOrdersOutput (RoundPhase round) 549 | allValid :: Bool 550 | (validation, allValid) = case game of 551 | TypicalGame TypicalRoundOne _ _ _ _ -> 552 | let validation = validateOrders orders game 553 | invalids = M.foldr pickInvalids S.empty validation 554 | in (validation, S.null invalids) 555 | TypicalGame TypicalRoundTwo _ _ _ _ -> 556 | let validation = validateOrders orders game 557 | invalids = M.foldr pickInvalids S.empty validation 558 | in (validation, S.null invalids) 559 | RetreatGame RetreatRoundOne _ _ _ _ _ _ -> 560 | let validation = validateOrders orders game 561 | invalids = M.foldr pickInvalids S.empty validation 562 | in (validation, S.null invalids) 563 | RetreatGame RetreatRoundTwo _ _ _ _ _ _ -> 564 | let validation = validateOrders orders game 565 | invalids = M.foldr pickInvalids S.empty validation 566 | in (validation, S.null invalids) 567 | AdjustGame AdjustRound _ _ _ _ -> 568 | let validation = validateOrders orders game 569 | invalids = M.foldr pickInvalids S.empty (fst validation) 570 | adjustSetInvalids = M.foldr S.union S.empty (snd validation) 571 | in (validation, S.null invalids && S.null adjustSetInvalids) 572 | in if allValid 573 | then (validation, nextGame) 574 | else (validation, game) 575 | where 576 | pickInvalids 577 | :: (Aligned Unit, SomeOrderObject phase, S.Set (SomeValidityCriterion phase)) 578 | -> S.Set (SomeValidityCriterion phase) 579 | -> S.Set (SomeValidityCriterion phase) 580 | pickInvalids (_, _, x) = S.union x 581 | 582 | validateOrders 583 | :: forall round . 584 | M.Map Zone (Aligned Unit, SomeOrderObject (RoundPhase round)) 585 | -> Game round RoundUnresolved 586 | -> ValidateOrdersOutput (RoundPhase round) 587 | validateOrders orders game = case game of 588 | -- The form of validation depends upon the game phase: 589 | -- - Typical and Retreat orders are validated independently, so we can 590 | -- express validation as a fold. 591 | -- - Adjust orders are validated independently and then ensemble. 592 | TypicalGame TypicalRoundOne _ _ _ _ -> M.mapWithKey (validateOrderTypical game) orders 593 | TypicalGame TypicalRoundTwo _ _ _ _ -> M.mapWithKey (validateOrderTypical game) orders 594 | RetreatGame RetreatRoundOne _ _ _ _ _ _ -> M.mapWithKey (validateOrderRetreat game) orders 595 | RetreatGame RetreatRoundTwo _ _ _ _ _ _ -> M.mapWithKey (validateOrderRetreat game) orders 596 | AdjustGame AdjustRound _ _ _ _ -> 597 | let independent = M.mapWithKey (validateOrderSubjectAdjust game) orders 598 | ensemble = validateOrdersAdjust game orders 599 | in (independent, ensemble) 600 | where 601 | 602 | validateOrderTypical 603 | :: forall round . 604 | ( RoundPhase round ~ Typical ) 605 | => Game round RoundUnresolved 606 | -> Zone 607 | -> (Aligned Unit, SomeOrderObject (RoundPhase round)) 608 | -> (Aligned Unit, SomeOrderObject (RoundPhase round), S.Set (SomeValidityCriterion Typical)) 609 | validateOrderTypical game zone (aunit, SomeOrderObject object) = 610 | (aunit, SomeOrderObject object, validation) 611 | where 612 | validation = case object of 613 | MoveObject _ -> analyze snd (S.singleton . SomeValidityCriterion . fst) S.empty S.union (moveVOC greatPower occupation) (Order (subject, object)) 614 | SupportObject _ _ -> analyze snd (S.singleton . SomeValidityCriterion . fst) S.empty S.union (supportVOC greatPower occupation) (Order (subject, object)) 615 | ConvoyObject _ _ -> analyze snd (S.singleton . SomeValidityCriterion . fst) S.empty S.union (convoyVOC greatPower occupation) (Order (subject, object)) 616 | occupation = gameOccupation game 617 | greatPower = alignedGreatPower aunit 618 | unit = alignedThing aunit 619 | subject = (unit, zoneProvinceTarget zone) 620 | 621 | validateOrderRetreat 622 | :: forall round . 623 | ( RoundPhase round ~ Retreat ) 624 | => Game round RoundUnresolved 625 | -> Zone 626 | -> (Aligned Unit, SomeOrderObject (RoundPhase round)) 627 | -> (Aligned Unit, SomeOrderObject (RoundPhase round), S.Set (SomeValidityCriterion Retreat)) 628 | validateOrderRetreat game zone (aunit, SomeOrderObject object) = 629 | (aunit, SomeOrderObject object, validation) 630 | where 631 | validation = case object of 632 | SurrenderObject -> analyze snd (S.singleton . SomeValidityCriterion . fst) S.empty S.union (surrenderVOC greatPower dislodgement) (Order (subject, object)) 633 | WithdrawObject _ -> analyze snd (S.singleton . SomeValidityCriterion . fst) S.empty S.union (withdrawVOC greatPower resolved) (Order (subject, object)) 634 | occupation = gameOccupation game 635 | resolved = gameResolved game 636 | dislodgement = gameDislodged game 637 | greatPower = alignedGreatPower aunit 638 | unit = alignedThing aunit 639 | subject = (unit, zoneProvinceTarget zone) 640 | 641 | -- The above two functions give us single-order validations for typical 642 | -- and retreat phases... for adjust we need single-order validation and 643 | -- also order-set validation. But then, the return value type of 644 | -- validateOrders must surely depend upon the phase, no? We want to 645 | -- associate each input order with its set of failed criteria, and then 646 | -- associate the set itself with its failed criteria. So we'll want 647 | -- a type family. 648 | validateOrderSubjectAdjust 649 | :: forall round . 650 | ( RoundPhase round ~ Adjust ) 651 | => Game round RoundUnresolved 652 | -> Zone 653 | -> (Aligned Unit, SomeOrderObject (RoundPhase round)) 654 | -> (Aligned Unit, SomeOrderObject (RoundPhase round), S.Set (SomeValidityCriterion Adjust)) 655 | validateOrderSubjectAdjust game zone (aunit, SomeOrderObject object) = 656 | (aunit, SomeOrderObject object, validation) 657 | where 658 | validation = case object of 659 | ContinueObject -> analyze snd (S.singleton . SomeValidityCriterion . fst) S.empty S.union (continueSubjectVOC greatPower occupation) subject 660 | DisbandObject -> analyze snd (S.singleton . SomeValidityCriterion . fst) S.empty S.union (disbandSubjectVOC greatPower occupation) subject 661 | BuildObject -> analyze snd (S.singleton . SomeValidityCriterion . fst) S.empty S.union (buildSubjectVOC greatPower occupation control) subject 662 | occupation = gameOccupation game 663 | control = gameControl game 664 | greatPower = alignedGreatPower aunit 665 | unit = alignedThing aunit 666 | subject = (unit, zoneProvinceTarget zone) 667 | 668 | -- Here we partition the subjects by GreatPower, because each power's set of 669 | -- adjust orders must be analyzed ensemble to determine whether it makes 670 | -- sense (enough disbands/not too many builds for instance). 671 | validateOrdersAdjust 672 | :: forall round . 673 | ( RoundPhase round ~ Adjust ) 674 | => Game round RoundUnresolved 675 | -> M.Map Zone (Aligned Unit, SomeOrderObject (RoundPhase round)) 676 | -> M.Map GreatPower (S.Set AdjustSetValidityCriterion) 677 | validateOrdersAdjust game orders = M.mapWithKey validation adjustSetsByGreatPower 678 | where 679 | validation 680 | :: GreatPower 681 | -> AdjustSubjects 682 | -> S.Set AdjustSetValidityCriterion 683 | validation greatPower subjects = analyze snd (S.singleton . fst) S.empty S.union (adjustSubjectsVOC greatPower occupation control subjects) subjects 684 | adjustSetsByGreatPower :: M.Map GreatPower AdjustSubjects 685 | adjustSetsByGreatPower = M.foldrWithKey pickSubject M.empty orders 686 | pickSubject 687 | :: Zone 688 | -> (Aligned Unit, SomeOrderObject (RoundPhase round)) 689 | -> M.Map GreatPower AdjustSubjects 690 | -> M.Map GreatPower AdjustSubjects 691 | pickSubject zone (aunit, SomeOrderObject object) = case object of 692 | ContinueObject -> M.alter (alterContinue subject) greatPower 693 | BuildObject -> M.alter (alterBuild subject) greatPower 694 | DisbandObject -> M.alter (alterDisband subject) greatPower 695 | where 696 | subject = (alignedThing aunit, zoneProvinceTarget zone) 697 | greatPower = alignedGreatPower aunit 698 | alterContinue 699 | :: Subject 700 | -> Maybe AdjustSubjects 701 | -> Maybe AdjustSubjects 702 | alterContinue subject x = Just $ case x of 703 | Nothing -> AdjustSubjects S.empty S.empty (S.singleton subject) 704 | Just x' -> x' { continueSubjects = S.insert subject (continueSubjects x') } 705 | alterBuild 706 | :: Subject 707 | -> Maybe AdjustSubjects 708 | -> Maybe AdjustSubjects 709 | alterBuild subject x = Just $ case x of 710 | Nothing -> AdjustSubjects (S.singleton subject) S.empty S.empty 711 | Just x' -> x' { buildSubjects = S.insert subject (buildSubjects x') } 712 | alterDisband 713 | :: Subject 714 | -> Maybe AdjustSubjects 715 | -> Maybe AdjustSubjects 716 | alterDisband subject x = Just $ case x of 717 | Nothing -> AdjustSubjects S.empty (S.singleton subject) S.empty 718 | Just x' -> x' { disbandSubjects = S.insert subject (disbandSubjects x') } 719 | occupation = gameOccupation game 720 | control = gameControl game 721 | 722 | -- | Issue orders without validating them. Do not use this with orders which 723 | -- have not been validated! 724 | issueOrdersUnsafe 725 | :: forall round . 726 | M.Map Zone (Aligned Unit, SomeOrderObject (RoundPhase round)) 727 | -> Game round RoundUnresolved 728 | -> Game round RoundUnresolved 729 | issueOrdersUnsafe validOrders game = M.foldrWithKey issueOrderUnsafe game validOrders 730 | where 731 | issueOrderUnsafe 732 | :: forall round . 733 | Zone 734 | -> (Aligned Unit, SomeOrderObject (RoundPhase round)) 735 | -> Game round RoundUnresolved 736 | -> Game round RoundUnresolved 737 | issueOrderUnsafe zone (aunit, someObject) game = case game of 738 | TypicalGame TypicalRoundOne s t zonedOrders v -> TypicalGame TypicalRoundOne s t (insertOrder zonedOrders) v 739 | TypicalGame TypicalRoundTwo s t zonedOrders v -> TypicalGame TypicalRoundTwo s t (insertOrder zonedOrders) v 740 | RetreatGame RetreatRoundOne s t res zonedOrders o c -> RetreatGame RetreatRoundOne s t res (insertOrder zonedOrders) o c 741 | RetreatGame RetreatRoundTwo s t res zonedOrders o c -> RetreatGame RetreatRoundTwo s t res (insertOrder zonedOrders) o c 742 | AdjustGame AdjustRound s t zonedOrders c -> AdjustGame AdjustRound s t (insertOrder zonedOrders) c 743 | where 744 | insertOrder 745 | :: M.Map Zone (Aligned Unit, SomeOrderObject (RoundPhase round)) 746 | -> M.Map Zone (Aligned Unit, SomeOrderObject (RoundPhase round)) 747 | insertOrder = M.alter (const (Just (aunit, someObject))) zone 748 | 749 | removeBuildOrders 750 | :: (RoundPhase round ~ Adjust) 751 | => S.Set GreatPower 752 | -> Game round RoundUnresolved 753 | -> Game round RoundUnresolved 754 | removeBuildOrders greatPowers game = case game of 755 | AdjustGame AdjustRound s t zonedOrders c -> 756 | let zonedOrders' = M.filter (not . shouldRemove) zonedOrders 757 | in AdjustGame AdjustRound s t zonedOrders' c 758 | where 759 | shouldRemove :: (Aligned Unit, SomeOrderObject Adjust) -> Bool 760 | shouldRemove (aunit, SomeOrderObject object) = case (S.member greatPower greatPowers, object) of 761 | (True, BuildObject) -> True 762 | _ -> False 763 | where 764 | greatPower = alignedGreatPower aunit 765 | 766 | resolve 767 | :: Game round RoundUnresolved 768 | -> Game round RoundResolved 769 | resolve game = case game of 770 | TypicalGame round _ turn zonedOrders control -> 771 | TypicalGame round Resolved turn (typicalResolution zonedOrders) control 772 | RetreatGame round _ turn previousResolution zonedOrders occupation control -> 773 | RetreatGame round Resolved turn previousResolution (retreatResolution zonedOrders) occupation control 774 | AdjustGame round _ turn zonedOrders control -> 775 | AdjustGame round Resolved turn (adjustResolution zonedOrders) control 776 | 777 | continue 778 | :: Game round RoundResolved 779 | -> Game (NextRound round) RoundUnresolved 780 | continue game = case game of 781 | 782 | TypicalGame round _ turn zonedResolvedOrders thisControl -> 783 | RetreatGame (nextRetreatRound round) Unresolved turn zonedResolvedOrders nextZonedOrders occupation thisControl 784 | where 785 | -- Give every dislodged unit a surrender order. 786 | nextZonedOrders :: M.Map Zone (Aligned Unit, SomeOrderObject Retreat) 787 | nextZonedOrders = M.map giveDefaultRetreatOrder dislodgement 788 | 789 | giveDefaultRetreatOrder 790 | :: Aligned Unit 791 | -> (Aligned Unit, SomeOrderObject Retreat) 792 | giveDefaultRetreatOrder aunit = (aunit, SomeOrderObject object) 793 | where 794 | object = SurrenderObject 795 | 796 | (dislodgement, occupation) = dislodgementAndOccupation zonedResolvedOrders 797 | 798 | RetreatGame RetreatRoundOne _ turn _ zonedResolvedOrders occupation thisControl -> 799 | TypicalGame TypicalRoundTwo Unresolved turn nextZonedOrders thisControl 800 | where 801 | -- Give every occupier a hold order. 802 | nextZonedOrders :: M.Map Zone (Aligned Unit, SomeOrderObject Typical) 803 | nextZonedOrders = M.mapWithKey giveDefaultTypicalOrder nextOccupation 804 | 805 | giveDefaultTypicalOrder 806 | :: Zone 807 | -> Aligned Unit 808 | -> (Aligned Unit, SomeOrderObject Typical) 809 | giveDefaultTypicalOrder zone aunit = (aunit, SomeOrderObject object) 810 | where 811 | object = MoveObject (zoneProvinceTarget zone) 812 | 813 | -- Every dislodged unit which successfully withdraws is added to the 814 | -- next occupation value; all others are forgotten. 815 | nextOccupation :: Occupation 816 | nextOccupation = M.foldrWithKey occupationFold occupation zonedResolvedOrders 817 | 818 | occupationFold 819 | :: Zone 820 | -> (Aligned Unit, SomeResolved OrderObject Retreat) 821 | -> Occupation 822 | -> Occupation 823 | occupationFold zone (aunit, SomeResolved (object, res)) = 824 | case (object, res) of 825 | (WithdrawObject withdrawingTo, Nothing) -> occupy withdrawingTo (Just aunit) 826 | _ -> id 827 | 828 | RetreatGame RetreatRoundTwo _ turn _ zonedResolvedOrders occupation thisControl -> 829 | AdjustGame AdjustRound Unresolved turn nextZonedOrders nextControl 830 | where 831 | nextZonedOrders :: M.Map Zone (Aligned Unit, SomeOrderObject Adjust) 832 | nextZonedOrders = M.mapWithKey giveDefaultAdjustOrder nextOccupation 833 | 834 | -- This one is not so trivial... what IS the default adjust order? 835 | -- It depends upon the deficit, and the distance of the unit from 836 | -- its home supply centre! That's because our goal is to enforce that 837 | -- the issued orders in a Game are always valid. So we can't just throw 838 | -- a bunch of Continue objects onto the order set here; the great power 839 | -- may need to disband some units! 840 | -- NB a player need not have a deficit of 0; it's ok to have a negative 841 | -- deficit, since the rule book states that a player may decline to 842 | -- build a unit that she is entitled to. 843 | -- 844 | -- First, let's calculate the deficits for each great power. 845 | -- Then, we'll order their units by minimum distance from home supply 846 | -- centre. 847 | -- Then, we give as many disband orders as the deficit if it's positive, 848 | -- using the list order; other units get ContinueObject. 849 | -- 850 | -- Associate every country with a list of the zones it occupies, 851 | -- ordered by distance from home supply centre. 852 | -- 853 | -- TODO must respect the rule "in case of a tie, fleets first, then 854 | -- alphabetically by province". 855 | zonesByDistance :: M.Map GreatPower [Zone] 856 | zonesByDistance = 857 | M.mapWithKey 858 | (\k -> sortWith (distanceFromHomeSupplyCentre k . ptProvince . zoneProvinceTarget)) 859 | (M.foldrWithKey foldZonesByDistance M.empty occupation) 860 | 861 | sortWith f = sortBy (\x y -> f x `compare` f y) 862 | 863 | foldZonesByDistance 864 | :: Zone 865 | -> Aligned Unit 866 | -> M.Map GreatPower [Zone] 867 | -> M.Map GreatPower [Zone] 868 | foldZonesByDistance zone aunit = M.alter alteration (alignedGreatPower aunit) 869 | where 870 | alteration m = case m of 871 | Nothing -> Just [zone] 872 | Just zs -> Just (zone : zs) 873 | 874 | disbands :: S.Set Zone 875 | disbands = M.foldrWithKey foldDisbands S.empty zonesByDistance 876 | 877 | foldDisbands 878 | :: GreatPower 879 | -> [Zone] 880 | -> S.Set Zone 881 | -> S.Set Zone 882 | -- take behaves as we want it to with negative numbers. 883 | foldDisbands greatPower zones = S.union (S.fromList (take deficit zones)) 884 | where 885 | deficit = supplyCentreDeficit greatPower nextOccupation nextControl 886 | 887 | giveDefaultAdjustOrder 888 | :: Zone 889 | -> Aligned Unit 890 | -> (Aligned Unit, SomeOrderObject Adjust) 891 | giveDefaultAdjustOrder zone aunit = case S.member zone disbands of 892 | True -> (aunit, SomeOrderObject DisbandObject) 893 | False -> (aunit, SomeOrderObject ContinueObject) 894 | 895 | -- Every dislodged unit which successfully withdraws is added to the 896 | -- next occupation value; all others are forgotten. 897 | nextOccupation :: Occupation 898 | nextOccupation = M.foldrWithKey occupationFold occupation zonedResolvedOrders 899 | 900 | occupationFold 901 | :: Zone 902 | -> (Aligned Unit, SomeResolved OrderObject Retreat) 903 | -> Occupation 904 | -> Occupation 905 | occupationFold zone (aunit, SomeResolved (object, res)) = 906 | case (object, res) of 907 | (WithdrawObject withdrawingTo, Nothing) -> occupy withdrawingTo (Just aunit) 908 | _ -> id 909 | 910 | -- Every unit in @nextOccupation@ takes control of the Province where it 911 | -- lies. 912 | nextControl :: Control 913 | nextControl = M.foldrWithKey controlFold thisControl nextOccupation 914 | 915 | controlFold 916 | :: Zone 917 | -> Aligned Unit 918 | -> Control 919 | -> Control 920 | controlFold zone aunit = control (ptProvince (zoneProvinceTarget zone)) (Just (alignedGreatPower aunit)) 921 | 922 | AdjustGame AdjustRound _ turn zonedResolvedOrders thisControl -> 923 | TypicalGame TypicalRoundOne Unresolved (nextTurn turn) nextZonedOrders thisControl 924 | where 925 | -- Give every occupier a hold order. 926 | nextZonedOrders :: M.Map Zone (Aligned Unit, SomeOrderObject Typical) 927 | nextZonedOrders = M.mapWithKey giveDefaultTypicalOrder nextOccupation 928 | 929 | giveDefaultTypicalOrder 930 | :: Zone 931 | -> Aligned Unit 932 | -> (Aligned Unit, SomeOrderObject Typical) 933 | giveDefaultTypicalOrder zone aunit = (aunit, SomeOrderObject object) 934 | where 935 | object = MoveObject (zoneProvinceTarget zone) 936 | 937 | -- Builds and continues become occupying units; disbands go away. 938 | nextOccupation :: Occupation 939 | nextOccupation = M.mapMaybe mapOccupation zonedResolvedOrders 940 | 941 | mapOccupation 942 | :: (Aligned Unit, SomeResolved OrderObject Adjust) 943 | -> Maybe (Aligned Unit) 944 | mapOccupation (aunit, SomeResolved (object, resolution)) = 945 | case (object, resolution) of 946 | (DisbandObject, Nothing) -> Nothing 947 | (BuildObject, Nothing) -> Just aunit 948 | (ContinueObject, Nothing) -> Just aunit 949 | -------------------------------------------------------------------------------- /src/Diplomacy/OrderValidation.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Diplomacy.OrderValidation 3 | Description : Definition of order validation 4 | Copyright : (c) Alexander Vieth, 2015 5 | Licence : BSD3 6 | Maintainer : aovieth@gmail.com 7 | Stability : experimental 8 | Portability : non-portable (GHC only) 9 | -} 10 | 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE PolyKinds #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | {-# LANGUAGE KindSignatures #-} 16 | {-# LANGUAGE DeriveFunctor #-} 17 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 18 | {-# LANGUAGE StandaloneDeriving #-} 19 | {-# LANGUAGE TypeFamilies #-} 20 | {-# LANGUAGE MultiParamTypeClasses #-} 21 | {-# LANGUAGE RankNTypes #-} 22 | {-# LANGUAGE ConstraintKinds #-} 23 | {-# LANGUAGE FlexibleInstances #-} 24 | {-# LANGUAGE UndecidableInstances #-} 25 | 26 | module Diplomacy.OrderValidation ( 27 | 28 | ValidityCharacterization(..) 29 | , ArgumentList(..) 30 | 31 | , ValidityCriterion(..) 32 | , SomeValidityCriterion(..) 33 | , AdjustSetValidityCriterion(..) 34 | , ValidityTag 35 | , AdjustSetValidityTag 36 | 37 | , synthesize 38 | , analyze 39 | 40 | , moveVOC 41 | , supportVOC 42 | , convoyVOC 43 | , surrenderVOC 44 | , withdrawVOC 45 | 46 | , AdjustSubjects(..) 47 | , disbandSubjectVOC 48 | , buildSubjectVOC 49 | , continueSubjectVOC 50 | , adjustSubjectsVOC 51 | 52 | ) where 53 | 54 | import GHC.Exts (Constraint) 55 | import Control.Monad 56 | import Control.Applicative 57 | import qualified Data.Map as M 58 | import qualified Data.Set as S 59 | import Data.MapUtil 60 | import Data.AtLeast 61 | import Data.Functor.Identity 62 | import Data.Functor.Constant 63 | import Data.Functor.Compose 64 | import Data.List as L 65 | import Diplomacy.GreatPower 66 | import Diplomacy.Aligned 67 | import Diplomacy.Unit 68 | import Diplomacy.Phase 69 | import Diplomacy.Subject 70 | import Diplomacy.OrderType 71 | import Diplomacy.OrderObject 72 | import Diplomacy.Order 73 | import Diplomacy.Province 74 | import Diplomacy.Zone 75 | import Diplomacy.ZonedSubject 76 | import Diplomacy.Occupation 77 | import Diplomacy.Dislodgement 78 | import Diplomacy.Control 79 | import Diplomacy.SupplyCentreDeficit 80 | import Diplomacy.OrderResolution 81 | 82 | import Debug.Trace 83 | 84 | -- Each one of these constructors is associated with a set. 85 | data ValidityCriterion (phase :: Phase) (order :: OrderType) where 86 | 87 | MoveValidSubject :: ValidityCriterion Typical Move 88 | MoveUnitCanOccupy :: ValidityCriterion Typical Move 89 | MoveReachable :: ValidityCriterion Typical Move 90 | 91 | SupportValidSubject :: ValidityCriterion Typical Support 92 | SupporterAdjacent :: ValidityCriterion Typical Support 93 | SupporterCanOccupy :: ValidityCriterion Typical Support 94 | SupportedCanDoMove :: ValidityCriterion Typical Support 95 | 96 | ConvoyValidSubject :: ValidityCriterion Typical Convoy 97 | ConvoyValidConvoySubject :: ValidityCriterion Typical Convoy 98 | ConvoyValidConvoyTarget :: ValidityCriterion Typical Convoy 99 | 100 | SurrenderValidSubject :: ValidityCriterion Retreat Surrender 101 | 102 | WithdrawValidSubject :: ValidityCriterion Retreat Withdraw 103 | WithdrawAdjacent :: ValidityCriterion Retreat Withdraw 104 | WithdrawUnoccupiedZone :: ValidityCriterion Retreat Withdraw 105 | WithdrawUncontestedZone :: ValidityCriterion Retreat Withdraw 106 | WithdrawNotDislodgingZone :: ValidityCriterion Retreat Withdraw 107 | 108 | ContinueValidSubject :: ValidityCriterion Adjust Continue 109 | DisbandValidSubject :: ValidityCriterion Adjust Disband 110 | BuildValidSubject :: ValidityCriterion Adjust Build 111 | 112 | deriving instance Show (ValidityCriterion phase order) 113 | deriving instance Eq (ValidityCriterion phase order) 114 | deriving instance Ord (ValidityCriterion phase order) 115 | 116 | data SomeValidityCriterion (phase :: Phase) where 117 | SomeValidityCriterion :: ValidityCriterion phase order -> SomeValidityCriterion phase 118 | 119 | instance Show (SomeValidityCriterion phase) where 120 | show (SomeValidityCriterion vc) = case vc of 121 | MoveValidSubject -> show vc 122 | MoveUnitCanOccupy -> show vc 123 | MoveReachable -> show vc 124 | SupportValidSubject -> show vc 125 | SupporterAdjacent -> show vc 126 | SupporterCanOccupy -> show vc 127 | SupportedCanDoMove -> show vc 128 | ConvoyValidSubject -> show vc 129 | ConvoyValidConvoySubject -> show vc 130 | ConvoyValidConvoyTarget -> show vc 131 | SurrenderValidSubject -> show vc 132 | WithdrawValidSubject -> show vc 133 | WithdrawAdjacent -> show vc 134 | WithdrawUnoccupiedZone -> show vc 135 | WithdrawUncontestedZone -> show vc 136 | WithdrawNotDislodgingZone -> show vc 137 | ContinueValidSubject -> show vc 138 | DisbandValidSubject -> show vc 139 | BuildValidSubject -> show vc 140 | 141 | instance Eq (SomeValidityCriterion phase) where 142 | SomeValidityCriterion vc1 == SomeValidityCriterion vc2 = case (vc1, vc2) of 143 | (MoveValidSubject, MoveValidSubject) -> True 144 | (MoveUnitCanOccupy, MoveUnitCanOccupy) -> True 145 | (MoveReachable, MoveReachable) -> True 146 | (SupportValidSubject, SupportValidSubject) -> True 147 | (SupporterAdjacent, SupporterAdjacent) -> True 148 | (SupporterCanOccupy, SupporterCanOccupy) -> True 149 | (SupportedCanDoMove, SupportedCanDoMove) -> True 150 | (ConvoyValidSubject, ConvoyValidSubject) -> True 151 | (ConvoyValidConvoySubject, ConvoyValidConvoySubject) -> True 152 | (ConvoyValidConvoyTarget, ConvoyValidConvoyTarget) -> True 153 | (SurrenderValidSubject, SurrenderValidSubject) -> True 154 | (WithdrawValidSubject, WithdrawValidSubject) -> True 155 | (WithdrawAdjacent, WithdrawAdjacent) -> True 156 | (WithdrawUnoccupiedZone, WithdrawUnoccupiedZone) -> True 157 | (WithdrawUncontestedZone, WithdrawUncontestedZone) -> True 158 | (WithdrawNotDislodgingZone, WithdrawNotDislodgingZone) -> True 159 | (ContinueValidSubject, ContinueValidSubject) -> True 160 | (DisbandValidSubject, DisbandValidSubject) -> True 161 | (BuildValidSubject, BuildValidSubject) -> True 162 | _ -> False 163 | 164 | instance Ord (SomeValidityCriterion phase) where 165 | SomeValidityCriterion vc1 `compare` SomeValidityCriterion vc2 = 166 | show vc1 `compare` show vc2 167 | 168 | data AdjustSetValidityCriterion where 169 | RequiredNumberOfDisbands :: AdjustSetValidityCriterion 170 | AdmissibleNumberOfBuilds :: AdjustSetValidityCriterion 171 | OnlyContinues :: AdjustSetValidityCriterion 172 | 173 | deriving instance Eq AdjustSetValidityCriterion 174 | deriving instance Ord AdjustSetValidityCriterion 175 | deriving instance Show AdjustSetValidityCriterion 176 | 177 | -- | All ProvinceTargets which a unit can legally occupy. 178 | unitCanOccupy :: Unit -> S.Set ProvinceTarget 179 | unitCanOccupy unit = case unit of 180 | Army -> S.map Normal . S.filter (not . isWater) $ S.fromList [minBound..maxBound] 181 | Fleet -> S.fromList $ do 182 | pr <- [minBound..maxBound] 183 | guard (not (isInland pr)) 184 | case provinceCoasts pr of 185 | [] -> return $ Normal pr 186 | xs -> fmap Special xs 187 | 188 | -- | All places to which a unit could possibly move (without regard for 189 | -- occupation rules as specified by unitCanOccupy). 190 | -- The Occupation parameter is needed to determine which convoys are possible. 191 | -- If it's nothing, we don't consider convoy routes. 192 | validMoveAdjacency :: Maybe Occupation -> Subject -> S.Set ProvinceTarget 193 | validMoveAdjacency occupation subject = case subjectUnit subject of 194 | Army -> case occupation of 195 | Nothing -> S.fromList $ neighbours pt 196 | Just o -> (S.fromList $ neighbours pt) `S.union` (S.map Normal (convoyTargets o pr)) 197 | Fleet -> S.fromList $ do 198 | n <- neighbours pt 199 | let np = ptProvince n 200 | let ppt = ptProvince pt 201 | -- If we have two coastal places, we must guarantee that they have a 202 | -- common coast. 203 | guard (not (isCoastal np) || not (isCoastal ppt) || not (null (commonCoasts pt n))) 204 | return n 205 | where 206 | pt = subjectProvinceTarget subject 207 | pr = ptProvince pt 208 | 209 | convoyPaths :: Occupation -> Province -> [(Province, [Province])] 210 | convoyPaths occupation pr = 211 | filter ((/=) pr . fst) . fmap (\(x, y, z) -> (x, y : z)) . paths occupiedByFleet pickCoastal . pure $ pr 212 | where 213 | occupiedByFleet pr = case provinceOccupier pr occupation of 214 | Just aunit -> alignedThing aunit == Fleet 215 | _ -> False 216 | pickCoastal pr = if isCoastal pr then Just pr else Nothing 217 | 218 | convoyTargets :: Occupation -> Province -> S.Set Province 219 | convoyTargets occupation = S.fromList . fmap fst . convoyPaths occupation 220 | 221 | validMoveTargets 222 | :: Maybe Occupation 223 | -> Subject 224 | -> S.Set ProvinceTarget 225 | validMoveTargets maybeOccupation subject = 226 | (validMoveAdjacency maybeOccupation subject) 227 | `S.intersection` 228 | (unitCanOccupy (subjectUnit subject)) 229 | 230 | -- | Valid support targets are any place where this subject could move without 231 | -- a convoy (this excludes the subject's own province target), and such that 232 | -- the common coast constraint is relaxed (a Fleet in Marseilles can support 233 | -- into Spain NC for example). 234 | validSupportTargets 235 | :: Subject 236 | -> S.Set ProvinceTarget 237 | validSupportTargets subject = S.fromList $ do 238 | x <- S.toList $ validMoveAdjacency Nothing subject 239 | guard (S.member x (unitCanOccupy (subjectUnit subject))) 240 | provinceTargetCluster x 241 | 242 | -- | Given two ProvinceTargets--the place from which support comes, and the 243 | -- place to which support is directed--we can use an Occupation to discover 244 | -- every subject which could be supported by this hypothetical supporter. 245 | validSupportSubjects 246 | :: Occupation 247 | -> ProvinceTarget -- ^ Source 248 | -> ProvinceTarget -- ^ Target 249 | -> S.Set Subject 250 | validSupportSubjects occupation source target = M.foldrWithKey f S.empty occupation 251 | where 252 | f zone aunit = 253 | if Zone source /= zone 254 | -- validMoveTargets will give us non-hold targets, so we explicitly 255 | -- handle the case of a hold. 256 | && (Zone target == zone 257 | -- If the subject here could move to the target, then it's a valid 258 | -- support target. We are careful *not* to use Zone-equality here, 259 | -- because in the case of supporting fleets into coastal territories, 260 | -- we want to rule out supporting to an unreachable coast. 261 | || S.member target (validMoveTargets (Just occupation) subject')) 262 | then S.insert subject' 263 | else id 264 | where 265 | subject' = (alignedThing aunit, zoneProvinceTarget zone) 266 | 267 | -- | Subjects which could act as convoyers: fleets in water. 268 | validConvoyers 269 | :: Maybe GreatPower 270 | -> Occupation 271 | -> S.Set Subject 272 | validConvoyers greatPower = M.foldrWithKey f S.empty 273 | where 274 | f zone aunit = case unit of 275 | Fleet -> if isWater (ptProvince pt) 276 | && ( greatPower == Nothing 277 | || greatPower == Just (alignedGreatPower aunit) 278 | ) 279 | then S.insert (unit, pt) 280 | else id 281 | _ -> id 282 | where 283 | pt = zoneProvinceTarget zone 284 | unit = alignedThing aunit 285 | 286 | -- | Subjects which could be convoyed: armies on coasts. 287 | validConvoySubjects 288 | :: Occupation 289 | -> S.Set Subject 290 | validConvoySubjects = M.foldrWithKey f S.empty 291 | where 292 | f zone aunit = if unit == Army && isCoastal (ptProvince pt) 293 | then S.insert (unit, pt) 294 | else id 295 | where 296 | unit = alignedThing aunit 297 | pt = zoneProvinceTarget zone 298 | 299 | -- | Valid convoy destinations: those reachable by some path of fleets in 300 | -- water which includes the convoyer subject, and initiates at the convoying 301 | -- subject's province target. 302 | validConvoyTargets 303 | :: Occupation 304 | -> Subject 305 | -> Subject 306 | -> S.Set ProvinceTarget 307 | validConvoyTargets occupation subjectConvoyer subjectConvoyed = 308 | let allConvoyPaths = convoyPaths occupation prConvoyed 309 | convoyPathsWithThis = filter (elem prConvoyer . snd) allConvoyPaths 310 | in S.fromList (fmap (Normal . fst) convoyPathsWithThis) 311 | where 312 | prConvoyer = ptProvince (subjectProvinceTarget subjectConvoyer) 313 | prConvoyed = ptProvince (subjectProvinceTarget subjectConvoyed) 314 | 315 | -- Would be nice to have difference, to simulate "not". Then we could say 316 | -- "not contested", "not attacking province" and "not occupied" and providing 317 | -- those contested, attacking province, and occupied sets, rather than 318 | -- providing their complements. 319 | -- 320 | -- Ok, so for withdraw, we wish to say 321 | -- 322 | -- subject : valid subject 323 | -- target : valid unconvoyed move target 324 | -- & not contested area 325 | -- & not dislodging province (of subject's province target) 326 | -- & not occupied province 327 | setOfAllProvinceTargets :: S.Set ProvinceTarget 328 | setOfAllProvinceTargets = S.fromList [minBound..maxBound] 329 | 330 | setOfAllZones :: S.Set Zone 331 | setOfAllZones = S.map Zone setOfAllProvinceTargets 332 | 333 | zoneSetToProvinceTargetSet :: S.Set Zone -> S.Set ProvinceTarget 334 | zoneSetToProvinceTargetSet = S.fold f S.empty 335 | where 336 | f zone = S.union (S.fromList (provinceTargetCluster (zoneProvinceTarget zone))) 337 | 338 | occupiedZones :: Occupation -> S.Set Zone 339 | occupiedZones = S.map (Zone . snd) . S.fromList . allSubjects Nothing 340 | 341 | -- A zone is contested iff there is at least one bounced move order to it, and 342 | -- no successful move order to it. 343 | contestedZones 344 | :: M.Map Zone (Aligned Unit, SomeResolved OrderObject Typical) 345 | -> S.Set Zone 346 | contestedZones = M.foldrWithKey g S.empty . M.foldr f M.empty 347 | where 348 | 349 | f :: (Aligned Unit, SomeResolved OrderObject Typical) 350 | -> M.Map Zone Bool 351 | -> M.Map Zone Bool 352 | f (aunit, SomeResolved (object, res)) = case object of 353 | MoveObject pt -> case res of 354 | Just (MoveBounced _) -> M.alter alteration (Zone pt) 355 | _ -> id 356 | where 357 | alteration (Just bool) = case res of 358 | Nothing -> Just False 359 | _ -> Just bool 360 | alteration Nothing = case res of 361 | Nothing -> Just False 362 | _ -> Just True 363 | _ -> id 364 | 365 | g :: Zone -> Bool -> S.Set Zone -> S.Set Zone 366 | g zone bool = case bool of 367 | True -> S.insert zone 368 | False -> id 369 | 370 | -- | The Zone, if any, which dislodged a unit in this Zone, without the 371 | -- use of a convoy! 372 | dislodgingZones 373 | :: M.Map Zone (Aligned Unit, SomeResolved OrderObject Typical) 374 | -> Zone 375 | -> S.Set Zone 376 | dislodgingZones resolved zone = M.foldrWithKey f S.empty resolved 377 | where 378 | f :: Zone 379 | -> (Aligned Unit, SomeResolved OrderObject Typical) 380 | -> S.Set Zone 381 | -> S.Set Zone 382 | f zone' (aunit, SomeResolved (object, res)) = case object of 383 | MoveObject pt -> 384 | if Zone pt == zone 385 | then case (routes, res) of 386 | ([], Nothing) -> S.insert zone' 387 | _ -> id 388 | else id 389 | where 390 | routes = successfulConvoyRoutes (convoyRoutes resolved subject pt) 391 | subject = (alignedThing aunit, zoneProvinceTarget zone') 392 | _ -> id 393 | 394 | {- 395 | data AdjustPhaseOrderSet where 396 | AdjustPhaseOrderSet 397 | :: Maybe (Either (S.Set (Order Adjust Build)) (S.Set (Order Adjust Disband))) 398 | -> S.Set (Order Adjust Continue) 399 | -> AdjustPhaseOrderSet 400 | 401 | validAdjustOrderSet 402 | :: GreatPower 403 | -> Occupation 404 | -> Control 405 | -> Maybe (Either (S.Set (Order Adjust Build)) (S.Set (Order Adjust Disband))) 406 | validAdjustOrderSet greatPower occupation control 407 | -- All possible sets of build orders: 408 | | deficit < 0 = Just . Left $ allBuildOrderSets 409 | | deficit > 0 = Just . Right $ allDisbandOrderSets 410 | | otherwise = Nothing 411 | where 412 | deficit = supplyCentreDeficit greatPower occupation control 413 | -- To construct all build order sets, we take all subsets of the home 414 | -- supply centres of cardinality at most |deficit| and for each of these, 415 | -- make a subject for each kind of unit which can occupy that place. Note 416 | -- that in the case of special areas like St. Petersburg, we have 3 options! 417 | allBuildOrderSets = flattenSet $ (S.map . S.map) (\s -> Order (s, BuildObject)) allBuildOrderSubjects 418 | -- To construct all disband order sets, we take all subsets of this great 419 | -- power's subjects of cardinality exactly deficit. 420 | -- All subsets of the home supply centres, for each unit which can go 421 | -- there. 422 | allDisbandOrderSets = S.empty 423 | -- New strategy: 424 | -- We have all of the valid ProvinceTargets. 425 | -- For each of these, get the set of all pairs with units which can go 426 | -- there. 427 | -- Now pick from this set of sets; all ways to pick one from each set 428 | -- without going over |deficit| 429 | --allBuildOrderSubjects :: S.Set (S.Set Subject) 430 | --allBuildOrderSubjects = S.map (S.filter (\(unit, pt) -> S.member pt (unitCanOccupy unit))) . (S.map (setCartesianProduct (S.fromList [minBound..maxBound]))) $ allBuildOrderProvinceTargetSets 431 | allBuildOrderSubjects :: S.Set (S.Set Subject) 432 | allBuildOrderSubjects = foldr (\i -> S.union (pickSet i candidateSubjectSets)) S.empty [0..(abs deficit)] 433 | --allBuildOrderSubjects = S.filter ((flip (<=)) (abs deficit) . S.size) (powerSet candidateSubjects) 434 | --candidateSubjects :: S.Set Subject 435 | --candidateSubjects = S.filter (\(unit, pt) -> S.member pt (unitCanOccupy unit)) ((setCartesianProduct (S.fromList [minBound..maxBound])) candidateSupplyCentreSet) 436 | candidateSubjectSets :: S.Set (S.Set Subject) 437 | candidateSubjectSets = S.map (\pt -> S.filter (\(unit, pt) -> S.member pt (unitCanOccupy unit)) (setCartesianProduct (S.fromList [minBound..maxBound]) (S.singleton pt))) candidateSupplyCentreSet 438 | -} 439 | 440 | -- All continue order subjects which would make sense without any other orders 441 | -- in context. 442 | candidateContinueSubjects :: GreatPower -> Occupation -> S.Set Subject 443 | candidateContinueSubjects greatPower = S.fromList . allSubjects (Just greatPower) 444 | 445 | -- All disband order subjects which would make sense without any other orders 446 | -- in context. 447 | candidateDisbandSubjects :: GreatPower -> Occupation -> S.Set Subject 448 | candidateDisbandSubjects greatPower = S.fromList . allSubjects (Just greatPower) 449 | 450 | -- All build subjects which would make sense without any other adjust orders 451 | -- in context: unoccupied home supply centre controlled by this great power 452 | -- which the unit could legally occupy. 453 | candidateBuildSubjects :: GreatPower -> Occupation -> Control -> S.Set Subject 454 | candidateBuildSubjects greatPower occupation control = 455 | let candidateTargets = S.fromList $ candidateSupplyCentreTargets greatPower occupation control 456 | units :: S.Set Unit 457 | units = S.fromList $ [minBound..maxBound] 458 | candidateSubjects :: S.Set Subject 459 | candidateSubjects = setCartesianProduct units candidateTargets 460 | in S.filter (\(u, pt) -> pt `S.member` unitCanOccupy u) candidateSubjects 461 | 462 | candidateSupplyCentreTargets :: GreatPower -> Occupation -> Control -> [ProvinceTarget] 463 | candidateSupplyCentreTargets greatPower occupation control = filter (not . (flip zoneOccupied) occupation . Zone) (controlledHomeSupplyCentreTargets greatPower control) 464 | 465 | controlledHomeSupplyCentreTargets :: GreatPower -> Control -> [ProvinceTarget] 466 | controlledHomeSupplyCentreTargets greatPower control = (controlledHomeSupplyCentres greatPower control >>= provinceTargets) 467 | 468 | controlledHomeSupplyCentres :: GreatPower -> Control -> [Province] 469 | controlledHomeSupplyCentres greatPower control = filter ((==) (Just greatPower) . (flip controller) control) (homeSupplyCentres greatPower) 470 | 471 | homeSupplyCentres :: GreatPower -> [Province] 472 | homeSupplyCentres greatPower = filter (isHome greatPower) supplyCentres 473 | 474 | setCartesianProduct :: (Ord t, Ord s) => S.Set t -> S.Set s -> S.Set (t, s) 475 | setCartesianProduct xs ys = S.foldr (\x -> S.union (S.map ((,) x) ys)) S.empty xs 476 | 477 | powerSet :: Ord a => S.Set a -> S.Set (S.Set a) 478 | powerSet = S.fold powerSetFold (S.singleton (S.empty)) 479 | where 480 | powerSetFold :: Ord a => a -> S.Set (S.Set a) -> S.Set (S.Set a) 481 | powerSetFold elem pset = S.union (S.map (S.insert elem) pset) pset 482 | 483 | flattenSet :: Ord a => S.Set (S.Set a) -> S.Set a 484 | flattenSet = S.foldr S.union S.empty 485 | 486 | setComplement :: Ord a => S.Set a -> S.Set a -> S.Set a 487 | setComplement relativeTo = S.filter (not . (flip S.member) relativeTo) 488 | 489 | -- Pick 1 thing from each of the sets to get a set of cardinality at most 490 | -- n. 491 | -- If there are m sets in the input set, you get a set of cardinality 492 | -- at most m. 493 | -- If n < 0 you get the empty set. 494 | pickSet :: Ord a => Int -> S.Set (S.Set a) -> S.Set (S.Set a) 495 | pickSet n sets 496 | | n <= 0 = S.singleton S.empty 497 | | otherwise = case S.size sets of 498 | 0 -> S.empty 499 | m -> let xs = S.findMin sets 500 | xss = S.delete xs sets 501 | in case S.size xs of 502 | 0 -> pickSet n xss 503 | l -> let rest = pickSet (n-1) xss 504 | in S.map (\(y, ys) -> S.insert y ys) (setCartesianProduct xs rest) `S.union` pickSet n xss 505 | 506 | choose :: Ord a => Int -> S.Set a -> S.Set (S.Set a) 507 | choose n set 508 | | n <= 0 = S.singleton (S.empty) 509 | | otherwise = case S.size set of 510 | 0 -> S.empty 511 | m -> let x = S.findMin set 512 | withoutX = choose n (S.delete x set) 513 | withX = S.map (S.insert x) (choose (n-1) (S.delete x set)) 514 | in withX `S.union` withoutX 515 | 516 | newtype Intersection t = Intersection [t] 517 | newtype Union t = Union [t] 518 | 519 | evalIntersection 520 | :: t 521 | -> (t -> t -> t) 522 | -> Intersection t 523 | -> t 524 | evalIntersection empty intersect (Intersection is) = foldr intersect empty is 525 | 526 | evalUnion 527 | :: t 528 | -> (t -> t -> t) 529 | -> Union t 530 | -> t 531 | evalUnion empty union (Union us) = foldr union empty us 532 | 533 | -- TBD better name, obviously. 534 | -- No Functor superclass because, due to constraints on the element type, this 535 | -- may not really be a Functor. 536 | class SuitableFunctor (f :: * -> *) where 537 | type SuitableFunctorConstraint f :: * -> Constraint 538 | suitableEmpty :: f t 539 | suitableUnion :: SuitableFunctorConstraint f t => f t -> f t -> f t 540 | suitableIntersect :: SuitableFunctorConstraint f t => f t -> f t -> f t 541 | suitableMember :: SuitableFunctorConstraint f t => t -> f t -> Bool 542 | suitableFmap 543 | :: ( SuitableFunctorConstraint f t 544 | , SuitableFunctorConstraint f s 545 | ) 546 | => (t -> s) 547 | -> f t 548 | -> f s 549 | suitablePure :: SuitableFunctorConstraint f t => t -> f t 550 | -- Instead of <*> we offer bundle, which can be used with 551 | -- suitableFmap and uncurry to emulate <*>. 552 | suitableBundle 553 | :: ( SuitableFunctorConstraint f t 554 | , SuitableFunctorConstraint f s 555 | ) 556 | => f t 557 | -> f s 558 | -> f (t, s) 559 | suitableJoin :: SuitableFunctorConstraint f t => f (f t) -> f t 560 | suitableBind 561 | :: ( SuitableFunctorConstraint f t 562 | , SuitableFunctorConstraint f (f s) 563 | , SuitableFunctorConstraint f s 564 | ) 565 | => f t 566 | -> (t -> f s) 567 | -> f s 568 | suitableBind x k = suitableJoin (suitableFmap k x) 569 | 570 | instance SuitableFunctor [] where 571 | type SuitableFunctorConstraint [] = Eq 572 | suitableEmpty = [] 573 | suitableUnion = union 574 | suitableIntersect = intersect 575 | suitableMember = elem 576 | suitableFmap = fmap 577 | suitableBundle = cartesianProduct 578 | where 579 | cartesianProduct :: (Eq a, Eq b) => [a] -> [b] -> [(a, b)] 580 | cartesianProduct xs ys = foldr (\x -> suitableUnion (fmap ((,) x) ys)) suitableEmpty xs 581 | suitablePure = pure 582 | suitableJoin = join 583 | 584 | -- Shit, can't throw functions into a set! 585 | -- Ok, so Ap is out; but can implement it with join instead. 586 | instance SuitableFunctor S.Set where 587 | type SuitableFunctorConstraint S.Set = Ord 588 | suitableEmpty = S.empty 589 | suitableUnion = S.union 590 | suitableIntersect = S.intersection 591 | suitableMember = S.member 592 | suitableFmap = S.map 593 | suitableBundle = setCartesianProduct 594 | suitablePure = S.singleton 595 | suitableJoin = S.foldr suitableUnion suitableEmpty 596 | 597 | -- Description of validity is here: given the prior arguments, produce a 598 | -- tagged union of intersections for the next argument. 599 | data ValidityCharacterization (g :: * -> *) (f :: * -> *) (k :: [*]) where 600 | VCNil 601 | :: ( SuitableFunctor f 602 | ) 603 | => ValidityCharacterization g f '[] 604 | VCCons 605 | :: ( SuitableFunctor f 606 | , SuitableFunctorConstraint f t 607 | ) 608 | => (ArgumentList Identity Identity ts -> TaggedIntersectionOfUnions g f t) 609 | -> ValidityCharacterization g f ts 610 | -> ValidityCharacterization g f (t ': ts) 611 | 612 | validityCharacterizationTrans 613 | :: (forall s . g s -> h s) 614 | -> ValidityCharacterization g f ts 615 | -> ValidityCharacterization h f ts 616 | validityCharacterizationTrans natTrans vc = case vc of 617 | VCNil -> VCNil 618 | VCCons f rest -> VCCons (taggedIntersectionOfUnionsTrans natTrans . f) (validityCharacterizationTrans natTrans rest) 619 | 620 | -- Each thing which we intersect is endowed with a tag (the functor g). 621 | type TaggedIntersectionOfUnions (g :: * -> *) (f :: * -> *) (t :: *) = Intersection (g (Union (f t))) 622 | 623 | taggedIntersectionOfUnionsTrans 624 | :: (forall s . g s -> h s) 625 | -> TaggedIntersectionOfUnions g f t 626 | -> TaggedIntersectionOfUnions h f t 627 | taggedIntersectionOfUnionsTrans trans iou = case iou of 628 | Intersection is -> Intersection (fmap trans is) 629 | 630 | evalTaggedIntersectionOfUnions 631 | :: ( SuitableFunctor f 632 | , SuitableFunctorConstraint f t 633 | ) 634 | => (forall s . g s -> s) 635 | -> TaggedIntersectionOfUnions g f t 636 | -> f t 637 | evalTaggedIntersectionOfUnions exitG (Intersection is) = 638 | -- Must take special care here, since we have no identity under intersection. 639 | -- This is unfortunate, but necessary if we want to admit [] and Set as 640 | -- suitable functors! 641 | case is of 642 | [] -> suitableEmpty 643 | [x] -> evalUnion suitableEmpty suitableUnion (exitG x) 644 | x : xs -> suitableIntersect (evalUnion suitableEmpty suitableUnion (exitG x)) (evalTaggedIntersectionOfUnions exitG (Intersection xs)) 645 | 646 | checkTaggedIntersectionOfUnions 647 | :: ( SuitableFunctor f 648 | , SuitableFunctorConstraint f t 649 | ) 650 | => (forall s . g s -> s) 651 | -> (forall s . g s -> r) 652 | -> r 653 | -> (r -> r -> r) 654 | -> t 655 | -> TaggedIntersectionOfUnions g f t 656 | -> r 657 | checkTaggedIntersectionOfUnions exitG inMonoid mempty mappend x (Intersection is) = 658 | foldr (\xs b -> if suitableMember x (evalUnion suitableEmpty suitableUnion (exitG xs)) then b else mappend (inMonoid xs) b) mempty is 659 | 660 | data ArgumentList (g :: * -> *) (f :: * -> *) (k :: [*]) where 661 | ALNil :: ArgumentList g f '[] 662 | ALCons :: g (f t) -> ArgumentList g f ts -> ArgumentList g f (t ': ts) 663 | 664 | type family Every (c :: * -> Constraint) (ts :: [*]) :: Constraint where 665 | Every c '[] = () 666 | Every c (t ': ts) = (c t, Every c ts) 667 | 668 | instance Every Show ts => Show (ArgumentList Identity Identity ts) where 669 | show al = case al of 670 | ALNil -> "ALNil" 671 | ALCons (Identity (Identity x)) rest -> "ALCons " ++ show x ++ " (" ++ show rest ++ ")" 672 | 673 | instance Every Eq ts => Eq (ArgumentList Identity Identity ts) where 674 | x == y = case (x, y) of 675 | (ALNil, ALNil) -> True 676 | (ALCons (Identity (Identity x')) xs, ALCons (Identity (Identity y')) ys) -> x' == y' && xs == ys 677 | 678 | instance (Every Ord ts, Every Eq ts) => Ord (ArgumentList Identity Identity ts) where 679 | x `compare` y = case (x, y) of 680 | (ALNil, ALNil) -> EQ 681 | (ALCons (Identity (Identity x')) xs, ALCons (Identity (Identity y')) ys) -> 682 | case x' `compare` y' of 683 | LT -> LT 684 | GT -> GT 685 | EQ -> xs `compare` ys 686 | 687 | argListTrans 688 | :: (forall s . g s -> h s) 689 | -> ArgumentList g f ts 690 | -> ArgumentList h f ts 691 | argListTrans natTrans argList = case argList of 692 | ALNil -> ALNil 693 | ALCons x rest -> ALCons (natTrans x) (argListTrans natTrans rest) 694 | 695 | argListTrans1 696 | :: Functor g 697 | => (forall s . f s -> h s) 698 | -> ArgumentList g f ts 699 | -> ArgumentList g h ts 700 | argListTrans1 natTrans argList = case argList of 701 | ALNil -> ALNil 702 | ALCons x rest -> ALCons (fmap natTrans x) (argListTrans1 natTrans rest) 703 | 704 | -- This function is to use the VCCons constructor functions to build an f 705 | -- coontaining all argument lists. Obviously, the SuitableFunctor must be 706 | -- capable of carrying ArgumentList Identity Identity ts 707 | -- 708 | -- No, we should never have to union or intersect on f's containing 709 | -- ArgumentList values, right? 710 | evalValidityCharacterization 711 | :: ( SuitableFunctor f 712 | , ValidityCharacterizationConstraint f ts 713 | ) 714 | => ValidityCharacterization Identity f ts 715 | -> f (ArgumentList Identity Identity ts) 716 | evalValidityCharacterization vc = case vc of 717 | VCNil -> suitablePure ALNil 718 | VCCons next rest -> 719 | let rest' = evalValidityCharacterization rest 720 | in suitableBind rest' $ \xs -> 721 | suitableBind (evalTaggedIntersectionOfUnions runIdentity (next xs)) $ \y -> 722 | suitablePure (ALCons (Identity (Identity y)) xs) 723 | 724 | type family ValidityCharacterizationConstraint (f :: * -> *) (ts :: [*]) :: Constraint where 725 | ValidityCharacterizationConstraint f '[] = ( 726 | SuitableFunctorConstraint f (ArgumentList Identity Identity '[]) 727 | ) 728 | ValidityCharacterizationConstraint f (t ': ts) = ( 729 | SuitableFunctorConstraint f t 730 | , SuitableFunctorConstraint f (f t) 731 | , SuitableFunctorConstraint f (f (ArgumentList Identity Identity (t ': ts))) 732 | , SuitableFunctorConstraint f (t, ArgumentList Identity Identity ts) 733 | , SuitableFunctorConstraint f (ArgumentList Identity Identity (t ': ts)) 734 | , SuitableFunctorConstraint f (ArgumentList Identity Identity ts) 735 | , ValidityCharacterizationConstraint f ts 736 | ) 737 | 738 | type Constructor ts t = ArgumentList Identity Identity ts -> t 739 | type Deconstructor ts t = t -> ArgumentList Identity Identity ts 740 | 741 | -- | VOC is an acronym for Valid Order Characterization 742 | type VOC g f ts t = (Constructor ts t, Deconstructor ts t, ValidityCharacterization g f ts) 743 | 744 | synthesize 745 | :: ( SuitableFunctor f 746 | , SuitableFunctorConstraint f (ArgumentList Identity Identity ts) 747 | , SuitableFunctorConstraint f t 748 | , ValidityCharacterizationConstraint f ts 749 | ) 750 | => (forall s . g s -> Identity s) 751 | -> VOC g f ts t 752 | -> f t 753 | synthesize trans (cons, _, vc) = 754 | let fArgList = evalValidityCharacterization (validityCharacterizationTrans trans vc) 755 | in suitableFmap cons fArgList 756 | 757 | analyze 758 | :: (forall s . g s -> s) 759 | -> (forall s . g s -> r) 760 | -> r 761 | -> (r -> r -> r) 762 | -> VOC g f ts t 763 | -> t 764 | -> r 765 | analyze exitG inMonoid mempty mappend (_, uncons, vd) x = 766 | -- We unconstruct into an argument list, and now we must compare its 767 | -- members with the description 768 | let challenge = uncons x 769 | in analyze' exitG inMonoid mempty mappend challenge vd 770 | where 771 | analyze' 772 | :: (forall s . g s -> s) 773 | -> (forall s . g s -> r) 774 | -> r 775 | -> (r -> r -> r) 776 | -> ArgumentList Identity Identity ts 777 | -> ValidityCharacterization g f ts 778 | -> r 779 | analyze' exitG inMonoid mempty mappend challenge vd = case (challenge, vd) of 780 | (ALNil, VCNil) -> mempty 781 | (ALCons (Identity (Identity x)) rest, VCCons f rest') -> 782 | let possibilities = f rest 783 | -- So here we are. possibilities is an intersection of unions. 784 | -- When evaluated (intersection taken) they give the set of all 785 | -- valid arguments here. 786 | -- BUT here we don't just take the intersection! No, we need 787 | -- to check membership in EACH of the intersectands, and if we 788 | -- find there's no membership, we must grab the tag and mappend 789 | -- it. 790 | here = checkTaggedIntersectionOfUnions 791 | exitG 792 | inMonoid 793 | mempty 794 | mappend 795 | x 796 | possibilities 797 | there = analyze' exitG inMonoid mempty mappend rest rest' 798 | in here `mappend` there 799 | 800 | -- Simple example case to see if things are working somewhat well. 801 | 802 | type ValidityTag phase order = (,) (ValidityCriterion phase order) 803 | 804 | type AdjustSetValidityTag = (,) (AdjustSetValidityCriterion) 805 | 806 | moveVOC 807 | :: GreatPower 808 | -> Occupation 809 | -> VOC (ValidityTag Typical Move) S.Set '[ProvinceTarget, Subject] (Order Typical Move) 810 | moveVOC greatPower occupation = (cons, uncons, vc) 811 | where 812 | vc :: ValidityCharacterization (ValidityTag Typical Move) S.Set '[ProvinceTarget, Subject] 813 | vc = VCCons (\(ALCons (Identity (Identity subject)) ALNil) -> Intersection [ 814 | (MoveUnitCanOccupy, Union [unitCanOccupy (subjectUnit subject)]) 815 | , (MoveReachable, Union [S.singleton (subjectProvinceTarget subject), validMoveAdjacency (Just occupation) subject]) 816 | ]) 817 | . VCCons (\ALNil -> Intersection [(MoveValidSubject, Union [S.fromList (allSubjects (Just greatPower) occupation)])]) 818 | $ VCNil 819 | cons :: ArgumentList Identity Identity '[ProvinceTarget, Subject] -> Order Typical Move 820 | cons argList = case argList of 821 | ALCons (Identity (Identity pt)) (ALCons (Identity (Identity subject)) ALNil) -> 822 | Order (subject, MoveObject pt) 823 | uncons :: Order Typical Move -> ArgumentList Identity Identity '[ProvinceTarget, Subject] 824 | uncons (Order (subject, MoveObject pt)) = 825 | ALCons (return (return pt)) (ALCons (return (return subject)) ALNil) 826 | 827 | supportVOC 828 | :: GreatPower 829 | -> Occupation 830 | -> VOC (ValidityTag Typical Support) S.Set '[Subject, ProvinceTarget, Subject] (Order Typical Support) 831 | supportVOC greatPower occupation = (cons, uncons, vc) 832 | where 833 | vc :: ValidityCharacterization (ValidityTag Typical Support) S.Set '[Subject, ProvinceTarget, Subject] 834 | vc = -- Given a subject for the supporter, and a target for the support, we 835 | -- characterize every valid subject which can be supported. 836 | VCCons (\(ALCons (Identity (Identity pt)) (ALCons (Identity (Identity subject1)) ALNil)) -> Intersection [ 837 | (SupportedCanDoMove, Union [S.filter (/= subject1) (validSupportSubjects occupation (subjectProvinceTarget subject1) pt)]) 838 | ]) 839 | -- Given a subject (the one who offers support), we check every place 840 | -- into which that supporter could offer support; that's every place 841 | -- where it could move without a convoy (or one of the special coasts 842 | -- of that place). 843 | . VCCons (\(ALCons (Identity (Identity subject)) ALNil) -> Intersection [ 844 | (SupporterAdjacent, Union [validSupportTargets subject]) 845 | ]) 846 | . VCCons (\ALNil -> Intersection [(SupportValidSubject, Union [S.fromList (allSubjects (Just greatPower) occupation)])]) 847 | $ VCNil 848 | cons :: ArgumentList Identity Identity '[Subject, ProvinceTarget, Subject] -> Order Typical Support 849 | cons argList = case argList of 850 | ALCons (Identity (Identity subject2)) (ALCons (Identity (Identity pt)) (ALCons (Identity (Identity subject1)) ALNil)) -> 851 | Order (subject1, SupportObject subject2 pt) 852 | uncons :: Order Typical Support -> ArgumentList Identity Identity '[Subject, ProvinceTarget, Subject] 853 | uncons order = case order of 854 | Order (subject1, SupportObject subject2 pt) -> 855 | ALCons (Identity (Identity subject2)) (ALCons (Identity (Identity pt)) (ALCons (Identity (Identity subject1)) ALNil)) 856 | 857 | convoyVOC 858 | :: GreatPower 859 | -> Occupation 860 | -> VOC (ValidityTag Typical Convoy) S.Set '[ProvinceTarget, Subject, Subject] (Order Typical Convoy) 861 | convoyVOC greatPower occupation = (cons, uncons, vc) 862 | where 863 | vc :: ValidityCharacterization (ValidityTag Typical Convoy) S.Set '[ProvinceTarget, Subject, Subject] 864 | vc = VCCons (\(ALCons (Identity (Identity convoyed)) (ALCons (Identity (Identity convoyer)) ALNil)) -> Intersection [ 865 | (ConvoyValidConvoyTarget, Union [validConvoyTargets occupation convoyer convoyed]) 866 | ]) 867 | . VCCons (\(ALCons (Identity (Identity subject)) ALNil) -> Intersection [ 868 | (ConvoyValidConvoySubject, Union [validConvoySubjects occupation]) 869 | ]) 870 | . VCCons (\ALNil -> Intersection [ 871 | (ConvoyValidSubject, Union [validConvoyers (Just greatPower) occupation]) 872 | ]) 873 | $ VCNil 874 | cons :: ArgumentList Identity Identity '[ProvinceTarget, Subject, Subject] -> Order Typical Convoy 875 | cons al = case al of 876 | ALCons (Identity (Identity pt)) (ALCons (Identity (Identity convoyed)) (ALCons (Identity (Identity convoyer)) ALNil)) -> 877 | Order (convoyer, ConvoyObject convoyed pt) 878 | uncons :: Order Typical Convoy -> ArgumentList Identity Identity '[ProvinceTarget, Subject, Subject] 879 | uncons order = case order of 880 | Order (convoyer, ConvoyObject convoyed pt) -> 881 | ALCons (Identity (Identity pt)) (ALCons (Identity (Identity convoyed)) (ALCons (Identity (Identity convoyer)) ALNil)) 882 | 883 | surrenderVOC 884 | :: GreatPower 885 | -> Dislodgement 886 | -> VOC (ValidityTag Retreat Surrender) S.Set '[Subject] (Order Retreat Surrender) 887 | surrenderVOC greatPower dislodgement = (cons, uncons, vc) 888 | where 889 | vc = VCCons (\ALNil -> Intersection [ 890 | (SurrenderValidSubject, Union [S.fromList (allSubjects (Just greatPower) dislodgement)]) 891 | ]) 892 | $ VCNil 893 | cons :: ArgumentList Identity Identity '[Subject] -> Order Retreat Surrender 894 | cons al = case al of 895 | ALCons (Identity (Identity subject)) ALNil -> 896 | Order (subject, SurrenderObject) 897 | uncons :: Order Retreat Surrender -> ArgumentList Identity Identity '[Subject] 898 | uncons order = case order of 899 | Order (subject, SurrenderObject) -> 900 | ALCons (Identity (Identity subject)) ALNil 901 | 902 | withdrawVOC 903 | :: GreatPower 904 | -> M.Map Zone (Aligned Unit, SomeResolved OrderObject Typical) 905 | -> VOC (ValidityTag Retreat Withdraw) S.Set '[ProvinceTarget, Subject] (Order Retreat Withdraw) 906 | withdrawVOC greatPower resolved = (cons, uncons, vc) 907 | where 908 | (dislodgement, occupation) = dislodgementAndOccupation resolved 909 | vc = VCCons (\(ALCons (Identity (Identity subject)) ALNil) -> Intersection [ 910 | (WithdrawAdjacent, Union [validMoveTargets Nothing subject]) 911 | , (WithdrawNotDislodgingZone, Union [zoneSetToProvinceTargetSet $ S.difference setOfAllZones (dislodgingZones resolved (Zone (subjectProvinceTarget subject)))]) 912 | , (WithdrawUncontestedZone, Union [zoneSetToProvinceTargetSet $ S.difference setOfAllZones (contestedZones resolved)]) 913 | , (WithdrawUnoccupiedZone, Union [zoneSetToProvinceTargetSet $ S.difference setOfAllZones (occupiedZones occupation)]) 914 | ]) 915 | . VCCons (\ALNil -> Intersection [ 916 | (WithdrawValidSubject, Union [S.fromList (allSubjects (Just greatPower) dislodgement)]) 917 | ]) 918 | $ VCNil 919 | cons :: ArgumentList Identity Identity '[ProvinceTarget, Subject] -> Order Retreat Withdraw 920 | cons al = case al of 921 | ALCons (Identity (Identity pt)) (ALCons (Identity (Identity subject)) ALNil) -> 922 | Order (subject, WithdrawObject pt) 923 | uncons :: Order Retreat Withdraw -> ArgumentList Identity Identity '[ProvinceTarget, Subject] 924 | uncons order = case order of 925 | Order (subject, WithdrawObject pt) -> 926 | ALCons (Identity (Identity pt)) (ALCons (Identity (Identity subject)) ALNil) 927 | 928 | continueSubjectVOC 929 | :: GreatPower 930 | -> Occupation 931 | -> VOC (ValidityTag Adjust Continue) S.Set '[Subject] Subject 932 | continueSubjectVOC greatPower occupation = (cons, uncons, vc) 933 | where 934 | vc :: ValidityCharacterization (ValidityTag Adjust Continue) S.Set '[Subject] 935 | vc = VCCons (\ALNil -> Intersection [(ContinueValidSubject, Union [candidateContinueSubjects greatPower occupation])]) 936 | $ VCNil 937 | cons :: ArgumentList Identity Identity '[Subject] -> Subject 938 | cons al = case al of 939 | ALCons (Identity (Identity subject)) ALNil -> subject 940 | uncons :: Subject -> ArgumentList Identity Identity '[Subject] 941 | uncons subject = 942 | ALCons (Identity (Identity subject)) ALNil 943 | 944 | disbandSubjectVOC 945 | :: GreatPower 946 | -> Occupation 947 | -> VOC (ValidityTag Adjust Disband) S.Set '[Subject] Subject 948 | disbandSubjectVOC greatPower occupation = (cons, uncons, vc) 949 | where 950 | vc :: ValidityCharacterization (ValidityTag Adjust Disband) S.Set '[Subject] 951 | vc = VCCons (\ALNil -> Intersection [(DisbandValidSubject, Union [candidateDisbandSubjects greatPower occupation])]) 952 | $ VCNil 953 | cons :: ArgumentList Identity Identity '[Subject] -> Subject 954 | cons al = case al of 955 | ALCons (Identity (Identity subject)) ALNil -> subject 956 | uncons :: Subject -> ArgumentList Identity Identity '[Subject] 957 | uncons subject = 958 | ALCons (Identity (Identity subject)) ALNil 959 | 960 | -- Not a very useful factoring. Oh well, can make it sharper later if needed. 961 | buildSubjectVOC 962 | :: GreatPower 963 | -> Occupation 964 | -> Control 965 | -> VOC (ValidityTag Adjust Build) S.Set '[Subject] Subject 966 | buildSubjectVOC greatPower occupation control = (cons, uncons, vc) 967 | where 968 | vc :: ValidityCharacterization (ValidityTag Adjust Build) S.Set '[Subject] 969 | vc = VCCons (\ALNil -> Intersection [(BuildValidSubject, Union [candidateBuildSubjects greatPower occupation control])]) 970 | $ VCNil 971 | cons :: ArgumentList Identity Identity '[Subject] -> Subject 972 | cons al = case al of 973 | ALCons (Identity (Identity subject)) ALNil -> subject 974 | uncons :: Subject -> ArgumentList Identity Identity '[Subject] 975 | uncons subject = 976 | ALCons (Identity (Identity subject)) ALNil 977 | 978 | -- Next up: given the set of adjust orders (special datatype or really 979 | -- a set of SomeOrder?) give the valid subsets. Special datatype. 980 | data AdjustSubjects = AdjustSubjects { 981 | buildSubjects :: S.Set Subject 982 | , disbandSubjects :: S.Set Subject 983 | , continueSubjects :: S.Set Subject 984 | } 985 | deriving (Eq, Ord, Show) 986 | 987 | -- Here we assume that all of the subjects are valid according to 988 | -- the characterizations with the SAME occupation, control, and great power. 989 | -- 990 | -- Really though, what should be the output? Sets of SomeOrder are annoying, 991 | -- because the Ord instance there is not trivial. Why not sets of 992 | -- AdjustSubjects as we have here? 993 | -- For 0 deficit, we give the singleton set of the AdjustSubjects in 994 | -- which we make the build and disband sets empty. 995 | -- For > 0 deficit, we take all deficit-element subsets of the disband 996 | -- subjects, and for each of them we throw in the complement relative to 997 | -- the continue subjects, and no build subjects. 998 | -- For < 0 deficit, we take all (-deficit)-element or less subsets of the 999 | -- build subjects, and for each of them we throw in the complement relative 1000 | -- to the continue subjects, and no disband subjects. 1001 | adjustSubjectsVOC 1002 | :: GreatPower 1003 | -> Occupation 1004 | -> Control 1005 | -> AdjustSubjects 1006 | -> VOC AdjustSetValidityTag S.Set '[AdjustSubjects] AdjustSubjects 1007 | adjustSubjectsVOC greatPower occupation control subjects = (cons, uncons, vc) 1008 | where 1009 | deficit = supplyCentreDeficit greatPower occupation control 1010 | vc :: ValidityCharacterization AdjustSetValidityTag S.Set '[AdjustSubjects] 1011 | vc = VCCons (\ALNil -> tiu) 1012 | $ VCNil 1013 | cons :: ArgumentList Identity Identity '[AdjustSubjects] -> AdjustSubjects 1014 | cons al = case al of 1015 | ALCons (Identity (Identity x)) ALNil -> x 1016 | uncons :: AdjustSubjects -> ArgumentList Identity Identity '[AdjustSubjects] 1017 | uncons x = 1018 | ALCons (Identity (Identity x)) ALNil 1019 | tiu :: TaggedIntersectionOfUnions AdjustSetValidityTag S.Set AdjustSubjects 1020 | tiu | deficit > 0 = let disbandSets = choose deficit disbands 1021 | pairs = S.map (\xs -> (xs, continues `S.difference` xs)) disbandSets 1022 | valids :: S.Set AdjustSubjects 1023 | valids = S.map (\(disbands, continues) -> AdjustSubjects S.empty disbands continues) pairs 1024 | in Intersection [(RequiredNumberOfDisbands, Union (fmap S.singleton (S.toList valids)))] 1025 | | deficit < 0 = let buildSetsUnzoned :: [S.Set (S.Set Subject)] 1026 | buildSetsUnzoned = fmap (\n -> choose n builds) [0..(-deficit)] 1027 | -- buildSetsUnzoned is not quite what we want; its 1028 | -- member sets may include subjects of the same 1029 | -- zone. A fleet in Marseilles and an army in 1030 | -- Marseilles, for instance. To remedy this, we 1031 | -- set-map each one to and from ZonedSubjectDull, 1032 | -- whose Eq/Ord instances ignore the unit and uses 1033 | -- zone-equality. Then, to rule out duplicate sets, 1034 | -- we do this again with the ZonedSubjectSharp 1035 | -- type, which uses zone-equality but does not 1036 | -- ignore the unit. This ensure that, for instance, 1037 | -- the sets {(Fleet, Marseilles)} and 1038 | -- {(Army, Marseilles)} can coexist in buildSets. 1039 | buildSets :: [S.Set (S.Set Subject)] 1040 | buildSets = 1041 | fmap 1042 | (S.map (S.map zonedSubjectSharp) . (S.map (S.map (ZonedSubjectSharp . zonedSubjectDull) . (S.map ZonedSubjectDull)))) 1043 | buildSetsUnzoned 1044 | pairs :: [S.Set (S.Set Subject, S.Set Subject)] 1045 | pairs = (fmap . S.map) (\xs -> (xs, continues `S.difference` xs)) buildSets 1046 | valids :: [S.Set AdjustSubjects] 1047 | valids = (fmap . S.map) (\(builds, continues) -> AdjustSubjects builds S.empty continues) pairs 1048 | in Intersection [(AdmissibleNumberOfBuilds, Union valids)] 1049 | | otherwise = Intersection [(OnlyContinues, Union [S.singleton (AdjustSubjects S.empty S.empty continues)])] 1050 | builds = buildSubjects subjects 1051 | disbands = disbandSubjects subjects 1052 | continues = continueSubjects subjects 1053 | --------------------------------------------------------------------------------