diff --git a/Data/AtLeast.hs b/Data/AtLeast.hs --- a/Data/AtLeast.hs +++ b/Data/AtLeast.hs @@ -38,7 +38,7 @@ import Data.TypeNat.Nat import Data.TypeNat.Vect -data AtLeast (n :: Nat) (t :: *) = AtLeast (Vect t n) [t] +data AtLeast (n :: Nat) (t :: *) = AtLeast (Vect n t) [t] -- Equality ignores order of elements. instance Eq t => Eq (AtLeast n t) where diff --git a/Diplomacy/Game.hs b/Diplomacy/Game.hs --- a/Diplomacy/Game.hs +++ b/Diplomacy/Game.hs @@ -42,6 +42,7 @@ , gameRound , gameSeason , issueOrders + , removeBuildOrders , resolve , continue , newGame @@ -456,9 +457,13 @@ -- | The game given as the second component of the return value will differ -- from the input game only if all orders are valid. --- NB for adjust phase we wipe all build orders; that's because there's +-- +-- NB for adjust phase we wipe all build orders for every great power with +-- at least one order appearing in the input order set; that's because there's -- no way to explicitly remove a build order by overwriting it with some --- other order. +-- other order. This is due to the way we represent build orders: they are +-- in the game map alongside a unit which doesn't really exist yet. Removing +-- this order involves removing that entry in the map. issueOrders :: forall round . M.Map Zone (Aligned Unit, SomeOrderObject (RoundPhase round)) @@ -466,7 +471,13 @@ -> (ValidateOrdersOutput (RoundPhase round), Game round RoundUnresolved) issueOrders orders game = let nextGame = case game of - AdjustGame AdjustRound _ _ _ _ -> issueOrdersUnsafe orders (removeBuildOrders game) + AdjustGame AdjustRound _ _ _ _ -> issueOrdersUnsafe orders (removeBuildOrders greatPowers game) + where + -- All great powers who have an order in the orders set. + greatPowers :: S.Set GreatPower + greatPowers = M.fold pickGreatPower S.empty orders + pickGreatPower :: (Aligned Unit, t) -> S.Set GreatPower -> S.Set GreatPower + pickGreatPower (aunit, _) = S.insert (alignedGreatPower aunit) _ -> issueOrdersUnsafe orders game validation :: ValidateOrdersOutput (RoundPhase round) allValid :: Bool @@ -671,17 +682,20 @@ removeBuildOrders :: (RoundPhase round ~ Adjust) - => Game round RoundUnresolved + => S.Set GreatPower -> Game round RoundUnresolved -removeBuildOrders game = case game of + -> Game round RoundUnresolved +removeBuildOrders greatPowers game = case game of AdjustGame AdjustRound s t zonedOrders c -> - let zonedOrders' = M.filter (not . isBuild) zonedOrders + let zonedOrders' = M.filter (not . shouldRemove) zonedOrders in AdjustGame AdjustRound s t zonedOrders' c where - isBuild :: (Aligned Unit, SomeOrderObject Adjust) -> Bool - isBuild (_, SomeOrderObject object) = case object of - BuildObject -> True + shouldRemove :: (Aligned Unit, SomeOrderObject Adjust) -> Bool + shouldRemove (aunit, SomeOrderObject object) = case (S.member greatPower greatPowers, object) of + (True, BuildObject) -> True _ -> False + where + greatPower = alignedGreatPower aunit resolve :: Game round RoundUnresolved diff --git a/Diplomacy/OrderValidation.hs b/Diplomacy/OrderValidation.hs --- a/Diplomacy/OrderValidation.hs +++ b/Diplomacy/OrderValidation.hs @@ -237,24 +237,29 @@ -> S.Set ProvinceTarget validSupportTargets subject = S.fromList $ do x <- S.toList $ validMoveAdjacency Nothing subject + guard (S.member x (unitCanOccupy (subjectUnit subject))) provinceTargetCluster x --- | Valid support targets depend upon the support subject AND its chosen --- target! For example, if we choose to support into Brest, then a fleet --- in the Tyrrhenian Sea cannot be the support subject. +-- | Given two ProvinceTargets--the place from which support comes, and the +-- place to which support is directed--we can use an Occupation to discover +-- every subject which could be supported by this hypothetical supporter. validSupportSubjects :: Occupation - -> Subject - -> ProvinceTarget + -> ProvinceTarget -- ^ Source + -> ProvinceTarget -- ^ Target -> S.Set Subject -validSupportSubjects occupation subject target = M.foldWithKey f S.empty occupation +validSupportSubjects occupation source target = M.foldWithKey f S.empty occupation where - pt = subjectProvinceTarget subject f zone aunit = - -- validMoveTargets will give us non-hold targets, so we explicitly - -- handle the case of a hold. - if target == zoneProvinceTarget zone - || S.member target (validMoveTargets (Just occupation) subject') + if Zone source /= zone + -- validMoveTargets will give us non-hold targets, so we explicitly + -- handle the case of a hold. + && (Zone target == zone + -- If the subject here could move to the target, then it's a valid + -- support target. We are careful *not* to use Zone-equality here, + -- because in the case of supporting fleets into coastal territories, + -- we want to rule out supporting to an unreachable coast. + || S.member target (validMoveTargets (Just occupation) subject')) then S.insert subject' else id where @@ -830,14 +835,14 @@ vc = -- Given a subject for the supporter, and a target for the support, we -- characterize every valid subject which can be supported. VCCons (\(ALCons (Identity (Identity pt)) (ALCons (Identity (Identity subject1)) ALNil)) -> Intersection [ - (SupportedCanDoMove, Union [S.filter (/= subject1) (validSupportSubjects occupation subject1 pt)]) + (SupportedCanDoMove, Union [S.filter (/= subject1) (validSupportSubjects occupation (subjectProvinceTarget subject1) pt)]) ]) - -- Given a subject for the supporter, we check every place into which - -- that supporter could offer support; that's every place where it - -- could move without a convoy. + -- Given a subject (the one who offers support), we check every place + -- into which that supporter could offer support; that's every place + -- where it could move without a convoy (or one of the special coasts + -- of that place). . VCCons (\(ALCons (Identity (Identity subject)) ALNil) -> Intersection [ - (SupporterCanOccupy, Union [unitCanOccupy (subjectUnit subject)]) - , (SupporterAdjacent, Union [validSupportTargets subject]) + (SupporterAdjacent, Union [validSupportTargets subject]) ]) . VCCons (\ALNil -> Intersection [(SupportValidSubject, Union [S.fromList (allSubjects (Just greatPower) occupation)])]) $ VCNil diff --git a/Diplomacy/Province.hs b/Diplomacy/Province.hs --- a/Diplomacy/Province.hs +++ b/Diplomacy/Province.hs @@ -72,6 +72,7 @@ import qualified Data.Set as S import Data.String (fromString, IsString) import Data.List (sort) +import Data.Char (toUpper, toLower) import Diplomacy.GreatPower import Text.Parsec hiding ((<|>)) import Text.Parsec.Text @@ -741,7 +742,7 @@ reps pr = let (s, ss) = provinceStringRepresentations pr in (pr, s, ss) makeParser :: (Province, String) -> Parser Province - makeParser (p, s) = try (string s) *> pure p + makeParser (p, s) = try (ciString s) *> pure p provinceCoastStringRepresentations :: ProvinceCoast -> [String] provinceCoastStringRepresentations pc = provinceReps >>= addSuffix @@ -774,7 +775,7 @@ bundleReps pc = let ss = provinceCoastStringRepresentations pc in (pc, ss) makeParser :: (ProvinceCoast, [String]) -> Parser ProvinceCoast - makeParser (pc, ss) = choice (fmap (try . string) ss) *> pure pc + makeParser (pc, ss) = choice (fmap (try . ciString) ss) *> pure pc parseProvinceTarget :: Parser ProvinceTarget parseProvinceTarget = try parseSpecial <|> parseNormal @@ -857,3 +858,10 @@ case indicator x of Just y -> return (y, first, rest) Nothing -> empty + +-- case-insensitive string parser. +ciString :: String -> Parser String +ciString = mapM ciChar + +ciChar :: Char -> Parser Char +ciChar c = char (toLower c) <|> char (toUpper c) diff --git a/Diplomacy/Unit.hs b/Diplomacy/Unit.hs --- a/Diplomacy/Unit.hs +++ b/Diplomacy/Unit.hs @@ -41,9 +41,9 @@ parseUnit = parseFleet <|> parseArmy where parseFleet :: Parser Unit - parseFleet = char 'F' *> pure Fleet + parseFleet = (char 'F' <|> char 'f') *> pure Fleet parseArmy :: Parser Unit - parseArmy = char 'A' *> pure Army + parseArmy = (char 'A' <|> char 'a') *> pure Army printUnit :: IsString a => Unit -> a printUnit unit = case unit of diff --git a/diplomacy.cabal b/diplomacy.cabal --- a/diplomacy.cabal +++ b/diplomacy.cabal @@ -2,20 +2,23 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: diplomacy -version: 0.1.0.0 -synopsis: The board game Diplomacy, spoken in Haskell --- description: +version: 0.2.0.0 +synopsis: Diplomacy board game +description: The board game Diplomacy, spoken in Haskell homepage: https://github.com/avieth/diplomacy license: BSD3 license-file: LICENSE author: Alexander Vieth maintainer: aovieth@gmail.com -- copyright: --- category: +category: Games build-type: Simple extra-source-files: README.md cabal-version: >=1.10 +source-repository head + type: git + location: http://github.com/avieth/diplomacy.git library exposed-modules: Diplomacy.OrderObject @@ -59,12 +62,11 @@ , RankNTypes , PatternSynonyms - build-depends: base >=4.7 && <4.8 + build-depends: base >=4.7 && <4.11 , containers >=0.5 && <0.6 - , transformers >=0.3 && <0.4 + , transformers >=0.3 && <0.6 , HUnit >=1.2 && <1.3 - , TypeNat >=0.4 && <0.5 + , TypeNat >=0.5 && <0.6 , parsec >= 3.1 && <3.2 -- hs-source-dirs: default-language: Haskell2010 -