From 905d5989c27bc4befb9c5b99235c483dcb479a61 Mon Sep 17 00:00:00 2001 From: Corwin Brust Date: Thu, 25 Jun 2026 06:31:44 -0500 Subject: [PATCH] Add nine games: Go Fish, Old Maid, Cribbage, Scopa, Casino, 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. --- Makefile | 2 +- README.org | 31 +++ card-games.el | 25 +- cg-cribbage.el | 437 ++++++++++++++++++++++++++++++++++ cg-match.el | 481 +++++++++++++++++++++++++++++++++++++ cg-scopa.el | 404 +++++++++++++++++++++++++++++++ cg-spite.el | 426 +++++++++++++++++++++++++++++++++ cg-trick-ext.el | 501 +++++++++++++++++++++++++++++++++++++++ test/card-games-tests.el | 116 +++++++++ 9 files changed, 2421 insertions(+), 2 deletions(-) create mode 100644 cg-cribbage.el create mode 100644 cg-match.el create mode 100644 cg-scopa.el create mode 100644 cg-spite.el create mode 100644 cg-trick-ext.el diff --git a/Makefile b/Makefile index ea21149..04841c1 100644 --- a/Makefile +++ b/Makefile @@ -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) diff --git a/README.org b/README.org index 2108afb..d32b359 100644 --- a/README.org +++ b/README.org @@ -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 diff --git a/card-games.el b/card-games.el index cb86611..8aca84c 100644 --- a/card-games.el +++ b/card-games.el @@ -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.") diff --git a/cg-cribbage.el b/cg-cribbage.el new file mode 100644 index 0000000..921b3a9 --- /dev/null +++ b/cg-cribbage.el @@ -0,0 +1,437 @@ +;;; cg-cribbage.el --- Cribbage, with pegging and the show -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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 "") #'cg-crib-left) + (define-key map (kbd "") #'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 diff --git a/cg-match.el b/cg-match.el new file mode 100644 index 0000000..02bf7b2 --- /dev/null +++ b/cg-match.el @@ -0,0 +1,481 @@ +;;; cg-match.el --- Go Fish and Old Maid -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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 "") #'cg-gf-left) + (define-key map (kbd "") #'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 "") #'cg-om-left) + (define-key map (kbd "") #'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 diff --git a/cg-scopa.el b/cg-scopa.el new file mode 100644 index 0000000..5b884ef --- /dev/null +++ b/cg-scopa.el @@ -0,0 +1,404 @@ +;;; cg-scopa.el --- Scopa and Casino, capturing games -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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 "") #'cg-fish-left) + (define-key map (kbd "") #'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 diff --git a/cg-spite.el b/cg-spite.el new file mode 100644 index 0000000..56d8a46 --- /dev/null +++ b/cg-spite.el @@ -0,0 +1,426 @@ +;;; cg-spite.el --- Spite and Malice, a competitive patience -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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 "") #'cg-spite-left) + (define-key map (kbd "") #'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 diff --git a/cg-trick-ext.el b/cg-trick-ext.el new file mode 100644 index 0000000..a8997be --- /dev/null +++ b/cg-trick-ext.el @@ -0,0 +1,501 @@ +;;; cg-trick-ext.el --- Euchre, Pitch and Briscola -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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 diff --git a/test/card-games-tests.el b/test/card-games-tests.el index b1de5ce..98caea3 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -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)))))