527 lines
26 KiB
EmacsLisp
527 lines
26 KiB
EmacsLisp
;;; card-games-cribbage.el --- Cribbage, with pegging and the show -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2026 Corwin Brust
|
|
|
|
;; Author: Corwin Brust <corwin@bru.st>
|
|
;; Maintainer: Corwin Brust <corwin@bru.st>
|
|
;; Version: 1.0.91
|
|
;; Keywords: games
|
|
;; URL: https://code.bru.st/corwin/card-game.el
|
|
|
|
;; This program is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; Two-handed Cribbage to 121, against the computer.
|
|
;;
|
|
;; Each deal you lay two cards away to the crib (which belongs to the
|
|
;; dealer), cut a starter, then play the pegging round -- adding cards
|
|
;; toward 31 and scoring fifteens, pairs, runs, and the go. Then comes
|
|
;; the show, where both hands and the crib are counted for fifteens,
|
|
;; pairs, runs, flushes, and his nobs. The deal alternates.
|
|
;;
|
|
;; Cards use the package cons (SUIT . RANK), RANK 0 (Ace) .. 12 (King);
|
|
;; for counting, an Ace is one, face cards ten, the rest their pip value.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'eieio)
|
|
(require 'card-games-core)
|
|
(require 'card-games-rummy)
|
|
|
|
(defcustom card-games-cribbage-target 121
|
|
"Points needed to win a game of Cribbage."
|
|
:type 'integer :group 'card-games)
|
|
|
|
(defclass card-games-cribbage-game (card-games-game)
|
|
((vname :initform "Cribbage"))
|
|
"A two-handed game of Cribbage.")
|
|
|
|
;;;; Scoring primitives
|
|
|
|
(defun card-games-crib--val (card)
|
|
"Return CARD's counting value (Ace 1, faces 10, else pip)."
|
|
(let ((r (cdr card))) (if (<= r 8) (1+ r) 10)))
|
|
|
|
(defun card-games-crib--count-15s (cards)
|
|
"Return points for all subsets of CARDS summing to fifteen."
|
|
(let ((n (length cards)) (vec (vconcat cards)) (count 0))
|
|
(dotimes (mask (ash 1 n))
|
|
(let ((sum 0))
|
|
(dotimes (i n)
|
|
(when (/= 0 (logand mask (ash 1 i)))
|
|
(setq sum (+ sum (card-games-crib--val (aref vec i))))))
|
|
(when (= sum 15) (setq count (+ count 2)))))
|
|
count))
|
|
|
|
(defun card-games-crib--count-pairs (cards)
|
|
"Return points for all pairs in CARDS."
|
|
(let ((cnt (make-vector 13 0)) (tot 0))
|
|
(dolist (c cards) (aset cnt (cdr c) (1+ (aref cnt (cdr c)))))
|
|
(dotimes (r 13)
|
|
(let ((k (aref cnt r))) (setq tot (+ tot (* k (1- k)))))) ; 2*C(k,2)=k*(k-1)
|
|
tot))
|
|
|
|
(defun card-games-crib--count-runs (cards)
|
|
"Return points for every run of three or more in CARDS (with multiplicity)."
|
|
(let ((cnt (make-vector 13 0)) (total 0) (r 0))
|
|
(dolist (c cards) (aset cnt (cdr c) (1+ (aref cnt (cdr c)))))
|
|
(while (< r 13)
|
|
(if (= 0 (aref cnt r)) (setq r (1+ r))
|
|
(let ((len 0) (mult 1))
|
|
(while (and (< r 13) (> (aref cnt r) 0))
|
|
(setq len (1+ len) mult (* mult (aref cnt r)) r (1+ r)))
|
|
(when (>= len 3) (setq total (+ total (* len mult)))))))
|
|
total))
|
|
|
|
(defun card-games-crib--flush (hand starter is-crib)
|
|
"Return flush points for the four-card HAND with STARTER.
|
|
A crib (IS-CRIB) flush must include the starter."
|
|
(let ((s (car (car hand))))
|
|
(cond ((not (cl-every (lambda (c) (= (car c) s)) hand)) 0)
|
|
((= (car starter) s) 5)
|
|
(is-crib 0)
|
|
(t 4))))
|
|
|
|
(defun card-games-crib--nobs (hand starter)
|
|
"Return 1 when HAND has the Jack of the STARTER's suit, else 0."
|
|
(if (cl-find-if (lambda (c) (and (= (cdr c) 10) (= (car c) (car starter)))) hand)
|
|
1 0))
|
|
|
|
(defun card-games-crib--score-show (hand starter &optional is-crib)
|
|
"Return the show score of the four-card HAND with STARTER.
|
|
IS-CRIB applies the stricter crib flush rule."
|
|
(let ((all (cons starter hand)))
|
|
(+ (card-games-crib--count-15s all)
|
|
(card-games-crib--count-pairs all)
|
|
(card-games-crib--count-runs all)
|
|
(card-games-crib--flush hand starter is-crib)
|
|
(card-games-crib--nobs hand starter))))
|
|
|
|
(defun card-games-crib--peg-score (seq total)
|
|
"Return pegging points for the play whose sequence is SEQ (newest first).
|
|
TOTAL is the running count after the play."
|
|
(let ((pts 0))
|
|
(when (= total 15) (setq pts (+ pts 2)))
|
|
(when (= total 31) (setq pts (+ pts 2)))
|
|
;; pairs: leading same-rank run in SEQ
|
|
(let ((r (cdr (car seq))) (m 0) (lst seq) (stop nil))
|
|
(while (and lst (not stop))
|
|
(if (= (cdr (car lst)) r) (setq m (1+ m) lst (cdr lst)) (setq stop t)))
|
|
(setq pts (+ pts (pcase m (2 2) (3 6) (4 12) (_ 0)))))
|
|
;; runs: largest k>=3 whose last k cards form a consecutive run
|
|
(let ((best 0) (k (length seq)))
|
|
(while (>= k 3)
|
|
(let* ((lastk (cl-subseq seq 0 k))
|
|
(ranks (sort (mapcar #'cdr lastk) #'<)))
|
|
(when (and (= (length ranks) (length (delete-dups (copy-sequence ranks))))
|
|
(= (- (car (last ranks)) (car ranks)) (1- k)))
|
|
(setq best (max best k))))
|
|
(setq k (1- k)))
|
|
(setq pts (+ pts best)))
|
|
pts))
|
|
|
|
;;;; Setup and flow
|
|
|
|
(defsubst card-games-crib--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
|
|
(defsubst card-games-crib--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
|
|
(defsubst card-games-crib--play (game s) "Return seat S's pegging-play cards in GAME." (aref (card-games-get game :play) s))
|
|
(defsubst card-games-crib--set-play (game s v) "Set seat S's pegging-play cards in GAME to V." (aset (card-games-get game :play) s v))
|
|
|
|
(defun card-games-crib--who (s) "Return the display name of seat S." (if (= s 0) "You" "Computer"))
|
|
|
|
(cl-defmethod card-games-crib--deal ((game card-games-cribbage-game))
|
|
"Deal a fresh Cribbage hand into GAME."
|
|
(let ((deck (card-games-rummy-deck)) (hands (make-vector 2 nil)))
|
|
(dotimes (s 2)
|
|
(aset hands s (card-games-rummy-sort-hand (cl-loop repeat 6 collect (pop deck)))))
|
|
(card-games-put game :hands hands)
|
|
(card-games-put game :deck deck)
|
|
(card-games-put game :crib nil)
|
|
(card-games-put game :starter nil)
|
|
(card-games-put game :phase 'discard)
|
|
(card-games-put game :cursor 0)
|
|
(card-games-put game :marks nil)
|
|
(unless (card-games-get game :scores) (card-games-put game :scores (make-vector 2 0)))
|
|
(unless (integerp (card-games-get game :dealer)) (card-games-put game :dealer 1))
|
|
(card-games-put game :message "Discard two cards to the crib: SPC marks, m confirms.")
|
|
game))
|
|
|
|
(defun card-games-crib--add (game s pts)
|
|
"Add PTS to GAME seat S and end the game if it reaches the target."
|
|
(when (> pts 0)
|
|
(aset (card-games-get game :scores) s (+ (aref (card-games-get game :scores) s) pts))
|
|
(when (>= (aref (card-games-get game :scores) s) card-games-cribbage-target)
|
|
(card-games-put game :phase 'game-over)
|
|
(card-games-put game :winner s))))
|
|
|
|
(defun card-games-crib--ai-discard (game s)
|
|
"Return the two cards GAME seat S should lay away (keep the best four)."
|
|
(let* ((hand (card-games-crib--hand game s)) (best nil) (bestv -1))
|
|
(dolist (combo (card-games-rummy--combinations hand 4))
|
|
(let ((v (card-games-crib--score-show combo '(0 . 0)))) ; rough: no starter
|
|
(when (> v bestv) (setq bestv v best combo))))
|
|
(cl-set-difference hand best :test #'equal)))
|
|
|
|
(cl-defmethod card-games-crib--start-play ((game card-games-cribbage-game))
|
|
"Cut GAME's starter and begin the pegging round."
|
|
(let* ((deck (card-games-get game :deck))
|
|
(starter (nth (random (length deck)) deck))
|
|
(dealer (card-games-get game :dealer)))
|
|
(card-games-put game :starter starter)
|
|
(when (= (cdr starter) 10) ; his heels: starter is a Jack
|
|
(card-games-crib--add game dealer 2))
|
|
(card-games-put game :play (vector (card-games-crib--hand game 0) (card-games-crib--hand game 1)))
|
|
(card-games-put game :seq nil)
|
|
(card-games-put game :total 0)
|
|
(card-games-put game :go nil)
|
|
(card-games-put game :last-player nil)
|
|
(card-games-put game :pturn (- 1 dealer)) ; non-dealer leads
|
|
(card-games-put game :phase (if (eq (card-games-get game :phase) 'game-over) 'game-over 'play))
|
|
(card-games-put game :cursor 0)
|
|
(card-games-put game :message
|
|
(format "Pegging: %s leads. Starter is %s."
|
|
(card-games-crib--who (- 1 dealer)) (card-games-rummy-card-string starter)))))
|
|
|
|
(defun card-games-crib--legal (game s)
|
|
"Return GAME seat S's play-cards that fit under 31."
|
|
(cl-remove-if (lambda (c) (> (card-games-crib--val c) (- 31 (card-games-get game :total))))
|
|
(card-games-crib--play game s)))
|
|
|
|
(defun card-games-crib--peg-play (game s card)
|
|
"Have GAME seat S play CARD into the pegging round, pegging any points."
|
|
(card-games-crib--set-play game s (cl-remove card (card-games-crib--play game s) :test #'equal :count 1))
|
|
(card-games-put game :seq (cons card (card-games-get game :seq)))
|
|
(card-games-put game :total (+ (card-games-get game :total) (card-games-crib--val card)))
|
|
(card-games-put game :last-player s)
|
|
(card-games-put game :go nil)
|
|
(let ((pts (card-games-crib--peg-score (card-games-get game :seq) (card-games-get game :total))))
|
|
(card-games-crib--add game s pts)
|
|
(card-games-put game :message
|
|
(format "%s played %s (count %d)%s."
|
|
(card-games-crib--who s) (card-games-rummy-card-string card) (card-games-get game :total)
|
|
(if (> pts 0) (format " for %d" pts) ""))))
|
|
(if (= (card-games-get game :total) 31)
|
|
(card-games-crib--peg-reset game)
|
|
(card-games-put game :pturn (- 1 s))))
|
|
|
|
(defun card-games-crib--peg-reset (game)
|
|
"Reset GAME's running count; the player after the last to play leads."
|
|
(card-games-put game :seq nil)
|
|
(card-games-put game :total 0)
|
|
(card-games-put game :go nil)
|
|
(card-games-put game :pturn (- 1 (card-games-get game :last-player))))
|
|
|
|
(defun card-games-crib--peg-over-p (game)
|
|
"Return non-nil when both GAME players have played out their cards."
|
|
(and (null (card-games-crib--play game 0)) (null (card-games-crib--play game 1))))
|
|
|
|
(defun card-games-crib--peg-go (game s)
|
|
"Handle GAME seat S being unable to play (a go)."
|
|
(let ((other (- 1 s)))
|
|
(if (card-games-crib--legal game other)
|
|
(card-games-put game :pturn other) ; opponent plays on
|
|
;; neither can play: last player pegs one for the go, then reset
|
|
(when (card-games-get game :last-player)
|
|
(card-games-crib--add game (card-games-get game :last-player) 1)
|
|
(card-games-put game :message
|
|
(format "%s pegs 1 for the go." (card-games-crib--who (card-games-get game :last-player)))))
|
|
(card-games-crib--peg-reset game))))
|
|
|
|
(cl-defmethod card-games-crib--ai-play ((game card-games-cribbage-game) s)
|
|
"Have GAME AI seat S play its best pegging card or declare a go."
|
|
(let ((legal (card-games-crib--legal game s)))
|
|
(if (null legal) (card-games-crib--peg-go game s)
|
|
(let ((best (car legal)) (bestv -1))
|
|
(dolist (c legal)
|
|
(let* ((seq (cons c (card-games-get game :seq)))
|
|
(tot (+ (card-games-get game :total) (card-games-crib--val c)))
|
|
(v (card-games-crib--peg-score seq tot)))
|
|
;; prefer points; tie-break toward keeping count off 5 and 21
|
|
(when (or (> v bestv)
|
|
(and (= v bestv) (> (card-games-crib--val c) (card-games-crib--val best))))
|
|
(setq best c bestv v))))
|
|
(card-games-crib--peg-play game s best)))))
|
|
|
|
(defun card-games-crib--peg-advance (game)
|
|
"Run GAME's AI pegging until your turn or the round ends."
|
|
(let ((guard 0))
|
|
(while (and (eq (card-games-get game :phase) 'play) (not (card-games-crib--peg-over-p game))
|
|
(/= (card-games-get game :pturn) 0) (< guard 200))
|
|
(setq guard (1+ guard))
|
|
(card-games-crib--ai-play game (card-games-get game :pturn))))
|
|
;; if it is your turn but you have no legal play, auto-go
|
|
(when (and (eq (card-games-get game :phase) 'play) (not (card-games-crib--peg-over-p game))
|
|
(= (card-games-get game :pturn) 0) (null (card-games-crib--legal game 0)))
|
|
(card-games-crib--peg-go game 0)
|
|
(card-games-crib--peg-advance game))
|
|
(when (and (eq (card-games-get game :phase) 'play) (card-games-crib--peg-over-p game))
|
|
(card-games-crib--show game)))
|
|
|
|
(cl-defmethod card-games-crib--show ((game card-games-cribbage-game))
|
|
"Count GAME's hands and crib, then set up the next deal."
|
|
(let* ((starter (card-games-get game :starter))
|
|
(dealer (card-games-get game :dealer)) (pone (- 1 dealer))
|
|
(h-pone (card-games-crib--hand game pone)) (h-dealer (card-games-crib--hand game dealer))
|
|
(crib (card-games-get game :crib))
|
|
(s-pone (card-games-crib--score-show h-pone starter))
|
|
(s-dealer (card-games-crib--score-show h-dealer starter))
|
|
(s-crib (card-games-crib--score-show crib starter t)))
|
|
;; count in order: non-dealer, dealer, crib (a player may win mid-count)
|
|
(card-games-crib--add game pone s-pone)
|
|
(when (not (eq (card-games-get game :phase) 'game-over)) (card-games-crib--add game dealer s-dealer))
|
|
(when (not (eq (card-games-get game :phase) 'game-over)) (card-games-crib--add game dealer s-crib))
|
|
(card-games-put game :show (list :pone s-pone :dealer s-dealer :crib s-crib))
|
|
(unless (eq (card-games-get game :phase) 'game-over) (card-games-put game :phase 'show))
|
|
(card-games-put game :message
|
|
(format "Show: %s %d, %s %d, crib %d. %s"
|
|
(card-games-crib--who pone) s-pone (card-games-crib--who dealer) s-dealer s-crib
|
|
(if (eq (card-games-get game :phase) 'game-over)
|
|
(format "%s wins! (n: new game)" (card-games-crib--who (card-games-get game :winner)))
|
|
"(n: next deal)")))))
|
|
|
|
;;;; UI
|
|
|
|
(defvar-local card-games-crib--game nil "The Cribbage game in the current buffer.")
|
|
|
|
(defun card-games-crib--svg (game)
|
|
"Return an SVG board for the Cribbage GAME (with a peg-track)."
|
|
(let* ((w card-games-svg-card-width) (h card-games-svg-card-height) (gap card-games-svg-card-gap) (pad 16)
|
|
(phase (card-games-get game :phase)) (scores (card-games-get game :scores))
|
|
(hand (if (eq phase 'play) (card-games-crib--play game 0) (card-games-crib--hand game 0)))
|
|
(n (length hand)) (cursor (card-games-get game :cursor)) (marks (card-games-get game :marks))
|
|
(overlap (cond ((> n 11) (- w 24)) ((> n 8) 20) (t 0)))
|
|
(step (max 14 (- (+ w gap) overlap)))
|
|
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
|
|
(target card-games-cribbage-target) (barw 220) (peg-h 14) (peg-gap 8)
|
|
(y-title 6) (y-peg 26)
|
|
(y-mid (+ y-peg (* 2 (+ peg-h peg-gap)) 18))
|
|
(y-hand (+ y-mid h 44))
|
|
(height (+ y-hand h 30))
|
|
(width (max (+ fanw (* 2 pad)) (+ pad 90 barw 120) 620))
|
|
(svg (svg-create width height))
|
|
(lc (card-games-color 'shadow :foreground "gray50"))
|
|
(regions '()))
|
|
(cl-labels ((txt (str x y &optional sz bold)
|
|
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
|
:font-family card-games-svg-font-family (and bold '(:font-weight "bold"))))
|
|
(card-games-crib--peg (label sc y)
|
|
(txt label pad (+ y 11) 12)
|
|
(let ((bx (+ pad 90)))
|
|
(svg-rectangle svg bx y barw peg-h :rx 4 :fill "none"
|
|
:stroke lc :stroke-width 1)
|
|
(svg-rectangle svg bx y
|
|
(round (* barw (/ (float (min sc target)) target)))
|
|
peg-h :rx 4 :fill "#3aa15a")
|
|
(txt (format "%d" sc) (+ bx barw 8) (+ y 11) 12)))
|
|
(crow (cards x y)
|
|
(let ((xx x))
|
|
(dolist (c cards)
|
|
(let ((sp (card-games-rummy--card-spec c)))
|
|
(card-games-svg-card svg xx y :rank (car sp) :suit (cdr sp)))
|
|
(setq xx (+ xx (round (* w 0.5))))))))
|
|
(txt (format "Cribbage (to %d)" target) pad (+ y-title 12) 13 t)
|
|
(card-games-crib--peg "You" (aref scores 0) y-peg)
|
|
(card-games-crib--peg "Computer" (aref scores 1) (+ y-peg peg-h peg-gap))
|
|
(txt (format "%s deals" (card-games-crib--who (card-games-get game :dealer)))
|
|
(+ pad 90 barw 60) (+ y-peg 11) 11)
|
|
(let ((mx pad))
|
|
(when (card-games-get game :starter)
|
|
(let ((sp (card-games-rummy--card-spec (card-games-get game :starter))))
|
|
(card-games-svg-card svg mx y-mid :rank (car sp) :suit (cdr sp))
|
|
(txt "Starter" mx (+ y-mid h 13) 11)
|
|
(setq mx (+ mx w gap 24))))
|
|
(cond
|
|
((eq phase 'play)
|
|
(txt (format "Count: %d" (card-games-get game :total)) mx (- y-mid 4) 12)
|
|
(crow (reverse (card-games-get game :seq)) mx y-mid))
|
|
((memq phase '(show game-over))
|
|
(when (card-games-get game :crib)
|
|
(txt (format "Crib (%s)" (card-games-crib--who (card-games-get game :dealer))) mx (- y-mid 4) 11)
|
|
(crow (card-games-get game :crib) mx y-mid)))))
|
|
(txt (format "Your %s" (if (eq phase 'play) "cards" "hand")) pad (- y-hand 6) 11)
|
|
(let ((x (max pad (- (/ width 2) (/ fanw 2)))) (i 0))
|
|
(dolist (c hand)
|
|
(let ((sp (card-games-rummy--card-spec c)) (curp (= i cursor))
|
|
(markp (and marks (memq i marks))))
|
|
(card-games-svg-card svg x y-hand :rank (car sp) :suit (cdr sp) :highlight curp)
|
|
(when markp
|
|
(svg-rectangle svg (- x 3) (- y-hand 3) (+ w 6) (+ h 6)
|
|
:rx 8 :fill "none" :stroke "#4a90d9" :stroke-width 3))
|
|
(push (cons (list x y-hand (if (= i (1- n)) w step) h) (cons 'hand i)) regions))
|
|
(setq x (+ x step) i (1+ i))))
|
|
(txt (or (card-games-get game :message) "") pad (- height 8) 12))
|
|
(propertize "*" 'display (card-games-svg-image svg (card-games-scale)) 'card-games-regions (nreverse regions))))
|
|
|
|
(cl-defmethod card-games-render ((game card-games-cribbage-game))
|
|
"Return a depiction of the Cribbage GAME: SVG board if graphical, else text."
|
|
(if (and card-games-rummy-svg-cards (display-graphic-p))
|
|
(card-games-crib--svg game)
|
|
(card-games-crib--render-text game)))
|
|
|
|
(defun card-games-crib--render-text (game)
|
|
"Return a plain-text depiction of the Cribbage GAME."
|
|
(let* ((out '()) (scores (card-games-get game :scores)) (phase (card-games-get game :phase))
|
|
(cursor (card-games-get game :cursor)))
|
|
(push (format " Cribbage to %d\n\n" card-games-cribbage-target) out)
|
|
(push (format " You %d Computer %d %s deals\n\n"
|
|
(aref scores 0) (aref scores 1) (card-games-crib--who (card-games-get game :dealer)))
|
|
out)
|
|
(when (card-games-get game :starter)
|
|
(push (format " Starter: %s\n" (card-games-rummy-card-string (card-games-get game :starter))) out))
|
|
(when (eq phase 'play)
|
|
(push (format " Count: %d\n Played: %s\n" (card-games-get game :total)
|
|
(mapconcat #'card-games-rummy-card-string (reverse (card-games-get game :seq)) " "))
|
|
out))
|
|
(when (memq phase '(show game-over))
|
|
(let ((sh (card-games-get game :show)))
|
|
(when sh
|
|
(push (format " Crib (%s): %s\n"
|
|
(card-games-crib--who (card-games-get game :dealer))
|
|
(mapconcat #'card-games-rummy-card-string (card-games-get game :crib) " ")) out))))
|
|
(let* ((hand (if (eq phase 'play) (card-games-crib--play game 0) (card-games-crib--hand game 0))))
|
|
(push (format "\n Your %s:\n " (if (eq phase 'play) "cards" "hand")) out)
|
|
(push (card-games-rummy--render-cards hand cursor (card-games-get game :marks) nil 'hand) out))
|
|
(push (format "\n\n %s\n" (card-games-get game :message)) out)
|
|
(apply #'concat (nreverse out))))
|
|
|
|
(cl-defmethod card-games-render-apply ((g card-games-cribbage-game) action)
|
|
"Apply a click ACTION on the hand to GAME G."
|
|
(pcase action
|
|
(`(hand . ,i) (card-games-put g :cursor i))
|
|
(_ (cl-call-next-method))))
|
|
|
|
(defun card-games-crib--redisplay ()
|
|
"Redraw the current Cribbage buffer."
|
|
(let ((game card-games-crib--game) (inhibit-read-only t))
|
|
(setq card-games-current-game game card-games-redisplay-function #'card-games-crib--redisplay)
|
|
(setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))
|
|
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
|
|
|
|
(defun card-games-crib--cur-list (g)
|
|
"Return seat 0's current card list in G (pegging plays or hand)."
|
|
(if (eq (card-games-get g :phase) 'play) (card-games-crib--play g 0) (card-games-crib--hand g 0)))
|
|
|
|
(defun card-games-crib-left ()
|
|
"Move the cursor left."
|
|
(interactive)
|
|
(let* ((g card-games-crib--game) (n (length (card-games-crib--cur-list g))))
|
|
(when (> n 0) (card-games-put g :cursor (mod (1- (card-games-get g :cursor)) n)))
|
|
(card-games-crib--redisplay)))
|
|
|
|
(defun card-games-crib-right ()
|
|
"Move the cursor right."
|
|
(interactive)
|
|
(let* ((g card-games-crib--game) (n (length (card-games-crib--cur-list g))))
|
|
(when (> n 0) (card-games-put g :cursor (mod (1+ (card-games-get g :cursor)) n)))
|
|
(card-games-crib--redisplay)))
|
|
|
|
(defun card-games-crib-mark ()
|
|
"Toggle a discard mark on the cursor card (discard phase)."
|
|
(interactive)
|
|
(let* ((g card-games-crib--game) (i (card-games-get g :cursor)) (marks (card-games-get g :marks)))
|
|
(when (eq (card-games-get g :phase) 'discard)
|
|
(card-games-put g :marks (if (memq i marks) (delq i marks)
|
|
(if (>= (length marks) 2) marks (cons i marks)))))
|
|
(card-games-crib--redisplay)))
|
|
|
|
(defun card-games-crib-confirm ()
|
|
"Confirm your two crib discards and start play."
|
|
(interactive)
|
|
(let* ((g card-games-crib--game) (hand (card-games-crib--hand g 0))
|
|
(marks (card-games-get g :marks)))
|
|
(if (or (not (eq (card-games-get g :phase) 'discard)) (/= (length marks) 2))
|
|
(progn (card-games-put g :message "Mark exactly two cards (SPC), then m.")
|
|
(card-games-crib--redisplay))
|
|
(let ((mine (mapcar (lambda (i) (nth i hand)) marks))
|
|
(ai (card-games-crib--ai-discard g 1)))
|
|
(card-games-crib--set-hand g 0 (cl-set-difference hand mine :test #'equal))
|
|
(card-games-crib--set-hand g 1 (cl-set-difference (card-games-crib--hand g 1) ai :test #'equal))
|
|
(card-games-put g :crib (append mine ai))
|
|
(card-games-put g :marks nil) (card-games-put g :cursor 0)
|
|
(card-games-crib--start-play g)
|
|
(card-games-crib--peg-advance g)
|
|
(card-games-crib--redisplay)))))
|
|
|
|
(defun card-games-crib-play ()
|
|
"Play the cursor card in pegging, or declare a go if you cannot."
|
|
(interactive)
|
|
(let* ((g card-games-crib--game))
|
|
(cond
|
|
((not (eq (card-games-get g :phase) 'play)) (card-games-put g :message "Not the pegging round."))
|
|
((/= (card-games-get g :pturn) 0) (card-games-put g :message "Not your turn."))
|
|
((null (card-games-crib--legal g 0))
|
|
(card-games-crib--peg-go g 0) (card-games-crib--peg-advance g))
|
|
(t (let ((card (nth (card-games-get g :cursor) (card-games-crib--play g 0))))
|
|
(if (or (null card) (> (card-games-crib--val card) (- 31 (card-games-get g :total))))
|
|
(card-games-put g :message "That card would go over 31 -- choose another.")
|
|
(card-games-crib--peg-play g 0 card)
|
|
(card-games-put g :cursor 0)
|
|
(card-games-crib--peg-advance g)))))
|
|
(card-games-crib--redisplay)))
|
|
|
|
(defun card-games-crib-new ()
|
|
"Start the next deal, or a new game when one is over."
|
|
(interactive)
|
|
(let ((g card-games-crib--game))
|
|
(when (eq (card-games-get g :phase) 'game-over)
|
|
(card-games-put g :scores (make-vector 2 0)) (card-games-put g :dealer 1))
|
|
(card-games-put g :dealer (- 1 (card-games-get g :dealer))) ; alternate the deal
|
|
(card-games-put g :show nil)
|
|
(card-games-crib--deal g)
|
|
(card-games-crib--redisplay)))
|
|
|
|
(defun card-games-crib-redraw () "Redraw." (interactive) (card-games-crib--redisplay))
|
|
(defun card-games-crib-help () "Describe the controls." (interactive)
|
|
(message "Arrows: choose SPC: mark (discard) m: confirm crib RET: play/go n: next g: redraw"))
|
|
|
|
(defvar card-games-cribbage-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map [mouse-1] #'card-games-card-click)
|
|
(define-key map "+" #'card-games-card-zoom-in)
|
|
(define-key map "=" #'card-games-card-zoom-in)
|
|
(define-key map "-" #'card-games-card-zoom-out)
|
|
(define-key map "0" #'card-games-card-zoom-reset)
|
|
(define-key map (kbd "<left>") #'card-games-crib-left)
|
|
(define-key map (kbd "<right>") #'card-games-crib-right)
|
|
(define-key map (kbd "SPC") #'card-games-crib-mark)
|
|
(define-key map "m" #'card-games-crib-confirm)
|
|
(define-key map (kbd "RET") #'card-games-crib-play)
|
|
(define-key map "n" #'card-games-crib-new)
|
|
(define-key map "g" #'card-games-crib-redraw)
|
|
(define-key map "?" #'card-games-crib-help)
|
|
(define-key map "q" #'card-games-quit-to-menu)
|
|
map)
|
|
"Keymap for `card-games-cribbage-mode'.")
|
|
|
|
(define-derived-mode card-games-cribbage-mode special-mode "Cribbage"
|
|
"Major mode for Cribbage."
|
|
(setq-local truncate-lines t)
|
|
(setq-local cursor-type card-games-cursor-type))
|
|
|
|
;;;###autoload
|
|
(defun card-games-cribbage ()
|
|
"Play two-handed Cribbage against the computer."
|
|
(interactive)
|
|
(let ((buf (get-buffer-create "*Cribbage*")))
|
|
(with-current-buffer buf
|
|
(card-games-cribbage-mode)
|
|
(setq card-games-crib--game (card-games-cribbage-game))
|
|
(card-games-crib--deal card-games-crib--game)
|
|
(card-games-crib--redisplay))
|
|
(switch-to-buffer buf)))
|
|
|
|
(provide 'card-games-cribbage)
|
|
;;; card-games-cribbage.el ends here
|