From 7bdd14fc838c58192ebb00b971bd97b1ed4e7328 Mon Sep 17 00:00:00 2001
From: Jesse McDonald <nybble41@gmail.com>
Date: Sat, 26 Jul 2014 17:08:39 -0500
Subject: [PATCH] add a WriterT for tracking the set of resources provided by
 an action

---
 src/Waterdeep/Types.hs | 35 +++++++++++++++++++++++++++++------
 1 file changed, 29 insertions(+), 6 deletions(-)

diff --git a/src/Waterdeep/Types.hs b/src/Waterdeep/Types.hs
index 887b31c..f9ef475 100644
--- a/src/Waterdeep/Types.hs
+++ b/src/Waterdeep/Types.hs
@@ -26,6 +26,7 @@ module Waterdeep.Types
    , Waterdeep
    , WaterdeepPrompt(..)
    , WaterdeepState(..)
+   , ResourceSet
    , lordName
    , lordQuote
    , lordBonus
@@ -95,6 +96,9 @@ module Waterdeep.Types
    , notifyState
    , broadcast
    , solicitChoice
+   , actionProvidedSet
+   , actionProvided
+   , delimitAction
    , runWaterdeepC
    , runWaterdeep
    , runWaterdeepM
@@ -108,9 +112,11 @@ import Control.Monad.Prompt
 import Control.Monad.Random
 import Control.Monad.State
 import Control.Monad.State.Class
+import Control.Monad.Writer.Class
 import Control.Monad.Trans
 import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
 import Control.Monad.Trans.State (StateT, runStateT)
+import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
 import Data.Maybe
 import Data.Monoid
 import Lens.Family2
@@ -122,6 +128,7 @@ import System.Random (StdGen)
 
 import qualified Data.IntMap   as IM
 import qualified Data.MultiSet as MS
+import qualified Data.Set      as Set
 import qualified System.Random as R
 
 type PlayerID = Int
@@ -256,8 +263,12 @@ data WaterdeepPrompt a where
    Broadcast     :: String -> WaterdeepPrompt ()
    SolicitChoice :: PlayerID -> String -> [(String, a)] -> WaterdeepPrompt a
 
+type ResourceSet     = Set.Set Resource
+
 data Waterdeep a =
-   Waterdeep { unWaterdeep :: StateT WaterdeepState (MaybeT (Prompt WaterdeepPrompt)) a }
+   Waterdeep { unWaterdeep :: WriterT ResourceSet
+                                 (StateT WaterdeepState
+                                    (MaybeT (Prompt WaterdeepPrompt))) a }
 
 makeLenses ''Lord
 makeLenses ''Faction
@@ -300,7 +311,7 @@ instance MonadPlus Waterdeep where
    (Waterdeep m) `mplus` (Waterdeep n) = Waterdeep (m `mplus` n)
 
 instance MonadState WaterdeepState Waterdeep where
-   state = Waterdeep . state
+   state = Waterdeep . lift . state
 
 instance MonadRandom Waterdeep where
    getRandom     = gameStdGen %%= random
@@ -371,7 +382,7 @@ newBuildingState p b =
       }
 
 waterdeepPrompt :: WaterdeepPrompt a -> Waterdeep a
-waterdeepPrompt = Waterdeep . lift . lift . prompt
+waterdeepPrompt = Waterdeep . lift . lift . lift . prompt
 
 notifyState :: Waterdeep ()
 notifyState = get >>= waterdeepPrompt . NotifyState
@@ -387,14 +398,26 @@ solicitChoice t cs  = do
    p <- use gameActivePlayer
    waterdeepPrompt (SolicitChoice p t cs)
 
+actionProvidedSet :: ResourceSet -> Waterdeep ()
+actionProvidedSet s = Waterdeep $ tell s
+
+actionProvided :: Resource -> Waterdeep ()
+actionProvided r = actionProvidedSet $ Set.singleton r
+
+delimitAction :: Waterdeep a -> Waterdeep (a, ResourceSet)
+delimitAction (Waterdeep m) = Waterdeep . lift $ runWriterT m
+
+evalWriterT :: Monad m => WriterT w m a -> m a
+evalWriterT m = return . fst =<< runWriterT m
+
 runWaterdeepC :: (Maybe (r, WaterdeepState) -> b) -> (forall a. WaterdeepPrompt a -> (a -> b) -> b) -> Waterdeep r -> WaterdeepState -> b
-runWaterdeepC r p (Waterdeep m) s = runPromptC r p $ runMaybeT $ runStateT m s
+runWaterdeepC r p (Waterdeep m) s = runPromptC r p $ runMaybeT $ runStateT (evalWriterT m) s
 
 runWaterdeep :: (forall a. WaterdeepPrompt a -> a) -> Waterdeep r -> WaterdeepState -> Maybe (r, WaterdeepState)
-runWaterdeep p (Waterdeep m) s = runPrompt p $ runMaybeT $ runStateT m s
+runWaterdeep p (Waterdeep m) s = runPrompt p $ runMaybeT $ runStateT (evalWriterT m) s
 
 runWaterdeepM :: (Monad m) => (forall a. WaterdeepPrompt a -> m a) -> Waterdeep r -> WaterdeepState -> m (Maybe (r, WaterdeepState))
-runWaterdeepM p (Waterdeep m) s = runPromptM p $ runMaybeT $ runStateT m s
+runWaterdeepM p (Waterdeep m) s = runPromptM p $ runMaybeT $ runStateT (evalWriterT m) s
 
 data ContWD a where
    Done :: Maybe (a, WaterdeepState) -> ContWD a