add lighthouse, haven, ambassador

Tested-on: figaro i686 GNU/Linux

Dominion/Attack.hs

@@ -14,27 +14,37 @@ isReaction c = not $ null [() | Reaction _ <- cardType c]
 getReaction :: Card -> Reaction -- unsafe!
 getReaction c = head [r | Reaction r <- cardType c]
 
+isDurationReaction :: Card -> Bool
+isDurationReaction c = not $ null [() | DReaction _ <- cardType c]
+
+getDurationReaction :: Card -> Reaction -- unsafe!
+getDurationReaction c = head [r | DReaction r <- cardType c]
+
 -- put some stuff here to say whether order matters, once we start
 -- parallelizing the attacks.
 
 attack :: String -> Game (Attack -> Game ())
 attack name = do self <- getSelf
                  n <- gets $ length . gamePlayers
                  let opps = filter (/=self) $ map PId [0..n-1]
-                 let react :: PId -> Game (Attack -> Attack)
-                     react p = do h <- getStack $ hand p
-                                  let rs = filter isReaction h
-                                  catchError `flip` (\_ -> return id) $ do
-                                    [r] <- askCards p rs (SelectReaction name)
-                                           (0,1)
-                                    name <- withPlayer p $ gets playerName
-                                    tellAll $ CardReveal name
-                                                [describeCard r] "hand"
-                                    getReaction r p (react p)
-                 rs <- mapM react opps
+                 rs <- mapM (react name []) opps
                  let att a = mapM_ (\(p,r) -> r a self p) $ zip opps rs
                  return att
 
+react :: String -> [Card] -> PId -> Game (Attack -> Attack)
+react a cs p = do ds <- filter isDurationReaction `fmap` getStack (durations p)
+                  case filter (not . (`elem`cs)) ds of
+                     d:ds' -> getDurationReaction d p (react a (d:cs) p)
+                     [] -> do
+                       h <- filter isReaction `fmap` getStack (hand p)
+                       let rs = filter (not . (`elem`cs)) ds
+                       catchError `flip` (\_ -> return id) $ do
+                         [r] <- askCards p rs (SelectReaction a)
+                                (0,1)
+                         name <- withPlayer p $ gets playerName
+                         tellAll $ CardReveal name [describeCard r] "hand"
+                         getReaction r p (react a (r:cs) p)
+
 attackNow :: String -> Attack -> Game ()
 attackNow s a = do att <- attack s
                    att a

Dominion/Cards.hs

@@ -132,7 +132,7 @@ intrigueSets =
     ]
 
 seaside :: [Card]  -- outpost, treasury, smugglers, .....
-seaside = [bazaar, caravan, embargo, fishingVillage, lookout, merchantShip,
+seaside = [ambassador, bazaar, caravan, embargo, fishingVillage, haven, lighthouse, lookout, merchantShip,
            nativeVillage, pearlDiver, salvager, tactician, warehouse, wharf]
 
 seasideSets :: [(String,[Card])]
@@ -625,6 +625,21 @@ wishingWell = Card 0 3 "Wishing Well" "..." [action $ try a]
 
 -- Seaside cards
 
+ambassador :: Card
+ambassador = Card 0 3 "Ambassador" "..." [action $ try a]
+    where a = do att <- attack "ambassador"
+                 (self,h,_) <- getSHP
+                 [c] <- askCards self h (GiveAway "ambassador") (1,1)
+                 let n = length $ filter (sameName c) h
+                     opts2 = if n>1 then [("2",return 2)] else []
+                     opts = ("0",return 0):("1",return 1):opts2
+                 name <- withPlayer self $ gets playerName
+                 num <- askMC self opts "Return how many?"
+                 tellAll $ InfoMessage $ name++" ungained "++show num
+                                         ++" copies of "++cardName c
+                 supply << take num (filter (sameName c) h)
+                 att $ \_ opp -> gain opp discard *<< [c]
+
 bazaar :: Card
 bazaar = Card 0 5 "Bazaar" "..." [action $ plusABCD 2 0 1 1]
 
@@ -646,6 +661,18 @@ fishingVillage :: Card
 fishingVillage = Card 0 3 "Fishing Village" "..." [duration a]
     where a = plusABCD 2 0 1 0 >> nextTurn (plusABCD 1 0 1 0)
 
+haven :: Card
+haven = Card 0 2 "Haven" "..." [duration $ try $ getSelf >>= a]
+    where a self = do plusABCD 1 0 0 1
+                      [c] <- askCardsHand (OtherQuestion "haven") (1,1)
+                      durations self << [c]
+                      nextTurn $ hand self << [c]
+
+lighthouse :: Card
+lighthouse = Card 0 2 "Lighthouse" "..." [duration a,DReaction r]
+    where a = plusABCD 1 0 1 0 >> nextTurn (plusCoin 1) 
+          r _ _ = return $ \_ _ _ -> return ()
+
 lookout :: Card
 lookout = Card 0 3 "Lookout" "..." [action $ try a]
     where a = do self <- getSelf

Dominion/Game.hs

@@ -125,7 +125,8 @@ turn = do self <- gets currentTurn
                                                          gets playerName
                                                  gainSilent self discard *<< cs
                                                  runBuyHooks self cs
-                                                 tellAll $ CardBuy name $
+                                                 when (not $ null cs) $
+                                                      tellAll $ CardBuy name $
                                                          map describeCard cs
                                          else attemptBuy self buys money
           duration self = do prevDuration <<< durations self

Dominion/Stack.hs

@@ -5,7 +5,7 @@ module Dominion.Stack ( OStack, UStack, IStack, printStack,
                         (*<<), (.<<), (<<), (*<#), (.<#), (<#),
                         (<*), (<.), (*<<<), (.<<<), (<<<), (#<), (#<#),
                         stackName, getStack, top, bottom,
-                        shuffle, shuffleIO,
+                        shuffle, shuffleIO, supply,
                         draw, hand, deck, discard, mat, trash,
                         durations, played, prevDuration, aside,
                         allSupply, supplyCards, inSupply, allCards,
@@ -285,7 +285,10 @@ trash = modifyInput (thread f) $ unorderedStack $ SN "trash"
                                               ss' = map (describeCard.snd) ss
                                           tellAll $ CardTrash p ss'
 
-allSupply :: Game [Card]
+supply :: UStack -- messages?
+supply = unorderedStack $ SN "supply"
+
+allSupply :: Game [Card] -- rewrite in terms of supply?
 allSupply = (concatMap iss . elems) `fmap` gets gameCards
     where iss (SN "supply",_,c) = [c]
           iss _ = []

Dominion/Types.hs

@@ -145,6 +145,7 @@ data CardType
     | Victory
     | Treasure Int
     | Reaction Reaction
+    | DReaction Reaction
     | Score (Int -> Game Int)
     | Hook HookType