implement sequencing of GameActions with a Monoid interface

src/Test.hs

@@ -4,6 +4,7 @@
 import Waterdeep.Types
 import Waterdeep.Monad
 import Waterdeep.Logic
+import Waterdeep.Util (mrepeat)
 import Control.Applicative
 import Control.Lens
 import Control.Monad
@@ -11,6 +12,7 @@ import Control.Monad.Prompt
 import Control.Monad.Random
 import Control.Monad.State
 import Data.List
+import Data.Monoid
 import Text.Printf
 import System.IO
 import System.Random
@@ -29,59 +31,57 @@ p2 = ("Ned", f2, l2)
 q1 = Quest { _questType = Arcana
            , _questTitle = "Research Palantirs"
            , _questQuote = ""
-           , _questAction = Transaction $
+           , _questAction = ReturnResource [Cleric]
-                              [ Transaction $
+                         <> ReturnResource [Rogue]
-                                 map (\r -> ReturnResource [r]) [Cleric,Rogue,Rogue,Wizard]
+                         <> ReturnResource [Rogue]
-                              , Repeat 4 $ ReturnResource [Gold]
+                         <> ReturnResource [Wizard]
-                              , ScorePoints 15
+                         <> mrepeat 4 (ReturnResource [Gold])
-                              , Repeat 8 $ TakeResource [Gold]
+                         <> ScorePoints 15
-                              ]
+                         <> mrepeat 8 (TakeResource [Gold])
            , _questPlotActions = []
            }
 
 q2 = Quest { _questType = Skullduggery
            , _questTitle = "Rob Waterdeep Bank"
            , _questQuote = ""
-           , _questAction = Transaction $
+           , _questAction = mrepeat 8 (ReturnResource [Rogue])
-                              [ Repeat 8 $ ReturnResource [Rogue]
+                         <> ScorePoints 10
-                              , ScorePoints 10
+                         <> mrepeat 16 (TakeResource [Gold])
-                              , Repeat 16 $ TakeResource [Gold]
-                              ]
            , _questPlotActions = []
            }
 
 b1 = Building { _buildingCost = 6
               , _buildingTitle = "Monastary"
-              , _buildingAction = Group [TakeResource [Cleric], TakeResource [Cleric]]
+              , _buildingAction = mrepeat 2 (TakeResource [Cleric])
               , _buildingOwnerAction = TakeResource [Cleric]
               , _buildingAccumType = NoAccumulation
               }
 
 b2 = Building { _buildingCost = 4
               , _buildingTitle = "Training Hall"
-              , _buildingAction = Group [TakeResource [Fighter], TakeResource [Fighter]]
+              , _buildingAction = mrepeat 2 (TakeResource [Fighter])
               , _buildingOwnerAction = TakeResource [Fighter]
               , _buildingAccumType = NoAccumulation
               }
 
 b3 = Building { _buildingCost = 4
               , _buildingTitle = "Prison Yard"
-              , _buildingAction = Group [TakeResource [Rogue], TakeResource [Rogue]]
+              , _buildingAction = mrepeat 2 (TakeResource [Rogue])
               , _buildingOwnerAction = TakeResource [Rogue]
               , _buildingAccumType = NoAccumulation
               }
 
 b4 = Building { _buildingCost = 6
               , _buildingTitle = "Wizard School"
-              , _buildingAction = Group [TakeResource [Wizard], TakeResource [Wizard]]
+              , _buildingAction = mrepeat 2 (TakeResource [Wizard])
               , _buildingOwnerAction = TakeResource [Wizard]
               , _buildingAccumType = NoAccumulation
               }
 
 b5 = Building { _buildingCost = 4
               , _buildingTitle = "Gold Mine"
-              , _buildingAction = Group $ replicate 4 $ TakeResource [Gold]
+              , _buildingAction = mrepeat 4 (TakeResource [Gold])
-              , _buildingOwnerAction = Group $ replicate 2 $ TakeResource [Gold]
+              , _buildingOwnerAction = mrepeat 4 (TakeResource [Gold])
               , _buildingAccumType = NoAccumulation
               }
 

src/Waterdeep/Logic.hs

@@ -16,6 +16,7 @@ import Control.Monad.Random
 import Control.Monad.State
 import Data.List
 import Data.Maybe
+import Data.Monoid
 import System.Random.Shuffle
 import Waterdeep.Types
 import Waterdeep.Monad
@@ -97,8 +98,25 @@ waterdeepGame = do
       replicateM_ (3 + p) $ performAction p $ TakeResource [Gold]
    forM_ [1..8] $ \round -> do
       beginRound round
+      fix $ \loop -> do
+         p <- use gameCurrentPlayer
+         success <- filterChoices $ performAction p AssignAgent
+         case success of
+            True -> do
+               filterChoices $ performAction p CompleteQuest
+               gameCurrentPlayer .= (p `mod` length ps) + 1
+               gameConsecutivePasses .= 0
+               loop
+            False -> do
+               passes <- gameConsecutivePasses <+= 1
+               when (passes < length ps) loop
       performAction 1 $ TakeResource [Cleric, Fighter, Rogue, Wizard, Gold]
-      performAction 2 $ ChooseQuest
+      filterChoices $ performAction 1 $
+            ReturnResource [Wizard]
+         <> ReturnResource [Cleric, Fighter, Gold]
+         <> ReturnResource [Cleric, Fighter]
+         <> ReturnResource [Cleric]
+      -- performAction 2 $ ChooseQuest
    scoreFinalPoints
    notifyState
    determineWinners
