(defparameter *deck*
  (iter (for suit in '(club diamond heart spade))
         (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)
                          (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)))

(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))

(defun fifteen-rule (sorted-hand)
  (>= (+ (hand-hcp* sorted-hand)
         (length (spades sorted-hand)))

(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)
  (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)
            (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)
      (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))))