# HG changeset patch # User Steve Losh # Date 1488545801 0 # Node ID b1656a023096094ac80dd15d6b8825563d11eb9e # Parent 964ca82e487d75d5bdf83f33abbbfbc630c7083a Add missing files diff -r 964ca82e487d -r b1656a023096 data/59-cipher.txt --- /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 diff -r 964ca82e487d -r b1656a023096 src/poker.lisp --- /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))))))))