(defparameter *deck*
(iter (for suit in '(club diamond heart spade))
(appending
(iter (for number in '(2 3 4 5 6 7 8 9 10 jack queen king ace))
(collect (cons suit number))))))
(defun shuffle-deck ()
(setf *deck* (shuffle *deck*)))
(defun card-hcp (card)
(case (cdr card)
(ace 4)
(king 3)
(queen 2)
(jack 1)
(t 0)))
(defun hand-hcp (hand)
(reduce #'+ (mapcar #'card-hcp hand)))
(defun sort-by-suit (hand)
"Returns 4 lists."
(iter (for suit in '(club diamond heart spade))
(collect (remove-if-not (lambda (s) (eq s suit)) hand :key #'car))))
(defun clubs (lst) (first lst))
(defun diamonds (lst) (second lst))
(defun hearts (lst) (third lst))
(defun spades (lst) (fourth lst))
(defun card-value (card)
"For convenience, AKQJ => 14/13/12/11."
(if (numberp (cdr card))
(cdr card)
(case (cdr card)
(ace 14)
(king 13)
(queen 12)
(jack 11))))
(defun card> (a b)
(> (card-value a) (card-value b)))
(defun sort-by-number (cards)
(sort cards #'card>))
(defun sort-hand (hand)
(mapcar #'sort-by-number (sort-by-suit hand)))
(defun take-cards (player)
"PLAYER is a number from 0 to 3. Returns 13 cards from *DECK*."
(sort-hand (subseq *deck* (* player 13) (* (1+ player) 13))))
(defun print-hand (sorted-hand)
(iter (for suit in (reverse sorted-hand))
(for suit-name in '("Spades: " "Hearts: " "Diamonds:" "Clubs: "))
(format t "~&~a ~{~a~}" suit-name
(iter (for card in suit)
(collect
(case (cdr card)
(ace "A")
(king "K")
(queen "Q")
(jack "J")
(t (cdr card))))))))
(defun has-figure (cards)
(some #'symbolp (mapcar #'cdr cards)))
(defun has-10 (cards)
(member 10 cards :key #'cdr))
(defun worthless-cards-p (cards)
"CARDS contains 0, 1 or 2 cards."
(and cards
(every (lambda (card)
(member (cdr card) '(king queen jack)))
cards)))
(defun hand-hcp* (sorted-hand)
"-1 point for singleton KQJ, or doubleton KQ/KJ/QJ.
+1 point for at least two 10s in suits of at least 3 cards with a figure."
(let ((hcp 0)
(tens 0))
(iter (for suit in sorted-hand)
(incf hcp (hand-hcp suit))
(if (< (length suit) 3)
(when (worthless-cards-p suit)
(decf hcp))
(when (and (has-10 suit) (has-figure suit))
(incf tens))))
(+ hcp (if (>= tens 2) 1 0))))
(defun hand-losers (sorted-hand)
(flet ((suit-losers (cards)
(let ((n (length cards)))
(+ (if (and (>= n 1) (not (member 'ace cards :key #'cdr))) 1 0)
(if (and (>= n 2) (not (member 'king cards :key #'cdr))) 1 0)
(if (and (>= n 3) (not (member 'queen cards :key #'cdr))) 1 0)))))
(reduce #'+ (mapcar #'suit-losers sorted-hand))))
(defun hand-losers-with-worthless-queens (sorted-hand)
"Qxx+ is a half loser."
(flet ((Qxx (suit)
(and (member 'queen suit :key #'cdr)
(> (length suit) 2)
(notany (lambda (card) (member card suit :key #'cdr))
'(ace king jack 10)))))
(+ (hand-losers sorted-hand)
(* 0.5 (length (remove-if-not #'Qxx sorted-hand))))))
(defun hand-losers* (sorted-hand)
"Counting 1.5 for A, 1 for K, and 0.5 for Q."
(flet ((suit-losers (cards)
(let ((n (length cards)))
(+ (if (and (>= n 1) (not (member 'ace cards :key #'cdr))) 1.5 0)
(if (and (>= n 2) (not (member 'king cards :key #'cdr))) 1 0)
(if (and (>= n 3) (not (member 'queen cards :key #'cdr))) 0.5 0)))))
(reduce #'+ (mapcar #'suit-losers sorted-hand))))
(defun twenty-rule (sorted-hand)
(let ((lengths (sort (mapcar #'length sorted-hand) #'>)))
(>= (+ (hand-hcp* sorted-hand)
(first lengths) (second lengths))
20)))
(defun fifteen-rule (sorted-hand)
(>= (+ (hand-hcp* sorted-hand)
(length (spades sorted-hand)))
15))
(defun balancedp (sorted-hand)
(and (notany (lambda (suit) (< (length suit) 2)) sorted-hand)
(< (count 2 sorted-hand :key #'length) 2)))
(defun very-strong-p (sorted-hand)
(>= (hand-hcp* sorted-hand) 22))
(defun majorp (suit)
(member suit '(heart spade)))
(defun minorp (suit)
(member suit '(club diamond)))
(defun michaelsp (sorted-hand opponent-suit)
(and (<= (hand-losers sorted-hand) 6)
(if (minorp opponent-suit)
(and (>= (length (hearts sorted-hand)) 5)
(>= (length (spades sorted-hand)) 5))
(and (or (>= (length (clubs sorted-hand)) 5)
(>= (length (diamonds sorted-hand)) 5))
(if (eq opponent-suit 'spade)
(>= (length (hearts sorted-hand)) 5)
(>= (length (spades sorted-hand)) 5))))))
(defun one-notrump-p (sorted-hand)
(and (<= 15 (hand-hcp* sorted-hand) 17)
(balancedp sorted-hand)
(< (length (hearts sorted-hand)) 5)
(< (length (spades sorted-hand)) 5)))
(defun two-notrumps-p (sorted-hand)
(and (<= 20 (hand-hcp* sorted-hand) 21)
(balancedp sorted-hand)))
(defun longest-suit-length (sorted-hand)
(first (sort (mapcar #'length sorted-hand) #'>)))
(defun pass-hand-p (sorted-hand)
"Simplified."
(and (not (twenty-rule sorted-hand))
(not (and (>= (longest-suit-length sorted-hand) 6)
(>= (hand-hcp* sorted-hand) 6)))))
(defun four-major-p (sorted-hand)
"Returns whether the hand has a major with >= 4 cards."
(or (>= (length (hearts sorted-hand)) 4)
(>= (length (spades sorted-hand)) 4)))
(defun singleton-count (sorted-hand)
(count 1 sorted-hand :key #'length))
(defun void-count (sorted-hand)
(count 0 sorted-hand :key #'length))
(defun longest-suit (sorted-hand)
(car (first (first (sort (copy-seq sorted-hand) #'> :key #'length)))))
(defun weak-two-p (sorted-hand)
(and (not (twenty-rule sorted-hand))
(= (longest-suit-length sorted-hand) 6)
(>= (hand-hcp* sorted-hand) 6)
(<= 7 (hand-losers-with-worthless-queens sorted-hand) 8)
(< (singleton-count sorted-hand) 2)
(= (void-count sorted-hand) 0)
(let ((longest (longest-suit sorted-hand)))
(cond ((minorp longest) (not (four-major-p sorted-hand)))
((eq longest 'heart) (< (length (spades sorted-hand)) 4))
((eq longest 'spade) (< (length (hearts sorted-hand)) 4))))))
(defun one-suit-hand (sorted-hand)
"Simplified. Returns the suit if any."
(when (and (twenty-rule sorted-hand)
(not (one-notrump-p sorted-hand))
(not (two-notrumps-p sorted-hand))
(not (very-strong-p sorted-hand)))
(let* ((suits-with-lengths (iter (for suit-name in '(club diamond heart spade))
(for suit in sorted-hand)
(collect (cons suit-name (length suit)))))
(sorted (stable-sort (nreverse suits-with-lengths) #'> :key #'cdr)))
(cond ((>= (cdr (first sorted)) 5) (car (first sorted)))
((minorp (car (first sorted))) (car (first sorted)))
((eq (car (second sorted)) 'club) 'club)
((eq (car (second sorted)) 'diamond)
(cond ((= (length (diamonds sorted-hand)) 4) 'diamond)
((= (length (clubs sorted-hand)) 3) 'club)
(t 'diamond)))
((eq (car (third sorted)) 'club) 'club)
((= (cdr (third sorted)) 3)
(if (= (cdr (fourth sorted)) 3)
'club
'diamond))
(t 'diamond)))))
(defun show-deck (deck)
(let ((*deck* deck))
(format t "~&South:")
(print-hand (take-cards 0))
(format t "~&West:")
(print-hand (take-cards 1))
(format t "~&North:")
(print-hand (take-cards 2))
(format t "~&East:")
(print-hand (take-cards 3))))
(defun binomial (n k)
(if (> k n)
0
(iter (for d from 1 to k)
(for m downfrom n)
(multiplying (/ m d)))))
(defun break-percentage (lho rho)
"What is the probability of the left-hand opponent getting exactly LHO cards,
and the right-hand opponent getting exactly RHO cards?"
(/ (* (binomial (- 26 lho rho) (- 13 lho))
(binomial (+ lho rho) lho))
(binomial 26 13)))
(defun break-percentage-two-way (a b)
(* (break-percentage a b) (if (= a b) 1 2)))
(defun percentage-of-opponent-having (all-cards cards)
"ALL-CARDS is a list of cards in the suit in question.
CARDS is a list of cards a given opponent has.
The card X means it can be anything.
Note that this is meant for a fixed opponent - multiply by 2 if it can go both ways."
(let ((all-xs (count 'x all-cards))
(xs (count 'x cards)))
(/ (* (binomial (- 26 (length all-cards)) (- 13 (length cards)))
(binomial all-xs xs))
(binomial 26 13))))
(defun percentage-of-opponent-having-at-least (all-cards cards)
"ALL-CARDS is the number of cards out in the suit in question.
CARDS is a list of cards a given opponent has (at least!).
The card X means it can be anything."
(let* ((n (length all-cards))
(m (length cards))
(not-xs (- m (count 'x cards))))
(/ (iter (for k from m to n)
(sum (* (binomial (- 26 n) (- 13 k))
(binomial (- n not-xs) (- k not-xs)))))
(binomial 26 13))))