Building a Rubber Bridge Game Engine and AI in Haskell
Contract bridge is a trick-taking card game played by four players in two competing partnerships. It is a game of high strategic depth, divided into two distinct phases: the bidding auction (where players bid for the minimum number of tricks they expect to win) and the card play (where the declaring side attempts to win those tricks while the defenders attempt to defeat them).
In this chapter, we build a complete Rubber Bridge game engine and AI in Haskell (ported from Common Lisp’s Bridge_game).
An important focus of this chapter is decoupled software architecture. When building games or applications, it is a best practice to separate core domain data, rules, and AI algorithms from any specific user interface (UI) rendering. By encapsulating all Bridge rules and game state transformations into a pure Haskell library (Bridge_game), we keep the engine completely independent of I/O. In this chapter, we drive the engine with an interactive Command Line Interface (CLI) client, but this exact same library can be reused in the future to drive a native macOS WebKit GUI client (Bridge_webkit) without modifying a single line of game logic.
The code for this project is located in the directory haskell_book/source-code/Bridge_game.
Decoupled Architecture Design
Our Bridge project is structured as a Haskell Cabal package consisting of two parts: a reusable library containing all game logic and an executable CLI wrapper that manages user prompts and table displays.
1 ┌─────────────────────────────┐
2 │ CLI (app/Main.hs) │
3 │ CLI loop, input prompts │
4 └──────────────┬──────────────┘
5 | (Actions)
6 v
7 ┌─────────────────────────────┐
8 │ src/Bridge/Engine.hs │
9 │ State Machine & deal loop │
10 └──────────────┬──────────────┘
11 |
12 +------------------------+------------------------+
13 | | |
14 v v v
15 src/Bridge/Bidding.hs src/Bridge/Play.hs src/Bridge/Scoring.hs
16 AI Bidding Rules & AI Card Play & Legal Rubber scorecard &
17 Contract Extraction Plays Heuristics Bonus/Penalty maths
By storing the hands, bid history, trick plays, and scoring rules in pure algebraic data types (ADTs), the library functions represent pure state transformers. They take a GameState and an action (like a BidType or a Card play) and return an updated GameState, making the core engine simple to test and isolate.
Domain Data Types: Bridge.Types
We start by defining the type-safe domain representation for Bridge cards, players, suits, and bids in src/Bridge/Types.hs.
1 module Bridge.Types where
2
3 data Suit = Clubs | Diamonds | Hearts | Spades
4 deriving (Eq, Ord, Enum, Bounded, Show)
5
6 data Rank = R2 | R3 | R4 | R5 | R6 | R7 | R8 | R9 | R10 | Jack | Queen | King | Ace
7 deriving (Eq, Ord, Enum, Bounded, Show)
8
9 data Card = Card { cardSuit :: Suit, cardRank :: Rank }
10 deriving (Eq)
11
12 instance Ord Card where
13 compare (Card s1 r1) (Card s2 r2) =
14 case compare s1 s2 of
15 EQ -> compare r1 r2
16 other -> other
17
18 instance Show Card where
19 show (Card suit rank) = rankSymbol rank ++ suitSymbol suit
20 where
21 rankSymbol Ace = "A"
22 rankSymbol King = "K"
23 rankSymbol Queen = "Q"
24 rankSymbol Jack = "J"
25 rankSymbol R10 = "10"
26 rankSymbol r = show (fromEnum r + 2)
27
28 suitSymbol Clubs = "C"
29 suitSymbol Diamonds = "D"
30 suitSymbol Hearts = "H"
31 suitSymbol Spades = "S"
32
33 data Player = North | East | South | West
34 deriving (Eq, Ord, Enum, Bounded)
35
36 instance Show Player where
37 show North = "North"
38 show East = "East"
39 show South = "South"
40 show West = "West"
41
42 partner :: Player -> Player
43 partner North = South
44 partner South = North
45 partner East = West
46 partner West = East
47
48 nextPlayer :: Player -> Player
49 nextPlayer North = East
50 nextPlayer East = South
51 nextPlayer South = West
52 nextPlayer West = North
53
54 side :: Player -> Int
55 side North = 0
56 side South = 0
57 side East = 1
58 side West = 1
59
60 data Strain = SuitStrain Suit | NoTrump
61 deriving (Eq)
62
63 instance Ord Strain where
64 compare (SuitStrain s1) (SuitStrain s2) = compare s1 s2
65 compare (SuitStrain _) NoTrump = LT
66 compare NoTrump (SuitStrain _) = GT
67 compare NoTrump NoTrump = EQ
68
69 instance Show Strain where
70 show (SuitStrain Clubs) = "C"
71 show (SuitStrain Diamonds) = "D"
72 show (SuitStrain Hearts) = "H"
73 show (SuitStrain Spades) = "S"
74 show NoTrump = "NT"
75
76 data BidType = SuitBid Int Strain | Pass | DoubleBid | RedoubleBid
77 deriving (Eq)
78
79 instance Show BidType where
80 show (SuitBid level strain) = show level ++ show strain
81 show Pass = "Pass"
82 show DoubleBid = "Dbl"
83 show RedoubleBid = "Rdbl"
84
85 data Phase = Dealing | Bidding | Playing | Scoring | Done
86 deriving (Eq, Show)
Cards, Deck Shuffling, and Hand Analysis: Bridge.Cards
The Bridge.Cards module implements deck generation, shuffles the deck using a standard random number generator, deals the cards, and analyzes hands for High Card Points (HCP) and distribution.
1 module Bridge.Cards where
2
3 import Bridge.Types
4 import System.Random (RandomGen, randomR)
5 import Data.List (sortBy, sort)
6
7 makeDeck :: [Card]
8 makeDeck = [Card s r | s <- [Clubs .. Spades], r <- [R2 .. Ace]]
9
10 -- Fisher-Yates pure shuffling using random number generator
11 shuffleDeck :: RandomGen g => [Card] -> g -> ([Card], g)
12 shuffleDeck [] g = ([], g)
13 shuffleDeck xs g =
14 let (n, g') = randomR (0, length xs - 1) g
15 (left, x:right) = splitAt n xs
16 (shuffled, g'') = shuffleDeck (left ++ right) g'
17 in (x : shuffled, g'')
18
19 dealHands :: [Card] -> ([Card], [Card], [Card], [Card])
20 dealHands deck =
21 let
22 distribute [] (h1, h2, h3, h4) = (h1, h2, h3, h4)
23 distribute (c1:c2:c3:c4:rest) (h1, h2, h3, h4) = distribute rest (c1:h1, c2:h2, c3:h3, c4:h4)
24 distribute (c1:c2:c3:[]) (h1, h2, h3, h4) = (c1:h1, c2:h2, c3:h3, h4)
25 distribute (c1:c2:[]) (h1, h2, h3, h4) = (c1:h1, c2:h2, h3, h4)
26 distribute (c1:[]) (h1, h2, h3, h4) = (c1:h1, h2, h3, h4)
27 (n, e, s, w) = distribute deck ([], [], [], [])
28 in (sortHand n, sortHand e, sortHand s, sortHand w)
29
30 -- Sort hands with Spades (highest) down to Clubs, then Ace down to R2
31 sortHand :: [Card] -> [Card]
32 sortHand = sortBy compareBridge
33 where
34 compareBridge (Card s1 r1) (Card s2 r2) =
35 case compare s2 s1 of
36 EQ -> compare r2 r1
37 other -> other
38
39 -- Hand analysis: HCP (Milton Work count)
40 cardHcp :: Card -> Int
41 cardHcp (Card _ Ace) = 4
42 cardHcp (Card _ King) = 3
43 cardHcp (Card _ Queen) = 2
44 cardHcp (Card _ Jack) = 1
45 cardHcp _ = 0
46
47 handHcp :: [Card] -> Int
48 handHcp = sum . map cardHcp
49
50 suitLength :: Suit -> [Card] -> Int
51 suitLength suit hand = length [c | c <- hand, cardSuit c == suit]
52
53 handSuitCards :: [Card] -> Suit -> [Card]
54 handSuitCards hand suit = [c | c <- hand, cardSuit c == suit]
55
56 handShape :: [Card] -> [Int]
57 handShape hand = [suitLength Spades hand, suitLength Hearts hand, suitLength Diamonds hand, suitLength Clubs hand]
58
59 handShapeSorted :: [Card] -> [Int]
60 handShapeSorted hand = reverse $ sort $ handShape hand
61
62 handLengthPoints :: [Card] -> Int
63 handLengthPoints hand =
64 sum [len - 4 | s <- [Clubs .. Spades], let len = suitLength s hand, len > 4]
65
66 handShortnessPoints :: [Card] -> Int
67 handShortnessPoints hand =
68 sum [points len | s <- [Clubs .. Spades], let len = suitLength s hand]
69 where
70 points 0 = 3
71 points 1 = 2
72 points 2 = 1
73 points _ = 0
74
75 handTotalPoints :: [Card] -> Bool -> Int
76 handTotalPoints hand trumpFitFound =
77 handHcp hand + if trumpFitFound then handShortnessPoints hand else handLengthPoints hand
78
79 isBalanced :: [Card] -> Bool
80 isBalanced hand =
81 let shape = handShapeSorted hand
82 in shape == [4, 3, 3, 3] || shape == [4, 4, 3, 2] || shape == [5, 3, 3, 2]
83
84 isSemiBalanced :: [Card] -> Bool
85 isSemiBalanced hand =
86 isBalanced hand ||
87 let shape = handShapeSorted hand
88 in shape == [5, 4, 2, 2] || shape == [6, 3, 2, 2]
89
90 handHasMajor :: [Card] -> Int -> Bool
91 handHasMajor hand minLen =
92 suitLength Hearts hand >= minLen || suitLength Spades hand >= minLen
93
94 handLongestSuit :: [Card] -> Suit
95 handLongestSuit hand =
96 let
97 lengths = [(suitLength s hand, s) | s <- [Clubs .. Spades]]
98 compareSuit (len1, s1) (len2, s2) =
99 case compare len2 len1 of
100 EQ -> compare s2 s1
101 other -> other
102 in snd $ head $ sortBy compareSuit lengths
103
104 handSuitHcp :: [Card] -> Suit -> Int
105 handSuitHcp hand suit = sum [cardHcp c | c <- hand, cardSuit c == suit]
106
107 handHasStopper :: [Card] -> Suit -> Bool
108 handHasStopper hand suit =
109 let
110 cards = handSuitCards hand suit
111 len = length cards
112 ranks = map cardRank cards
113 in
114 len > 0 &&
115 (Ace `elem` ranks ||
116 (len >= 2 && King `elem` ranks) ||
117 (len >= 3 && Queen `elem` ranks) ||
118 (len >= 4 && Jack `elem` ranks))
119
120 handSuitHonorCount :: [Card] -> Suit -> Int
121 handSuitHonorCount hand suit =
122 length [c | c <- hand, cardSuit c == suit, cardRank c >= R10]
AI Bidding Conventions & Rule Decisions: Bridge.Bidding
Bridge bidding conventions communicate hand features between partners. The bidding module implements:
-
Simplified Standard American rules:
- Opening at 1-level in majors (5+ cards) or minors.
- 1NT (balanced 15-17 HCP) or 2NT (balanced 20-21 HCP).
- Strong artificial 2♣ (22+ HCP) forcing opening.
- Weak twos and preemptive 3-level openings.
- Responder bids: Raises, Stayman inquiries (asking for 4-card majors), and slam explorations (Gerber and Blackwood).
- Contract extraction: Traverses the chronological bidding history to find the final contract bid, declarer (the first player on the winning side who bid the contract strain), and doubling status.
1 module Bridge.Bidding where
2
3 import Bridge.Types
4 import Bridge.Cards
5 import Data.List (find)
6
7 lastSuitBid :: [(Player, BidType)] -> Maybe BidType
8 lastSuitBid history = fmap snd $ find (\(_, b) -> isSuitBid b) history
9
10 isSuitBid :: BidType -> Bool
11 isSuitBid (SuitBid _ _) = True
12 isSuitBid _ = False
13
14 bidIndex :: BidType -> Maybe Int
15 bidIndex (SuitBid level strain) =
16 let strainIdx = case strain of
17 SuitStrain Clubs -> 0
18 SuitStrain Diamonds -> 1
19 SuitStrain Hearts -> 2
20 SuitStrain Spades -> 3
21 NoTrump -> 4
22 in Just ((level - 1) * 5 + strainIdx)
23 bidIndex _ = Nothing
24
25 bidHigherThan :: BidType -> BidType -> Bool
26 bidHigherThan b1 b2 =
27 case (bidIndex b1, bidIndex b2) of
28 (Just idx1, Just idx2) -> idx1 > idx2
29 _ -> False
30
31 biddingComplete :: [(Player, BidType)] -> Bool
32 biddingComplete history =
33 let
34 bids = map snd history
35 hasSuitBid = any isSuitBid bids
36 in case bids of
37 _ | length bids == 4 && all (== Pass) bids -> True
38 (Pass:Pass:Pass:_) | hasSuitBid -> True
39 _ -> False
40
41 passedOut :: [(Player, BidType)] -> Bool
42 passedOut history = length history == 4 && all (\(_, b) -> b == Pass) history
43
44 extractContract :: [(Player, BidType)] -> Player -> Maybe (BidType, Player, Int)
45 extractContract history _dealer =
46 let
47 findLastSuit [] = Nothing
48 findLastSuit ((p, SuitBid l s):_) = Just (SuitBid l s, p)
49 findLastSuit (_:xs) = findLastSuit xs
50 in case findLastSuit history of
51 Just (contract@(SuitBid _ strain), finalBidder) ->
52 let
53 declSide = side finalBidder
54 chronoHistory = reverse history
55
56 firstBidderOfStrain [] = finalBidder
57 firstBidderOfStrain ((p, SuitBid _ s):xs)
58 | s == strain && side p == declSide = p
59 | otherwise = firstBidderOfStrain xs
60 firstBidderOfStrain (_:xs) = firstBidderOfStrain xs
61
62 declarer = firstBidderOfStrain chronoHistory
63
64 checkDouble [] d = d
65 checkDouble ((_, SuitBid _ _):_) d = d
66 checkDouble ((_, DoubleBid):xs) 0 = checkDouble xs 1
67 checkDouble ((_, RedoubleBid):xs) 1 = checkDouble xs 2
68 checkDouble (_:xs) d = checkDouble xs d
69
70 doubled = checkDouble history 0
71 in Just (contract, declarer, doubled)
72 _ -> Nothing
73
74 findPartnerOpening :: [(Player, BidType)] -> Player -> Maybe BidType
75 findPartnerOpening history me =
76 let
77 p = partner me
78 chrono = reverse history
79 partnerBids = [bid | (bidder, bid) <- chrono, bidder == p, isSuitBid bid]
80 in case partnerBids of
81 (firstBid:_) -> Just firstBid
82 [] -> Nothing
83
84 findMyOpening :: [(Player, BidType)] -> Player -> Maybe BidType
85 findMyOpening history me =
86 let
87 chrono = reverse history
88 myBids = [bid | (bidder, bid) <- chrono, bidder == me, isSuitBid bid]
89 in case myBids of
90 (firstBid:_) -> Just firstBid
91 [] -> Nothing
92
93 staymanResponseP :: BidType -> BidType -> Bool
94 staymanResponseP (SuitBid 2 (SuitStrain Clubs)) (SuitBid 1 NoTrump) = True
95 staymanResponseP (SuitBid 3 (SuitStrain Clubs)) (SuitBid 2 NoTrump) = True
96 staymanResponseP _ _ = False
97
98 blackwoodResponseP :: BidType -> Bool
99 blackwoodResponseP (SuitBid 4 NoTrump) = True
100 blackwoodResponseP _ = False
101
102 blackwoodKingAskP :: BidType -> Bool
103 blackwoodKingAskP (SuitBid 5 NoTrump) = True
104 blackwoodKingAskP _ = False
105
106 gerberResponseP :: BidType -> BidType -> Bool
107 gerberResponseP (SuitBid 4 (SuitStrain Clubs)) (SuitBid _ NoTrump) = True
108 gerberResponseP _ _ = False
109
110 gerberKingAskP :: BidType -> Bool
111 gerberKingAskP (SuitBid 5 (SuitStrain Clubs)) = True
112 gerberKingAskP _ = False
113
114 aiOpeningBid :: [Card] -> Maybe BidType
115 aiOpeningBid hand
116 | hcp >= 22 = Just (SuitBid 2 (SuitStrain Clubs))
117 | balanced && hcp >= 20 && hcp <= 21 = Just (SuitBid 2 NoTrump)
118 | balanced && hcp >= 15 && hcp <= 17 = Just (SuitBid 1 NoTrump)
119 | hcp >= 13 && hcp <= 21 = Just (SuitBid 1 openingSuit)
120 | hcp < 13, (s:_) <- sevenCardSuits = Just (SuitBid 3 s)
121 | hcp < 13 && hcp >= 5, (s:_) <- weakTwoSuits = Just (SuitBid 2 s)
122 | otherwise = Nothing
123 where
124 hcp = handHcp hand
125 balanced = isBalanced hand
126
127 openingSuit
128 | suitLength Spades hand >= 5 && suitLength Hearts hand >= 5 = SuitStrain Spades
129 | suitLength Spades hand >= 5 = SuitStrain Spades
130 | suitLength Hearts hand >= 5 = SuitStrain Hearts
131 | suitLength Diamonds hand > suitLength Clubs hand = SuitStrain Diamonds
132 | otherwise = SuitStrain Clubs
133
134 sevenCardSuits =
135 [SuitStrain s | s <- [Clubs .. Spades], suitLength s hand >= 7, handSuitHonorCount hand s >= 2]
136
137 weakTwoSuits =
138 [SuitStrain s | s <- [Diamonds, Hearts, Spades], suitLength s hand >= 6]
139
140 aiRespondingBid :: [Card] -> BidType -> Maybe BidType
141 aiRespondingBid hand partnerBid =
142 case partnerBid of
143 SuitBid pLevel NoTrump ->
144 let hcp = handHcp hand
145 in if pLevel == 1
146 then
147 if hcp <= 7
148 then
149 if suitLength Spades hand >= 5 then Just (SuitBid 2 (SuitStrain Spades))
150 else if suitLength Hearts hand >= 5 then Just (SuitBid 2 (SuitStrain Hearts))
151 else if suitLength Diamonds hand >= 5 then Just (SuitBid 2 (SuitStrain Diamonds))
152 else Nothing
153 else if hcp >= 8 && (suitLength Hearts hand >= 4 || suitLength Spades hand >= 4)
154 then Just (SuitBid 2 (SuitStrain Clubs))
155 else if hcp <= 9 then Just (SuitBid 2 NoTrump)
156 else if hcp <= 15 && suitLength Spades hand >= 6 then Just (SuitBid 4 (SuitStrain Spades))
157 else if hcp <= 15 && suitLength Hearts hand >= 6 then Just (SuitBid 4 (SuitStrain Hearts))
158 else if hcp <= 15 && suitLength Spades hand >= 5 then Just (SuitBid 3 (SuitStrain Spades))
159 else if hcp <= 15 && suitLength Hearts hand >= 5 then Just (SuitBid 3 (SuitStrain Hearts))
160 else if hcp <= 15 then Just (SuitBid 3 NoTrump)
161 else Just (SuitBid 4 NoTrump)
162 else
163 if hcp <= 4 && all (\s -> suitLength s hand < 5) [Clubs .. Spades]
164 then Nothing
165 else if hcp >= 4 && (suitLength Hearts hand >= 4 || suitLength Spades hand >= 4)
166 then Just (SuitBid 3 (SuitStrain Clubs))
167 else if hcp >= 5 then Just (SuitBid 3 NoTrump)
168 else Nothing
169
170 SuitBid pLevel (SuitStrain pSuit) ->
171 let hcp = handHcp hand
172 in if pLevel == 1
173 then
174 if pSuit >= Hearts
175 then
176 if hcp <= 5 then Nothing
177 else if hcp <= 10
178 then
179 if suitLength pSuit hand >= 3
180 then Just (SuitBid 2 (SuitStrain pSuit))
181 else if pSuit == Hearts && suitLength Spades hand >= 4
182 then Just (SuitBid 1 (SuitStrain Spades))
183 else Just (SuitBid 1 NoTrump)
184 else if hcp <= 12
185 then
186 if suitLength pSuit hand >= 3
187 then Just (SuitBid 3 (SuitStrain pSuit))
188 else
189 let longest = handLongestSuit hand
190 in if longest > pSuit
191 then Just (SuitBid 2 (SuitStrain longest))
192 else Just (SuitBid 2 NoTrump)
193 else
194 if suitLength pSuit hand >= 3
195 then Just (SuitBid 4 (SuitStrain pSuit))
196 else Just (SuitBid 3 NoTrump)
197 else
198 if hcp < 6 then Nothing
199 else if suitLength Hearts hand >= 4 || suitLength Spades hand >= 4
200 then
201 let
202 hLen = suitLength Hearts hand
203 sLen = suitLength Spades hand
204 in Just $ if hLen >= 5 && sLen >= 5 then SuitBid 1 (SuitStrain Spades)
205 else if hLen >= 4 && sLen >= 4 then SuitBid 1 (SuitStrain Hearts)
206 else if hLen >= 4 then SuitBid 1 (SuitStrain Hearts)
207 else SuitBid 1 (SuitStrain Spades)
208 else if hcp <= 10 then Just (SuitBid 1 NoTrump)
209 else if hcp <= 12
210 then
211 if suitLength pSuit hand >= 4
212 then Just (SuitBid 3 (SuitStrain pSuit))
213 else Just (SuitBid 2 NoTrump)
214 else if hcp <= 15
215 then
216 if suitLength pSuit hand >= 4
217 then Just (SuitBid 5 (SuitStrain pSuit))
218 else Just (SuitBid 3 NoTrump)
219 else Just (SuitBid 4 NoTrump)
220 else if pSuit == Clubs
221 then
222 if hcp < 8 then Just (SuitBid 2 (SuitStrain Diamonds))
223 else if not (isBalanced hand) && suitLength Spades hand >= 5 then Just (SuitBid 2 (SuitStrain Spades))
224 else if not (isBalanced hand) && suitLength Hearts hand >= 5 then Just (SuitBid 2 (SuitStrain Hearts))
225 else if not (isBalanced hand) && suitLength Diamonds hand >= 5 then Just (SuitBid 3 (SuitStrain Diamonds))
226 else if not (isBalanced hand) && suitLength Clubs hand >= 5 then Just (SuitBid 3 (SuitStrain Clubs))
227 else Just (SuitBid 2 NoTrump)
228 else
229 if pLevel == 2
230 then
231 if suitLength pSuit hand >= 3 && hcp >= 14 then Just (SuitBid 4 (SuitStrain pSuit))
232 else if suitLength pSuit hand >= 3 && hcp >= 10 then Just (SuitBid 3 (SuitStrain pSuit))
233 else Nothing
234 else
235 if suitLength pSuit hand >= 3 && hcp >= 14
236 then Just (SuitBid (if pSuit >= Hearts then 4 else 5) (SuitStrain pSuit))
237 else Nothing
238 _ -> Nothing
239
240 aiOpenerRebid :: [Card] -> BidType -> BidType -> Maybe BidType
241 aiOpenerRebid hand myOpening partnerResponse =
242 case (myOpening, partnerResponse) of
243 (SuitBid _ myStrain, SuitBid pLevel pStrain) ->
244 cond myStrain pStrain pLevel
245 _ -> Nothing
246 where
247 hcp = handHcp hand
248 cond myStrain pStrain pLevel
249 | staymanResponseP partnerResponse myOpening =
250 let responseLevel = if bidLevel myOpening == 1 then 2 else 3
251 in Just $ if suitLength Hearts hand >= 4 && suitLength Spades hand >= 4 then SuitBid responseLevel (SuitStrain Hearts)
252 else if suitLength Hearts hand >= 4 then SuitBid responseLevel (SuitStrain Hearts)
253 else if suitLength Spades hand >= 4 then SuitBid responseLevel (SuitStrain Spades)
254 else SuitBid responseLevel (SuitStrain Diamonds)
255
256 | blackwoodResponseP partnerResponse =
257 let aces = length [c | c <- hand, cardRank c == Ace]
258 in Just (SuitBid 5 (intToStrain (aces `mod` 5)))
259
260 | blackwoodKingAskP partnerResponse =
261 let kings = length [c | c <- hand, cardRank c == King]
262 in Just (SuitBid 6 (intToStrain (kings `mod` 5)))
263
264 | gerberResponseP partnerResponse myOpening =
265 let aces = length [c | c <- hand, cardRank c == Ace]
266 in Just $ case aces of
267 0 -> SuitBid 4 (SuitStrain Diamonds)
268 1 -> SuitBid 4 (SuitStrain Hearts)
269 2 -> SuitBid 4 (SuitStrain Spades)
270 3 -> SuitBid 4 NoTrump
271 _ -> SuitBid 5 (SuitStrain Clubs)
272
273 | gerberKingAskP partnerResponse =
274 let kings = length [c | c <- hand, cardRank c == King]
275 in Just $ case kings of
276 0 -> SuitBid 5 (SuitStrain Diamonds)
277 1 -> SuitBid 5 (SuitStrain Hearts)
278 2 -> SuitBid 5 (SuitStrain Spades)
279 3 -> SuitBid 5 NoTrump
280 _ -> SuitBid 6 (SuitStrain Clubs)
281
282 | pStrain == NoTrump =
283 case myStrain of
284 SuitStrain s | suitLength s hand >= 6 -> Just (SuitBid (pLevel + 1) myStrain)
285 _ | hcp <= 15 -> Nothing
286 _ | hcp <= 17 -> Just (SuitBid (pLevel + 1) NoTrump)
287 _ -> Just (SuitBid (pLevel + 2) NoTrump)
288
289 | SuitStrain s <- myStrain, SuitStrain ps <- pStrain, s == ps =
290 if hcp <= 15 then Nothing
291 else if hcp >= 19 && s >= Hearts then Just (SuitBid 4 NoTrump)
292 else if s >= Hearts && hcp <= 18 then Just (SuitBid 4 myStrain)
293 else Just (SuitBid (if s >= Hearts then 4 else 5) myStrain)
294
295 | SuitStrain ps <- pStrain =
296 if suitLength ps hand >= 4
297 then Just (SuitBid (pLevel + 1) pStrain)
298 else case myStrain of
299 SuitStrain s | suitLength s hand >= 6 -> Just (SuitBid 2 myStrain)
300 _ | hcp <= 15 && isBalanced hand -> Just (SuitBid (if pLevel >= 2 then pLevel else 1) NoTrump)
301 SuitStrain s | suitLength s hand >= 5 -> Just (SuitBid 2 myStrain)
302 _ -> Just (SuitBid 1 NoTrump)
303
304 | otherwise = Nothing
305
306 bidLevel (SuitBid l _) = l
307 bidLevel _ = 1
308
309 intToStrain 0 = SuitStrain Clubs
310 intToStrain 1 = SuitStrain Diamonds
311 intToStrain 2 = SuitStrain Hearts
312 intToStrain 3 = SuitStrain Spades
313 intToStrain _ = NoTrump
314
315 ensureLegalBid :: Maybe BidType -> Maybe BidType -> Maybe BidType
316 ensureLegalBid Nothing _ = Nothing
317 ensureLegalBid (Just bid) Nothing = Just bid
318 ensureLegalBid (Just bid) (Just currentHighest)
319 | not (isSuitBid bid) = Just bid
320 | bidHigherThan bid currentHighest = Just bid
321 | otherwise = Nothing
322
323 aiSelectBid :: [Card] -> [(Player, BidType)] -> Player -> Player -> BidType
324 aiSelectBid hand history me _dealer =
325 let
326 currentHighest = lastSuitBid history
327 partnerBid = findPartnerOpening history me
328 myBid = findMyOpening history me
329
330 rawBid = case (myBid, partnerBid) of
331 (Just mb, Just pb) -> aiOpenerRebid hand mb pb
332 (Nothing, Just pb) -> aiRespondingBid hand pb
333 _ | Nothing <- currentHighest -> aiOpeningBid hand
334 _ ->
335 let hcp = handHcp hand
336 in if hcp >= 13 && handHasMajor hand 5
337 then if suitLength Spades hand >= 5
338 then Just (SuitBid 1 (SuitStrain Spades))
339 else Just (SuitBid 1 (SuitStrain Hearts))
340 else if hcp >= 15 && hcp <= 18 && isBalanced hand
341 then Just (SuitBid 1 NoTrump)
342 else Nothing
343
344 legalBid = ensureLegalBid rawBid currentHighest
345 in case legalBid of
346 Just b -> b
347 Nothing -> Pass
Trick Play & Legal Rules: Bridge.Play
Card play AI evaluates tricks using heuristics:
- Opening Leads: Leads from sequences (top of a sequence, e.g. King from King-Queen-Jack), 4th-best from the longest non-trump suit, or short side suits.
- Following Suit: Plays low if partner is already winning (saving high cards), plays cheapest winner if able to win the trick, and plays lowest card when losing.
- Trumping / Discarding: Ruffs (trumps) if partner is losing and has trumps, otherwise discards from weakest suits.
1 module Bridge.Play where
2
3 import Bridge.Types
4 import Bridge.Cards
5 import Data.List (sortBy, minimumBy, maximumBy, find)
6
7 legalPlays :: [Card] -> Maybe Suit -> [Card]
8 legalPlays hand Nothing = hand
9 legalPlays hand (Just leadSuit) =
10 let inSuit = handSuitCards hand leadSuit
11 in if null inSuit then hand else inSuit
12
13 playersInPlayOrder :: Player -> [Player]
14 playersInPlayOrder leader =
15 [ leader
16 , nextPlayer leader
17 , nextPlayer (nextPlayer leader)
18 , nextPlayer (nextPlayer (nextPlayer leader))
19 ]
20
21 cardScore :: Card -> Suit -> Maybe Suit -> Int
22 cardScore (Card suit rank) leadSuit trumpSuit =
23 case trumpSuit of
24 Just ts | suit == ts -> 100 + fromEnum rank
25 _ | suit == leadSuit -> 50 + fromEnum rank
26 _ -> fromEnum rank
27
28 trickWinner :: [Card] -> Player -> Maybe Suit -> Player
29 trickWinner [] leader _ = leader
30 trickWinner trick leader trumpSuit =
31 let
32 leadCard = head trick
33 leadSuit = cardSuit leadCard
34 plays = zip trick (playersInPlayOrder leader)
35
36 score c = cardScore c leadSuit trumpSuit
37 comparePlays (c1, _) (c2, _) = compare (score c1) (score c2)
38 (_, winner) = maximumBy comparePlays plays
39 in winner
40
41 lowestCard :: [Card] -> Card
42 lowestCard = minimumBy (\c1 c2 -> compare (cardRank c1) (cardRank c2))
43
44 highestCard :: [Card] -> Card
45 highestCard = maximumBy (\c1 c2 -> compare (cardRank c1) (cardRank c2))
46
47 isPartnerWinning :: [Card] -> Player -> Maybe Suit -> Player -> Bool
48 isPartnerWinning [] _ _ _ = False
49 isPartnerWinning trick leader trumpSuit me =
50 let winner = trickWinner trick leader trumpSuit
51 in side winner == side me
52
53 canWinTrick :: [Card] -> [Card] -> Player -> Maybe Suit -> Bool
54 canWinTrick [] _ _ _ = False
55 canWinTrick _ [] _ _ = True
56 canWinTrick inSuit trick leader trumpSuit =
57 let
58 leadSuit = cardSuit (head trick)
59 score c = cardScore c leadSuit trumpSuit
60 winningScore = maximum (map score trick)
61 in any (\c -> score c > winningScore) inSuit
62
63 cheapestWinner :: [Card] -> [Card] -> Player -> Maybe Suit -> Card
64 cheapestWinner inSuit trick leader trumpSuit =
65 let
66 leadSuit = cardSuit (head trick)
67 score c = cardScore c leadSuit trumpSuit
68 winningScore = maximum (map score trick)
69 winners = [c | c <- inSuit, score c > winningScore]
70 in if null winners
71 then lowestCard inSuit
72 else lowestCard winners
73
74 bestDiscard :: [Card] -> Maybe Suit -> Card
75 bestDiscard [] _ = error "Empty hand to discard from"
76 bestDiscard cards trumpSuit =
77 let
78 longest = handLongestNonTrump cards trumpSuit
79 inLongest = handSuitCards cards longest
80 in if null inLongest
81 then lowestCard cards
82 else lowestCard inLongest
83
84 handLongestNonTrump :: [Card] -> Maybe Suit -> Suit
85 handLongestNonTrump hand trumpSuit =
86 let
87 suits = case trumpSuit of
88 Just ts -> [s | s <- [Clubs .. Spades], s /= ts]
89 Nothing -> [Clubs .. Spades]
90 lengths = [(suitLength s hand, s) | s <- suits]
91 compareSuit (len1, s1) (len2, s2) =
92 case compare len2 len1 of
93 EQ -> compare s2 s1
94 other -> other
95 in if null lengths
96 then handLongestSuit hand
97 else snd $ head $ sortBy compareSuit lengths
98
99 aiSelectLead :: [Card] -> Maybe Suit -> Player -> Player -> Card
100 aiSelectLead hand trumpSuit me declarer =
101 let
102 meSide = side me
103 declSide = side declarer
104 defending = meSide /= declSide
105 in if defending
106 then
107 case leadTopOfSequence hand trumpSuit of
108 Just c -> c
109 Nothing ->
110 case leadFourthBest hand trumpSuit of
111 Just c -> c
112 Nothing ->
113 case leadShortSuit hand trumpSuit of
114 Just c -> c
115 Nothing -> lowestCard (handSuitCards hand (handLongestNonTrump hand trumpSuit))
116 else
117 case trumpSuit of
118 Just ts | suitLength ts hand >= 3 && any (\c -> cardRank c >= Queen) (handSuitCards hand ts) ->
119 maximumBy (\c1 c2 -> compare (cardRank c1) (cardRank c2)) (handSuitCards hand ts)
120 _ ->
121 case leadTopOfSequence hand trumpSuit of
122 Just c -> c
123 Nothing ->
124 case leadFourthBest hand trumpSuit of
125 Just c -> c
126 Nothing -> head hand
127
128 leadTopOfSequence :: [Card] -> Maybe Suit -> Maybe Card
129 leadTopOfSequence hand trumpSuit =
130 let
131 suits = case trumpSuit of
132 Just ts -> [s | s <- [Clubs .. Spades], s /= ts]
133 Nothing -> [Clubs .. Spades]
134 checkSuit suit =
135 let cards = sortBy (\c1 c2 -> compare (cardRank c2) (cardRank c1)) (handSuitCards hand suit)
136 in case cards of
137 (c1:c2:c3:_) | cardRank c1 >= Jack
138 && fromEnum (cardRank c1) == fromEnum (cardRank c2) + 1
139 && fromEnum (cardRank c2) == fromEnum (cardRank c3) + 1 -> Just c1
140 _ -> Nothing
141 results = [c | s <- suits, Just c <- [checkSuit s]]
142 in case results of
143 (res:_) -> Just res
144 [] -> Nothing
145
146 leadFourthBest :: [Card] -> Maybe Suit -> Maybe Card
147 leadFourthBest hand trumpSuit =
148 let
149 longest = handLongestNonTrump hand trumpSuit
150 cards = sortBy (\c1 c2 -> compare (cardRank c2) (cardRank c1)) (handSuitCards hand longest)
151 in if length cards >= 4
152 then Just (cards !! 3)
153 else Nothing
154
155 leadShortSuit :: [Card] -> Maybe Suit -> Maybe Card
156 leadShortSuit hand Nothing = Nothing
157 leadShortSuit hand (Just ts) =
158 let
159 sideSuits = [s | s <- [Clubs .. Spades], s /= ts]
160 lengths = sortBy (\(l1, _) (l2, _) -> compare l1 l2)
161 [(suitLength s hand, s) | s <- sideSuits, suitLength s hand > 0]
162 in case lengths of
163 ((_, shortSuit):_) ->
164 let cards = sortBy (\c1 c2 -> compare (cardRank c2) (cardRank c1)) (handSuitCards hand shortSuit)
165 in Just (head cards)
166 _ -> Nothing
167
168 aiSelectFollow :: [Card] -> [Card] -> Player -> Maybe Suit -> Player -> Player -> Card
169 aiSelectFollow hand trick leader trumpSuit me declarer =
170 let
171 leadSuit = cardSuit (head trick)
172 legal = legalPlays hand (Just leadSuit)
173 cardsPlayed = length trick
174 partnerWinning = isPartnerWinning trick leader trumpSuit me
175 defending = side me /= side declarer
176 in case legal of
177 [singlePlay] -> singlePlay
178 _ | any (\c -> cardSuit c == leadSuit) legal ->
179 let inSuit = [c | c <- legal, cardSuit c == leadSuit]
180 in if cardsPlayed == 3 && partnerWinning
181 then lowestCard inSuit
182 else if canWinTrick inSuit trick leader trumpSuit
183 then cheapestWinner inSuit trick leader trumpSuit
184 else lowestCard inSuit
185 _ ->
186 let
187 trumps = case trumpSuit of
188 Just ts -> [c | c <- legal, cardSuit c == ts]
189 Nothing -> []
190 nonTrumps = case trumpSuit of
191 Just ts -> [c | c <- legal, cardSuit c /= ts]
192 Nothing -> legal
193 in if not partnerWinning && not (null trumps)
194 then lowestCard trumps
195 else bestDiscard nonTrumps trumpSuit
196
197 aiSelectCard :: [Card] -> [Card] -> Player -> Maybe Suit -> Player -> Player -> Card
198 aiSelectCard hand trick leader trumpSuit me declarer =
199 let
200 leadSuit = fmap cardSuit (find (\_ -> True) trick)
201 card = if null trick
202 then aiSelectLead hand trumpSuit me declarer
203 else aiSelectFollow hand trick leader trumpSuit me declarer
204 legal = legalPlays hand leadSuit
205 in if card `elem` legal
206 then card
207 else case legal of
208 (fallback:_) -> fallback
209 [] -> head hand
Scoring Rules: Bridge.Scoring
Rubber bridge is scored using two columns (N-S and E-W), separated by a horizontal line:
- Below the line: Houses trick scores for contracts bid and made. Accumulating 100+ points below the line wins a game, reset both sides’ below-the-line columns, and makes that side vulnerable.
- Above the line: Houses penalties (when declarer goes down), overtrick bonuses, insult bonuses (for making doubled/redoubled contracts), and slam bonuses (slam/grand slam).
- Rubber completion: The first side to win 2 games wins the rubber, earning a bonus of 700 (if won 2-0) or 500 (if won 2-1).
1 module Bridge.Scoring where
2
3 import Bridge.Types
4
5 data RubberState = RubberState
6 { nsBelow :: Int
7 , ewBelow :: Int
8 , nsAbove :: Int
9 , ewAbove :: Int
10 , nsGames :: Int
11 , ewGames :: Int
12 , nsVulnerable :: Bool
13 , ewVulnerable :: Bool
14 , currentDealer:: Player
15 , dealsPlayed :: Int
16 } deriving (Show, Eq)
17
18 newRubberState :: RubberState
19 newRubberState = RubberState
20 { nsBelow = 0, ewBelow = 0, nsAbove = 0, ewAbove = 0
21 , nsGames = 0, ewGames = 0, nsVulnerable = False, ewVulnerable = False
22 , currentDealer = North, dealsPlayed = 0
23 }
24
25 trickValue :: Strain -> Int -> Int
26 trickValue strain doubled =
27 let
28 base = case strain of
29 SuitStrain Clubs -> 20
30 SuitStrain Diamonds -> 20
31 _ -> 30
32 mult = case doubled of 1 -> 2; 2 -> 4; _ -> 1
33 in base * mult
34
35 contractTrickScore :: Int -> Strain -> Int -> Int
36 contractTrickScore level strain doubled =
37 let
38 basePerTrick = trickValue strain doubled
39 extra = case (strain, doubled) of
40 (NoTrump, 0) -> 10
41 (NoTrump, 1) -> 20
42 (NoTrump, 2) -> 40
43 _ -> 0
44 in extra + basePerTrick * level
45
46 scoreRubberDeal :: Int -> Strain -> Int -> Player -> Int -> RubberState -> (RubberState, Int)
47 scoreRubberDeal level strain tricksWon declarer doubled rs =
48 let
49 tricksNeeded = level + 6
50 overtricks = tricksWon - tricksNeeded
51 made = tricksWon >= tricksNeeded
52 nsSide = declarer == North || declarer == South
53 vul = if nsSide then nsVulnerable rs else ewVulnerable rs
54 in if made
55 then
56 let
57 belowScore = contractTrickScore level strain doubled
58 overtrickVal = case doubled of
59 0 -> trickValue strain 0
60 1 -> if vul then 200 else 100
61 _ -> if vul then 400 else 200
62 overtrickBonus = if overtricks > 0 then overtricks * overtrickVal else 0
63 insultBonus = case doubled of 1 -> 50; 2 -> 100; _ -> 0
64 slamBonus = if level == 6 then (if vul then 750 else 500)
65 else if level == 7 then (if vul then 1500 else 1000)
66 else 0
67 aboveScore = overtrickBonus + insultBonus + slamBonus
68
69 (rs1, newBelow) =
70 if nsSide
71 then (rs { nsBelow = nsBelow rs + belowScore, nsAbove = nsAbove rs + aboveScore }, nsBelow rs + belowScore)
72 else (rs { ewBelow = ewBelow rs + belowScore, ewAbove = ewAbove rs + aboveScore }, ewBelow rs + belowScore)
73
74 rs2 = if newBelow >= 100
75 then if nsSide
76 then rs1 { nsGames = nsGames rs1 + 1, nsVulnerable = True, nsBelow = 0, ewBelow = 0 }
77 else rs1 { ewGames = ewGames rs1 + 1, ewVulnerable = True, nsBelow = 0, ewBelow = 0 }
78 else rs1
79 in (rs2, belowScore)
80 else
81 let
82 down = abs overtricks
83 penalty = case doubled of
84 0 -> down * (if vul then 100 else 50)
85 1 -> if vul
86 then 200 + (down - 1) * 300
87 else case down of
88 1 -> 100
89 2 -> 300
90 3 -> 500
91 _ -> 500 + (down - 3) * 300
92 _ -> 2 * if vul
93 then 200 + (down - 1) * 300
94 else case down of
95 1 -> 100
96 2 -> 300
97 3 -> 500
98 _ -> 500 + (down - 3) * 300
99 rs1 = if nsSide
100 -- Penalties go above line for defenders
101 then rs { ewAbove = ewAbove rs + penalty }
102 else rs { nsAbove = nsAbove rs + penalty }
103 in (rs1, -penalty)
104
105 rubberComplete :: RubberState -> Bool
106 rubberComplete rs = nsGames rs >= 2 || ewGames rs >= 2
107
108 rubberBonus :: RubberState -> (Int, Maybe String)
109 rubberBonus rs
110 | nsGames rs >= 2 = (if ewGames rs == 0 then 700 else 500, Just "N-S")
111 | ewGames rs >= 2 = (if nsGames rs == 0 then 700 else 500, Just "E-W")
112 | otherwise = (0, Nothing)
113
114 rubberTotalScores :: RubberState -> (Int, Int)
115 rubberTotalScores rs =
116 let
117 (bonus, winner) = rubberBonus rs
118 nsTotal = nsAbove rs + if winner == Just "N-S" then bonus else 0
119 ewTotal = ewAbove rs + if winner == Just "E-W" then bonus else 0
120 in (nsTotal, ewTotal)
Core Game State Machine: Bridge.Engine
The game engine brings everything together. GameState holds the deals, hands, bidding auction histories, trick queues, and phase indicators. The engine defines pure FFI-friendly state transformers (applyBid and applyCardPlay) to drive the game forward.
1 module Bridge.Engine where
2
3 import Bridge.Types
4 import Bridge.Cards
5 import Bridge.Bidding
6 import Bridge.Play
7 import System.Random (StdGen)
8 import qualified Data.Map.Strict as Map
9
10 data Vulnerability = None | NsOnly | EwOnly | Both
11 deriving (Eq, Show)
12
13 data GameState = GameState
14 { hands :: Map.Map Player [Card]
15 , originalHands :: Map.Map Player [Card]
16 , dealer :: Player
17 , vulnerability :: Vulnerability
18 , humanPlayer :: Player
19 , bidHistory :: [(Player, BidType)]
20 , contract :: Maybe BidType
21 , declarer :: Maybe Player
22 , doubled :: Int
23 , dummy :: Maybe Player
24 , currentTrick :: [(Player, Card)]
25 , trickLead :: Player
26 , tricksNs :: Int
27 , tricksEw :: Int
28 , tricksPlayed :: Int
29 , cardsPlayed :: [Card]
30 , trumpSuit :: Maybe Suit
31 , phase :: Phase
32 } deriving (Show)
33
34 newGame :: Player -> Vulnerability -> Player -> StdGen -> GameState
35 newGame dealerVal vul humanVal gen =
36 let
37 deck = makeDeck
38 (shuffled, _) = shuffleDeck deck gen
39 (n, e, s, w) = dealHands shuffled
40 handsMap = Map.fromList [(North, n), (East, e), (South, s), (West, w)]
41 in GameState
42 { hands = handsMap, originalHands = handsMap, dealer = dealerVal, vulnerability = vul
43 , humanPlayer = humanVal, bidHistory = [], contract = Nothing, declarer = Nothing
44 , doubled = 0, dummy = Nothing, currentTrick = [], trickLead = dealerVal
45 , tricksNs = 0, tricksEw = 0, tricksPlayed = 0, cardsPlayed = []
46 , trumpSuit = Nothing, phase = Bidding
47 }
48
49 currentActor :: GameState -> Maybe Player
50 currentActor gs =
51 case phase gs of
52 Bidding ->
53 if null (bidHistory gs)
54 then Just (dealer gs)
55 else Just (nextPlayer (fst (head (bidHistory gs))))
56 Playing ->
57 if null (currentTrick gs)
58 then Just (trickLead gs)
59 else Just (nextPlayer (fst (head (currentTrick gs))))
60 _ -> Nothing
61
62 applyBid :: BidType -> GameState -> GameState
63 applyBid bid gs =
64 case currentActor gs of
65 Nothing -> gs
66 Just actor ->
67 let
68 history' = (actor, bid) : bidHistory gs
69 complete = biddingComplete history'
70 in if complete
71 then
72 if passedOut history'
73 then gs { bidHistory = history', phase = Done }
74 else
75 case extractContract history' (dealer gs) of
76 Nothing -> gs { bidHistory = history', phase = Done }
77 Just (contract', declarer', doubled') ->
78 let
79 dummy' = partner declarer'
80 ts = case contract' of
81 SuitBid _ (SuitStrain s) -> Just s
82 _ -> Nothing
83
84 (hands', dummy'') =
85 if declarer' == North && humanPlayer gs == South
86 then
87 let
88 northCards = hands gs Map.! North
89 southCards = hands gs Map.! South
90 swapped = Map.fromList [(North, southCards), (East, hands gs Map.! East), (South, northCards), (West, hands gs Map.! West)]
91 in (swapped, North)
92 else (hands gs, dummy')
93 in gs
94 { bidHistory = history', contract = Just contract', declarer = Just declarer'
95 , doubled = doubled', dummy = Just dummy'', trumpSuit = ts
96 , trickLead = nextPlayer declarer', phase = Playing, hands = hands'
97 }
98 else gs { bidHistory = history' }
99
100 applyCardPlay :: Card -> GameState -> GameState
101 applyCardPlay card gs =
102 case currentActor gs of
103 Nothing -> gs
104 Just actor ->
105 let
106 hand' = filter (/= card) (hands gs Map.! actor)
107 hands' = Map.insert actor hand' (hands gs)
108 currentTrick' = (actor, card) : currentTrick gs
109 cardsPlayed' = card : cardsPlayed gs
110 in if length currentTrick' == 4
111 then
112 let
113 trickInPlayOrder = map snd (reverse currentTrick')
114 winner = trickWinner trickInPlayOrder (trickLead gs) (trumpSuit gs)
115
116 nsScore = if winner == North || winner == South then 1 else 0
117 ewScore = if winner == East || winner == West then 1 else 0
118
119 tricksNs' = tricksNs gs + nsScore
120 tricksEw' = tricksEw gs + ewScore
121 tricksPlayed' = tricksPlayed gs + 1
122 nextPhase = if tricksPlayed' == 13 then Scoring else Playing
123 in gs
124 { hands = hands', currentTrick = [], trickLead = winner, tricksNs = tricksNs'
125 , tricksEw = tricksEw', tricksPlayed = tricksPlayed', cardsPlayed = cardsPlayed'
126 , phase = nextPhase
127 }
128 else gs { hands = hands', currentTrick = currentTrick', cardsPlayed = cardsPlayed' }
Swapping Hands for North Contracts
A critical detail in the applyBid logic:
1 (hands', dummy'') =
2 if declarer' == North && humanPlayer gs == South
3 then ...
When South’s partner (North) wins the auction, North becomes the declarer, and South becomes the dummy. In actual bridge, declarer plays both their own hand and dummy’s cards. Thus, the human (South) must take over North’s original cards, while their original hand moves to North as the dummy. This swap is cleanly executed by modifying the hands map inside the pure state transition.
Interactive Command Line Front-end: app/Main.hs
The command line application implements the interactive prompts, parses inputs, and updates state. We design the interface with recursive monadic state loops in the GHC IO monad, providing the player with side-by-side terminal rendering of West/East/South hands and cards in play.
Due to the length of Main.hs, we showcase its most vital loops and parsing functions. The complete file can be examined in the source folder.
Running Bidding and Playing loops
1 runBiddingLoop :: GameState -> IO (Either String GameState)
2 runBiddingLoop gs =
3 if phase gs /= Bidding
4 then return (Right gs)
5 else case currentActor gs of
6 Nothing -> return (Right gs)
7 Just actor ->
8 if actor == South
9 then do
10 res <- promptForBid gs
11 case res of
12 Left err -> return (Left err)
13 Right bid -> runBiddingLoop (applyBid bid gs)
14 else do
15 let aiBid = aiSelectBid (hands gs Map.! actor) (bidHistory gs) actor (dealer gs)
16 putStrLn $ " " ++ show actor ++ " bids: " ++ show aiBid
17 runBiddingLoop (applyBid aiBid gs)
18
19 runPlayingLoop :: GameState -> IO (Either String GameState)
20 runPlayingLoop gs =
21 if phase gs /= Playing
22 then return (Right gs)
23 else case currentActor gs of
24 Nothing -> return (Right gs)
25 Just actor -> do
26 when (null (currentTrick gs)) $ do
27 putStrLn $ "\n── Trick " ++ show (tricksPlayed gs + 1) ++ " ──"
28 putStrLn $ " N-S tricks won: " ++ show (tricksNs gs) ++ " E-W tricks won: " ++ show (tricksEw gs)
29
30 let
31 isHuman = actor == South
32 isDummy = Just actor == dummy gs
33 declarerSide = fmap side (declarer gs)
34 humanPlaysDummy = isDummy && (declarerSide == Just 0)
35 humanPlaysThis = isHuman || humanPlaysDummy
36 leadSuit = case currentTrick gs of
37 [] -> Nothing
38 _ -> Just (cardSuit (snd (last (currentTrick gs))))
39
40 if humanPlaysThis
41 then do
42 when (not (null (currentTrick gs))) $ do
43 putStrLn "\n Trick in progress:"
44 mapM_ (\(p, c) -> putStrLn $ " " ++ show p ++ " played: " ++ show c) (reverse (currentTrick gs))
45
46 res <- promptForCard gs actor leadSuit
47 case res of
48 Left err -> return (Left err)
49 Right card -> do
50 let gs' = applyCardPlay card gs
51 when (null (currentTrick gs')) $ do
52 let prevTrickWinner = trickLead gs'
53 putStrLn $ " → " ++ show prevTrickWinner ++ " wins the trick."
54 runPlayingLoop gs'
55 else do
56 let
57 card = aiSelectCard (hands gs Map.! actor) (map snd (currentTrick gs)) (trickLead gs) (trumpSuit gs) actor (maybe South id (declarer gs))
58 isActorDummy = Just actor == dummy gs
59 putStrLn $ " " ++ show actor ++ (if isActorDummy then " (Dummy)" else "") ++ " plays: " ++ show card
60
61 let gs' = applyCardPlay card gs
62 when (null (currentTrick gs')) $ do
63 let prevTrickWinner = trickLead gs'
64 putStrLn $ " → " ++ show prevTrickWinner ++ " wins the trick."
65 runPlayingLoop gs'
Compilation and Running the Game
Building and running the bridge game is fully integrated into GHC’s build system and the root repository Makefile.
Building with Cabal
Navigate to the Bridge_game directory and build the package:
1 cd Bridge_game
2 cabal build
This compiles all library modules and links the command line executable.
Playing the Game
Run the executable using Cabal:
1 cabal run bridge-game
When prompted during the bidding phase, enter standard bids (such as 1H, 1NT, PASS, or DBL). During the playing phase, you can select card plays using the index numbers shown on the screen (e.g., 1, 2) or short symbols (such as AS, 10H). Typing Q or QUIT at any prompt exits the game.
Optional Practice Problems
- Extend the heuristic bidding AI in the Bridge game library to evaluate the vulnerability status (vulnerable vs. non-vulnerable) of all players before choosing a bid.
- Write Hspec test assertions under
Bridge_game/testto verify that contract scoring calculations for trick points match official scoring rules under doubled or redoubled states.