corwin/card-game.el
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add nine games: Go Fish, Old Maid, Cribbage, Scopa, Casino,

Browse source 
Euchre, Pitch, Briscola, and Spite & Malice

Five new files, each reusing or extending an existing engine.

* cg-match.el: Go Fish and Old Maid, matching games on a shared
  helper set (completes the original wishlist).
* cg-cribbage.el: two-handed Cribbage to 121 -- the crib, the cut,
  pegging, and a full show scorer (fifteens, pairs, runs, flush, nobs).
* cg-scopa.el: a capture-by-sum engine driving Scopa (40-card, sette
  bello, primiera, scopas) and Casino (pairs and sums, big/little
  casino, aces, sweeps). Casino omits builds.
* cg-trick-ext.el: Euchre (24-card with both bowers), Auction Pitch
  (bid, pitch sets trump, High/Low/Jack/Game), and Briscola (fixed
  trump, no follow), as subclasses of the cg-trick engine.
* cg-spite.el: Spite & Malice, a competitive patience to empty the
  goal pile onto shared Ace-to-Queen centre piles; Kings are wild.

Wire all nine commands into the card-game chooser, extend the Makefile
EL list, and add README sections. Add ten ERT tests covering each
game's engine and a full AI-driven game; the suite is now 107/107 and
every file byte-compiles cleanly.

New files at Version 1.0.60 to match the tree; post-1.0.60 work
toward 1.0.90.
This commit is contained in:
Corwin Brust 2026-06-25 06:31:44 -05:00
parent 86c44a362a
commit 905d5989c2
9 changed files with 2421 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -3,7 +3,7 @@ EMACS ?= emacs
PKG = card-games
VERSION = 1.0.60
# Source files in dependency order (cg-core first).
EL = cg-core.el cg-svg.el cg-render.el cg-net.el cg-bid.el cg-gaps.el cg-bid-ui.el cg-bid-net.el cg-solitaire.el cg-trick.el cg-eights.el cg-patience.el cg-president.el cg-rummy.el cg-rum500.el cg-handfoot.el card-games.el
EL = cg-core.el cg-svg.el cg-render.el cg-net.el cg-bid.el cg-gaps.el cg-bid-ui.el cg-bid-net.el cg-solitaire.el cg-trick.el cg-eights.el cg-patience.el cg-president.el cg-rummy.el cg-rum500.el cg-handfoot.el cg-match.el cg-cribbage.el cg-scopa.el cg-trick-ext.el cg-spite.el card-games.el
ELC = $(EL:.el=.elc)
PKGDESC = $(PKG)-pkg.el
TARDIR = $(PKG)-$(VERSION)

31
README.org
View file

@ -74,6 +74,37 @@ with its command.
and then a foot, build books of a rank with Twos and Jokers wild, and go
out once your side has completed two of them.
** Matching
- ~cg-go-fish~ -- Go Fish. Ask another player for a rank you hold;
collect all four to lay down a book, and make the most books.
- ~cg-old-maid~ -- Old Maid. One Queen is set aside; discard pairs and
draw blind from your neighbour, and do not be left with the odd Queen.
** Pegging
- ~cg-cribbage~ -- Cribbage. Lay two cards to the crib, cut a starter,
peg toward 31, then count fifteens, pairs, runs, flushes, and his nobs.
Two-handed to 121.
** Capturing
- ~cg-scopa~ -- Scopa. A 40-card deck; capture table cards by value and
sweep the board for a scopa. Score cards, coins, the sette bello, and
primiera to 11.
- ~cg-casino~ -- Casino. The full deck; capture by pairs and sums and
score cards, spades, the casinos, and aces to 21.
** More trick-taking
- ~cg-euchre~ -- Euchre. A 24-card deck with the two bowers; order up or
call trump and take three of five tricks. Partnership to 10.
- ~cg-pitch~ -- Auction Pitch. Bid for the pitch; your first lead sets
trump. Score High, Low, Jack, and Game; first to 7.
- ~cg-briscola~ -- Briscola. A fixed trump turned from the deal and no
obligation to follow suit; capture the Aces and Threes. Partnership to
61 of the 120 points.
** Climbing patience
- ~cg-spite~ -- Spite & Malice. Race the computer to empty your goal
pile onto shared centre piles that build Ace to Queen; Kings are wild.
* TODO
- [X] make the suit symbols customizable (~cg-symbols~) and obey them
- [ ] a Texinfo manual

25
card-games.el
View file

