b1656a023096

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/data/59-cipher.txt	Fri Mar 03 12:56:41 2017 +0000
@@ -0,0 +1,1 @@
+79,59,12,2,79,35,8,28,20,2,3,68,8,9,68,45,0,12,9,67,68,4,7,5,23,27,1,21,79,85,78,79,85,71,38,10,71,27,12,2,79,6,2,8,13,9,1,13,9,8,68,19,7,1,71,56,11,21,11,68,6,3,22,2,14,0,30,79,1,31,6,23,19,10,0,73,79,44,2,79,19,6,28,68,16,6,16,15,79,35,8,11,72,71,14,10,3,79,12,2,79,19,6,28,68,32,0,0,73,79,86,71,39,1,71,24,5,20,79,13,9,79,16,15,10,68,5,10,3,14,1,10,14,1,3,71,24,13,19,7,68,32,0,0,73,79,87,71,39,1,71,12,22,2,14,16,2,11,68,2,25,1,21,22,16,15,6,10,0,79,16,15,10,22,2,79,13,20,65,68,41,0,16,15,6,10,0,79,1,31,6,23,19,28,68,19,7,5,19,79,12,2,79,0,14,11,10,64,27,68,10,14,15,2,65,68,83,79,40,14,9,1,71,6,16,20,10,8,1,79,19,6,28,68,14,1,68,15,6,9,75,79,5,9,11,68,19,7,13,20,79,8,14,9,1,71,8,13,17,10,23,71,3,13,0,7,16,71,27,11,71,10,18,2,29,29,8,1,1,73,79,81,71,59,12,2,79,8,14,8,12,19,79,23,15,6,10,2,28,68,19,7,22,8,26,3,15,79,16,15,10,68,3,14,22,12,1,1,20,28,72,71,14,10,3,79,16,15,10,68,3,14,22,12,1,1,20,28,68,4,14,10,71,1,1,17,10,22,71,10,28,19,6,10,0,26,13,20,7,68,14,27,74,71,89,68,32,0,0,71,28,1,9,27,68,45,0,12,9,79,16,15,10,68,37,14,20,19,6,23,19,79,83,71,27,11,71,27,1,11,3,68,2,25,1,21,22,11,9,10,68,6,13,11,18,27,68,19,7,1,71,3,13,0,7,16,71,28,11,71,27,12,6,27,68,2,25,1,21,22,11,9,10,68,10,6,3,15,27,68,5,10,8,14,10,18,2,79,6,2,12,5,18,28,1,71,0,2,71,7,13,20,79,16,2,28,16,14,2,11,9,22,74,71,87,68,45,0,12,9,79,12,14,2,23,2,3,2,71,24,5,20,79,10,8,27,68,19,7,1,71,3,13,0,7,16,92,79,12,2,79,19,6,28,68,8,1,8,30,79,5,71,24,13,19,1,1,20,28,68,19,0,68,19,7,1,71,3,13,0,7,16,73,79,93,71,59,12,2,79,11,9,10,68,16,7,11,71,6,23,71,27,12,2,79,16,21,26,1,71,3,13,0,7,16,75,79,19,15,0,68,0,6,18,2,28,68,11,6,3,15,27,68,19,0,68,2,25,1,21,22,11,9,10,72,71,24,5,20,79,3,8,6,10,0,79,16,8,79,7,8,2,1,71,6,10,19,0,68,19,7,1,71,24,11,21,3,0,73,79,85,87,79,38,18,27,68,6,3,16,15,0,17,0,7,68,19,7,1,71,24,11,21,3,0,71,24,5,20,79,9,6,11,1,71,27,12,21,0,17,0,7,68,15,6,9,75,79,16,15,10,68,16,0,22,11,11,68,3,6,0,9,72,16,71,29,1,4,0,3,9,6,30,2,79,12,14,2,68,16,7,1,9,79,12,2,79,7,6,2,1,73,79,85,86,79,33,17,10,10,71,6,10,71,7,13,20,79,11,16,1,68,11,14,10,3,79,5,9,11,68,6,2,11,9,8,68,15,6,23,71,0,19,9,79,20,2,0,20,11,10,72,71,7,1,71,24,5,20,79,10,8,27,68,6,12,7,2,31,16,2,11,74,71,94,86,71,45,17,19,79,16,8,79,5,11,3,68,16,7,11,71,13,1,11,6,1,17,10,0,71,7,13,10,79,5,9,11,68,6,12,7,2,31,16,2,11,68,15,6,9,75,79,12,2,79,3,6,25,1,71,27,12,2,79,22,14,8,12,19,79,16,8,79,6,2,12,11,10,10,68,4,7,13,11,11,22,2,1,68,8,9,68,32,0,0,73,79,85,84,79,48,15,10,29,71,14,22,2,79,22,2,13,11,21,1,69,71,59,12,14,28,68,14,28,68,9,0,16,71,14,68,23,7,29,20,6,7,6,3,68,5,6,22,19,7,68,21,10,23,18,3,16,14,1,3,71,9,22,8,2,68,15,26,9,6,1,68,23,14,23,20,6,11,9,79,11,21,79,20,11,14,10,75,79,16,15,6,23,71,29,1,5,6,22,19,7,68,4,0,9,2,28,68,1,29,11,10,79,35,8,11,74,86,91,68,52,0,68,19,7,1,71,56,11,21,11,68,5,10,7,6,2,1,71,7,17,10,14,10,71,14,10,3,79,8,14,25,1,3,79,12,2,29,1,71,0,10,71,10,5,21,27,12,71,14,9,8,1,3,71,26,23,73,79,44,2,79,19,6,28,68,1,26,8,11,79,11,1,79,17,9,9,5,14,3,13,9,8,68,11,0,18,2,79,5,9,11,68,1,14,13,19,7,2,18,3,10,2,28,23,73,79,37,9,11,68,16,10,68,15,14,18,2,79,23,2,10,10,71,7,13,20,79,3,11,0,22,30,67,68,19,7,1,71,8,8,8,29,29,71,0,2,71,27,12,2,79,11,9,3,29,71,60,11,9,79,11,1,79,16,15,10,68,33,14,16,15,10,22,73

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/poker.lisp	Fri Mar 03 12:56:41 2017 +0000
@@ -0,0 +1,138 @@
+(in-package :euler.poker)
+
+;;;; Parsing ------------------------------------------------------------------
+(defun parse-value (char)
+  (switch (char :test #'char=)
+    (#\T 10)
+    (#\J 11)
+    (#\Q 12)
+    (#\K 13)
+    (#\A 14)
+    (t (digit-char-p char))))
+
+(defun parse-suit (char)
+  (eswitch (char :test #'char=)
+    (#\D 'diamonds)
+    (#\S 'spades)
+    (#\H 'hearts)
+    (#\C 'clubs)))
+
+(defun parse-card (card)
+  (list (parse-value (aref card 0))
+        (parse-suit (aref card 1))))
+
+
+;;;; Utils --------------------------------------------------------------------
+(defun emptyp (sequence)
+  (if (listp sequence)
+    (null sequence)
+    (= 0 (length sequence))))
+
+(defun all-equal (sequence &key (test #'eql))
+  (or (emptyp sequence)
+      (not (find (elt sequence 0) sequence :start 1 :test-not test))))
+
+(defun high-card-value (cards)
+  (apply #'max (mapcar #'first cards)))
+
+(defun same-suit-p (cards)
+  (all-equal (mapcar #'second cards)))
+
+(defun run-p (cards)
+  (-<> cards
+    (mapcar #'first <>)
+    (sort <> #'<)
+    (n-grams 2 <>)
+    (mapcar (curry #'apply #'-) <>)
+    (apply #'= -1 <>)))
+
+(defun groupings (cards)
+  (-<> cards
+    (mapcar #'first <>)
+    (equivalence-classes #'= <>)))
+
+(defun pairs (cards)
+  (remove 2 (groupings cards) :key #'length :test-not #'=))
+
+
+;;;; Hand Predicates ----------------------------------------------------------
+;;; These return `nil` if the hand is not of the appropriate type, or a list of
+;;; card values if it is.  E.g. a hand with a 9-high straight would return (10),
+;;; and a full house of 7's and 2's would return (7 2).
+
+(defun royal-flush-p (hand)
+  (when (and (straight-flush-p hand)
+             (member 14 hand :key #'first))
+    (list 14)))
+
+(defun straight-flush-p (hand)
+  (when (and (same-suit-p hand)
+             (run-p hand))
+    (list (high-card-value hand))))
+
+(defun four-of-a-kind-p (hand)
+  (when-let* ((group (find 4 (groupings hand) :key #'length)))
+    (list (first group))))
+
+(defun full-house-p (hand)
+  (let ((groups (groupings hand)))
+    (when (euler::set-equal '(3 2) (mapcar #'length groups))
+      (mapcar #'first groups))))
+
+(defun flush-p (hand)
+  (when (same-suit-p hand)
+    (list (high-card-value hand))))
+
+(defun straight-p (hand)
+  (when (run-p hand)
+    (list (high-card-value hand))))
+
+(defun three-of-a-kind-p (hand)
+  (when-let* ((group (find 3 (groupings hand) :key #'length)))
+    (list (first group))))
+
+(defun two-pair-p (hand)
+  (let ((pairs (pairs hand)))
+    (when (= 2 (length pairs))
+      (sort (mapcar #'first pairs) #'>))))
+
+(defun one-pair-p (hand)
+  (let ((pairs (pairs hand)))
+    (when (= 1 (length pairs))
+      (list (first (first pairs))))))
+
+
+;;;; Hand Comparison ----------------------------------------------------------
+(defun hand-value (hand)
+  (acond
+    ((royal-flush-p hand) (values 9 it))
+    ((straight-flush-p hand) (values 8 it))
+    ((four-of-a-kind-p hand) (values 7 it))
+    ((full-house-p hand) (values 6 it))
+    ((flush-p hand) (values 5 it))
+    ((straight-p hand) (values 4 it))
+    ((three-of-a-kind-p hand) (values 3 it))
+    ((two-pair-p hand) (values 2 it))
+    ((one-pair-p hand) (values 1 it))
+    (t (values 0 (list (high-card-value hand))))))
+
+
+(defun tie-break-p (values-1 values-2)
+  (iterate (for c1 :in (sort (copy-list values-1) #'>))
+           (for c2 :in (sort (copy-list values-2) #'>))
+           (cond ((< c1 c2) (return 2))
+                 ((> c1 c2) (return 1)))))
+
+
+(defun poker-hand-beats-p (hand1 hand2)
+  (multiple-value-bind* (((hand-value-1 components-1) (hand-value hand1))
+                         ((hand-value-2 components-2) (hand-value hand2)))
+    (cond ((< hand-value-1 hand-value-2) nil)
+          ((> hand-value-1 hand-value-2) t)
+          (t (ecase (tie-break-p components-1 components-2)
+               ((1) t)
+               ((2) nil)
+               ((nil) (ecase (tie-break-p (mapcar #'first hand1)
+                                          (mapcar #'first hand2))
+                        ((1) t)
+                        ((2) nil))))))))