大貧民, http://qiita.com/Nabetani/items/5c10c132e1f78131563f

2012-11-09-the-poor.lisp

;;;; Last modified: 2013-12-17 20:22:56 tkych


;;====================================================================
;; 大貧民
;;====================================================================
;; - [大貧民 〜 横へな 2012.11.9](http://nabetani.sakura.ne.jp/hena/ord5dahimi/)
;; - [第五回オフラインリアルタイムどう書くの問題](http://qiita.com/Nabetani/items/5c10c132e1f78131563f)


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

(in-package :cl-user)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :split-sequence))
(defpackage :the-poor
  (:use :cl)
  (:import-from :split-sequence :split-sequence))
(in-package :the-poor)


;;--------------------------------------------------------------------
;; Utils
;;--------------------------------------------------------------------

(defun last1 (lst) (first (last lst)))

(defun mappend (fn &rest lists)
  (apply #'append (apply #'mapcar fn lists)))

(defun combination (lst n)
  (labels ((rec (lst n)
             (cond ((zerop n) (list nil))
                   ((= n (length lst)) (list lst))
                   (t (destructuring-bind (x . xs) lst
                        (append (mapcar (lambda (y) (cons x y))
                                        (rec xs (1- n)))
                                (rec xs n)))))))
    (when (<= n (length lst))
      (rec lst n))))


;;--------------------------------------------------------------------
;; Main
;;--------------------------------------------------------------------
;; <card>  ::= (suit . rank)
;; <suit>  ::= #\H, #\D, #\S, #\C, #\J
;; <rank>  ::= <integer: 3 16>
;; <cards> ::= (<card>*), sorted by rank
;; <hand>  ::= <string>, s.t. "H7JoD7"

(defun suit (card) (car card))
(defun rank (card) (cdr card))
(defun make-card (suit rank) (cons suit rank))
(defun jokerp (card) (and card (char= #\J (suit card))))

;; "H7JoD7" -> ((#\J . 16) (#\H . 7) (#\D . 7))
(defun hand->cards (hand)
  (loop :repeat (floor (length hand) 2)
        :for s :from 0 :by 2
        :for r :from 1 :by 2
        :collect (make-card (char hand s)
                            (position (char hand r) "___3456789TJQKA2o"))
          :into cards
        :finally (return (sort cards #'> :key #'rank))))

;; ((#\J . 16) (#\C . 15) (#\H . 14) (#\C . 13) (#\C . 12) (#\C . 10) (#\C . 9))
;; -> "JoC2HACKCQCTC9"
(defun cards->hand (cards)
  (with-output-to-string (out)
    (loop :for (s . r) :in cards
          :do (princ s out)
              (princ (case r
                       (16 #\o) (15 #\2) (14 #\A) (13 #\K)
                       (12 #\Q) (11 #\J) (10 #\T) (t r))
                     out))))

;; ((#\C . 15) (#\H . 15) (#\C . 13) (#\C . 9) (#\S . 9) (#\H . 9))
;; -> (((#\H . 15) (#\C . 15)) ((#\C . 13)) ((#\H . 9) (#\S . 9) (#\C . 9)))
(defun group-same-rank (cards)
  (labels ((rec (cards acc)
             (if (null cards)
                 (nreverse acc)
                 (destructuring-bind (c . cs) cards
                   (destructuring-bind (g . gs) acc
                     (if (= (rank c) (rank (first g)))
                         (rec cs (cons (cons c g) gs))
                         (rec cs (cons (list c) acc))))))))
    (rec (rest cards)
         (list (list (first cards))))))

;; input -> (field-rank . field-num), cards, joker-in-hand?
;; "H7Jo,S3D9CTHJ" -> (7 . 2), ((#\H . 11) (#\C . 10) (#\D . 9) (#\S . 3)), NIL
(defun parse (input)
  (destructuring-bind
      (field-cards hand-cards) (mapcar #'hand->cards (split-sequence #\, input))
    (let ((joker-in-hand? (jokerp (first hand-cards))))
      (values (cons (rank (last1 field-cards)) ; last1 for joker on field
                    (length field-cards))
              (if joker-in-hand? (rest hand-cards) hand-cards)
              joker-in-hand?))))

(defun main (input)
  (multiple-value-bind (field cards joker-in-hand?) (parse input)
    (destructuring-bind (field-rank . field-num) field
      (let ((cards% (remove-if (lambda (c) (<= (rank c) field-rank))
                               cards)))
        (if (= 1 field-num)
            (format nil "~{~A~^,~}"
                    (mapcar #'cards->hand (mapcar #'list cards%)))
            (let ((grouped (group-same-rank cards%)))
              (setf grouped (remove-if (lambda (g)
                                         (if joker-in-hand?
                                             (< (1+ (length g)) field-num)
                                             (< (length g) field-num)))
                                       grouped))
              (when joker-in-hand?
                (setf grouped (mapcar (lambda (g) (cons (make-card #\J 16) g))
                                      grouped)))
              (setf grouped (mappend (lambda (g) (combination g field-num))
                                     grouped))
              (format nil "~{~A~^,~}"
                      (mapcar #'cards->hand grouped))))))))


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

;; (hands-equal "H9D9,H9C9,D9C9,D2C2" "C9H9,H9D9,C2D2,D9C9") => T
;; (hands-equal "-" "-") => T
(defun hands-equal (hands1 hands2)
  (flet ((string-to-cards (hands)
           (mapcar (lambda (hand) (sort (hand->cards hand) #'char> :key #'suit))
                   (split-sequence #\, hands))))
    (null (set-difference (string-to-cards hands1)
                          (string-to-cards hands2)
                          :test #'equal))))

(defun =>? (got expected)
  (assert (hands-equal got expected)))

(progn
  (=>? (main "DJ,") "-")
  (=>? (main "H7,HK") "HK")
  (=>? (main "S3,D4D2") "D4,D2")
  (=>? (main "S9,C8H4") "-")
  (=>? (main "S6,S7STCK") "CK,ST,S7")
  (=>? (main "H4,SAS8CKH6S4") "S8,CK,H6,SA")
  (=>? (main "ST,D6S8JoC7HQHAC2CK") "Jo,C2,CK,HA,HQ")
  (=>? (main "SA,HAD6S8S6D3C4H2C5D4CKHQS7D5") "H2")
  (=>? (main "S2,D8C9D6HQS7H4C6DTS5S6C7HAD4SQ") "-")
  (=>? (main "Jo,HAC8DJSJDTH2") "-")
  (=>? (main "S4Jo,CQS6C9DQH9S2D6S3") "DQCQ,D6S6,H9C9")
  (=>? (main "CTDT,S9C2D9D3JoC6DASJS4") "JoC2,SJJo,DAJo")
  (=>? (main "H3D3,DQS2D6H9HAHTD7S6S7Jo") "JoHA,JoD6,JoH9,D6S6,D7S7,JoS6,HTJo,JoDQ,S2Jo,JoD7,JoS7")
  (=>? (main "D5Jo,CQDAH8C6C9DQH7S2SJCKH5") "CQDQ")
  (=>? (main "C7H7,S7CTH8D5HACQS8JoD6SJS5H4") "HAJo,JoSJ,H8S8,H8Jo,CQJo,CTJo,JoS8")
  (=>? (main "SAHA,S7SKCTS3H9DJHJH7S5H2DKDQS4") "-")
  (=>? (main "JoC8,H6D7C5S9CQH9STDTCAD9S5DAS2CT") "CTDT,H9D9,S9D9,DACA,CTST,H9S9,DTST")
  (=>? (main "HTST,SJHJDJCJJoS3D2") "DJCJ,SJDJ,JoHJ,CJHJ,SJJo,HJSJ,DJJo,JoCJ,JoD2,SJCJ,DJHJ")
  (=>? (main "C7D7,S8D8JoCTDTD4CJ") "D8S8,JoS8,CTJo,DTJo,JoCJ,CTDT,D8Jo")
  (=>? (main "DJSJ,DTDKDQHQJoC2") "JoDK,HQDQ,DQJo,C2Jo,JoHQ")
  (=>? (main "C3H3D3,CKH2DTD5H6S4CJS5C6H5S9CA") "S5H5D5")
  (=>? (main "D8H8S8,CQHJCJJoHQ") "JoCQHQ,JoHJCJ")
  (=>? (main "H6D6S6,H8S8D8C8JoD2H2") "D2H2Jo,D8JoS8,D8S8C8,C8D8H8,JoC8S8,H8JoC8,S8H8C8,JoS8H8,C8JoD8,D8H8S8,D8JoH8")
  (=>? (main "JoD4H4,D3H3S3C3CADASAD2") "DACASA")
  (=>? (main "DJHJSJ,SQDQJoHQCQC2CA") "SQJoCQ,DQCQJo,JoSQHQ,SQCQHQ,DQHQSQ,HQDQCQ,HQDQJo,SQDQCQ,CQJoHQ,SQJoDQ")
  (=>? (main "H3D3Jo,D4SKH6CTS8SAS2CQH4HAC5DADKD9") "HASADA")
  (=>? (main "C3JoH3D3,S2S3H7HQCACTC2CKC6S7H5C7") "-")
  (=>? (main "H5C5S5D5,C7S6D6C3H7HAH6H4C6HQC9") "C6D6S6H6")
  (=>? (main "H7S7C7D7,S5SAH5HAD5DAC5CA") "SADACAHA")
  (=>? (main "D4H4S4C4,S6SAH6HAD6DAC6CAJo") "C6H6S6D6,SAJoDACA,S6H6C6Jo,SACAJoHA,HADASAJo,HADAJoCA,CADAHASA,D6C6JoH6,S6D6C6Jo,H6JoS6D6")
  (=>? (main "DTCTSTHT,S3SQH3HQD3DQC3CQJo") "HQSQJoDQ,SQCQDQJo,DQCQHQJo,SQHQJoCQ,CQDQHQSQ")
  (=>? (main "JoS8D8H8,S9DTH9CTD9STC9CAC2") "H9C9D9S9")
  )

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