(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))) ;; from here, its 3-3 or 3-2 or 4-1 in the minors ((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)))) ;;; Probabilities (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))) ;;; Example: (format t "~2$~%" (break-percentage 2 2)) (defun break-percentage-two-way (a b) (* (break-percentage a b) (if (= a b) 1 2))) ;;; Example: (format t "~2$~%" (break-percentage-two-way 1 3)) (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)))) ;;; Example: (format t "~1$" (* 100 (percentage-of-opponent-having '(k j x x x) '(x x x)))) (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)))) ;;; Example: (format t "~1$" (* 100 (percentage-of-opponent-having-at-least '(k j x x x) '(k j))))