@@ -124,15 +142,54 @@ initialAgents players round =
    if round >= 5 then startingAgents + 1 else startingAgents
    where startingAgents = 6 - players
 
+data ContWD a where
+   Done :: (a, WaterdeepState) -> ContWD a
+   Cont :: WaterdeepPrompt b -> (b -> ContWD a) -> ContWD a
+
+-- |Permit only choices which lead to a True result.
+-- Returns False if and only if no such choice exists.
+-- If result is False, state remains unchanged.
+filterChoices :: Waterdeep Bool -> Waterdeep Bool
+filterChoices m = do
+   mw' <- filteredChoice =<< (runWaterdeepC Done Cont m <$> get)
+   case mw' of
+      Just w' -> put w' >> return True
+      Nothing -> return False
+   where
+      tryChoice :: ContWD Bool -> Bool
+      tryChoice (Done a) = fst a
+      tryChoice (Cont (NotifyState w) cont) = tryChoice $ cont ()
+      tryChoice (Cont (SolicitChoice w p t cs) cont) =
+         or $ map (tryChoice . cont . snd) cs
+      filteredChoice :: ContWD Bool -> Waterdeep (Maybe WaterdeepState)
+      filteredChoice (Done (a,w)) = if a then return (Just w) else return Nothing
+      filteredChoice (Cont (NotifyState w) cont) = filteredChoice $ cont ()
+      filteredChoice (Cont (SolicitChoice w p t cs) cont) = do
+         let cs' = filter (tryChoice . cont . snd) cs
+         if null cs'
+            then return Nothing
+            else filteredChoice =<< (cont <$> (put w >> solicitChoice p t cs'))
+
 performAction :: PlayerID -> GameAction -> Waterdeep Bool
 performAction p a = case a of
+   NoAction -> return True
    ScorePoints n -> do
       gamePlayer p . playerScore += n
       return True
    TakeResource rs -> do
-      r <- solicitChoice p "Please choose one:" $ map (show &&& id) rs
+      r <- solicitChoice p "Take one item:" $ map (show &&& id) rs
       gamePlayer p . playerTavern %= flip (M.unionWith (+)) (M.fromList [(r, 1)])
       return True
+   ReturnResource rs -> do
+      tavern <- use $ gamePlayer p . playerTavern
+      let rs' = filter ((> 0) . maybe 0 id . flip M.lookup tavern) rs
+      if null rs'
+         then return False
+         else do
+            r <- solicitChoice p "Return one item:" $ map (show &&& id) rs'
+            let removeOne x = if x > 1 then Just (x-1) else Nothing
+            gamePlayer p . playerTavern %= M.update removeOne r
+            return True
    ChooseQuest -> do
       qs <- use gameCliffwatchInn
       if null qs
@@ -158,6 +215,8 @@ performAction p a = case a of
          Just i  -> do
             gamePlayer p . playerIntrigueCards %= (++[i])
             return True
+   a1 `Then` a2 -> do
+      (&&) <$> performAction p a1 <*> performAction p a2
    _ -> return False
 
 scoreFinalPoints :: Waterdeep ()

src/Waterdeep/Types.hs

@@ -81,6 +81,7 @@ module Waterdeep.Types
 import Control.Lens
 import Data.IntMap (IntMap)
 import Data.Map (Map)
+import Data.Monoid
 import System.Random (StdGen)
 
 type PlayerID = Int
@@ -192,7 +193,8 @@ data AccumulationType = NoAccumulation
                       | AccumulateResource Resource Int
                       deriving (Eq,Show)
 
-data GameAction = ScorePoints Int
+data GameAction = NoAction
+                | ScorePoints Int
                 | TakeResource [Resource]
                 | ReturnResource [Resource]
                 | GiveResource [Resource]
@@ -201,6 +203,7 @@ data GameAction = ScorePoints Int
                 | DrawQuest
                 | DrawNamedQuestType
                 | DistributeQuests
+                | CompleteQuest
                 | ChooseAndCompleteQuest
                 | DiscardUncompletedQuest
                 | BuyBuilding
@@ -220,18 +223,18 @@ data GameAction = ScorePoints Int
                 | TakeAccumulated
                 | TakeResourceFromOpponent [Resource]
                 | AssignMandatoryQuest Quest
-                | Group [GameAction]
                 | Optional GameAction
-                | ChooseFrom [GameAction]
+                | ChooseOne [GameAction]
-                | Transaction [GameAction]
+                | Then GameAction GameAction
-                | Repeat Int GameAction
+                | OrElse GameAction GameAction
-                | IfThenElse GameAction GameAction GameAction
                 | ForEachBuilding GameAction
                 | ForEachControlledBuilding GameAction
                 | OneOpponent GameAction
                 | EachOpponent GameAction
                 | CurrentPlayer GameAction
                 deriving (Show)
+infixr `Then`
+infixr `OrElse`
 
 data PlotQualifier = ActionProvides [Resource]
                    | CompletesQuest [QuestType]
@@ -275,3 +278,10 @@ instance Eq Building where
 
 instance Eq IntrigueCard where
    a == b = a^.intrigueTitle == b^.intrigueTitle
+
+instance Monoid GameAction where
+   mempty = NoAction
+   NoAction `mappend` x = x
+   x `mappend` NoAction = x
+   (x `Then` y) `mappend` z = x `Then` (y `mappend` z)
+   x `mappend` y = x `Then` y

src/Waterdeep/Util.hs

@@ -0,0 +1,8 @@
+module Waterdeep.Util 
+   ( mrepeat
+   ) where
+
+import Data.Monoid
+
+mrepeat :: (Monoid m) => Int -> m -> m
+mrepeat n m = mconcat $ replicate n m