うーん，どっかがバグってるはず。

どもです。
現在，Problem 54 をやっていて，答えが出て，その答えが400で，
怪しいなぁと思いつつ入力したら，やっぱり不正解orz。
ユニットテスト書いてないので，どこがバグっているかわからんし，
ちと疲れたので今日はここまで。
ちなみに調べたところ，役で引き分けになるのは，
ブタ，ワンペア，ツーペア，スリーカードのいずれかのようだ。
これも怪しいがね。

以下コード。

;;;; problem 54
(defparameter *cards* (make-hash-table))
(clrhash *cards*)
(loop for i from 2 to 10
      do (setf (gethash (digit-char i) *cards*) i))
(setf (gethash #\J *cards*) 11)
(setf (gethash #\Q *cards*) 12)
(setf (gethash #\K *cards*) 13)
(setf (gethash #\A *cards*) 14)

(defparameter *p1-hands* nil)
(defparameter *p2-hands* nil)

(defun read-hands (filename)
  (with-open-file (is filename :direction :input)
    (do ((ch (read-char is nil :eof) (read-char is nil :eof))
         (num)
         (suit)
         (hand)
         (ncard 0)
         (nhands 0))
        ((or (eq ch :eof))
         (setf *p1-hands* (nreverse *p1-hands*)
               *p2-hands* (nreverse *p2-hands*))
         nhands)
      (cond
        ((or (char= ch #\ ) (char= ch #\Newline))
         (incf ncard)
         (push (list num suit) hand)
         (cond
           ((= ncard 5)
            (push (sort hand #'< :key #'car) *p1-hands*)
            (incf nhands)
            (setf hand nil))
           ((= ncard 10)
            (push (sort hand #'< :key #'car) *p2-hands*)
            (incf nhands)
            (setf hand nil
                  ncard 0))))
        ((or (digit-char-p ch)
             (char= ch #\J)
             (char= ch #\Q)
             (char= ch #\K)
             (char= ch #\A))
         (setf num (gethash ch *cards*)))
        ((alpha-char-p ch)
         (setf suit (read (make-string-input-stream (princ-to-string ch)))))))))

(defun construct-hands (filename)
  (setf *p1-hands* nil
        *p2-hands* nil)
  (read-hands filename))

(defun hand->rank (hand)
  (cond
    ((royal-flush-p hand) 9)
    ((straight-flush-p hand) 8)
    ((four-card-p hand) 7)
    ((fullhouse-p hand) 6)
    ((flush-p hand) 5)
    ((straight-p hand) 4)
    ((three-card-p hand) 3)
    ((two-pairs-p hand) 2)
    ((one-pair-p hand) 1)
    ((high-card-p hand) 0)))

(defun royal-flush-p (hand)
  "HAND should properly be sorted."
  (and (every #'identity (mapcar #'eql (mapcar #'car hand)
                            '(10 11 12 13 14)))
       (flush-p hand)))

(defun straight-flush-p (hand)
  (and (straight-p hand)
       (flush-p hand)))

(defun four-card-p (hand)
  (loop with nums = (mapcar #'car hand)
        for i in nums
        when (= 4 (count i nums))
          return i
        finally (return nil)))

(defun fullhouse-p (hand)
  (let ((three (three-card-p hand)))
    (if three
        (let ((nums (remove three (mapcar #'car hand))))
          (if (= (car nums) (cadr nums))
              (list three (car nums))
              nil))
        nil)))

(defun flush-p (hand)
  (and (every #'eql (mapcar #'cadr hand)
              (cdr (mapcar #'cadr hand)))
       (apply #'max (mapcar #'car hand))))

(defun straight-p (hand)
  (and (every (lambda (n) (= n 1))
              (mapcar #'- (sort (cdr (mapcar #'car hand)) #'<)
                      (sort (mapcar #'car hand) #'<)))
       (apply #'max (mapcar #'car hand))))

(defun three-card-p (hand)
  (count-ncard-p hand 3))

(defun count-ncard-p (hand count)
  (loop with nums = (mapcar #'car hand)
        for n in nums
        when (= count (count n nums))
          return n
        finally (return nil)))

(defun two-pairs-p (hand)
  (let ((nums (mapcar #'car hand))
        (ret nil))
    (and (loop for n in nums
               when (= 2 (count n nums))
                 return (setf nums (remove n nums)
                              ret (cons n ret))
               finally (return nil))
         (loop for n in nums
               when (= 2 (count n nums))
                 return (cons n ret)
               finally (return nil)))))

(defun one-pair-p (hand)
  (count-ncard-p hand 2))

(defun high-card-p (hand)
  (apply #'max (mapcar #'car hand)))

(defun judge-hands (hand1 hand2)
  "Return t if hand1 wins. Otherwise nil or -1."
  (let ((rank1 (hand->rank hand1))
        (rank2 (hand->rank hand2)))
    (cond
      ((> rank1 rank2) t)
      ((< rank1 rank2) nil)
      (t
       ;; Tie
       (case rank1
         ;; highest card
         (0 (high-card-tie hand1 hand2))
         ;; one pair
         (1 (one-pair-tie hand1 hand2))
         ;; two pairs
         (2 (two-pairs-tie hand1 hand2))
         (3 (three-card-tie hand1 hand2))
         (4 (straight-tie hand1 hand2))
         (5 (flush-tie hand1 hand2))
         (6 (fullhouse-tie hand1 hand2))
         (7 (four-card-tie hand1 hand2))
         (8 (straight-flush-tie hand1 hand2))
         (otherwise -1))))))

(defun high-card-tie (hand1 hand2)
  (judge-highest (mapcar #'car hand1)
                 (mapcar #'car hand2)))

(defun judge-highest (nums1 nums2)
  (if (or (null nums1) (null nums2))
      -1
      (let ((m1 (apply #'max nums1))
            (m2 (apply #'max nums2)))
        (cond
          ((> m1 m2) t)
          ((< m1 m2) nil)
          (t (judge-highest (remove m1 nums1)
                            (remove m2 nums2)))))))

(defun one-pair-tie (hand1 hand2)
  (let ((nums1 (mapcar #'car hand1))
        (c1 (one-pair-p hand1))
        (nums2 (mapcar #'car hand2))
        (c2 (one-pair-p hand2)))
    (cond
      ((> c1 c2) t)
      ((< c1 c2) nil)
      (t (judge-highest (remove c1 nums1)
                        (remove c2 nums2))))))

(defun two-pairs-tie (hand1 hand2)
  (let* ((nums1 (mapcar #'car hand1))
         (c1 (sort (two-pairs-p hand1) #'<))
         (nums2 (mapcar #'car hand2))
         (c2 (sort (two-pairs-p hand2) #'<))
         (ret (judge-highest c1 c2)))
    ;(format t "c1=~S, c2=~S~%" c1 c2)
    (if (not (numberp ret))
        ret
        (judge-highest (set-difference nums1 c1)
                       (set-difference nums2 c2)))))


(defun three-card-tie (hand1 hand2)
  (let ((c1 (three-card-p hand1))
        (c2 (three-card-p hand2)))
    (cond
      ((> c1 c2) t)
      ((< c1 c2) nil)
      (t (error "Cannot happen in three cards!!")))))

(defun straight-tie (hand1 hand2)
  (let ((c1 (straight-p hand1))
        (c2 (straight-p hand2)))
    (cond
      ((> c1 c2) t)
      ((< c1 c2) nil)
      (t (error "Tie with straight!!")))))

(defun flush-tie (hand1 hand2)
  (let ((nums1 (mapcar #'car hand1))
        (c1 (flush-p hand1))
        (nums2 (mapcar #'car hand2))
        (c2 (flush-p hand2)))
    (cond
      ((> c1 c2) t)
      ((< c1 c2) nil)
      (t (judge-highest (remove c1 nums1)
                        (remove c2 nums2))))))

(defun fullhouse-tie (hand1 hand2)
  (let* ((c1 (fullhouse-p hand1))
         (c2 (fullhouse-p hand2)))
    ;;(format t "c1=~S, c2=~S~%" c1 c2)
    ;; compare three cards part
    (> (car c1) (car c2))))

(defun four-card-tie (hand1 hand2)
  -1)

(defun straight-flush-tie (hand1 hand2)
  -1)

(defun euler-problem-54 ()
  (construct-hands "poker.txt")
  (loop for h1 in *p1-hands*
        for h2 in *p2-hands*
        for result = (judge-hands h1 h2)
        with p1-wins = 0
        with p2-wins = 0
        when (not (numberp result))
          do (if result
                 (incf p1-wins)
                 (incf p2-wins))
        finally (return (list p1-wins p2-wins))))