@ -52,6 +52,11 @@
(require 'cg-rummy)
(require 'cg-rum500)
(require 'cg-handfoot)
(require 'cg-match)
(require 'cg-cribbage)
(require 'cg-scopa)
(require 'cg-trick-ext)
(require 'cg-spite)
(defvar card-games-list
'(("500 (Bid)" cg-bid
@ -99,7 +104,25 @@
("Rummy 500" cg-rum500
"Rummy: score the cards you lay down; race past 500.")
("Hand & Foot" cg-handfoot
"Rummy: partnership Canasta cousin; build books from hand and foot."))
"Rummy: partnership Canasta cousin; build books from hand and foot.")
("Go Fish" cg-go-fish
"Matching: ask for ranks and collect books of four.")
("Old Maid" cg-old-maid
"Matching: shed pairs and avoid the leftover Queen.")
("Cribbage" cg-cribbage
"Pegging and the show: fifteens, pairs, runs, and his nobs to 121.")
("Scopa" cg-scopa
"Capturing: take table cards by value; sweep for a scopa.")
("Casino" cg-casino
"Capturing: pairs and sums; big and little casino, aces, sweeps.")
("Euchre" cg-euchre
"Trick-taking: 24 cards, bowers, order up; partnership to 10.")
("Pitch" cg-pitch
"Trick-taking: bid, pitch to set trump, score High-Low-Jack-Game.")
("Briscola" cg-briscola
"Trick-taking: fixed trump, no follow; capture the points to 61.")
("Spite & Malice" cg-spite
"Climbing patience: race to empty your goal pile; Kings are wild."))
"Registry of playable games.
Each entry is (NAME COMMAND DESCRIPTION); `card-game' lists them.")

437
cg-cribbage.el Normal file
View file

@ -0,0 +1,437 @@
;;; cg-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.60
;; Package-Requires: ((emacs "26.1"))
;; 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 'cg-core)
(require 'cg-rummy)
(defcustom cg-cribbage-target 121
"Points needed to win a game of Cribbage."
:type 'integer :group 'card-games)
(defclass cg-cribbage-game (cg-game)
((vname :initform "Cribbage"))
"A two-handed game of Cribbage.")
;;;; Scoring primitives
(defun cg-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 cg-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 (cg-crib--val (aref vec i))))))
(when (= sum 15) (setq count (+ count 2)))))
count))
(defun cg-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 cg-crib--count-runs (cards)
"Return points for all runs 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 cg-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 cg-crib--nobs (hand starter)
"Return 1 when HAND holds 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 cg-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)))
(+ (cg-crib--count-15s all)
(cg-crib--count-pairs all)
(cg-crib--count-runs all)
(cg-crib--flush hand starter is-crib)
(cg-crib--nobs hand starter))))
(defun cg-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 cg-crib--hand (game s) (aref (cg-get game :hands) s))
(defsubst cg-crib--set-hand (game s v) (aset (cg-get game :hands) s v))
(defsubst cg-crib--play (game s) (aref (cg-get game :play) s))
(defsubst cg-crib--set-play (game s v) (aset (cg-get game :play) s v))
(defun cg-crib--who (s) (if (= s 0) "You" "Computer"))
(cl-defmethod cg-crib--deal ((game cg-cribbage-game))
"Deal a fresh Cribbage hand into GAME."
(let ((deck (cg-rummy-deck)) (hands (make-vector 2 nil)))
(dotimes (s 2)
(aset hands s (cg-rummy-sort-hand (cl-loop repeat 6 collect (pop deck)))))
(cg-put game :hands hands)
(cg-put game :deck deck)
(cg-put game :crib nil)
(cg-put game :starter nil)
(cg-put game :phase 'discard)
(cg-put game :cursor 0)
(cg-put game :marks nil)
(unless (cg-get game :scores) (cg-put game :scores (make-vector 2 0)))
(unless (integerp (cg-get game :dealer)) (cg-put game :dealer 1))
(cg-put game :message "Discard two cards to the crib: SPC marks, m confirms.")
game))
(defun cg-crib--add (game s pts)
"Add PTS to seat S and end the game if it reaches the target."
(when (> pts 0)
(aset (cg-get game :scores) s (+ (aref (cg-get game :scores) s) pts))
(when (>= (aref (cg-get game :scores) s) cg-cribbage-target)
(cg-put game :phase 'game-over)
(cg-put game :winner s))))
(defun cg-crib--ai-discard (game s)
"Return the two cards seat S should lay away (keep the best four)."
(let* ((hand (cg-crib--hand game s)) (best nil) (bestv -1))
(dolist (combo (cg-rummy--combinations hand 4))
(let ((v (cg-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 cg-crib--start-play ((game cg-cribbage-game))
"Cut the starter and begin the pegging round."
(let* ((deck (cg-get game :deck))
(starter (nth (random (length deck)) deck))
(dealer (cg-get game :dealer)))
(cg-put game :starter starter)
(when (= (cdr starter) 10) ; his heels: starter is a Jack
(cg-crib--add game dealer 2))
(cg-put game :play (vector (cg-crib--hand game 0) (cg-crib--hand game 1)))
(cg-put game :seq nil)
(cg-put game :total 0)
(cg-put game :go nil)
(cg-put game :last-player nil)
(cg-put game :pturn (- 1 dealer)) ; non-dealer leads
(cg-put game :phase (if (eq (cg-get game :phase) 'game-over) 'game-over 'play))
(cg-put game :cursor 0)
(cg-put game :message
(format "Pegging: %s leads. Starter is %s."
(cg-crib--who (- 1 dealer)) (cg-rummy-card-string starter)))))
(defun cg-crib--legal (game s)
"Return seat S's play-cards that fit under 31."
(cl-remove-if (lambda (c) (> (cg-crib--val c) (- 31 (cg-get game :total))))
(cg-crib--play game s)))
(defun cg-crib--peg-play (game s card)
"Seat S plays CARD into the pegging round and pegs any points."
(cg-crib--set-play game s (cl-remove card (cg-crib--play game s) :test #'equal :count 1))
(cg-put game :seq (cons card (cg-get game :seq)))
(cg-put game :total (+ (cg-get game :total) (cg-crib--val card)))
(cg-put game :last-player s)
(cg-put game :go nil)
(let ((pts (cg-crib--peg-score (cg-get game :seq) (cg-get game :total))))
(cg-crib--add game s pts)
(cg-put game :message
(format "%s played %s (count %d)%s."
(cg-crib--who s) (cg-rummy-card-string card) (cg-get game :total)
(if (> pts 0) (format " for %d" pts) ""))))
(if (= (cg-get game :total) 31)
(cg-crib--peg-reset game)
(cg-put game :pturn (- 1 s))))
(defun cg-crib--peg-reset (game)
"Reset the running count; the player after the last to play leads."
(cg-put game :seq nil)
(cg-put game :total 0)
(cg-put game :go nil)
(cg-put game :pturn (- 1 (cg-get game :last-player))))
(defun cg-crib--peg-over-p (game)
"Return non-nil when both players have played out their cards."
(and (null (cg-crib--play game 0)) (null (cg-crib--play game 1))))
(defun cg-crib--peg-go (game s)
"Handle seat S being unable to play (a go)."
(let ((other (- 1 s)))
(if (cg-crib--legal game other)
(cg-put game :pturn other) ; opponent plays on
;; neither can play: last player pegs one for the go, then reset
(when (cg-get game :last-player)
(cg-crib--add game (cg-get game :last-player) 1)
(cg-put game :message
(format "%s pegs 1 for the go." (cg-crib--who (cg-get game :last-player)))))
(cg-crib--peg-reset game))))
(cl-defmethod cg-crib--ai-play ((game cg-cribbage-game) s)
"Have AI seat S either play its best pegging card or declare a go."
(let ((legal (cg-crib--legal game s)))
(if (null legal) (cg-crib--peg-go game s)
(let ((best (car legal)) (bestv -1))
(dolist (c legal)
(let* ((seq (cons c (cg-get game :seq)))
(tot (+ (cg-get game :total) (cg-crib--val c)))
(v (cg-crib--peg-score seq tot)))
;; prefer points; tie-break toward keeping count off 5 and 21
(when (or (> v bestv)
(and (= v bestv) (> (cg-crib--val c) (cg-crib--val best))))
(setq best c bestv v))))
(cg-crib--peg-play game s best)))))
(defun cg-crib--peg-advance (game)
"Run AI pegging turns until it is your turn or the round ends."
(let ((guard 0))
(while (and (eq (cg-get game :phase) 'play) (not (cg-crib--peg-over-p game))
(/= (cg-get game :pturn) 0) (< guard 200))
(setq guard (1+ guard))
(cg-crib--ai-play game (cg-get game :pturn))))
;; if it is your turn but you have no legal play, auto-go
(when (and (eq (cg-get game :phase) 'play) (not (cg-crib--peg-over-p game))
(= (cg-get game :pturn) 0) (null (cg-crib--legal game 0)))
(cg-crib--peg-go game 0)
(cg-crib--peg-advance game))
(when (and (eq (cg-get game :phase) 'play) (cg-crib--peg-over-p game))
(cg-crib--show game)))
(cl-defmethod cg-crib--show ((game cg-cribbage-game))
"Count the hands and the crib, then set up the next deal."
(let* ((starter (cg-get game :starter))
(dealer (cg-get game :dealer)) (pone (- 1 dealer))
(h-pone (cg-crib--hand game pone)) (h-dealer (cg-crib--hand game dealer))
(crib (cg-get game :crib))
(s-pone (cg-crib--score-show h-pone starter))
(s-dealer (cg-crib--score-show h-dealer starter))
(s-crib (cg-crib--score-show crib starter t)))
;; count in order: non-dealer, dealer, crib (a player may win mid-count)
(cg-crib--add game pone s-pone)
(when (not (eq (cg-get game :phase) 'game-over)) (cg-crib--add game dealer s-dealer))
(when (not (eq (cg-get game :phase) 'game-over)) (cg-crib--add game dealer s-crib))
(cg-put game :show (list :pone s-pone :dealer s-dealer :crib s-crib))
(unless (eq (cg-get game :phase) 'game-over) (cg-put game :phase 'show))
(cg-put game :message
(format "Show: %s %d, %s %d, crib %d. %s"
(cg-crib--who pone) s-pone (cg-crib--who dealer) s-dealer s-crib
(if (eq (cg-get game :phase) 'game-over)
(format "%s wins! (n: new game)" (cg-crib--who (cg-get game :winner)))
"(n: next deal)")))))
;;;; UI
(defvar-local cg-crib--game nil "The Cribbage game in the current buffer.")
(cl-defmethod cg-render ((game cg-cribbage-game))
"Return a propertized depiction of the Cribbage GAME."
(let* ((out '()) (scores (cg-get game :scores)) (phase (cg-get game :phase))
(cursor (cg-get game :cursor)))
(push (format " Cribbage to %d\n\n" cg-cribbage-target) out)
(push (format " You %d Computer %d %s deals\n\n"
(aref scores 0) (aref scores 1) (cg-crib--who (cg-get game :dealer)))
out)
(when (cg-get game :starter)
(push (format " Starter: %s\n" (cg-rummy-card-string (cg-get game :starter))) out))
(when (eq phase 'play)
(push (format " Count: %d\n Played: %s\n" (cg-get game :total)
(mapconcat #'cg-rummy-card-string (reverse (cg-get game :seq)) " "))
out))
(when (memq phase '(show game-over))
(let ((sh (cg-get game :show)))
(when sh
(push (format " Crib (%s): %s\n"
(cg-crib--who (cg-get game :dealer))
(mapconcat #'cg-rummy-card-string (cg-get game :crib) " ")) out))))
(let* ((hand (if (eq phase 'play) (cg-crib--play game 0) (cg-crib--hand game 0))))
(push (format "\n Your %s:\n " (if (eq phase 'play) "cards" "hand")) out)
(push (cg-rummy--render-cards hand cursor (cg-get game :marks)) out))
(push (format "\n\n %s\n" (cg-get game :message)) out)
(apply #'concat (nreverse out))))
(defun cg-crib--redisplay ()
(let ((game cg-crib--game) (inhibit-read-only t))
(setq-local mode-line-process (format " [%s]" (cg-get game :phase)))
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
(defun cg-crib--cur-list (g)
(if (eq (cg-get g :phase) 'play) (cg-crib--play g 0) (cg-crib--hand g 0)))
(defun cg-crib-left ()
"Move the cursor left."
(interactive)
(let* ((g cg-crib--game) (n (length (cg-crib--cur-list g))))
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n)))
(cg-crib--redisplay)))
(defun cg-crib-right ()
"Move the cursor right."
(interactive)
(let* ((g cg-crib--game) (n (length (cg-crib--cur-list g))))
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n)))
(cg-crib--redisplay)))
(defun cg-crib-mark ()
"Toggle a discard mark on the cursor card (discard phase)."
(interactive)
(let* ((g cg-crib--game) (i (cg-get g :cursor)) (marks (cg-get g :marks)))
(when (eq (cg-get g :phase) 'discard)
(cg-put g :marks (if (memq i marks) (delq i marks)
(if (>= (length marks) 2) marks (cons i marks)))))
(cg-crib--redisplay)))
(defun cg-crib-confirm ()
"Confirm your two crib discards and start play."
(interactive)
(let* ((g cg-crib--game) (hand (cg-crib--hand g 0))
(marks (cg-get g :marks)))
(if (or (not (eq (cg-get g :phase) 'discard)) (/= (length marks) 2))
(progn (cg-put g :message "Mark exactly two cards (SPC), then m.")
(cg-crib--redisplay))
(let ((mine (mapcar (lambda (i) (nth i hand)) marks))
(ai (cg-crib--ai-discard g 1)))
(cg-crib--set-hand g 0 (cl-set-difference hand mine :test #'equal))
(cg-crib--set-hand g 1 (cl-set-difference (cg-crib--hand g 1) ai :test #'equal))
(cg-put g :crib (append mine ai))
(cg-put g :marks nil) (cg-put g :cursor 0)
(cg-crib--start-play g)
(cg-crib--peg-advance g)
(cg-crib--redisplay)))))
(defun cg-crib-play ()
"Play the cursor card in pegging, or declare a go if you cannot."
(interactive)
(let* ((g cg-crib--game))
(cond
((not (eq (cg-get g :phase) 'play)) (cg-put g :message "Not the pegging round."))
((/= (cg-get g :pturn) 0) (cg-put g :message "Not your turn."))
((null (cg-crib--legal g 0))
(cg-crib--peg-go g 0) (cg-crib--peg-advance g))
(t (let ((card (nth (cg-get g :cursor) (cg-crib--play g 0))))
(if (or (null card) (> (cg-crib--val card) (- 31 (cg-get g :total))))
(cg-put g :message "That card would go over 31 -- choose another.")
(cg-crib--peg-play g 0 card)
(cg-put g :cursor 0)
(cg-crib--peg-advance g)))))
(cg-crib--redisplay)))
(defun cg-crib-new ()
"Start the next deal, or a new game when one is over."
(interactive)
(let ((g cg-crib--game))
(when (eq (cg-get g :phase) 'game-over)
(cg-put g :scores (make-vector 2 0)) (cg-put g :dealer 1))
(cg-put g :dealer (- 1 (cg-get g :dealer))) ; alternate the deal
(cg-put g :show nil)
(cg-crib--deal g)
(cg-crib--redisplay)))
(defun cg-crib-redraw () "Redraw." (interactive) (cg-crib--redisplay))
(defun cg-crib-help () "Describe the controls." (interactive)
(message "Arrows: choose SPC: mark (discard) m: confirm crib RET: play/go n: next g: redraw"))
(defvar cg-cribbage-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "<left>") #'cg-crib-left)
(define-key map (kbd "<right>") #'cg-crib-right)
(define-key map (kbd "SPC") #'cg-crib-mark)
(define-key map "m" #'cg-crib-confirm)
(define-key map (kbd "RET") #'cg-crib-play)
(define-key map "n" #'cg-crib-new)
(define-key map "g" #'cg-crib-redraw)
(define-key map "?" #'cg-crib-help)
map)
"Keymap for `cg-cribbage-mode'.")
(define-derived-mode cg-cribbage-mode special-mode "Cribbage"
"Major mode for Cribbage."
(setq-local truncate-lines t))
;;;###autoload
(defun cg-cribbage ()
"Play two-handed Cribbage against the computer."
(interactive)
(let ((buf (get-buffer-create "*Cribbage*")))
(with-current-buffer buf
(cg-cribbage-mode)
(setq cg-crib--game (cg-cribbage-game))
(cg-crib--deal cg-crib--game)
(cg-crib--redisplay))
(switch-to-buffer buf)))
(provide 'cg-cribbage)
;;; cg-cribbage.el ends here

481
cg-match.el Normal file
View file

@ -0,0 +1,481 @@
;;; cg-match.el --- Go Fish and Old Maid -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Corwin Brust
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; 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 children's classics that turn on matching ranks rather than melding.
;;
;; `cg-go-fish' -- Go Fish. On your turn ask another player for a rank
;; you already hold; collect all four of a rank to lay down a book.
;; Whoever lays down the most books wins.
;; `cg-old-maid' -- Old Maid. One Queen is removed, so one stays
;; unpaired. Discard pairs, then draw blind from your neighbour; do
;; not be the one left holding the odd Queen.
;;
;; You are the first player; the rest are computer opponents. Cards use
;; the package cons (SUIT . RANK), RANK 0 (Ace) .. 12 (King).
;;; Code:
(require 'cl-lib)
(require 'eieio)
(require 'cg-core)
(require 'cg-rummy)
;;;; Go Fish
(defcustom cg-go-fish-players 3
"Number of players in Go Fish, including you (2-5)."
:type '(choice (const 2) (const 3) (const 4) (const 5)) :group 'card-games)
(defclass cg-go-fish-game (cg-game)
((vname :initform "Go Fish"))
"A game of Go Fish.")
(defsubst cg-gf--hand (game s) (aref (cg-get game :hands) s))
(defsubst cg-gf--set-hand (game s v) (aset (cg-get game :hands) s v))
(defun cg-gf--books (game s) (aref (cg-get game :books) s))
(defun cg-gf--rank-count (hand rank)
"Return how many cards of RANK are in HAND."
(cl-count rank hand :key #'cdr))
(defun cg-gf--check-books (game s)
"Lay down any completed four-of-a-kind books from seat S's hand."
(dotimes (r 13)
(when (>= (cg-gf--rank-count (cg-gf--hand game s) r) 4)
(cg-gf--set-hand game s (cl-remove r (cg-gf--hand game s) :key #'cdr))
(aset (cg-get game :books) s (1+ (aref (cg-get game :books) s))))))
(cl-defmethod cg-gf--deal ((game cg-go-fish-game))
"Deal a fresh Go Fish game into GAME."
(let* ((n (max 2 (min 5 cg-go-fish-players)))
(deck (cg-rummy-deck)) (per (if (<= n 3) 7 5))
(hands (make-vector n nil)))
(dotimes (s n) (aset hands s (cl-loop repeat per collect (pop deck))))
(cg-put game :hands hands)
(cg-put game :books (make-vector n 0))
(cg-put game :nplayers n)
(cg-put game :stock deck)
(cg-put game :turn 0)
(cg-put game :phase 'play)
(cg-put game :cursor 0)
(dotimes (s n)
(cg-gf--set-hand game s (cg-rummy-sort-hand (cg-gf--hand game s)))
(cg-gf--check-books game s))
(cg-put game :message "Pick a card, then press 1-4 to ask that player for its rank.")
game))
(defun cg-gf--draw (game s)
"Draw one stock card into seat S's hand. Return it, or nil if empty."
(let ((stock (cg-get game :stock)))
(when stock
(cg-gf--set-hand game s (cg-rummy-sort-hand (cons (car stock) (cg-gf--hand game s))))
(cg-put game :stock (cdr stock))
(car stock))))
(defun cg-gf--total-books (game)
(let ((sum 0)) (dotimes (s (cg-get game :nplayers))
(setq sum (+ sum (cg-gf--books game s))))
sum))
(defun cg-gf--maybe-over (game)
"End the game when all thirteen books are made."
(when (>= (cg-gf--total-books game) 13)
(let ((best 0))
(dotimes (s (cg-get game :nplayers))
(when (> (cg-gf--books game s) (cg-gf--books game best)) (setq best s)))
(cg-put game :phase 'game-over)
(cg-put game :winner best)
(cg-put game :message
(format "Game over. %s wins with %d books! (n: new game)"
(cg-gf--who best) (cg-gf--books game best))))))
(defun cg-gf--who (s) (if (= s 0) "You" (format "Player %d" s)))
(cl-defmethod cg-gf--ask ((game cg-go-fish-game) asker target rank)
"ASKER asks TARGET for RANK. Return non-nil if ASKER keeps the turn."
(let* ((got (cl-remove-if-not (lambda (c) (= (cdr c) rank)) (cg-gf--hand game target)))
(keep nil))
(if got
(progn
(cg-gf--set-hand game target (cl-remove rank (cg-gf--hand game target) :key #'cdr))
(cg-gf--set-hand game asker
(cg-rummy-sort-hand (append got (cg-gf--hand game asker))))
(cg-put game :message
(format "%s took %d %s%s from %s."
(cg-gf--who asker) (length got)
(aref cg-rummy-ranks rank) (if (> (length got) 1) "s" "")
(cg-gf--who target)))
(setq keep t))
;; go fish
(let ((drawn (cg-gf--draw game asker)))
(cg-put game :message
(format "%s asked %s for %ss -- go fish!%s"
(cg-gf--who asker) (cg-gf--who target) (aref cg-rummy-ranks rank)
(cond ((null drawn) " (stock empty)")
((= (cdr drawn) rank) " Fished it -- go again!")
(t ""))))
(when (and drawn (= (cdr drawn) rank)) (setq keep t))))
(cg-gf--check-books game asker)
;; refill an empty hand from the stock if possible
(when (and (null (cg-gf--hand game asker)) (cg-get game :stock))
(cg-gf--draw game asker))
(cg-gf--maybe-over game)
(when (and (eq (cg-get game :phase) 'play) (not keep))
(cg-put game :turn (cg-gf--next game asker)))
keep))
(defun cg-gf--next (game s)
"Return the next seat after S that still has cards (or stock to draw)."
(let ((n (cg-get game :nplayers)) (i (mod (1+ s) (cg-get game :nplayers))) (tries 0))
(while (and (< tries n) (null (cg-gf--hand game i)) (null (cg-get game :stock)))
(setq i (mod (1+ i) n) tries (1+ tries)))
i))
(defun cg-gf--start-turn (game s)
"Ready seat S to act: draw up if empty; pass the turn if it cannot ask.
Return non-nil when S can ask."
(when (and (null (cg-gf--hand game s)) (cg-get game :stock))
(cg-gf--draw game s))
(cg-gf--maybe-over game)
(cond ((not (eq (cg-get game :phase) 'play)) nil)
((cg-gf--hand game s) t)
(t (cg-put game :turn (cg-gf--next game s)) nil)))
(cl-defmethod cg-gf--ai-turn ((game cg-go-fish-game) s)
"Take seat S's whole AI turn (it may keep asking)."
(when (cg-gf--start-turn game s)
(let ((guard 0))
(while (and (= (cg-get game :turn) s) (eq (cg-get game :phase) 'play)
(cg-gf--hand game s) (< guard 40))
(setq guard (1+ guard))
(let* ((hand (cg-gf--hand game s))
(counts (make-vector 13 0)) (rank (cdr (car hand))))
(dolist (c hand) (aset counts (cdr c) (1+ (aref counts (cdr c)))))
(dotimes (r 13) (when (> (aref counts r) (aref counts rank)) (setq rank r)))
(let* ((others (cl-loop for o below (cg-get game :nplayers)
unless (= o s) when (cg-gf--hand game o) collect o))
(target (and others (nth (random (length others)) others))))
(if target (cg-gf--ask game s target rank)
(cg-put game :turn (cg-gf--next game s)))))))))
(defun cg-gf--run (game)
"Advance AI seats until it is your turn or the game ends."
(let ((guard 0))
(while (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0) (< guard 1000))
(setq guard (1+ guard))
(cg-gf--ai-turn game (cg-get game :turn))))
(when (and (eq (cg-get game :phase) 'play) (= (cg-get game :turn) 0))
(unless (cg-gf--start-turn game 0)
(when (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0))
(cg-gf--run game)))))
;;;; Go Fish UI
(defvar-local cg-gf--game nil "The Go Fish game in the current buffer.")
(cl-defmethod cg-render ((game cg-go-fish-game))
"Return a propertized depiction of the Go Fish GAME."
(let* ((out '()) (hand (cg-gf--hand game 0)) (cursor (cg-get game :cursor)))
(push " Go Fish\n\n" out)
(dotimes (s (cg-get game :nplayers))
(unless (= s 0)
(push (format " Player %d: %d cards books %d\n"
s (length (cg-gf--hand game s)) (cg-gf--books game s)) out)))
(push (format "\n Stock: %d Your books: %d\n\n"
(length (cg-get game :stock)) (cg-gf--books game 0)) out)
(push " Your hand:\n " out)
(push (cg-rummy--render-cards hand cursor nil) out)
(push (format "\n\n %s\n" (cg-get game :message)) out)
(apply #'concat (nreverse out))))
(defun cg-gf--redisplay ()
(let ((game cg-gf--game) (inhibit-read-only t))
(setq-local mode-line-process (format " [%s]" (cg-get game :phase)))
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
(defun cg-gf-left ()
"Move the hand cursor left."
(interactive)
(let* ((g cg-gf--game) (n (length (cg-gf--hand g 0))))
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n)))
(cg-gf--redisplay)))
(defun cg-gf-right ()
"Move the hand cursor right."
(interactive)
(let* ((g cg-gf--game) (n (length (cg-gf--hand g 0))))
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n)))
(cg-gf--redisplay)))
(defun cg-gf-ask ()
"Ask the player whose number you pressed for the cursor card's rank."
(interactive)
(let* ((g cg-gf--game)
(target (- last-command-event ?0))
(card (nth (cg-get g :cursor) (cg-gf--hand g 0))))
(cond
((not (eq (cg-get g :phase) 'play)) (cg-put g :message "Press n for a new game."))
((/= (cg-get g :turn) 0) (cg-put g :message "Not your turn."))
((null card) (cg-put g :message "Pick a card first."))
((or (< target 1) (>= target (cg-get g :nplayers)))
(cg-put g :message "No such player to ask."))
((null (cg-gf--hand g target)) (cg-put g :message "That player has no cards."))
(t (cg-gf--ask g 0 target (cdr card))
(cg-put g :cursor 0)
(unless (= (cg-get g :turn) 0) (cg-gf--run g))))
(cg-gf--redisplay)))
(defun cg-gf-new () "Deal a new Go Fish game." (interactive)
(cg-gf--deal cg-gf--game) (cg-gf--redisplay))
(defun cg-gf-redraw () "Redraw." (interactive) (cg-gf--redisplay))
(defun cg-gf-help () "Describe the controls." (interactive)
(message "Arrows: choose a rank 1-4: ask that player n: new g: redraw"))
(defvar cg-go-fish-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "<left>") #'cg-gf-left)
(define-key map (kbd "<right>") #'cg-gf-right)
(dolist (k '("1" "2" "3" "4")) (define-key map k #'cg-gf-ask))
(define-key map "n" #'cg-gf-new)
(define-key map "g" #'cg-gf-redraw)
(define-key map "?" #'cg-gf-help)
map)
"Keymap for `cg-go-fish-mode'.")
(define-derived-mode cg-go-fish-mode special-mode "GoFish"
"Major mode for Go Fish."
(setq-local truncate-lines t))
;;;###autoload
(defun cg-go-fish ()
"Play Go Fish against the computer."
(interactive)
(let ((buf (get-buffer-create "*Go Fish*")))
(with-current-buffer buf
(cg-go-fish-mode)
(setq cg-gf--game (cg-go-fish-game))
(cg-gf--deal cg-gf--game)
(cg-gf--redisplay))
(switch-to-buffer buf)))
;;;; Old Maid
(defcustom cg-old-maid-players 3
"Number of players in Old Maid, including you (2-5)."
:type '(choice (const 2) (const 3) (const 4) (const 5)) :group 'card-games)
(defclass cg-old-maid-game (cg-game)
((vname :initform "Old Maid"))
"A game of Old Maid.")
(defsubst cg-om--hand (game s) (aref (cg-get game :hands) s))
(defsubst cg-om--set-hand (game s v) (aset (cg-get game :hands) s v))
(defun cg-om--discard-pairs (hand)
"Return HAND with every matched pair of ranks removed."
(let ((out '()) (byrank (make-hash-table :test 'eql)))
(dolist (c hand) (push c (gethash (cdr c) byrank)))
(maphash (lambda (_r cs)
(when (cl-oddp (length cs)) (push (car cs) out)))
byrank)
(cg-rummy-sort-hand out)))
(cl-defmethod cg-om--deal ((game cg-old-maid-game))
"Deal a fresh Old Maid game into GAME (one Queen removed)."
(let* ((n (max 2 (min 5 cg-old-maid-players)))
(deck (cl-remove (cons 0 11) (cg-rummy-deck) :test #'equal :count 1))
(hands (make-vector n nil)) (i 0))
(dolist (c deck)
(aset hands i (cons c (aref hands i)))
(setq i (mod (1+ i) n)))
(dotimes (s n) (aset hands s (cg-om--discard-pairs (aref hands s))))
(cg-put game :hands hands)
(cg-put game :nplayers n)
(cg-put game :turn 0)
(cg-put game :phase 'play)
(cg-put game :pick 0)
(cg-put game :message "Draw a card from the next player: arrows pick, RET draws.")
(cg-om--skip-empty game)
game))
(defun cg-om--active (game)
"Return the list of seats still holding cards."
(cl-loop for s below (cg-get game :nplayers)
when (cg-om--hand game s) collect s))
(defun cg-om--target (game s)
"Return the next active seat after S to draw from."
(let ((n (cg-get game :nplayers)) (i (mod (1+ s) (cg-get game :nplayers))) (tries 0))
(while (and (< tries n) (or (= i s) (null (cg-om--hand game i))))
(setq i (mod (1+ i) n) tries (1+ tries)))
(and (cg-om--hand game i) i)))
(defun cg-om--skip-empty (game)
"Advance the turn past any seat that has run out of cards."
(let ((n (cg-get game :nplayers)) (tries 0))
(while (and (< tries n) (null (cg-om--hand game (cg-get game :turn))))
(cg-put game :turn (mod (1+ (cg-get game :turn)) n))
(setq tries (1+ tries)))))
(defun cg-om--total (game)
(let ((sum 0)) (dotimes (s (cg-get game :nplayers))
(setq sum (+ sum (length (cg-om--hand game s)))))
sum))
(cl-defmethod cg-om--draw ((game cg-old-maid-game) drawer idx)
"DRAWER takes card IDX from the next active hand, then discards a pair."
(let ((target (cg-om--target game drawer)))
(when target
(let* ((thand (cg-om--hand game target))
(card (nth (min idx (1- (length thand))) thand)))
(cg-om--set-hand game target (cl-remove card thand :test #'equal :count 1))
(cg-om--set-hand game drawer
(cg-om--discard-pairs (cons card (cg-om--hand game drawer))))
(cg-put game :message
(format "%s drew from %s."
(if (= drawer 0) "You" (format "Player %d" drawer))
(if (= target 0) "you" (format "Player %d" target))))))
(if (<= (cg-om--total game) 1)
(cg-om--finish game)
(cg-put game :turn (mod (1+ drawer) (cg-get game :nplayers)))
(cg-put game :pick 0)
(cg-om--skip-empty game))))
(cl-defmethod cg-om--finish ((game cg-old-maid-game))
"End the game; whoever holds the last card is the Old Maid."
(let ((loser (car (cg-om--active game))))
(cg-put game :phase 'game-over)
(cg-put game :winner loser)
(cg-put game :message
(if loser
(format "%s is left holding the Old Maid! (n: new game)"
(if (= loser 0) "You are" (format "Player %d is" loser)))
"All paired off -- a draw! (n: new game)"))))
(defun cg-om--ai-turn (game s)
"Take seat S's AI turn: draw a random card from the next hand."
(let ((target (cg-om--target game s)))
(if (null target) (cg-om--finish game)
(cg-om--draw game s (random (length (cg-om--hand game target)))))))
(defun cg-om--run (game)
"Advance AI seats until it is your turn or the game ends."
(let ((guard 0))
(while (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0) (< guard 500))
(setq guard (1+ guard))
(cg-om--ai-turn game (cg-get game :turn)))))
;;;; Old Maid UI
(defvar-local cg-om--game nil "The Old Maid game in the current buffer.")
(cl-defmethod cg-render ((game cg-old-maid-game))
"Return a propertized depiction of the Old Maid GAME."
(let* ((out '()) (target (cg-om--target game 0)))
(push " Old Maid\n\n" out)
(dotimes (s (cg-get game :nplayers))
(unless (= s 0)
(push (format " Player %d: %d cards%s\n" s (length (cg-om--hand game s))
(if (eql s target) " <- you draw from here" "")) out)))
(when (and target (eq (cg-get game :phase) 'play) (= (cg-get game :turn) 0))
(push (format "\n Player %d's cards (pick one to draw):\n " target) out)
(let ((np (length (cg-om--hand game target))) (pk (cg-get game :pick)))
(dotimes (i np)
(push (propertize " ##" 'face (if (= i pk) 'cg-cursor 'cg-gap)) out))))
(push "\n\n Your hand:\n " out)
(push (cg-rummy--render-cards (cg-om--hand game 0) -1 nil) out)
(push (format "\n\n %s\n" (cg-get game :message)) out)
(apply #'concat (nreverse out))))
(defun cg-om--redisplay ()
(let ((game cg-om--game) (inhibit-read-only t))
(setq-local mode-line-process (format " [%s]" (cg-get game :phase)))
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
(defun cg-om-left ()
"Move the pick cursor left over the target's cards."
(interactive)
(let* ((g cg-om--game) (target (cg-om--target g 0))
(np (and target (length (cg-om--hand g target)))))
(when (and np (> np 0)) (cg-put g :pick (mod (1- (cg-get g :pick)) np)))
(cg-om--redisplay)))
(defun cg-om-right ()
"Move the pick cursor right over the target's cards."
(interactive)
(let* ((g cg-om--game) (target (cg-om--target g 0))
(np (and target (length (cg-om--hand g target)))))
(when (and np (> np 0)) (cg-put g :pick (mod (1+ (cg-get g :pick)) np)))
(cg-om--redisplay)))
(defun cg-om-draw ()
"Draw the selected card from the next player."
(interactive)
(let ((g cg-om--game))
(cond
((not (eq (cg-get g :phase) 'play)) (cg-put g :message "Press n for a new game."))
((/= (cg-get g :turn) 0) (cg-put g :message "Not your turn."))
(t (cg-om--draw g 0 (cg-get g :pick))
(unless (= (cg-get g :turn) 0) (cg-om--run g))))
(cg-om--redisplay)))
(defun cg-om-new () "Deal a new Old Maid game." (interactive)
(cg-om--deal cg-om--game) (cg-om--redisplay))
(defun cg-om-redraw () "Redraw." (interactive) (cg-om--redisplay))
(defun cg-om-help () "Describe the controls." (interactive)
(message "Arrows: pick a card from the next player RET: draw it n: new g: redraw"))
(defvar cg-old-maid-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "<left>") #'cg-om-left)
(define-key map (kbd "<right>") #'cg-om-right)
(define-key map (kbd "RET") #'cg-om-draw)
(define-key map "n" #'cg-om-new)
(define-key map "g" #'cg-om-redraw)
(define-key map "?" #'cg-om-help)
map)
"Keymap for `cg-old-maid-mode'.")
(define-derived-mode cg-old-maid-mode special-mode "OldMaid"
"Major mode for Old Maid."
(setq-local truncate-lines t))
;;;###autoload
(defun cg-old-maid ()
"Play Old Maid against the computer."
(interactive)
(let ((buf (get-buffer-create "*Old Maid*")))
(with-current-buffer buf
(cg-old-maid-mode)
(setq cg-om--game (cg-old-maid-game))
(cg-om--deal cg-om--game)
(cg-om--redisplay))
(switch-to-buffer buf)))
(provide 'cg-match)
;;; cg-match.el ends here

404
cg-scopa.el Normal file
View file

@ -0,0 +1,404 @@
;;; cg-scopa.el --- Scopa and Casino, capturing games -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Corwin Brust
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; 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 capturing ("fishing") games on a shared engine. You play a card
;; from your hand to capture cards from the table: either a single card of
;; equal value or a combination that sums to it. Clear the whole table
;; for a sweep.
;;
;; `cg-scopa' -- Scopa. The Italian classic on a 40-card deck; score
;; for cards, coins (diamonds), the sette bello (seven of diamonds),
;; primiera, and each sweep ("scopa"). Game to 11.
;; `cg-casino' -- Casino. The English cousin on the full deck; score for
;; cards, spades, big casino (ten of diamonds), little casino (two of
;; spades), each ace, and each sweep. Game to 21.
;;
;; You are the first player against the computer. Captures are resolved
;; automatically (a single equal card if there is one, otherwise the
;; combination taking the most cards). This Casino omits builds and
;; multiple captures from a single card. Cards use the package cons
;; (SUIT . RANK), RANK 0 (Ace) .. 12 (King); suit 2 is diamonds.
;;; Code:
(require 'cl-lib)
(require 'eieio)
(require 'cg-core)
(require 'cg-rummy)
(defclass cg-fish-game (cg-game)
((nplayers :initarg :nplayers :initform 2)
(hand-size :initarg :hand-size :initform 3)
(target :initarg :target :initform 11))
"Abstract base for the capturing games Scopa and Casino."
:abstract t)
(cl-defgeneric cg-fish--value (game card)
"Return CARD's capture value in GAME, or nil if it captures only by rank.")
(cl-defgeneric cg-fish--deck (game)
"Return a fresh shuffled deck for GAME.")
(cl-defgeneric cg-fish--face-pair-p (game card)
"Return non-nil when CARD captures only equal-rank cards (no sums).")
(cl-defmethod cg-fish--face-pair-p ((_game cg-fish-game) _card) nil)
(cl-defgeneric cg-fish--score-round (game)
"Add this round's points to GAME's running scores.")
(defsubst cg-fish--hand (game s) (aref (cg-get game :hands) s))
(defsubst cg-fish--set-hand (game s v) (aset (cg-get game :hands) s v))
(defsubst cg-fish--captured (game s) (aref (cg-get game :captured) s))
(defun cg-fish--who (s) (if (= s 0) "You" "Computer"))
;;;; Capture search
(defun cg-fish--best-subset (cards target valfn)
"Return the largest subset of CARDS whose values (via VALFN) sum to TARGET.
Only subsets of two or more cards are considered. Return nil if none."
(let ((best nil) (vec (vconcat cards)) (n (length cards)))
(dotimes (mask (ash 1 n))
(let ((sum 0) (sub '()) (cnt 0))
(dotimes (i n)
(when (/= 0 (logand mask (ash 1 i)))
(let ((v (funcall valfn (aref vec i))))
(when v (setq sum (+ sum v) sub (cons (aref vec i) sub) cnt (1+ cnt))))))
(when (and (>= cnt 2) (= sum target) (> cnt (length best)))
(setq best sub))))
best))
(defun cg-fish--capture (game card)
"Return the table cards CARD would capture in GAME, or nil."
(let ((table (cg-get game :table)))
(if (cg-fish--face-pair-p game card)
(let ((same (cl-remove-if-not (lambda (c) (= (cdr c) (cdr card))) table)))
(and same (list (car same))))
(let ((v (cg-fish--value game card)))
(and v (let ((single (cl-find-if (lambda (c) (eql (cg-fish--value game c) v))
table)))
(if single (list single)
(cg-fish--best-subset table v
(lambda (c) (cg-fish--value game c))))))))))
;;;; Flow
(cl-defmethod cg-fish--deal-round ((game cg-fish-game))
"Start a fresh round: shuffle, deal the table and the first hands."
(let* ((n (oref game nplayers)) (deck (cg-fish--deck game))
(hands (make-vector n nil)) (table '()))
(dotimes (_ 4) (push (pop deck) table))
(dotimes (s n)
(aset hands s (cg-rummy-sort-hand (cl-loop repeat (oref game hand-size)
collect (pop deck)))))
(cg-put game :hands hands)
(cg-put game :table table)
(cg-put game :deck deck)
(cg-put game :captured (make-vector n nil))
(cg-put game :sweeps (make-vector n 0))
(cg-put game :nplayers n)
(cg-put game :turn 0)
(cg-put game :phase 'play)
(cg-put game :cursor 0)
(cg-put game :last-capturer nil)
(unless (cg-get game :scores) (cg-put game :scores (make-vector n 0)))
(cg-put game :message "Play a card to capture by value, or trail it on the table.")
game))
(defun cg-fish--refill (game)
"Deal fresh hands from the deck when every hand is empty."
(when (and (cl-every #'null (append (cg-get game :hands) nil)) (cg-get game :deck))
(let ((deck (cg-get game :deck)))
(dotimes (s (cg-get game :nplayers))
(cg-fish--set-hand game s
(cg-rummy-sort-hand
(cl-loop repeat (oref game hand-size)
while deck collect (pop deck)))))
(cg-put game :deck deck))))
(defun cg-fish--round-over-p (game)
(and (null (cg-get game :deck))
(cl-every #'null (append (cg-get game :hands) nil))))
(cl-defmethod cg-fish--play ((game cg-fish-game) s card)
"Seat S plays CARD: capture if possible, else trail it on the table."
(cg-fish--set-hand game s (cl-remove card (cg-fish--hand game s) :test #'equal :count 1))
(let ((cap (cg-fish--capture game card)))
(if cap
(progn
(dolist (c cap)
(cg-put game :table (cl-remove c (cg-get game :table) :test #'equal :count 1)))
(aset (cg-get game :captured) s (append (cons card cap) (cg-fish--captured game s)))
(cg-put game :last-capturer s)
(when (and (null (cg-get game :table)) (not (cg-fish--round-over-p game)))
(aset (cg-get game :sweeps) s (1+ (aref (cg-get game :sweeps) s))))
(cg-put game :message
(format "%s captured %d card%s with %s.%s" (cg-fish--who s)
(length cap) (if (> (length cap) 1) "s" "")
(cg-rummy-card-string card)
(if (null (cg-get game :table)) " Sweep!" ""))))
(cg-put game :table (cons card (cg-get game :table)))
(cg-put game :message (format "%s trailed %s." (cg-fish--who s)
(cg-rummy-card-string card))))
(cg-put game :turn (mod (1+ s) (cg-get game :nplayers)))
(cg-fish--refill game)
(when (cg-fish--round-over-p game) (cg-fish--finish-round game))))
(cl-defmethod cg-fish--finish-round ((game cg-fish-game))
"Award leftover table cards to the last capturer and score the round."
(when (and (cg-get game :table) (cg-get game :last-capturer))
(let ((s (cg-get game :last-capturer)))
(aset (cg-get game :captured) s
(append (cg-get game :table) (cg-fish--captured game s)))
(cg-put game :table nil)))
(cg-fish--score-round game)
(let ((win nil) (n (cg-get game :nplayers)) (best most-negative-fixnum))
(dotimes (s n)
(when (and (>= (aref (cg-get game :scores) s) (oref game target))
(> (aref (cg-get game :scores) s) best))
(setq win s best (aref (cg-get game :scores) s))))
(cg-put game :phase (if win 'game-over 'round-over))
(cg-put game :winner win)
(cg-put game :message
(format "Round over. Scores: You %d, Computer %d. %s"
(aref (cg-get game :scores) 0) (aref (cg-get game :scores) 1)
(if win (format "%s wins! (n: new game)" (cg-fish--who win))
"(n: next round)")))))
(defun cg-fish--award-most (game suit-pred pts)
"Give PTS to whoever captured more cards satisfying SUIT-PRED."
(let ((c0 (cl-count-if suit-pred (cg-fish--captured game 0)))
(c1 (cl-count-if suit-pred (cg-fish--captured game 1))))
(cond ((> c0 c1) (aset (cg-get game :scores) 0 (+ (aref (cg-get game :scores) 0) pts)))
((> c1 c0) (aset (cg-get game :scores) 1 (+ (aref (cg-get game :scores) 1) pts))))))
(cl-defmethod cg-fish--ai-play ((game cg-fish-game) s)
"Have AI seat S capture the most it can, else trail its lowest card."
(let ((hand (cg-fish--hand game s)) (best nil) (bestn -1) (sweep nil))
(dolist (c hand)
(let* ((cap (cg-fish--capture game c))
(nn (length cap))
(sw (and cap (= nn (length (cg-get game :table))))))
(when (or (and sw (not sweep))
(and (eq (and sw t) (and sweep t)) (> nn bestn)))
(setq best c bestn nn sweep sw))))
(unless best ; nothing captures: trail the lowest-value card
(setq best (car (sort (copy-sequence hand)
(lambda (a b) (< (or (cg-fish--value game a) 99)
(or (cg-fish--value game b) 99)))))))
(cg-fish--play game s best)))
(defun cg-fish--run (game)
"Advance AI seats until it is your turn or the round ends."
(let ((guard 0))
(while (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0) (< guard 200))
(setq guard (1+ guard))
(cg-fish--ai-play game (cg-get game :turn)))))
;;;; UI
(defvar-local cg-fish--game nil "The fishing game in the current buffer.")
(cl-defmethod cg-render ((game cg-fish-game))
"Return a propertized depiction of the fishing GAME."
(let* ((out '()) (cursor (cg-get game :cursor)))
(push (format " %s to %d\n\n" (oref game vname) (oref game target)) out)
(push (format " Computer: %d cards captured %d (score %d)\n"
(length (cg-fish--hand game 1)) (length (cg-fish--captured game 1))
(aref (cg-get game :scores) 1)) out)
(push (format " Deck: %d Your captured: %d (score %d)\n\n"
(length (cg-get game :deck)) (length (cg-fish--captured game 0))
(aref (cg-get game :scores) 0)) out)
(push " Table:\n " out)
(push (if (cg-get game :table)
(cg-rummy--render-cards (cg-rummy-sort-hand (cg-get game :table)) -1 nil)
"(empty)")
out)
(push "\n\n Your hand:\n " out)
(push (cg-rummy--render-cards (cg-fish--hand game 0) cursor nil) out)
(push (format "\n\n %s\n" (cg-get game :message)) out)
(apply #'concat (nreverse out))))
(defun cg-fish--redisplay ()
(let ((game cg-fish--game) (inhibit-read-only t))
(setq-local mode-line-process (format " [%s]" (cg-get game :phase)))
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
(defun cg-fish-left ()
"Move the hand cursor left."
(interactive)
(let* ((g cg-fish--game) (n (length (cg-fish--hand g 0))))
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n)))
(cg-fish--redisplay)))
(defun cg-fish-right ()
"Move the hand cursor right."
(interactive)
(let* ((g cg-fish--game) (n (length (cg-fish--hand g 0))))
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n)))
(cg-fish--redisplay)))
(defun cg-fish-play ()
"Play the card under the cursor."
(interactive)
(let* ((g cg-fish--game) (card (nth (cg-get g :cursor) (cg-fish--hand g 0))))
(cond
((not (eq (cg-get g :phase) 'play)) (cg-put g :message "Press n to continue."))
((/= (cg-get g :turn) 0) (cg-put g :message "Not your turn."))
((null card) (cg-put g :message "No card selected."))
(t (cg-fish--play g 0 card)
(cg-put g :cursor 0)
(when (eq (cg-get g :phase) 'play) (cg-fish--run g))))
(cg-fish--redisplay)))
(defun cg-fish-new ()
"Start the next round, or a new game when one is over."
(interactive)
(let ((g cg-fish--game))
(when (eq (cg-get g :phase) 'game-over)
(cg-put g :scores (make-vector (oref g nplayers) 0)))
(cg-fish--deal-round g)
(cg-fish--run g)
(cg-fish--redisplay)))
(defun cg-fish-redraw () "Redraw." (interactive) (cg-fish--redisplay))
(defun cg-fish-help () "Describe the controls." (interactive)
(message "Arrows: choose RET: play the card n: next round / new game g: redraw"))
(defvar cg-fish-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "<left>") #'cg-fish-left)
(define-key map (kbd "<right>") #'cg-fish-right)
(define-key map (kbd "RET") #'cg-fish-play)
(define-key map "n" #'cg-fish-new)
(define-key map "g" #'cg-fish-redraw)
(define-key map "?" #'cg-fish-help)
map)
"Keymap for `cg-fish-mode'.")
(define-derived-mode cg-fish-mode special-mode "Fish"
"Major mode for the capturing games Scopa and Casino."
(setq-local truncate-lines t))
(defun cg-fish--start (game buffer-name)
"Start GAME in a buffer named BUFFER-NAME."
(let ((buf (get-buffer-create buffer-name)))
(with-current-buffer buf
(cg-fish-mode)
(setq cg-fish--game game)
(cg-fish--deal-round game)
(cg-fish--run game)
(cg-fish--redisplay))
(switch-to-buffer buf)))
;;;; Scopa
(defclass cg-scopa-game (cg-fish-game)
((vname :initform "Scopa") (hand-size :initform 3) (target :initform 11))
"A game of Scopa.")
(cl-defmethod cg-fish--value ((_game cg-scopa-game) card)
"Return CARD's Scopa value (Ace 1 .. 7, Jack 8, Queen 9, King 10)."
(let ((r (cdr card)))
(cond ((<= r 6) (1+ r)) ((= r 10) 8) ((= r 11) 9) ((= r 12) 10))))
(cl-defmethod cg-fish--deck ((_game cg-scopa-game))
"Return a shuffled 40-card Scopa deck (no eights, nines, or tens)."
(random t)
(cg-shuffle (cl-loop for s below 4 append
(cl-loop for r below 13
unless (memq r '(7 8 9)) collect (cons s r)))))
(defun cg-scopa--prime (card)
"Return the primiera prime value of CARD."
(pcase (cdr card)
(6 21) (5 18) (0 16) (4 15) (3 14) (2 13) (1 12) (_ 10)))
(cl-defmethod cg-fish--score-round ((game cg-scopa-game))
"Score a Scopa round: cards, coins, sette bello, primiera, sweeps."
(let ((scores (cg-get game :scores)))
(cg-fish--award-most game (lambda (_c) t) 1) ; most cards
(cg-fish--award-most game (lambda (c) (= (car c) 2)) 1) ; most coins (diamonds)
;; sette bello: 7 of diamonds
(dotimes (s 2)
(when (cl-find '(2 . 6) (cg-fish--captured game s) :test #'equal)
(aset scores s (1+ (aref scores s)))))
;; primiera: best prime total across suits
(let ((p (vector 0 0)))
(dotimes (s 2)
(let ((bysuit (make-vector 4 0)))
(dolist (c (cg-fish--captured game s))
(aset bysuit (car c) (max (aref bysuit (car c)) (cg-scopa--prime c))))
(aset p s (apply #'+ (append bysuit nil)))))
(cond ((> (aref p 0) (aref p 1)) (aset scores 0 (1+ (aref scores 0))))
((> (aref p 1) (aref p 0)) (aset scores 1 (1+ (aref scores 1))))))
;; sweeps
(dotimes (s 2) (aset scores s (+ (aref scores s) (aref (cg-get game :sweeps) s))))))
;;;###autoload
(defun cg-scopa ()
"Play Scopa against the computer."
(interactive)
(cg-fish--start (cg-scopa-game) "*Scopa*"))
;;;; Casino
(defclass cg-casino-game (cg-fish-game)
((vname :initform "Casino") (hand-size :initform 4) (target :initform 21))
"A game of Casino.")
(cl-defmethod cg-fish--value ((_game cg-casino-game) card)
"Return CARD's Casino value (Ace 1, pips 2-10, faces nil)."
(let ((r (cdr card)))
(cond ((= r 0) 1) ((<= r 9) (1+ r)) (t nil))))
(cl-defmethod cg-fish--face-pair-p ((_game cg-casino-game) card)
"Return non-nil when CARD is a face card (captures only by matching rank)."
(>= (cdr card) 10))
(cl-defmethod cg-fish--deck ((_game cg-casino-game))
"Return a shuffled 52-card deck for Casino."
(cg-rummy-deck))
(cl-defmethod cg-fish--score-round ((game cg-casino-game))
"Score a Casino round: cards, spades, casinos, aces, sweeps."
(let ((scores (cg-get game :scores)))
(cg-fish--award-most game (lambda (_c) t) 3) ; most cards
(cg-fish--award-most game (lambda (c) (= (car c) 0)) 1) ; most spades
(dotimes (s 2)
(let ((caps (cg-fish--captured game s)))
(when (cl-find '(2 . 9) caps :test #'equal) ; big casino 10D
(aset scores s (+ (aref scores s) 2)))
(when (cl-find '(0 . 1) caps :test #'equal) ; little casino 2S
(aset scores s (+ (aref scores s) 1)))
(aset scores s (+ (aref scores s) (cl-count 0 caps :key #'cdr))) ; aces
(aset scores s (+ (aref scores s) (aref (cg-get game :sweeps) s)))))))
;;;###autoload
(defun cg-casino ()
"Play Casino against the computer."
(interactive)
(cg-fish--start (cg-casino-game) "*Casino*"))
(provide 'cg-scopa)
;;; cg-scopa.el ends here

426
cg-spite.el Normal file
View file

@ -0,0 +1,426 @@
;;; cg-spite.el --- Spite and Malice, a competitive patience -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Corwin Brust
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; 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:
;; Spite & Malice (also called Cat & Mouse): a race between you and the
;; computer to empty a face-down goal pile. Play cards onto up to four
;; shared centre piles, which build up from Ace to Queen regardless of
;; suit; a pile that reaches a Queen is cleared away. Kings are wild and
;; stand for whatever rank a pile needs next.
;;
;; On your turn, draw your hand up to five, then play from the top of your
;; goal pile, your hand, or the tops of your four discard piles. Playing
;; your goal card is how you win, so take every chance to. End your turn
;; by discarding one card to a discard pile.
;;
;; Targets are chosen automatically (the first centre pile a card fits).
;; Cards use the package cons (SUIT . RANK), RANK 0 (Ace) .. 12 (King);
;; the build order runs Ace(0) up to Queen(11), and the King(12) is wild.
;;; Code:
(require 'cl-lib)
(require 'eieio)
(require 'cg-core)
(require 'cg-rummy)
(defcustom cg-spite-goal-size 20
"Number of cards in each player's goal pile."
:type 'integer :group 'card-games)
(defclass cg-spite-game (cg-game)
((vname :initform "Spite & Malice"))
"A game of Spite & Malice.")
(defun cg-spite--wild-p (card) "Return non-nil when CARD (a King) is wild."
(= (cdr card) 12))
(defun cg-spite--nat (card) "Return CARD's natural build rank, or nil if wild."
(if (cg-spite--wild-p card) nil (cdr card)))
(defun cg-spite--deck ()
"Return two shuffled standard decks (104 cards)."
(random t)
(cg-shuffle (cl-loop repeat 2 append
(cl-loop for s below 4 append
(cl-loop for r below 13 collect (cons s r))))))
;;;; Accessors
(defsubst cg-spite--goal (game s) (aref (cg-get game :goal) s))
(defsubst cg-spite--set-goal (game s v) (aset (cg-get game :goal) s v))
(defsubst cg-spite--hand (game s) (aref (cg-get game :hand) s))
(defsubst cg-spite--set-hand (game s v) (aset (cg-get game :hand) s v))
(defsubst cg-spite--disc (game s) (aref (cg-get game :disc) s)) ; vector of 4 lists
(defun cg-spite--who (s) (if (= s 0) "You" "Computer"))
(cl-defmethod cg-spite--deal ((game cg-spite-game))
"Deal a fresh Spite & Malice game into GAME."
(let ((deck (cg-spite--deck)) (goal (make-vector 2 nil))
(hand (make-vector 2 nil)) (disc (vector nil nil)))
(dotimes (s 2)
(aset goal s (cl-loop repeat cg-spite-goal-size collect (pop deck)))
(aset hand s (cg-rummy-sort-hand (cl-loop repeat 5 collect (pop deck))))
(aset disc s (make-vector 4 nil)))
(cg-put game :goal goal)
(cg-put game :hand hand)
(cg-put game :disc disc)
(cg-put game :center (make-vector 4 nil)) ; each nil or (TOPRANK . CARDS)
(cg-put game :muck nil)
(cg-put game :stock deck)
(cg-put game :turn 0)
(cg-put game :phase 'play)
(cg-put game :cursor 0)
(cg-put game :message "Your turn. RET plays a hand card; G plays your goal card.")
game))
;;;; Stock and centre piles
(defun cg-spite--draw-stock (game)
"Pop one card from the stock, recycling the muck when the stock is empty."
(when (and (null (cg-get game :stock)) (cg-get game :muck))
(cg-put game :stock (cg-shuffle (cg-get game :muck)))
(cg-put game :muck nil))
(let ((stock (cg-get game :stock)))
(when stock (cg-put game :stock (cdr stock)) (car stock))))
(defun cg-spite--refill (game s)
"Draw seat S's hand back up to five cards."
(while (and (< (length (cg-spite--hand game s)) 5) (or (cg-get game :stock)
(cg-get game :muck)))
(let ((c (cg-spite--draw-stock game)))
(when c (cg-spite--set-hand game s (cg-rummy-sort-hand
(cons c (cg-spite--hand game s))))))))
(defun cg-spite--needed (game i)
"Return the rank the centre pile I needs next (0 for an empty slot)."
(let ((p (aref (cg-get game :center) i)))
(if p (1+ (car p)) 0)))
(defun cg-spite--legal-center (game card)
"Return the index of the first centre pile CARD may be played on, or nil."
(let ((found nil))
(dotimes (i 4)
(let ((need (cg-spite--needed game i)))
(when (and (null found) (<= need 11)
(or (cg-spite--wild-p card) (eql (cg-spite--nat card) need)))
(setq found i))))
found))
(defun cg-spite--put-center (game card i)
"Place CARD on centre pile I; clear the pile if it reaches a Queen."
(let* ((need (cg-spite--needed game i))
(p (aref (cg-get game :center) i))
(cards (cons card (and p (cdr p)))))
(if (= need 11) ; completed Ace..Queen
(progn (cg-put game :muck (append cards (cg-get game :muck)))
(aset (cg-get game :center) i nil))
(aset (cg-get game :center) i (cons need cards)))))
;;;; Plays
(defun cg-spite--play-hand (game s card i)
"Seat S plays hand CARD onto centre pile I."
(cg-spite--set-hand game s (cl-remove card (cg-spite--hand game s) :test #'equal :count 1))
(cg-spite--put-center game card i)
(when (null (cg-spite--hand game s)) (cg-spite--refill game s)))
(defun cg-spite--play-goal (game s i)
"Seat S plays the top of their goal pile onto centre pile I."
(let ((card (car (cg-spite--goal game s))))
(cg-spite--set-goal game s (cdr (cg-spite--goal game s)))
(cg-spite--put-center game card i)
(when (null (cg-spite--goal game s))
(cg-put game :phase 'game-over) (cg-put game :winner s))))
(defun cg-spite--play-disc (game s d i)
"Seat S plays the top of discard pile D onto centre pile I."
(let* ((pile (aref (cg-spite--disc game s) d)) (card (car pile)))
(aset (cg-spite--disc game s) d (cdr pile))
(cg-spite--put-center game card i)))
(defun cg-spite--discard (game s card d)
"Seat S discards CARD from hand onto discard pile D, ending the turn."
(cg-spite--set-hand game s (cl-remove card (cg-spite--hand game s) :test #'equal :count 1))
(aset (cg-spite--disc game s) d (cons card (aref (cg-spite--disc game s) d)))
(cg-put game :turn (- 1 s)))
;;;; AI
(defun cg-spite--ai-one (game s)
"Make one beneficial play for seat S; return non-nil if a play was made."
(let ((goal (car (cg-spite--goal game s))) (done nil))
(cond
;; 1. advance the goal card (a wild goal card plays anywhere)
((and goal (cg-spite--legal-center game goal))
(cg-spite--play-goal game s (cg-spite--legal-center game goal)) (setq done t))
;; 2. a non-wild hand card that fits
((cl-find-if (lambda (c) (and (not (cg-spite--wild-p c))
(cg-spite--legal-center game c)))
(cg-spite--hand game s))
(let ((card (cl-find-if (lambda (c) (and (not (cg-spite--wild-p c))
(cg-spite--legal-center game c)))
(cg-spite--hand game s))))
(cg-spite--play-hand game s card (cg-spite--legal-center game card))
(setq done t)))
(t
;; 3. a non-wild discard top that fits
(catch 'hit
(dotimes (d 4)
(let ((top (car (aref (cg-spite--disc game s) d))))
(when (and top (not (cg-spite--wild-p top)) (cg-spite--legal-center game top))
(cg-spite--play-disc game s d (cg-spite--legal-center game top))
(setq done t) (throw 'hit t))))
;; 4. use a wild King: bridge to the goal card if possible, else
;; advance the most-built pile to keep cards flowing
(let ((king (cl-find-if #'cg-spite--wild-p (cg-spite--hand game s))))
(when king
(let* ((gr (and goal (cg-spite--nat goal))) (target nil))
(when gr
(dotimes (i 4)
(let ((need (cg-spite--needed game i)))
(when (and (null target) (<= need 11) (= need (1- gr)))
(setq target i)))))
(unless target
(let ((bestneed -1))
(dotimes (i 4)
(let ((need (cg-spite--needed game i)))
(when (and (<= need 11) (> need bestneed))
(setq bestneed need target i))))))
(when target
(cg-spite--play-hand game s king target) (setq done t))))))))
done))
(defun cg-spite--ai-turn (game s)
"Take seat S's whole AI turn: play what helps, then discard."
(cg-spite--refill game s)
(let ((guard 0))
(while (and (eq (cg-get game :phase) 'play) (< guard 300)
(cg-spite--ai-one game s))
(setq guard (1+ guard))))
(when (eq (cg-get game :phase) 'play)
(let ((hand (cg-spite--hand game s)))
(if (null hand)
(cg-put game :turn (- 1 s)) ; played out, nothing to discard
;; discard the highest non-wild card; keep Kings (wild)
(let* ((nonk (cl-remove-if #'cg-spite--wild-p hand))
(card (car (sort (copy-sequence (or nonk hand))
(lambda (a b) (> (cdr a) (cdr b))))))
(d (cg-spite--ai-disc-pile game s card)))
(cg-spite--discard game s card d))))))
(defun cg-spite--ai-disc-pile (game s card)
"Choose a discard pile for CARD: an empty one, else the one topped just above."
(let ((disc (cg-spite--disc game s)) (empty nil) (best nil) (bestv 99))
(dotimes (d 4)
(let ((top (car (aref disc d))))
(cond ((null top) (unless empty (setq empty d)))
((and (not (cg-spite--wild-p top)) (>= (cdr top) (cdr card))
(< (- (cdr top) (cdr card)) bestv))
(setq best d bestv (- (cdr top) (cdr card)))))))
(or best empty 0)))
(defun cg-spite--run (game)
"Let the computer (seat 1) take its turns until it is your turn or the game ends."
(let ((guard 0))
(while (and (eq (cg-get game :phase) 'play) (= (cg-get game :turn) 1) (< guard 200))
(setq guard (1+ guard))
(cg-spite--ai-turn game 1))))
;;;; UI
(defvar-local cg-spite--game nil "The Spite & Malice game in the current buffer.")
(defun cg-spite--center-string (game)
"Return a one-line depiction of the centre piles."
(let ((parts '()))
(dotimes (i 4)
(let ((p (aref (cg-get game :center) i)))
(push (if p (format "[%s->%s]" (length (cdr p))
(aref cg-rummy-ranks (car p)))
"[ -- ]")
parts)))
(mapconcat #'identity (nreverse parts) " ")))
(defun cg-spite--disc-string (game s)
"Return a depiction of seat S's four discard-pile tops."
(let ((parts '()))
(dotimes (d 4)
(let ((top (car (aref (cg-spite--disc game s) d))))
(push (format "%d:%s" (1+ d) (if top (cg-rummy-card-string top) "--")) parts)))
(mapconcat #'identity (nreverse parts) " ")))
(cl-defmethod cg-render ((game cg-spite-game))
"Return a propertized depiction of the Spite & Malice GAME."
(let* ((out '()) (cursor (cg-get game :cursor)))
(push " Spite & Malice\n\n" out)
(push (format " Computer goal: %d left hand: %d discards: %s\n\n"
(length (cg-spite--goal game 1)) (length (cg-spite--hand game 1))
(cg-spite--disc-string game 1))
out)
(push (format " Centre: %s\n" (cg-spite--center-string game)) out)
(push (format " Stock: %d Muck: %d\n\n"
(length (cg-get game :stock)) (length (cg-get game :muck))) out)
(push (format " Your goal: %s (%d left)\n"
(let ((g (car (cg-spite--goal game 0))))
(if g (cg-rummy-card-string g) "--"))
(length (cg-spite--goal game 0)))
out)
(push (format " Your discards: %s\n\n" (cg-spite--disc-string game 0)) out)
(push " Your hand:\n " out)
(push (cg-rummy--render-cards (cg-spite--hand game 0) cursor nil) out)
(push (format "\n\n %s\n" (cg-get game :message)) out)
(apply #'concat (nreverse out))))
(defun cg-spite--redisplay ()
(let ((game cg-spite--game) (inhibit-read-only t))
(setq-local mode-line-process (format " [%s]" (cg-get game :phase)))
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
(defun cg-spite--my-turn-p (g)
(and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0)))
(defun cg-spite-left ()
"Move the hand cursor left."
(interactive)
(let* ((g cg-spite--game) (n (length (cg-spite--hand g 0))))
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n)))
(cg-spite--redisplay)))
(defun cg-spite-right ()
"Move the hand cursor right."
(interactive)
(let* ((g cg-spite--game) (n (length (cg-spite--hand g 0))))
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n)))
(cg-spite--redisplay)))
(defun cg-spite--ensure-hand (g)
"Draw your hand up to five at the start of your turn."
(cg-spite--refill g 0))
(defun cg-spite-play ()
"Play the cursor hand card onto the first centre pile it fits."
(interactive)
(let* ((g cg-spite--game) (card (nth (cg-get g :cursor) (cg-spite--hand g 0))))
(cond
((not (cg-spite--my-turn-p g)) (cg-put g :message "Not your turn."))
((null card) (cg-put g :message "No card selected."))
(t (let ((i (cg-spite--legal-center g card)))
(if (null i) (cg-put g :message "That card fits no centre pile.")
(cg-spite--play-hand g 0 card i)
(cg-put g :cursor 0)
(cg-put g :message "Played. Keep going, or d to discard and end turn.")))))
(cg-spite--redisplay)))
(defun cg-spite-goal ()
"Play your goal-pile top onto the first centre pile it fits."
(interactive)
(let* ((g cg-spite--game) (card (car (cg-spite--goal g 0))))
(cond
((not (cg-spite--my-turn-p g)) (cg-put g :message "Not your turn."))
((null card) (cg-put g :message "Your goal pile is empty."))
(t (let ((i (cg-spite--legal-center g card)))
(if (null i) (cg-put g :message "Your goal card fits no centre pile.")
(cg-spite--play-goal g 0 i)
(if (eq (cg-get g :phase) 'game-over)
(cg-put g :message "You emptied your goal -- you win! (n: new game)")
(cg-put g :message "Goal card played!"))))))
(cg-spite--redisplay)))
(defun cg-spite-play-disc ()
"Play the top of the discard pile whose number you pressed."
(interactive)
(let* ((g cg-spite--game) (d (- last-command-event ?1))
(top (and (>= d 0) (< d 4) (car (aref (cg-spite--disc g 0) d)))))
(cond
((not (cg-spite--my-turn-p g)) (cg-put g :message "Not your turn."))
((null top) (cg-put g :message "That discard pile is empty."))
(t (let ((i (cg-spite--legal-center g top)))
(if (null i) (cg-put g :message "That card fits no centre pile.")
(cg-spite--play-disc g 0 d i)
(cg-put g :message "Played from a discard pile.")))))
(cg-spite--redisplay)))
(defun cg-spite-discard ()
"Discard the cursor card to a discard pile and end your turn."
(interactive)
(let* ((g cg-spite--game) (card (nth (cg-get g :cursor) (cg-spite--hand g 0))))
(cond
((not (cg-spite--my-turn-p g)) (cg-put g :message "Not your turn."))
((null card) (cg-put g :message "No card to discard."))
(t (cg-spite--discard g 0 card (cg-spite--ai-disc-pile g 0 card))
(cg-put g :cursor 0)
(cg-spite--run g)
(when (eq (cg-get g :phase) 'play)
(cg-spite--ensure-hand g)
(cg-put g :message "Your turn."))))
(cg-spite--redisplay)))
(defun cg-spite-new ()
"Deal a fresh game."
(interactive)
(cg-spite--deal cg-spite--game)
(cg-spite--redisplay))
(defun cg-spite-redraw () "Redraw." (interactive) (cg-spite--redisplay))
(defun cg-spite-help () "Describe the controls." (interactive)
(message "Arrows: choose RET: play hand card G: play goal 1-4: play discard top d: discard/end n: new"))
(defvar cg-spite-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "<left>") #'cg-spite-left)
(define-key map (kbd "<right>") #'cg-spite-right)
(define-key map (kbd "RET") #'cg-spite-play)
(define-key map "G" #'cg-spite-goal)
(dolist (k '("1" "2" "3" "4")) (define-key map k #'cg-spite-play-disc))
(define-key map "d" #'cg-spite-discard)
(define-key map "n" #'cg-spite-new)
(define-key map "g" #'cg-spite-redraw)
(define-key map "?" #'cg-spite-help)
map)
"Keymap for `cg-spite-mode'.")
(define-derived-mode cg-spite-mode special-mode "Spite"
"Major mode for Spite & Malice."
(setq-local truncate-lines t))
;;;###autoload
(defun cg-spite ()
"Play Spite & Malice against the computer."
(interactive)
(let ((buf (get-buffer-create "*Spite & Malice*")))
(with-current-buffer buf
(cg-spite-mode)
(setq cg-spite--game (cg-spite-game))
(cg-spite--deal cg-spite--game)
(cg-spite--redisplay))
(switch-to-buffer buf)))
;;;###autoload
(defalias 'cg-cat-and-mouse #'cg-spite)
(provide 'cg-spite)
;;; cg-spite.el ends here

501
cg-trick-ext.el Normal file
View file

@ -0,0 +1,501 @@
;;; cg-trick-ext.el --- Euchre, Pitch and Briscola -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Corwin Brust
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; 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:
;; Three more trick-taking games built on the engine in cg-trick.el, each
;; a four-handed game against three AI opponents (you are South).
;;
;; `cg-euchre' -- Euchre. A 24-card deck, the Jack of trump (right
;; bower) and its same-colour Jack (left bower) outranking everything;
;; order up or call trump, then take three tricks. Partnership to 10.
;; `cg-pitch' -- Auction Pitch (All Fours). Bid for the privilege of
;; pitching; the first card led sets trump. Score High, Low, Jack and
;; Game. First to 7.
;; `cg-briscola' -- Briscola. A 40-card deck, a fixed trump turned from
;; the deal, and no need to follow suit; capture the Aces and Threes.
;; Partnership race to 61 of the 120 points.
;;
;; Cards use the package cons (SUIT . RANK), RANK 0 (Two) .. 12 (Ace) as
;; in cg-trick.el.
;;; Code:
(require 'cl-lib)
(require 'eieio)
(require 'cg-core)
(require 'cg-trick)
;;;; Shared helpers
(defun cg-tx--deck (ranks)
"Return a shuffled deck holding only the RANKS (a list of rank indices)."
(random t)
(cg-shuffle (cl-loop for s below 4 append
(cl-loop for r in ranks collect (cons s r)))))
(defun cg-tx--deal (game deck hs)
"Deal HS cards each from DECK into GAME, in the cg-trick layout."
(let ((hands (make-vector 4 nil)) (last nil) (d deck))
(dotimes (s 4)
(let ((h nil))
(dotimes (_ hs) (setq last (pop d)) (push last h))
(aset hands s (cg-trick--sort h))))
(cg-put game :hands hands)
(cg-put game :deck d)
(cg-put game :last-card last)
(cg-put game :trick nil)
(cg-put game :tricks (make-vector 4 0))
(cg-put game :taken (make-vector 4 nil))
(cg-put game :broken t)
(cg-put game :trick-no 0)
game))
(defun cg-tx--winner (plays trump powerfn ledfn)
"Return the winning seat of PLAYS (a list of (SEAT . CARD), play order).
TRUMP is the trump suit; POWERFN and LEDFN rank cards for this game."
(let* ((led (funcall ledfn (cdr (car plays)) trump))
(best (car plays))
(bestp (funcall powerfn (cdr (car plays)) trump led)))
(dolist (p (cdr plays))
(let ((pp (funcall powerfn (cdr p) trump led)))
(when (> pp bestp) (setq best p bestp pp))))
(car best)))
(defun cg-tx--ai (game seat powerfn ledfn valuefn)
"Pick a card for SEAT: win cheaply if leading, else shed the cheapest.
POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(let* ((legal (cg-trick--legal-moves game seat))
(trick (cg-get game :trick)) (trump (oref game trump)))
(if (null trick)
(car (sort (copy-sequence legal)
(lambda (a b) (< (funcall valuefn a) (funcall valuefn b)))))
(let* ((order (reverse trick))
(led (funcall ledfn (cdr (car order)) trump))
(winners '()) (losers '()))
(dolist (c legal)
(if (= seat (cg-tx--winner (append order (list (cons seat c)))
trump powerfn ledfn))
(push c winners) (push c losers)))
(if winners
(car (sort winners (lambda (a b) (< (funcall powerfn a trump led)
(funcall powerfn b trump led)))))
(car (sort (or losers legal)
(lambda (a b) (< (funcall valuefn a) (funcall valuefn b))))))))))
(defun cg-tx--plain-led (card _trump) (car card))
;;;; Briscola
(defconst cg-briscola--ranks '(0 1 2 3 4 5 9 10 11 12)
"Rank indices in a 40-card Briscola deck (no 8, 9, or 10).")
(defclass cg-briscola-game (cg-trick-game)
((trump :initform nil) (target :initform 61) (hand-size :initform 10)
(vname :initform "Briscola"))
"Briscola: fixed trump, no follow, capture the points.")
(defun cg-bris--power (card _trump _led)
"Return CARD's rank power within its suit for Briscola."
(- 10 (or (cl-position (cdr card) '(12 1 11 10 9 5 4 3 2 0)) 10)))
(defun cg-bris--points (card)
"Return CARD's Briscola point value."
(pcase (cdr card) (12 11) (1 10) (11 4) (10 3) (9 2) (_ 0)))
(defun cg-bris--win-power (card trump led)
"Power with trump dominance, for resolving a Briscola trick."
(cond ((= (car card) trump) (+ 200 (cg-bris--power card trump led)))
((= (car card) led) (+ 100 (cg-bris--power card trump led)))
(t 0)))
(cl-defmethod cg-trick--legal-p ((game cg-briscola-game) seat card)
"Briscola has no obligation to follow suit."
(and (member card (cg-trick--hand game seat)) t))
(cl-defmethod cg-trick--winner ((game cg-briscola-game))
(cg-tx--winner (reverse (cg-get game :trick)) (oref game trump)
#'cg-bris--win-power #'cg-tx--plain-led))
(cl-defmethod cg-trick--ai-play ((game cg-briscola-game) seat)
(cg-tx--ai game seat #'cg-bris--win-power #'cg-tx--plain-led #'cg-bris--points))
(cl-defmethod cg-trick--begin-hand ((game cg-briscola-game))
(cg-tx--deal game (cg-tx--deck cg-briscola--ranks) 10)
(cg-put game :dealer (mod (1+ (or (cg-get game :dealer) 3)) 4))
(oset game trump (car (cg-get game :last-card)))
(cg-put game :cursor 0)
(let ((lead (mod (1+ (cg-get game :dealer)) 4)))
(cg-put game :leader lead) (cg-put game :turn lead))
(cg-put game :phase 'play)
(cg-put game :message
(format "Trump is %s. No need to follow suit."
(cg-suit-glyph (oref game trump))))
(cg-trick--run game))
(cl-defmethod cg-trick--score-hand ((game cg-briscola-game))
(let ((scores (cg-get game :scores)) (tp (make-vector 2 0)))
(dotimes (s 4)
(aset tp (cg-trick--team s)
(+ (aref tp (cg-trick--team s))
(apply #'+ (mapcar #'cg-bris--points (aref (cg-get game :taken) s))))))
(dotimes (s 4) (aset scores s (+ (aref scores s) (aref tp (cg-trick--team s)))))))
(cl-defmethod cg-trick--game-over-p ((game cg-briscola-game))
(or (>= (aref (cg-get game :scores) 0) (oref game target))
(>= (aref (cg-get game :scores) 1) (oref game target))))
(cl-defmethod cg-trick--winner-seat ((game cg-briscola-game))
(if (>= (aref (cg-get game :scores) 0) (aref (cg-get game :scores) 1)) 0 1))
(cl-defmethod cg-trick--result-string ((game cg-briscola-game))
(let ((w (cg-trick--winner-seat game)))
(format "%s win (%d points)" (if (= w 0) "You and North" "West and East")
(aref (cg-get game :scores) w))))
;;;###autoload
(defun cg-briscola ()
"Play Briscola against three AI opponents."
(interactive)
(cg-trick--play-game 'cg-briscola-game))
;;;; Auction Pitch
(defclass cg-pitch-game (cg-trick-game)
((trump :initform nil) (target :initform 7) (hand-size :initform 6)
(vname :initform "Pitch"))
"Auction Pitch: bid, pitch to set trump, score High/Low/Jack/Game.")
(defun cg-pitch--pip (rank)
"Return the Game-point pip value of RANK."
(pcase rank (12 4) (11 3) (10 2) (9 1) (8 10) (_ 0)))
(defun cg-pitch--power (card trump led)
"Rank CARD for a Pitch trick under TRUMP given the LED suit."
(cond ((and trump (= (car card) trump)) (+ 100 (cdr card)))
((= (car card) led) (+ 50 (cdr card)))
(t (cdr card))))
(cl-defmethod cg-trick--legal-p ((game cg-pitch-game) seat card)
"Pitch: follow the led suit if able, but you may always trump."
(let ((hand (cg-trick--hand game seat)) (trick (cg-get game :trick))
(trump (oref game trump)))
(and (member card hand)
(or (null trick)
(let ((led (cg-trick--led-suit game)))
(cond ((= (car card) led) t)
((and trump (= (car card) trump)) t)
((cl-some (lambda (c) (= (car c) led)) hand) nil)
(t t)))))))
(cl-defmethod cg-trick--play ((game cg-pitch-game) seat card)
"Set trump from the pitcher's first lead, then play normally."
(when (and (null (oref game trump)) (null (cg-get game :trick)))
(oset game trump (car card))
(cg-put game :message
(format "%s leads %s -- %s is trump."
(aref cg-trick-seat-names seat) (cg-trick-card-string card)
(cg-suit-glyph (car card)))))
(cl-call-next-method))
(cl-defmethod cg-trick--ai-play ((game cg-pitch-game) seat)
(if (and (null (oref game trump)) (= seat (cg-get game :leader)))
;; pitcher's opening lead: lead high from the strongest suit
(let ((best nil) (bestv -1))
(dotimes (s 4)
(let ((v (cg-pitch--suit-strength game seat s)))
(when (> v bestv) (setq bestv v best s))))
(car (sort (cl-remove-if-not (lambda (c) (= (car c) best))
(cg-trick--hand game seat))
(lambda (a b) (> (cdr a) (cdr b))))))
(cg-tx--ai game seat #'cg-pitch--power #'cg-tx--plain-led
(lambda (c) (cg-pitch--pip (cdr c))))))
(defun cg-pitch--suit-strength (game seat suit)
"Estimate SEAT's strength if SUIT were trump."
(let ((v 0))
(dolist (c (cg-trick--hand game seat))
(when (= (car c) suit)
(setq v (+ v 2 (pcase (cdr c) (12 4) (11 3) (9 3) (_ 1))))))
v))
(cl-defmethod cg-trick--ai-bid ((game cg-pitch-game) seat)
"Return SEAT's Pitch bid (0 to pass, else 2..4), bidding only what is makeable."
(let ((bid 0))
(dotimes (s 4)
(let* ((cards (cl-remove-if-not (lambda (c) (= (car c) s))
(cg-trick--hand game seat)))
(n (length cards))
(hasa (cl-find 12 cards :key #'cdr))
(hask (cl-find 11 cards :key #'cdr))
(hasj (cl-find 9 cards :key #'cdr))
(b (cond ((and (>= n 4) hasa hasj) 4)
((and (>= n 3) hasa (or hask hasj)) 3)
((and (>= n 3) hasa) 2)
((and (>= n 2) hasa hask) 2)
(t 0))))
(setq bid (max bid b))))
bid))
(defun cg-pitch--read-bid (game high)
"Prompt you for a Pitch bid that must beat HIGH (or 0 to pass)."
(let ((sug (cg-trick--ai-bid game 0)))
(max 0 (min 4 (read-number
(format "Your bid (0 pass, else %d-4) [suggest %d]: "
(max 2 (1+ high)) sug)
sug)))))
(cl-defmethod cg-trick--begin-hand ((game cg-pitch-game))
(cg-tx--deal game (cg-tx--deck (number-sequence 0 12)) 6)
(oset game trump nil)
(cg-put game :dealer (mod (1+ (or (cg-get game :dealer) 3)) 4))
(cg-put game :cursor 0)
(let ((high 0) (bidder nil))
(dotimes (k 4)
(let* ((s (mod (+ (cg-get game :dealer) 1 k) 4))
(b (if (= s 0)
(if noninteractive (cg-trick--ai-bid game 0) (cg-pitch--read-bid game high))
(cg-trick--ai-bid game s))))
(when (and (>= b 2) (> b high)) (setq high b bidder s))))
(unless bidder (setq bidder (cg-get game :dealer) high 2)) ; stuck dealer pitches 2
(cg-put game :bidder bidder) (cg-put game :bid high)
(cg-put game :leader bidder) (cg-put game :turn bidder)
(cg-put game :phase 'play)
(cg-put game :message
(format "%s pitches (bid %d). Their first card sets trump."
(aref cg-trick-seat-names bidder) high))
(cg-trick--run game)))
(cl-defmethod cg-trick--score-hand ((game cg-pitch-game))
(let* ((trump (oref game trump)) (scores (cg-get game :scores))
(earned (make-vector 4 0)) (game-pts (make-vector 4 0))
(bidder (cg-get game :bidder)) (bid (cg-get game :bid))
(hi nil) (hiseat nil) (lo nil) (loseat nil) (jackseat nil))
(dotimes (s 4)
(dolist (c (aref (cg-get game :taken) s))
(when (= (car c) trump)
(when (or (null hi) (> (cdr c) hi)) (setq hi (cdr c) hiseat s))
(when (or (null lo) (< (cdr c) lo)) (setq lo (cdr c) loseat s))
(when (= (cdr c) 9) (setq jackseat s)))
(aset game-pts s (+ (aref game-pts s) (cg-pitch--pip (cdr c))))))
(when hiseat (aset earned hiseat (1+ (aref earned hiseat))))
(when loseat (aset earned loseat (1+ (aref earned loseat))))
(when jackseat (aset earned jackseat (1+ (aref earned jackseat))))
(let ((best -1) (bs nil) (tie nil))
(dotimes (s 4)
(cond ((> (aref game-pts s) best) (setq best (aref game-pts s) bs s tie nil))
((= (aref game-pts s) best) (setq tie t))))
(when (and bs (not tie) (> best 0)) (aset earned bs (1+ (aref earned bs)))))
(dotimes (s 4)
(if (= s bidder)
(if (>= (aref earned s) bid)
(aset scores s (+ (aref scores s) (aref earned s)))
(aset scores s (- (aref scores s) bid)))
(aset scores s (+ (aref scores s) (aref earned s)))))
(cg-put game :last-earned earned)))
(cl-defmethod cg-trick--game-over-p ((game cg-pitch-game))
(cl-some (lambda (s) (>= s (oref game target))) (append (cg-get game :scores) nil)))
(cl-defmethod cg-trick--winner-seat ((game cg-pitch-game))
(let ((best 0)) (dotimes (s 4)
(when (> (aref (cg-get game :scores) s)
(aref (cg-get game :scores) best)) (setq best s)))
best))
(cl-defmethod cg-trick--result-string ((game cg-pitch-game))
(format "%s wins" (aref cg-trick-seat-names (cg-trick--winner-seat game))))
;;;###autoload
(defun cg-pitch ()
"Play Auction Pitch against three AI opponents."
(interactive)
(cg-trick--play-game 'cg-pitch-game))
;;;; Euchre
(defclass cg-euchre-game (cg-trick-game)
((trump :initform nil) (target :initform 10) (hand-size :initform 5)
(vname :initform "Euchre"))
"Euchre: 24 cards, bowers, order up or call trump, partnership to 10.")
(defun cg-euchre--right-bower-p (card trump)
(and (= (cdr card) 9) (= (car card) trump)))
(defun cg-euchre--left-bower-p (card trump)
(and (= (cdr card) 9) (= (car card) (cg-sister-suit trump))))
(defun cg-euchre--eff-suit (card trump)
"Return CARD's effective suit (the left bower belongs to TRUMP)."
(if (cg-euchre--left-bower-p card trump) trump (car card)))
(defun cg-euchre--power (card trump led)
"Rank CARD for a Euchre trick under TRUMP given the effective LED suit."
(cond ((cg-euchre--right-bower-p card trump) 1000)
((cg-euchre--left-bower-p card trump) 999)
((= (cg-euchre--eff-suit card trump) trump) (+ 900 (cdr card)))
((= (cg-euchre--eff-suit card trump) led) (+ 100 (cdr card)))
(t (cdr card))))
(defun cg-euchre--eff-led (card trump) (cg-euchre--eff-suit card trump))
(cl-defmethod cg-trick--legal-p ((game cg-euchre-game) seat card)
"Euchre: follow the effective led suit if able (left bower is trump)."
(let ((hand (cg-trick--hand game seat)) (trick (cg-get game :trick))
(trump (oref game trump)))
(and (member card hand)
(or (null trick)
(let ((led (cg-euchre--eff-suit (cdr (cg-trick--first-play game)) trump)))
(if (cl-some (lambda (c) (= (cg-euchre--eff-suit c trump) led)) hand)
(= (cg-euchre--eff-suit card trump) led)
t))))))
(cl-defmethod cg-trick--winner ((game cg-euchre-game))
(cg-tx--winner (reverse (cg-get game :trick)) (oref game trump)
#'cg-euchre--power #'cg-euchre--eff-led))
(cl-defmethod cg-trick--ai-play ((game cg-euchre-game) seat)
(cg-tx--ai game seat #'cg-euchre--power #'cg-euchre--eff-led
(lambda (c) (cg-euchre--power c (oref game trump) -1))))
(defun cg-euchre--strength (game seat suit)
"Estimate SEAT's trump strength if SUIT were trump."
(let ((v 0))
(dolist (c (cg-trick--hand game seat))
(cond ((cg-euchre--right-bower-p c suit) (setq v (+ v 4)))
((cg-euchre--left-bower-p c suit) (setq v (+ v 3)))
((= (cg-euchre--eff-suit c suit) suit) (setq v (+ v 2)))
((= (cdr c) 12) (setq v (+ v 1))))) ; off-ace
v))
(defun cg-euchre--ai-order (game seat upsuit)
"Return non-nil if SEAT orders up the UPSUIT."
(>= (cg-euchre--strength game seat upsuit) 6))
(defun cg-euchre--ai-call (game seat upsuit)
"Return a suit SEAT calls in round two, or nil to pass."
(let ((best nil) (bestv 0))
(dotimes (s 4)
(unless (= s upsuit)
(let ((v (cg-euchre--strength game seat s)))
(when (> v bestv) (setq bestv v best s)))))
(and (>= bestv 6) best)))
(defun cg-euchre--best-suit (game seat upsuit)
"Return SEAT's strongest suit other than UPSUIT (for a stuck dealer)."
(let ((best (mod (1+ upsuit) 4)) (bestv -1))
(dotimes (s 4)
(unless (= s upsuit)
(let ((v (cg-euchre--strength game seat s)))
(when (> v bestv) (setq bestv v best s)))))
best))
(defun cg-euchre--dealer-pickup (game up)
"Dealer takes the UP card and discards their weakest card."
(let* ((d (cg-get game :dealer)) (trump (car up))
(hand (cons up (cg-trick--hand game d)))
(worst (car (sort (copy-sequence hand)
(lambda (a b) (< (cg-euchre--power a trump -1)
(cg-euchre--power b trump -1)))))))
(cg-trick--set-hand game d (cg-trick--sort (remove worst hand)))))
(cl-defmethod cg-trick--begin-hand ((game cg-euchre-game))
(cg-tx--deal game (cg-tx--deck '(7 8 9 10 11 12)) 5)
(oset game trump nil)
(cg-put game :dealer (mod (1+ (or (cg-get game :dealer) 3)) 4))
(cg-put game :cursor 0)
(let* ((up (car (cg-get game :deck))) (upsuit (car up))
(dealer (cg-get game :dealer)) (maker nil) (chosen nil))
(cg-put game :up up)
(cl-block bid
(dotimes (k 4)
(let ((s (mod (+ dealer 1 k) 4)))
(when (if (= s 0)
(if noninteractive (cg-euchre--ai-order game 0 upsuit)
(y-or-n-p (format "Order up %s as trump? " (cg-suit-glyph upsuit))))
(cg-euchre--ai-order game s upsuit))
(setq maker s chosen upsuit)
(cg-euchre--dealer-pickup game up)
(cl-return-from bid))))
(dotimes (k 4)
(let* ((s (mod (+ dealer 1 k) 4))
(suit (if (= s 0)
(if noninteractive (cg-euchre--ai-call game 0 upsuit)
(cg-euchre--human-call upsuit))
(cg-euchre--ai-call game s upsuit))))
(when suit (setq maker s chosen suit) (cl-return-from bid)))))
(unless chosen
(setq maker dealer chosen (cg-euchre--best-suit game dealer upsuit)))
(oset game trump chosen)
(cg-put game :maker maker)
(let ((lead (mod (1+ dealer) 4)))
(cg-put game :leader lead) (cg-put game :turn lead))
(cg-put game :phase 'play)
(cg-put game :message
(format "%s makes %s trump." (aref cg-trick-seat-names maker)
(cg-suit-glyph chosen)))
(cg-trick--run game)))
(defun cg-euchre--human-call (upsuit)
"Prompt you to name a trump suit other than UPSUIT, or pass."
(let* ((choices (cl-loop for s below 4 unless (= s upsuit)
collect (cons (aref cg-suit-names s) s)))
(pick (completing-read "Call trump (or RET to pass): "
(mapcar #'car choices) nil t)))
(cdr (assoc pick choices))))
(cl-defmethod cg-trick--score-hand ((game cg-euchre-game))
(let* ((scores (cg-get game :scores))
(mteam (cg-trick--team (cg-get game :maker)))
(mt (+ (aref (cg-get game :tricks) mteam)
(aref (cg-get game :tricks) (+ mteam 2))))
(oteam (- 1 mteam)))
(cl-flet ((award (team n) (dolist (s (list team (+ team 2)))
(aset scores s (+ (aref scores s) n)))))
(cond ((>= mt 5) (award mteam 2))
((>= mt 3) (award mteam 1))
(t (award oteam 2))))))
(cl-defmethod cg-trick--game-over-p ((game cg-euchre-game))
(or (>= (aref (cg-get game :scores) 0) (oref game target))
(>= (aref (cg-get game :scores) 1) (oref game target))))
(cl-defmethod cg-trick--winner-seat ((game cg-euchre-game))
(if (>= (aref (cg-get game :scores) 0) (aref (cg-get game :scores) 1)) 0 1))
(cl-defmethod cg-trick--result-string ((game cg-euchre-game))
(let ((w (cg-trick--winner-seat game)))
(format "%s win" (if (= w 0) "You and North" "West and East"))))
;;;###autoload
(defun cg-euchre ()
"Play Euchre against three AI opponents."
(interactive)
(cg-trick--play-game 'cg-euchre-game))
(provide 'cg-trick-ext)
;;; cg-trick-ext.el ends here

116
test/card-games-tests.el
View file

@ -908,3 +908,119 @@
(when (> turns 500000) (error "runaway")))))
(should (eq (cg-get g :phase) 'game-over))
(should (stringp (cg-render g)))))
;;;; Matching games (Go Fish, Old Maid)
(ert-deftest cgt-gofish-full ()
(let ((cg-go-fish-players 4) (g (cg-go-fish-game)) (guard 0))
(cg-gf--deal g)
(while (and (not (eq (cg-get g :phase) 'game-over)) (< guard 20000))
(cg-gf--ai-turn g (cg-get g :turn)) (cl-incf guard))
(should (eq (cg-get g :phase) 'game-over))
(let ((tot 0)) (dotimes (s 4) (cl-incf tot (cg-gf--books g s)))
(should (= tot 13)))
(should (stringp (cg-render g)))))
(ert-deftest cgt-oldmaid-full ()
(let ((cg-old-maid-players 4) (g (cg-old-maid-game)) (guard 0))
(cg-om--deal g)
(while (and (not (eq (cg-get g :phase) 'game-over)) (< guard 20000))
(cg-om--ai-turn g (cg-get g :turn)) (cl-incf guard))
(should (eq (cg-get g :phase) 'game-over))
(should (= 1 (cg-om--total g)))
(should (stringp (cg-render g)))))
;;;; Cribbage
(ert-deftest cgt-cribbage-scorer ()
(should (= 29 (cg-crib--score-show '((0 . 4)(1 . 4)(3 . 4)(2 . 10)) '(2 . 4))))
(should (= 12 (cg-crib--count-pairs '((0 . 4)(1 . 4)(2 . 4)(3 . 4)))))
(should (= 5 (cg-crib--count-runs '((0 . 1)(0 . 2)(0 . 3)(0 . 4)(0 . 5)))))
(should (= 2 (cg-crib--peg-score '((0 . 10)(0 . 4)) 15)))
(should (= 3 (cg-crib--peg-score '((0 . 2)(0 . 3)(0 . 4)) 12)))
(should (= 6 (cg-crib--peg-score '((0 . 6)(1 . 6)(2 . 6)) 21))))
(ert-deftest cgt-cribbage-full ()
(let ((g (cg-cribbage-game)) (deals 0))
(cg-put g :dealer 1)
(cl-flet ((ai-deal (g)
(cg-crib--deal g)
(let ((d0 (cg-crib--ai-discard g 0)) (d1 (cg-crib--ai-discard g 1)))
(cg-crib--set-hand g 0 (cl-set-difference (cg-crib--hand g 0) d0 :test #'equal))
(cg-crib--set-hand g 1 (cl-set-difference (cg-crib--hand g 1) d1 :test #'equal))
(cg-put g :crib (append d0 d1)))
(cg-crib--start-play g)
(let ((guard 0))
(while (and (eq (cg-get g :phase) 'play) (not (cg-crib--peg-over-p g))
(< guard 400))
(cl-incf guard)
(let ((s (cg-get g :pturn)))
(if (cg-crib--legal g s) (cg-crib--ai-play g s) (cg-crib--peg-go g s)))))
(when (and (eq (cg-get g :phase) 'play) (cg-crib--peg-over-p g))
(cg-crib--show g))))
(while (and (not (eq (cg-get g :phase) 'game-over)) (< deals 300))
(cg-put g :dealer (- 1 (cg-get g :dealer)))
(ai-deal g) (cl-incf deals)))
(should (eq (cg-get g :phase) 'game-over))
(should (stringp (cg-render g)))))
;;;; Fishing games (Scopa, Casino)
(ert-deftest cgt-fish-capture ()
(let ((g (cg-scopa-game)))
(cg-put g :table '((0 . 0)(1 . 1)(2 . 3)))
(should (equal (sort (mapcar #'cdr (cg-fish--capture g '(3 . 4))) #'<) '(0 3))))
(let ((g (cg-casino-game)))
(cg-put g :table '((0 . 12)(1 . 12)(2 . 5)))
(should (= 1 (length (cg-fish--capture g '(3 . 12)))))))
(ert-deftest cgt-fish-full ()
(dolist (mk (list #'cg-scopa-game #'cg-casino-game))
(let ((g (funcall mk)) (rounds 0))
(cg-fish--deal-round g)
(while (and (not (eq (cg-get g :phase) 'game-over)) (< rounds 200))
(if (eq (cg-get g :phase) 'round-over)
(cg-fish--deal-round g)
(cg-fish--ai-play g (cg-get g :turn)) (cl-incf rounds)))
(should (eq (cg-get g :phase) 'game-over))
(should (stringp (cg-render g))))))
;;;; Trick extensions (Euchre, Pitch, Briscola)
(ert-deftest cgt-euchre-bowers ()
(should (> (cg-euchre--power '(0 . 9) 0 0) (cg-euchre--power '(1 . 9) 0 0)))
(should (> (cg-euchre--power '(1 . 9) 0 0) (cg-euchre--power '(0 . 12) 0 0)))
(should (= 120 (let ((s 0)) (dolist (su '(0 1 2 3))
(dolist (r cg-briscola--ranks)
(setq s (+ s (cg-bris--points (cons su r)))))) s))))
(ert-deftest cgt-trick-ext-full ()
(dolist (class '(cg-briscola-game cg-pitch-game cg-euchre-game))
(let ((g (make-instance class)) (guard 0))
(cg-trick--new g)
(while (and (not (eq (cg-get g :phase) 'game-over)) (< guard 50000))
(cl-incf guard)
(if (cg-trick--hand-over-p g)
(cg-trick--finish-hand g)
(let ((s (cg-get g :turn)))
(cg-trick--play g s (cg-trick--ai-play g s)))))
(should (eq (cg-get g :phase) 'game-over))
(should (stringp (cg-render g))))))
;;;; Spite & Malice
(ert-deftest cgt-spite-legal ()
(let ((g (cg-spite-game)))
(cg-spite--deal g) (cg-put g :center (make-vector 4 nil))
(should (eql 0 (cg-spite--legal-center g '(0 . 0)))) ; Ace starts a pile
(should (null (cg-spite--legal-center g '(0 . 1)))) ; a Two cannot
(should (eql 0 (cg-spite--legal-center g '(0 . 12)))) ; King is wild
(cg-spite--put-center g '(0 . 0) 0)
(should (= 1 (cg-spite--needed g 0)))))
(ert-deftest cgt-spite-full ()
(let ((cg-spite-goal-size 10) (g (cg-spite-game)) (turns 0))
(cg-spite--deal g)
(while (and (eq (cg-get g :phase) 'play) (< turns 6000))
(cl-incf turns) (cg-spite--ai-turn g (cg-get g :turn)))
(should (eq (cg-get g :phase) 'game-over))
(should (stringp (cg-render g)))))