ポーカーの残り＋, http://qiita.com/Nabetani/items/d819d1e5f2378317511e

2013-05-10-poker-plus.lisp

;;;; Last modified: 2013-12-09 21:52:45 tkych


;;====================================================================
;; ポーカーの残り＋
;;====================================================================
;; - [ポーカーの残り＋ 〜 横へな 2013.5.10 の参考問題](http://nabetani.sakura.ne.jp/hena/ord10pokarest/)
;; - [第10回オフラインリアルタイムどう書くの参考問題](http://qiita.com/Nabetani/items/d819d1e5f2378317511e)


;;--------------------------------------------------------------------
;; Package
;;--------------------------------------------------------------------

(in-package :cl-user)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :cl-ppcre))
(defpackage :poker+ (:use :cl))
(in-package :poker+)


;;--------------------------------------------------------------------
;; Main
;;--------------------------------------------------------------------
;; <card>  ::= (<rank> . <suit>)
;; <cards> ::= (<card> <card> <card> <card> <card>), sorted by rank

(defun rank (card) (car card))
(defun suit (card) (cdr card))
(defun make-card (rank suit) (cons rank suit))

;; (get-ranks '((14 . #\s) (12 . #\c) (11 . #\d) (2 . #\h) (2 . #\d)))
;; => (14 12 11 2 1)
(defun get-ranks (cards)
  (let ((ranks '()))
    (when (= 14 (rank (first cards)))
      (push 1 ranks))
    (loop :for (r . _) :in (reverse cards) :do (pushnew r ranks))
    ranks))

;; (get-suits '((14 . #\s) (12 . #\c) (11 . #\d) (10 . #\d) (2 . #\d)))
;; => (#\s #\c #\d #\d #\d)
(defun get-suits (cards)
  (mapcar #'suit cards))

(defun flushp (suits)
  (= 1 (length (remove-duplicates suits))))

(defun straightp (ranks &optional (continuous 5))
  (loop :with cont := 1
        :for r1 :in (rest ranks)
        :and r0 := (first ranks) :then r1
        :do (if (= r0 (1+ r1))
                (progn
                  (incf cont)
                  (when (= cont continuous)
                    (RETURN T)))
                (setf cont 1))))

;; (find-4suit '(#\s #\d #\d #\d #\h)) => NIL
;; (find-4suit '(#\s #\d #\d #\d #\d)) => #\d
(defun find-4suit (suits)
  (when (= 2 (length (remove-duplicates suits)))
    (let ((4suit (first suits)))
      (case (count 4suit suits)
        (4 4suit)
        (1 (second suits))
        (t nil)))))

(defun 4straight-flush-p (4suit cards)
  (straightp
   (get-ranks (remove-if (lambda (s) (char/= 4suit s))
                         cards :key #'suit))
   4))

;; input -> cards
;; "2dQcJdAs10d" -> ((14 . #\s) (12 . #\c) (11 . #\d) (10 . #\d) (2 . #\d))
(defun parse (input)
  (let ((input% (cl-ppcre:regex-replace-all "10" input "T")))
    (loop :repeat 5
          :for r :from 0 :by 2
          :for s :from 1 :by 2
          :collect (make-card (position (char input% r) "__23456789TJQKA")
                              (char input% s))
            :into cards
          :finally (return (sort cards #'> :key #'rank)))))

(defun main (input)
  (let* ((cards     (parse input))
         (ranks     (get-ranks cards))
         (suits     (get-suits cards))
         (flush?    (flushp suits))
         (straight? (straightp ranks 5)))
    (cond ((and flush? straight?)
           (if (= 13 (second ranks))
               "RF"
               "SF"))
          (flush?    "FL")
          (straight? "ST")
          (t (let ((4suit (find-4suit suits)))
               (if 4suit
                   (if (4straight-flush-p 4suit cards)
                       "4SF"
                       "4F")
                   (if (straightp ranks 4)
                       "4S"
                       "-")))))))


;;--------------------------------------------------------------------
;; Tests
;;--------------------------------------------------------------------

(defun =>? (got want)
  (assert (string= got want)))

(progn
  (=>? (main "Qs9s3dJd10h") "4S")
  (=>? (main "KdAdJd10dQd") "RF")
  (=>? (main "QhJhKhAh10h") "RF")
  (=>? (main "10dAdJsQdKd") "ST")
  (=>? (main "Kd10dAdJd3d") "FL")
  (=>? (main "4d3d2dAd5d") "SF")
  (=>? (main "5d5d2d3dAd") "FL")
  (=>? (main "4d2sAd5d3d") "ST")
  (=>? (main "As10dJdQdKd") "ST")
  (=>? (main "10d10dQdAsJd") "4F")
  (=>? (main "AcJd10dQdKd") "ST")
  (=>? (main "Kd2sJdAdQd") "4SF")
  (=>? (main "JdAdQcKd2s") "4S")
  (=>? (main "KdAdKdJd2s") "4F")
  (=>? (main "As2dKdQdJd") "4F")
  (=>? (main "AsKdQd2dJh") "4S")
  (=>? (main "QhAd2s3dKd") "-")
  (=>? (main "Ad4dKh3s2d") "4S")
  (=>? (main "3d2dAh5d4s") "ST")
  (=>? (main "QcKdAs2dJd") "4S")
  (=>? (main "2dQcJdAs10d") "-")
  (=>? (main "4d7d5s3c2d") "4S")
  (=>? (main "7d5s4dAd3c") "-")
  (=>? (main "3s8s10sQs6s") "FL")
  (=>? (main "6hAh3h2h8h") "FL")
  (=>? (main "3h4hJh9hQh") "FL")
  (=>? (main "3s6s5s2sQs") "FL")
  (=>? (main "9d3cKdQc2c") "-")
  (=>? (main "5sKs7hQcKh") "-")
  (=>? (main "Ad6d7h7c9h") "-")
  (=>? (main "10h4cAh6s10c") "-")
  (=>? (main "9sKsJcQs10d") "ST")
  (=>? (main "5d3c2cAs4c") "ST")
  (=>? (main "KcQs9c10sJs") "ST")
  (=>? (main "9d8s10hJdQd") "ST")
  (=>? (main "6c5s10h7d4c") "4S")
  (=>? (main "QhJcKsAh8c") "4S")
  (=>? (main "JsQc3h10cKs") "4S")
  (=>? (main "10c9h7hAd8d") "4S")
  (=>? (main "3d4dKd8d5c") "4F")
  (=>? (main "10h3hQh9h2s") "4F")
  (=>? (main "Qh5h7h9h6c") "4F")
  (=>? (main "6s8s7s3sKc") "4F")
  (=>? (main "10h8h9hJhQh") "SF")
  (=>? (main "10h9hQhKhJh") "SF")
  (=>? (main "6d4d7d5d3d") "SF")
  (=>? (main "6h9h7h5h8h") "SF")
  (=>? (main "Ac6s4s3s5s") "4SF")
  (=>? (main "3c9d2c5c4c") "4SF")
  (=>? (main "Kh2sQh10hJh") "4SF")
  (=>? (main "4h5h2h3h4s") "4SF")
  (=>? (main "Js10sAsQsKs") "RF")
  (=>? (main "10dKdQdAdJd") "RF")
  
  ;; from http://qiita.com/cielavenir/items/e7bacd5e658c0723c3d5 by cielavenir
  (=>? (main "2d2h3s4d5c") "4S")
  (=>? (main "2d2h3s4dAc") "4S")
  )


             
;;====================================================================