Download
(defconst poker-ranks '(2 3 4 5 6 7 8 9 10 j q k a))
(defconst poker-suits '(h d s c))
(defconst poker-best-hands
'(
royal-flush
straight-flush
four-of-a-kind
full-house
flush
straight
three-of-a-kind
two-pair
one-pair
))
(defconst poker-debug nil)
(defvar poker-deck '())
(defvar poker-hand '())
(defvar poker-discard-list '())
(defvar poker-game-state 0)
(defun rank-of-card (card)
(first card))
(defun rank-value (rank)
(position rank poker-ranks))
(defun rank-value-of-card (card)
(rank-value (rank-of-card card)))
(defun max-rank (rank1 rank2)
(elt poker-ranks (max (rank-value rank1)
(rank-value rank2))))
(defun card-< (card1 card2)
(<= (rank-value-of-card card1) (rank-value-of-card card2)))
(defun max-card-2 (card1 card2)
(cond
((>= (rank-value-of-card card1) (rank-value-of-card card2)) card1)
(t card2)))
(defun max-card-in-hand (hand)
(cond
((= 1 (length hand)) (car hand))
(t (max-card-2 (car hand) (max-card-in-hand (cdr hand))))))
(defun is-straight (hand)
(cond
((null hand) (error 'null-hand))
((= 1 (length hand)) t)
(t
(let* ((hi-card-1 (max-card-in-hand hand))
(hand-without-hi-card-1 (remove hi-card-1 hand))
(hi-card-2 (max-card-in-hand hand-without-hi-card-1)))
(and (= 1 (- (rank-value-of-card hi-card-1) (rank-value-of-card hi-card-2)))
(is-straight hand-without-hi-card-1))))))
(defun suit (card)
(second card))
(defun eq-suit (card1 card2)
(let ((ret (eq (suit card1) (suit card2))))
(when poker-debug (format "(eq-suit %s %s) => %s\n" card1 card2 ret))
ret))
(defun is-flush (hand)
(cond
((null hand) (error 'null-hand))
((= 1 (length hand)) t)
(t (and (eq-suit (first hand) (second hand))
(is-flush (cdr hand))))))
(defun is-straight-flush (hand)
(and (is-straight hand) (is-flush hand)))
(defun is-royal-flush (hand)
(and (is-straight-flush hand) (equal 'A (rank-of-card (max-card-in-hand hand)))))
(defun get-best-hand (hand)
(dolist (x poker-best-hands)
(let* ((pred-func (intern-soft (concat "is-" (symbol-name x)))))
(when (funcall pred-func hand) (return x)))))
(defun count-ranks (hand)
(let* ((ranks (mapcar #'rank-of-card hand))
(ranks-no-dups (remove-duplicates ranks)))
(mapcar
(lambda (rank) (list rank (count rank ranks)))
ranks-no-dups)))
(defun num-pairs (hand)
(count 2 (count-ranks hand) :key #'second))
(defun is-two-pair (hand)
(= 2 (num-pairs hand)))
(defun is-one-pair (hand)
(= 1 (num-pairs hand)))
(defun is-three-of-a-kind (hand)
(when (find 3 (count-ranks hand) :key #'second) t))
(defun is-four-of-a-kind (hand)
(when (find 4 (count-ranks hand) :key #'second) t))
(defun is-full-house (hand)
(and (is-three-of-a-kind hand) (is-one-pair hand)))
(defun card (rank suit)
(list rank suit))
(defun random-rank ()
(elt poker-ranks (random (length poker-ranks))))
(defun random-suit ()
(elt poker-suits (random (length poker-suits))))
(defun random-card ()
(card (random-rank) (random-suit)))
(defun full-deck ()
(let ((ret '()))
(dolist (suit poker-suits)
(dolist (rank poker-ranks)
(setf ret (cons (card rank suit) ret))))
ret))
(defun random-deck ()
(interactive)
(let* ((ret '())
(random-card '())
(deck (full-deck))
(deck-len (length deck)))
(dotimes (i deck-len)
(setf deck-len (length deck))
(setf random-card-num (random deck-len))
(setf random-card (elt deck (random deck-len)))
(setf deck (remove random-card deck))
(setf ret (cons random-card ret)))
ret))
(defun new-deck! ()
(setf poker-deck (random-deck)))
(defun num-cards-left-in-deck (deck)
(length deck))
(defun take-from-deck! (num)
(let ((ret '()))
(dotimes (i num)
(setf ret (push (pop poker-deck) ret)))
(setf ret (nreverse ret))))
(defun deal-me! (num)
(when (< (num-cards-left-in-deck poker-deck) 5)
(new-deck!))
(setf poker-hand (append poker-hand (take-from-deck! num))))
(defun discard! (list-of-nums)
(when poker-debug (insert (format "list-of-nums = %s\n" list-of-nums)))
(let* ((list-of-cards (mapcar (lambda (x) (elt poker-hand x)) list-of-nums)))
(when poker-debug (insert (format "list-of-cards = %s\n" list-of-cards)))
(dolist (card list-of-cards)
(when poker-debug (insert (format "Discarding: %s\n" card)))
(setf poker-hand (remove card poker-hand))))
poker-hand)
(defun goto-pos (x y)
(goto-line y)
(beginning-of-line)
(forward-char x))
(defun display-card-old (card)
(interactive)
(insert "+---------+")
(forward-line)
(backward-char 11)
(insert (format "| %-2s %1s |" (rank-of-card card) (suit card)))
(forward-line)
(backward-char 11)
(dotimes (i 3)
(insert "| |")
(forward-line)
(backward-char 11))
(insert (format "| %1s %-2s |" (suit card) (rank-of-card card)))
(forward-line)
(backward-char 11)
(insert "+---------+"))
(defun display-card (i)
(let ((card (elt poker-hand i)))
(goto-pos (* i 13) 4) (delete-char 11) (insert "+---------+")
(goto-pos (* i 13) 5) (delete-char 11) (insert (format "| %-2s %1s |" (rank-of-card card) (suit card)))
(dotimes (y 3)
(goto-pos (* i 13) (+ y 6)) (delete-char 11) (insert "| |"))
(goto-pos (* i 13) 9) (delete-char 11) (insert (format "| %1s %2s |" (suit card) (rank-of-card card)))
(goto-pos (* i 13) 10) (delete-char 11) (insert "+---------+")))
(defun mark-for-discard (i)
(goto-pos (* i 13) 4) (delete-char 11) (insert "+---------+")
(dotimes (y 5)
(goto-pos (* i 13) (+ y 5)) (delete-char 11) (insert "|xxxxxxxxx|")))
(defun toggle-card-display (i)
(interactive)
(let ((discarded (find i poker-discard-list)))
(cond
(discarded (display-card i))
(t (mark-for-discard i)))
(setf poker-discard-list (if discarded (remove i poker-discard-list) (cons i poker-discard-list)))))
(defconst poker-mode-map
(let ((map (make-keymap)))
(suppress-keymap map t)
(define-key map "1" '(lambda () (interactive) (toggle-card-display 0)))
(define-key map "2" '(lambda () (interactive) (toggle-card-display 1)))
(define-key map "3" '(lambda () (interactive) (toggle-card-display 2)))
(define-key map "4" '(lambda () (interactive) (toggle-card-display 3)))
(define-key map "5" '(lambda () (interactive) (toggle-card-display 4)))
(define-key map (kbd "RET") '(lambda () (interactive) (discard-and-deal-new)))
map))
(defun poker-mode ()
(interactive)
(kill-all-local-variables)
(use-local-map poker-mode-map)
(setq major-mode 'poker-mode)
(setq mode-name "Poker"))
(defun display-hand (hand)
(interactive)
(dotimes (r 7)
(dotimes (c 68)
(insert " "))
(insert "\n"))
(dolist (card hand)
(display-card (position card hand))))
(defun update-screen()
(erase-buffer)
(insert "\n\n\n")
(display-hand poker-hand)
(goto-char (point-max))
(insert "\n\nYou have: " (symbol-name (get-best-hand poker-hand)) "\n\n")
(when (= poker-game-state 1)
(insert "Choose cards to discard with number keys and then press <Enter> to deal new ones."))
(when (= poker-game-state 2)
(insert "Press <Enter> to deal a new hand.")))
(defun poker-play ()
(interactive)
(switch-to-buffer "poker-poker")
(poker-mode)
(setf poker-deck (full-deck))
(new-deck!)
(setf poker-hand '())
(deal-me! 5)
(setf poker-game-state 1)
(update-screen))
(defun discard-and-deal-new ()
(when (= poker-game-state 2)
(setf poker-discard-list '(0 1 2 3 4)))
(when poker-debug (insert (format "Discard: %s\n" poker-discard-list)))
(discard! poker-discard-list)
(when poker-debug (insert (format "Hand: %s\n" poker-hand)))
(deal-me! (length poker-discard-list))
(when poker-debug (insert (format "Hand: %s\n" poker-hand)))
(setf poker-discard-list '())
(setf poker-game-state (if (= poker-game-state 1) 2 1))
(update-screen))
(provide 'poker)