diff --git a/Makefile b/Makefile index ecc7d0c..d77e1ff 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 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 cg-bridge.el card-games.el ELC = $(EL:.el=.elc) PKGDESC = $(PKG)-pkg.el TARDIR = $(PKG)-$(VERSION) diff --git a/README.org b/README.org index 1fadacb..1cdbfa1 100644 --- a/README.org +++ b/README.org @@ -60,6 +60,57 @@ with its command. beat it or pass; first out rules, last out scrubs, and the roles trade cards on the next deal. +** Rummy +- ~cg-gin~ -- Gin Rummy. A two-handed duel: draw or take the discard, + build sets and runs, and knock once your deadwood is ten or less, or go + gin with none; your opponent then lays off and may undercut you. First + to 100 wins. +- ~cg-rummy-basic~ -- Rummy. Meld sets and runs onto the table and lay + cards off onto them; empty your hand to go out and score the cards left + in the other hands. +- ~cg-rum500~ -- Rummy 500. As above, but you score the cards you lay + down and lose the cards left in your hand; first past 500 wins. +- ~cg-handfoot~ -- Hand & Foot. A partnership Canasta cousin: play a hand + 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. + +** Bridge +- ~cg-bridge~ -- Contract Bridge. A full auction (bids, pass, double, + redouble), play with the dummy exposed, and classic rubber scoring with + vulnerability. You are South; when you declare you play the dummy too. + The bidding AI is a small natural system, sensible but no expert. + * 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 de17e2b..b9b783b 100644 --- a/card-games.el +++ b/card-games.el @@ -49,6 +49,15 @@ (require 'cg-eights) (require 'cg-patience) (require 'cg-president) +(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) +(require 'cg-bridge) (defvar card-games-list '(("500 (Bid)" cg-bid @@ -88,7 +97,35 @@ ("Oh Hell" cg-ohhell "Trick-taking: shrinking hands; bid the exact tricks you will take.") ("President" cg-president - "Climbing: shed your hand; first out rules, last out scrubs.")) + "Climbing: shed your hand; first out rules, last out scrubs.") + ("Gin Rummy" cg-gin + "Rummy: form melds, knock with little deadwood; head to head to 100.") + ("Rummy" cg-rummy-basic + "Rummy: meld your whole hand to the table to go out.") + ("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.") + ("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.") + ("Bridge" cg-bridge + "Trick-taking: the auction, the dummy, and rubber scoring, to 121.")) "Registry of playable games. Each entry is (NAME COMMAND DESCRIPTION); `card-game' lists them.") diff --git a/cg-bridge.el b/cg-bridge.el new file mode 100644 index 0000000..d3b7379 --- /dev/null +++ b/cg-bridge.el @@ -0,0 +1,730 @@ +;;; cg-bridge.el --- Contract Bridge with rubber scoring -*- 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: + +;; Contract Bridge: you are South, partnered with North, against East and +;; West. Each deal has an auction -- bids of a level (1-7) and a strain +;; (clubs, diamonds, hearts, spades, or no-trump), plus Pass, Double, and +;; Redouble -- followed by the play of thirteen tricks with the dummy (the +;; declarer's partner) exposed. Scoring is the classic rubber game: trick +;; points below the line race toward game, and bonuses, overtricks, and +;; penalties go above; two games win the rubber. +;; +;; When you are declarer you play both your own hand and the dummy; when +;; you defend you play your own cards and the computer plays the rest. +;; +;; The bidding AI is a deliberately small natural system (it opens on +;; about twelve points, raises to game with a fit, and overcalls a good +;; long suit); it reaches sensible contracts but is no expert. Cards use +;; the package cons (SUIT . RANK), SUIT 0 spades, 1 clubs, 2 diamonds, +;; 3 hearts, RANK 0 (Two) .. 12 (Ace). + +;;; Code: + +(require 'cl-lib) +(require 'eieio) +(require 'cg-core) + +(defconst cg-bridge-ranks + ["2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K" "A"] + "Rank labels indexed 0 (Two) .. 12 (Ace).") + +(defconst cg-bridge-strains ["♣" "♦" "♥" "♠" "NT"] + "Strain glyphs indexed 0 clubs, 1 diamonds, 2 hearts, 3 spades, 4 no-trump.") + +(defconst cg-bridge--strain-suit [1 2 3 0 nil] + "Map a strain index to its trump suit index (nil for no-trump).") + +(defconst cg-bridge--suit-strain [3 0 1 2] + "Map a suit index (0 S,1 C,2 D,3 H) to its strain index.") + +(defconst cg-bridge-seat-names ["South" "West" "North" "East"] + "Seat names indexed 0..3 clockwise from the human.") + +(defclass cg-bridge-game (cg-game) + ((vname :initform "Bridge")) + "A game of contract Bridge.") + +(defun cg-bridge-card-string (card) + "Return a short string for CARD." + (if (null card) "·" + (concat (aref cg-bridge-ranks (cdr card)) (cg-suit-glyph (car card))))) + +(defun cg-bridge--sort (cards) + "Return CARDS sorted by suit then rank (high first) for display." + (sort (copy-sequence cards) + (lambda (a b) (if (= (car a) (car b)) (> (cdr a) (cdr b)) (< (car a) (car b)))))) + +(defun cg-bridge--deck () + "Return a fresh shuffled 52-card deck." + (random t) + (cg-shuffle (cl-loop for s below 4 append + (cl-loop for r below 13 collect (cons s r))))) + +;;;; Hand evaluation + +(defun cg-bridge--hcp (hand) + "Return the high-card points of HAND (A=4 K=3 Q=2 J=1)." + (let ((p 0)) + (dolist (c hand p) + (setq p (+ p (pcase (cdr c) (12 4) (11 3) (10 2) (9 1) (_ 0))))))) + +(defun cg-bridge--suit-len (hand suit) + "Return how many cards of SUIT are in HAND." + (cl-count suit hand :key #'car)) + +(defun cg-bridge--longest (hand) + "Return the suit index HAND holds most of (ties prefer majors, then spades)." + (let ((best 0) (bestn -1)) + ;; check in order hearts, diamonds, clubs, spades so spades win ties last + (dolist (s '(3 2 1 0)) + (let ((n (cg-bridge--suit-len hand s))) + (when (>= n bestn) (setq bestn n best s)))) + best)) + +(defun cg-bridge--balanced-p (hand) + "Return non-nil when HAND has a balanced shape (no void/singleton)." + (let ((doubletons 0) (ok t)) + (dotimes (s 4) + (let ((n (cg-bridge--suit-len hand s))) + (when (< n 2) (setq ok nil)) + (when (= n 2) (setq doubletons (1+ doubletons))))) + (and ok (<= doubletons 1)))) + +;;;; Auction mechanics + +(defsubst cg-bridge--hand (game s) (aref (cg-get game :hands) s)) +(defsubst cg-bridge--set-hand (game s v) (aset (cg-get game :hands) s v)) +(defsubst cg-bridge--side (s) (mod s 2)) + +(cl-defmethod cg-bridge--deal ((game cg-bridge-game)) + "Deal a fresh Bridge hand into GAME, leaving it ready for the auction." + (let ((deck (cg-bridge--deck)) (hands (make-vector 4 nil))) + (dotimes (s 4) + (aset hands s (cg-bridge--sort (cl-loop repeat 13 collect (pop deck))))) + (cg-put game :hands hands) + (cg-put game :calls nil) ; list of (SEAT . CALL), newest first + (cg-put game :contract nil) ; (LEVEL . STRAIN) + (cg-put game :declarer nil) + (cg-put game :doubled 0) + (cg-put game :dealer (or (cg-get game :dealer) 0)) + (cg-put game :bidder (cg-get game :dealer)) + (cg-put game :phase 'auction) + (cg-put game :cursor 0) + (cg-put game :bid-level 1) ; UI: level being composed + (cg-put game :bid-strain 0) + (cg-put game :trick nil) + (cg-put game :tricks 0) ; declarer-side tricks won + (cg-put game :dummy nil) + (cg-put game :exposed nil) + (unless (cg-get game :below) (cg-put game :below (make-vector 2 0))) + (unless (cg-get game :above) (cg-put game :above (make-vector 2 0))) + (unless (cg-get game :games) (cg-put game :games (make-vector 2 0))) + (unless (cg-get game :vul) (cg-put game :vul (make-vector 2 nil))) + (cg-put game :message "Auction: compose a bid and press RET, or p/d to pass/double.") + game)) + +(defun cg-bridge--high-bid (game) + "Return the highest (LEVEL . STRAIN) bid so far, or nil." + (cl-loop for (_s . call) in (cg-get game :calls) + when (consp call) return call)) + +(defun cg-bridge--high-bidder (game) + "Return the seat that made the highest bid, or nil." + (cl-loop for (s . call) in (cg-get game :calls) + when (consp call) return s)) + +(defun cg-bridge--call> (a b) + "Return non-nil when bid A is higher than bid B (each (LEVEL . STRAIN))." + (or (null b) + (> (car a) (car b)) + (and (= (car a) (car b)) (> (cdr a) (cdr b))))) + +(defun cg-bridge--legal-call-p (game call) + "Return non-nil when CALL is legal now in GAME." + (let ((high (cg-bridge--high-bid game)) + (hb (cg-bridge--high-bidder game))) + (pcase call + ('pass t) + ('double (and high (/= (cg-bridge--side hb) (cg-bridge--side (cg-get game :bidder))) + (= (cg-get game :doubled) 0))) + ('redouble (and high (= (cg-bridge--side hb) (cg-bridge--side (cg-get game :bidder))) + (= (cg-get game :doubled) 1))) + (_ (and (consp call) (>= (car call) 1) (<= (car call) 7) + (cg-bridge--call> call high)))))) + +(defun cg-bridge--apply-call (game seat call) + "Record CALL by SEAT and update doubling state." + (cg-put game :calls (cons (cons seat call) (cg-get game :calls))) + (pcase call + ('double (cg-put game :doubled 1)) + ('redouble (cg-put game :doubled 2)) + ((pred consp) (cg-put game :doubled 0))) + (cg-put game :bidder (mod (1+ seat) 4))) + +(defun cg-bridge--auction-done-p (game) + "Return non-nil when the auction has ended. +Sets up the contract (or a pass-out) as a side effect." + (let* ((calls (cg-get game :calls)) (n (length calls))) + (cond + ;; four passes with no bid: passed out + ((and (= n 4) (cl-every (lambda (c) (eq (cdr c) 'pass)) calls)) + (cg-put game :phase 'passed-out) t) + ;; a bid then three passes + ((and (cg-bridge--high-bid game) + (>= n 3) + (cl-every (lambda (c) (eq (cdr c) 'pass)) + (cl-subseq calls 0 3))) + (cg-bridge--establish-contract game) t) + (t nil)))) + +(defun cg-bridge--establish-contract (game) + "Set the contract, declarer, and start of play from the finished auction." + (let* ((bid (cg-bridge--high-bid game)) + (side (cg-bridge--side (cg-bridge--high-bidder game))) + (strain (cdr bid)) + (declarer + ;; first player of SIDE to have named STRAIN + (cl-loop for (s . call) in (reverse (cg-get game :calls)) + when (and (consp call) (= (cdr call) strain) + (= (cg-bridge--side s) side)) + return s))) + (cg-put game :contract bid) + (cg-put game :declarer declarer) + (cg-put game :dummy (mod (+ declarer 2) 4)) + (cg-put game :phase 'play) + (cg-put game :leader (mod (1+ declarer) 4)) + (cg-put game :turn (mod (1+ declarer) 4)) + (cg-put game :trick nil) + (cg-put game :tricks 0) + (cg-put game :cursor 0) + (cg-put game :message + (format "Contract: %s by %s. %s leads." + (cg-bridge--contract-string game) + (aref cg-bridge-seat-names declarer) + (aref cg-bridge-seat-names (cg-get game :leader)))))) + +(defun cg-bridge--contract-string (game) + "Return a label for GAME's contract, e.g. \"4NT x\"." + (let ((c (cg-get game :contract)) (d (cg-get game :doubled))) + (if (null c) "passed out" + (format "%d%s%s" (car c) (aref cg-bridge-strains (cdr c)) + (pcase d (1 " x") (2 " xx") (_ "")))))) + +;;;; Play mechanics + +(defun cg-bridge--trump (game) + "Return the trump suit index for GAME, or nil for no-trump." + (and (cg-get game :contract) (aref cg-bridge--strain-suit (cdr (cg-get game :contract))))) + +(defun cg-bridge--led-suit (game) + "Return the suit led to the current trick, or nil." + (let ((tr (cg-get game :trick))) + (and tr (car (cdr (car (last tr))))))) + +(defun cg-bridge--legal-play-p (game seat card) + "Return non-nil when SEAT may play CARD now (follow suit if able)." + (let ((hand (cg-bridge--hand game seat)) (led (cg-bridge--led-suit game))) + (and (member card hand) + (or (null led) + (= (car card) led) + (not (cl-some (lambda (c) (= (car c) led)) hand)))))) + +(defun cg-bridge--legal-plays (game seat) + "Return SEAT's legal cards now." + (cl-remove-if-not (lambda (c) (cg-bridge--legal-play-p game seat c)) + (cg-bridge--hand game seat))) + +(defun cg-bridge--trick-winner (plays trump) + "Return the winning seat of complete PLAYS ((SEAT . CARD), play order)." + (let ((best (car plays))) + (dolist (p (cdr plays)) + (let ((bc (cdr best)) (pc (cdr p))) + (cond + ((and trump (= (car pc) trump) (/= (car bc) trump)) (setq best p)) + ((and (= (car pc) (car bc)) (> (cdr pc) (cdr bc))) (setq best p))))) + (car best))) + +(defun cg-bridge--play-card (game seat card) + "Have SEAT play CARD; resolve and score the trick when it completes." + (cg-bridge--set-hand game seat (remove card (cg-bridge--hand game seat))) + (cg-put game :trick (cons (cons seat card) (cg-get game :trick))) + ;; expose the dummy after the opening lead + (unless (cg-get game :exposed) + (cg-put game :exposed t)) + (if (= 4 (length (cg-get game :trick))) + (let ((w (cg-bridge--trick-winner (reverse (cg-get game :trick)) + (cg-bridge--trump game)))) + (when (= (cg-bridge--side w) (cg-bridge--side (cg-get game :declarer))) + (cg-put game :tricks (1+ (cg-get game :tricks)))) + (cg-put game :trick nil) + (cg-put game :leader w) + (cg-put game :turn w) + (cg-put game :last-winner w) + (when (cl-every #'null (append (cg-get game :hands) nil)) + (cg-bridge--score-deal game)) + w) + (cg-put game :turn (mod (1+ seat) 4)) + nil)) + +;;;; Scoring (rubber) + +(defun cg-bridge--undertrick-points (n doubled vul) + "Return defender points for N undertricks at DOUBLED level and VUL state." + (cond + ((= doubled 0) (* n (if vul 100 50))) + (t (let ((mult (if (= doubled 2) 2 1)) (sum 0)) + (dotimes (i n) + (setq sum (+ sum (* mult (if vul (if (= i 0) 200 300) + (cond ((= i 0) 100) ((< i 3) 200) (t 300))))))) + sum)))) + +(defun cg-bridge--deal-score (level strain doubled vul tricks) + "Return a plist scoring a contract result. +LEVEL/STRAIN/DOUBLED describe the contract, VUL the declarer's +vulnerability, and TRICKS the declarer side's trick count. Keys: +:below contracted points, :datk declarer bonus points above the line, +:defend defender points, :result tricks over/under the contract." + (let* ((need (+ 6 level)) (result (- tricks need)) + (mult (pcase doubled (0 1) (1 2) (2 4))) + (below 0) (datk 0) (defend 0)) + (if (>= result 0) + (progn + (setq below (* mult (if (= strain 4) (+ 40 (* 30 (1- level))) + (* (if (<= strain 1) 20 30) level)))) + (when (> result 0) + (setq datk (+ datk (if (= doubled 0) + (* result (if (= strain 4) 30 (if (<= strain 1) 20 30))) + (* result (* (if (= doubled 2) 2 1) (if vul 200 100))))))) + (when (> doubled 0) (setq datk (+ datk (if (= doubled 2) 100 50)))) + (cond ((= level 6) (setq datk (+ datk (if vul 750 500)))) + ((= level 7) (setq datk (+ datk (if vul 1500 1000)))))) + (setq defend (cg-bridge--undertrick-points (- result) doubled vul))) + (list :below below :datk datk :defend defend :result result))) + +(defun cg-bridge--score-deal (game) + "Score the finished deal into GAME's rubber state." + (let* ((c (cg-get game :contract)) (level (car c)) (strain (cdr c)) + (decl (cg-get game :declarer)) (side (cg-bridge--side decl)) + (opp (- 1 side)) (doubled (cg-get game :doubled)) + (vul (aref (cg-get game :vul) side)) + (sc (cg-bridge--deal-score level strain doubled vul (cg-get game :tricks))) + (below (cg-get game :below)) (above (cg-get game :above))) + (aset below side (+ (aref below side) (plist-get sc :below))) + (aset above side (+ (aref above side) (plist-get sc :datk))) + (aset above opp (+ (aref above opp) (plist-get sc :defend))) + (cg-put game :deal-result sc) + ;; game / rubber bookkeeping + (when (>= (aref below side) 100) + (let ((games (cg-get game :games))) + (aset games side (1+ (aref games side))) + (aset (cg-get game :vul) side t) + (aset below 0 0) (aset below 1 0) + (when (>= (aref games side) 2) + (aset above side (+ (aref above side) + (if (>= (aref games opp) 1) 500 700))) + (cg-put game :rubber-winner side)))) + (cg-put game :phase 'scored) + (cg-put game :message + (format "%s: %s. %s" + (cg-bridge--contract-string game) + (let ((r (plist-get sc :result))) + (cond ((>= r 0) (format "made +%d" r)) + (t (format "down %d" (- r))))) + (if (cg-get game :rubber-winner) + (format "%s win the rubber! (n: new rubber)" + (if (= side 0) "You and North" "East and West")) + "(n: next deal)"))))) + +;;;; AI -- bidding + +(cl-defmethod cg-bridge--ai-call ((game cg-bridge-game) seat) + "Return a call for AI SEAT from a small natural system." + (let* ((hand (cg-bridge--hand game seat)) (hcp (cg-bridge--hcp hand)) + (high (cg-bridge--high-bid game)) (hb (cg-bridge--high-bidder game)) + (ours (and high (= (cg-bridge--side hb) (cg-bridge--side seat))))) + (cond + ((null high) ; opening + (cond ((and (cg-bridge--balanced-p hand) (>= hcp 15) (<= hcp 17)) (cons 1 4)) + ((and (cg-bridge--balanced-p hand) (>= hcp 20) (<= hcp 21)) (cons 2 4)) + ((>= hcp 12) + (let ((suit (cg-bridge--longest hand))) + (cons 1 (aref cg-bridge--suit-strain suit)))) + (t 'pass))) + (ours ; partner has the contract + (let* ((est (+ hcp 13)) (hl (car high)) (hs (cdr high)) + (fit (or (= hs 4) + (>= (cg-bridge--suit-len + hand (aref cg-bridge--strain-suit hs)) 3)))) + (if (and fit (>= est 26) (< hl 4) + (cg-bridge--legal-call-p + game (cond ((= hs 4) (cons 3 4)) + ((>= hs 2) (cons 4 hs)) + (t (cons 5 hs))))) + (cond ((= hs 4) (cons 3 4)) ((>= hs 2) (cons 4 hs)) (t (cons 5 hs))) + 'pass))) + (t ; opponents have the contract + (let* ((suit (cg-bridge--longest hand)) + (len (cg-bridge--suit-len hand suit)) + (st (aref cg-bridge--suit-strain suit)) + (cand (if (> st (cdr high)) (cons (car high) st) + (cons (1+ (car high)) st)))) + (if (and (>= hcp 11) (>= len 5) (<= (car cand) 3) + (cg-bridge--legal-call-p game cand)) + cand 'pass)))))) + +;;;; AI -- play + +(cl-defmethod cg-bridge--ai-play ((game cg-bridge-game) seat) + "Return a card for AI SEAT: win cheaply or shed low." + (let* ((legal (cg-bridge--legal-plays game seat)) + (trump (cg-bridge--trump game)) (trick (cg-get game :trick))) + (if (null trick) + ;; leading: low from the longest non-trump suit, else lowest + (car (sort (copy-sequence legal) + (lambda (a b) (< (cdr a) (cdr b))))) + (let* ((order (reverse trick)) + (cur (cg-bridge--trick-winner order trump)) + (partner (= (cg-bridge--side cur) (cg-bridge--side seat))) + (winners (cl-remove-if-not + (lambda (c) (= seat (cg-bridge--trick-winner + (append order (list (cons seat c))) trump))) + legal))) + (cond + ;; partner already winning: throw the lowest card + ((and partner (>= (length trick) 1)) + (car (sort (copy-sequence legal) (lambda (a b) (< (cdr a) (cdr b)))))) + ;; can win: take it with the cheapest winner + (winners (car (sort winners (lambda (a b) (< (cdr a) (cdr b)))))) + ;; cannot win: discard lowest + (t (car (sort (copy-sequence legal) (lambda (a b) (< (cdr a) (cdr b))))))))))) + +(defun cg-bridge--controls (game) + "Return the list of seats the human controls during play." + (let ((decl (cg-get game :declarer))) + (cond ((null decl) nil) + ((= decl 0) '(0 2)) ; South declares: play hand + dummy + ((= decl 2) nil) ; North declares: AI plays both + (t '(0))))) ; South defends + +(defun cg-bridge--auto-seat-p (game seat) + "Return non-nil when SEAT is played automatically (by AI) in GAME." + (not (memq seat (cg-bridge--controls game)))) + +(defun cg-bridge--run-play (game) + "Advance AI plays until a human-controlled seat must act or the deal ends." + (let ((guard 0)) + (while (and (eq (cg-get game :phase) 'play) + (cg-bridge--auto-seat-p game (cg-get game :turn)) + (< guard 60)) + (setq guard (1+ guard)) + (cg-bridge--play-card game (cg-get game :turn) + (cg-bridge--ai-play game (cg-get game :turn)))))) + +(defun cg-bridge--run-auction (game) + "Advance the auction through AI seats until South must call or it ends." + (let ((guard 0)) + (while (and (eq (cg-get game :phase) 'auction) (/= (cg-get game :bidder) 0) + (< guard 40)) + (setq guard (1+ guard)) + (let* ((s (cg-get game :bidder)) (call (cg-bridge--ai-call game s))) + (unless (cg-bridge--legal-call-p game call) (setq call 'pass)) + (cg-bridge--apply-call game s call) + (cg-bridge--auction-done-p game))) + (when (eq (cg-get game :phase) 'play) (cg-bridge--run-play game)))) + +;;;; UI + +(defvar-local cg-bridge--game nil "The Bridge game in the current buffer.") + +(defun cg-bridge--hand-by-suit (cards) + "Return CARDS grouped into four lines by suit, as a string." + (let ((out '())) + (dolist (s '(0 3 2 1)) ; S H D C + (let ((in (cg-bridge--sort (cl-remove-if-not (lambda (c) (= (car c) s)) cards)))) + (push (format " %s %s\n" (cg-suit-glyph s) + (if in (mapconcat (lambda (c) (aref cg-bridge-ranks (cdr c))) in " ") + "--")) + out))) + (apply #'concat (nreverse out)))) + +(defun cg-bridge--auction-string (game) + "Return a compact record of the auction so far." + (let ((calls (reverse (cg-get game :calls))) (out '())) + (dolist (sc calls) + (push (format "%s:%s" (aref cg-bridge-seat-names (car sc)) + (pcase (cdr sc) + ('pass "pass") ('double "X") ('redouble "XX") + (c (format "%d%s" (car c) (aref cg-bridge-strains (cdr c)))))) + out)) + (if out (mapconcat #'identity (nreverse out) " ") "(no calls yet)"))) + +(cl-defmethod cg-render ((game cg-bridge-game)) + "Return a propertized depiction of the Bridge GAME." + (let* ((out '()) (phase (cg-get game :phase)) (cursor (cg-get game :cursor))) + (push " Bridge\n" out) + (push (format " Rubber: You/North games %d East/West games %d%s\n" + (aref (cg-get game :games) 0) (aref (cg-get game :games) 1) + (let ((v (cg-get game :vul))) + (format " (vul: %s)" + (cond ((and (aref v 0) (aref v 1)) "both") + ((aref v 0) "N-S") ((aref v 1) "E-W") (t "none"))))) + out) + (push (format " Below: You/N %d E/W %d Above: You/N %d E/W %d\n\n" + (aref (cg-get game :below) 0) (aref (cg-get game :below) 1) + (aref (cg-get game :above) 0) (aref (cg-get game :above) 1)) + out) + (pcase phase + ('auction + (push (format " Auction so far: %s\n\n" (cg-bridge--auction-string game)) out) + (push (format " Compose: %d %s (Up/Down level, Left/Right strain)\n\n" + (cg-get game :bid-level) + (aref cg-bridge-strains (cg-get game :bid-strain))) + out)) + ((or 'play 'scored 'passed-out) + (push (format " Contract: %s by %s Declarer tricks: %d\n" + (cg-bridge--contract-string game) + (if (cg-get game :declarer) + (aref cg-bridge-seat-names (cg-get game :declarer)) "--") + (cg-get game :tricks)) + out) + (when (and (cg-get game :exposed) (cg-get game :dummy)) + (push (format "\n Dummy (%s):\n%s" + (aref cg-bridge-seat-names (cg-get game :dummy)) + (cg-bridge--hand-by-suit (cg-bridge--hand game (cg-get game :dummy)))) + out)) + (push "\n Trick: " out) + (if (cg-get game :trick) + (dolist (p (reverse (cg-get game :trick))) + (push (format "%s:%s " (aref cg-bridge-seat-names (car p)) + (cg-bridge-card-string (cdr p))) out)) + (push "(empty)" out)) + (push "\n" out))) + ;; the human's hand (South), or the seat being played from when it is dummy + (let* ((act (if (and (eq phase 'play) (memq (cg-get game :turn) + (cg-bridge--controls game))) + (cg-get game :turn) 0)) + (hand (cg-bridge--sort (cg-bridge--hand game act)))) + (push (format "\n %s%s:\n " + (aref cg-bridge-seat-names act) + (cond ((eq phase 'auction) " (you)") + ((= act 0) " (you)") + (t " (dummy, you play)"))) + out) + (if (eq phase 'play) + (let ((i 0)) + (dolist (c hand) + (let ((cs (cg-bridge-card-string c)) (faces nil)) + (when (cg-red-suit-p (car c)) (push 'cg-red-suit faces)) + (when (and (= (cg-get game :turn) act) + (cg-bridge--legal-play-p game act c)) (push 'cg-hint faces)) + (when (= i cursor) (push 'cg-cursor faces)) + (push (propertize (format "%4s" cs) 'face (or faces 'default)) out)) + (setq i (1+ i)))) + (push (cg-bridge--hand-by-suit hand) out))) + (push (format "\n\n %s\n" (cg-get game :message)) out) + (apply #'concat (nreverse out)))) + +(defun cg-bridge--redisplay () + (let ((game cg-bridge--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)))) + +;;;; Auction commands + +(defun cg-bridge-bid-level-up () + "Raise the level being composed." + (interactive) + (let ((g cg-bridge--game)) + (cg-put g :bid-level (min 7 (1+ (cg-get g :bid-level)))) + (cg-bridge--redisplay))) + +(defun cg-bridge-bid-level-down () + "Lower the level being composed." + (interactive) + (let ((g cg-bridge--game)) + (cg-put g :bid-level (max 1 (1- (cg-get g :bid-level)))) + (cg-bridge--redisplay))) + +(defun cg-bridge-bid-strain-left () + "Move the composed strain down (toward clubs)." + (interactive) + (let ((g cg-bridge--game)) + (cg-put g :bid-strain (max 0 (1- (cg-get g :bid-strain)))) + (cg-bridge--redisplay))) + +(defun cg-bridge-bid-strain-right () + "Move the composed strain up (toward no-trump)." + (interactive) + (let ((g cg-bridge--game)) + (cg-put g :bid-strain (min 4 (1+ (cg-get g :bid-strain)))) + (cg-bridge--redisplay))) + +(defun cg-bridge--after-call (g) + "Resolve end-of-auction and run AI after South calls in G." + (unless (cg-bridge--auction-done-p g) + (cg-bridge--run-auction g)) + (when (eq (cg-get g :phase) 'play) (cg-bridge--run-play g)) + (cg-bridge--redisplay)) + +(defun cg-bridge-bid () + "Make the composed bid." + (interactive) + (let* ((g cg-bridge--game) + (call (cons (cg-get g :bid-level) (cg-get g :bid-strain)))) + (cond + ((not (eq (cg-get g :phase) 'auction)) (cg-put g :message "Not bidding now.")) + ((/= (cg-get g :bidder) 0) (cg-put g :message "Not your turn.")) + ((not (cg-bridge--legal-call-p g call)) + (cg-put g :message "That bid is too low.")) + (t (cg-bridge--apply-call g 0 call) (cg-bridge--after-call g))) + (cg-bridge--redisplay))) + +(defun cg-bridge-pass () + "Pass in the auction." + (interactive) + (let ((g cg-bridge--game)) + (if (and (eq (cg-get g :phase) 'auction) (= (cg-get g :bidder) 0)) + (progn (cg-bridge--apply-call g 0 'pass) (cg-bridge--after-call g)) + (cg-put g :message "Nothing to pass on.")) + (cg-bridge--redisplay))) + +(defun cg-bridge-double () + "Double (or redouble) in the auction." + (interactive) + (let* ((g cg-bridge--game) + (call (if (= (cg-get g :doubled) 1) 'redouble 'double))) + (if (and (eq (cg-get g :phase) 'auction) (= (cg-get g :bidder) 0) + (cg-bridge--legal-call-p g call)) + (progn (cg-bridge--apply-call g 0 call) (cg-bridge--after-call g)) + (cg-put g :message "You cannot double now.")) + (cg-bridge--redisplay))) + +;;;; Play commands + +(defun cg-bridge--act-hand (g) + "Return the hand the cursor currently indexes (the seat to act)." + (let ((act (if (memq (cg-get g :turn) (cg-bridge--controls g)) (cg-get g :turn) 0))) + (cg-bridge--sort (cg-bridge--hand g act)))) + +(defun cg-bridge-left () + "Move the cursor left." + (interactive) + (let* ((g cg-bridge--game) (n (length (cg-bridge--act-hand g)))) + (cond ((eq (cg-get g :phase) 'auction) (cg-bridge-bid-strain-left)) + (t (when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n))) + (cg-bridge--redisplay))))) + +(defun cg-bridge-right () + "Move the cursor right." + (interactive) + (let* ((g cg-bridge--game) (n (length (cg-bridge--act-hand g)))) + (cond ((eq (cg-get g :phase) 'auction) (cg-bridge-bid-strain-right)) + (t (when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n))) + (cg-bridge--redisplay))))) + +(defun cg-bridge-up () + "Raise the bid level (auction only)." + (interactive) + (if (eq (cg-get cg-bridge--game :phase) 'auction) (cg-bridge-bid-level-up) + (cg-bridge--redisplay))) + +(defun cg-bridge-down () + "Lower the bid level (auction only)." + (interactive) + (if (eq (cg-get cg-bridge--game :phase) 'auction) (cg-bridge-bid-level-down) + (cg-bridge--redisplay))) + +(defun cg-bridge-play () + "Play the cursor card, or make the composed bid during the auction." + (interactive) + (let ((g cg-bridge--game)) + (if (eq (cg-get g :phase) 'auction) + (cg-bridge-bid) + (let* ((turn (cg-get g :turn))) + (cond + ((not (eq (cg-get g :phase) 'play)) (cg-put g :message "Press n to continue.")) + ((not (memq turn (cg-bridge--controls g))) + (cg-put g :message "Wait for your turn.")) + (t (let ((card (nth (cg-get g :cursor) (cg-bridge--sort (cg-bridge--hand g turn))))) + (if (or (null card) (not (cg-bridge--legal-play-p g turn card))) + (cg-put g :message "You must follow suit.") + (cg-bridge--play-card g turn card) + (cg-put g :cursor 0) + (when (eq (cg-get g :phase) 'play) (cg-bridge--run-play g)))))) + (cg-bridge--redisplay))))) + +(defun cg-bridge-new () + "Deal the next hand, or a fresh rubber when one is over." + (interactive) + (let ((g cg-bridge--game)) + (when (or (cg-get g :rubber-winner)) + (cg-put g :below (make-vector 2 0)) (cg-put g :above (make-vector 2 0)) + (cg-put g :games (make-vector 2 0)) (cg-put g :vul (make-vector 2 nil)) + (cg-put g :rubber-winner nil)) + (cg-put g :dealer (mod (1+ (or (cg-get g :dealer) 0)) 4)) + (cg-bridge--deal g) + (cg-bridge--run-auction g) + (cg-bridge--redisplay))) + +(defun cg-bridge-redraw () "Redraw." (interactive) (cg-bridge--redisplay)) +(defun cg-bridge-help () "Describe the controls." (interactive) + (message "Auction: Up/Down level, Left/Right strain, RET bid, p pass, d double. Play: arrows + RET. n: next")) + +(defvar cg-bridge-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "") #'cg-bridge-left) + (define-key map (kbd "") #'cg-bridge-right) + (define-key map (kbd "") #'cg-bridge-up) + (define-key map (kbd "") #'cg-bridge-down) + (define-key map (kbd "RET") #'cg-bridge-play) + (define-key map "p" #'cg-bridge-pass) + (define-key map "d" #'cg-bridge-double) + (define-key map "n" #'cg-bridge-new) + (define-key map "g" #'cg-bridge-redraw) + (define-key map "?" #'cg-bridge-help) + map) + "Keymap for `cg-bridge-mode'.") + +(define-derived-mode cg-bridge-mode special-mode "Bridge" + "Major mode for contract Bridge." + (setq-local truncate-lines t)) + +;;;###autoload +(defun cg-bridge () + "Play contract Bridge against the computer." + (interactive) + (let ((buf (get-buffer-create "*Bridge*"))) + (with-current-buffer buf + (cg-bridge-mode) + (setq cg-bridge--game (cg-bridge-game)) + (cg-put cg-bridge--game :dealer 0) + (cg-bridge--deal cg-bridge--game) + (cg-bridge--run-auction cg-bridge--game) + (cg-bridge--redisplay)) + (switch-to-buffer buf))) + +(provide 'cg-bridge) +;;; cg-bridge.el ends here 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-handfoot.el b/cg-handfoot.el new file mode 100644 index 0000000..33e3a97 --- /dev/null +++ b/cg-handfoot.el @@ -0,0 +1,535 @@ +;;; cg-handfoot.el --- Hand and Foot, a partnership rummy -*- 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: + +;; Hand & Foot, a Canasta cousin played in partnerships. Each player is +;; dealt two packets: a "hand" played first and a "foot" taken up once the +;; hand is gone. Partners build *books* -- three or more cards of one +;; rank, suits ignored -- on the table; a book of seven is complete (a +;; "pile"), clean if it holds no wild card and dirty if it does. Twos and +;; Jokers are wild. You go out, ending the round, once your side owns at +;; least two complete books and you can empty your foot. +;; +;; You partner the North player against East and West, all three of them +;; computer opponents. Mark cards with SPC, meld them with m, lay off onto +;; a book with l, and discard with RET. +;; +;; This is a deliberately streamlined Hand & Foot: it omits picking up the +;; discard pile, the red-three bonus, and round-by-round minimum-meld +;; requirements, keeping the books, wilds, hand/foot, and partnership +;; scoring that give the game its character. Cards use the package cons +;; (SUIT . RANK), RANK 0 (Ace) .. 12 (King), with jokers as (joker . 0). + +;;; Code: + +(require 'cl-lib) +(require 'eieio) +(require 'cg-core) +(require 'cg-rummy) + +(defcustom cg-handfoot-target 5000 + "Points a partnership needs to win Hand & Foot." + :type 'integer :group 'card-games) + +(defconst cg-handfoot--names ["You" "West" "North" "East"] + "Seat labels; North is your partner.") + +(defclass cg-handfoot-game (cg-rummy-game) + ((vname :initform "Hand & Foot")) + "A game of Hand & Foot.") + +;;;; Cards + +(defun cg-hf--wild-p (card) + "Return non-nil when CARD is wild (a Joker or a Two)." + (or (cg-rummy-joker-p card) (= (cdr card) 1))) + +(defun cg-hf--three-p (card) + "Return non-nil when CARD is a three (never meldable)." + (and (not (cg-rummy-joker-p card)) (= (cdr card) 2))) + +(defun cg-hf-value (card) + "Return the Hand & Foot point value of CARD." + (cond ((cg-rummy-joker-p card) 50) + (t (let ((r (cdr card))) + (cond ((= r 1) 20) ; Two (wild) + ((= r 0) 20) ; Ace + ((= r 2) 5) ; Three + ((<= r 6) 5) ; 4 5 6 7 + (t 10)))))) ; 8 9 10 J Q K + +(defun cg-hf--book-rank (cards) + "Return the natural rank shared by CARDS, or nil if invalid." + (let ((nats (cl-remove-if #'cg-hf--wild-p cards))) + (and nats + (let ((r (cdr (car nats)))) + (and (cl-every (lambda (c) (= (cdr c) r)) nats) + (/= r 2) + r))))) + +(defun cg-hf--book-valid-p (cards) + "Return non-nil when CARDS form a legal book." + (let* ((nats (cl-remove-if #'cg-hf--wild-p cards)) + (wilds (cl-remove-if-not #'cg-hf--wild-p cards))) + (and (>= (length cards) 3) + (cg-hf--book-rank cards) + (>= (length nats) 2) + (<= (length wilds) 3) + (<= (length wilds) (length nats))))) + +(defun cg-hf--book-complete-p (cards) (>= (length cards) 7)) +(defun cg-hf--book-clean-p (cards) (not (cl-some #'cg-hf--wild-p cards))) + +;;;; Setup + +(defun cg-hf--team (game s) (mod s (cg-get game :nteams))) + +(cl-defmethod cg-hf--deal ((game cg-handfoot-game)) + "Deal a fresh round into GAME." + (let* ((n (cg-get game :nplayers)) + (decks (1+ n)) + (deck (cg-rummy-deck decks 2)) + (hands (make-vector n nil)) (feet (make-vector n nil)) + (stage (make-vector n 0))) + (dotimes (s n) + (aset hands s (cg-rummy-sort-hand (cl-loop repeat 11 collect (pop deck)))) + (aset feet s (cg-rummy-sort-hand (cl-loop repeat 11 collect (pop deck))))) + (cg-put game :hands hands) + (cg-put game :feet feet) + (cg-put game :stage stage) + (cg-put game :books (make-vector (cg-get game :nteams) nil)) + (cg-put game :discard (list (pop deck))) + (cg-put game :stock deck) + (cg-put game :turn 0) + (cg-put game :step 'draw) + (cg-put game :phase 'play) + (cg-put game :cursor 0) + (cg-put game :marks nil) + (cg-put game :message "Your turn: s draws two cards.") + game)) + +(defun cg-hf--books (game team) (aref (cg-get game :books) team)) +(defun cg-hf--set-books (game team v) (aset (cg-get game :books) team v)) + +;;;; Engine + +(defun cg-hf--draw2 (game s) + "Draw two stock cards into seat S's hand. Return nil if stock runs out." + (let ((ok t)) + (dotimes (_ 2) + (let ((stock (cg-get game :stock))) + (if (null stock) (setq ok nil) + (cg-rummy--set-hand game s (cg-rummy-sort-hand + (cons (car stock) (cg-rummy--hand game s)))) + (cg-put game :stock (cdr stock))))) + ok)) + +(defun cg-hf--meld (game s cards) + "Have seat S lay CARDS as a new book for their team. Return non-nil on win." + (when (and (cg-hf--book-valid-p cards) + (cl-subsetp cards (cg-rummy--hand game s) :test #'equal)) + (let ((team (cg-hf--team game s))) + (dolist (c cards) + (cg-rummy--set-hand game s (cg-rummy--remove1 c (cg-rummy--hand game s)))) + (cg-hf--set-books game team + (append (cg-hf--books game team) + (list (cg-rummy-sort-hand (copy-sequence cards))))) + t))) + +(defun cg-rummy--remove1 (card list) + "Return LIST with one copy of CARD (an `equal' match) removed." + (let ((seen nil)) + (cl-remove-if (lambda (c) (and (not seen) (equal c card) (setq seen t))) list))) + +(defun cg-hf--layoff (game s card) + "Lay CARD off onto a team book it fits. Return non-nil on success." + (let* ((team (cg-hf--team game s)) (books (cg-hf--books game team)) (done nil)) + (catch 'hit + (dolist (bk books) + (unless (cg-hf--book-complete-p bk) + (let ((cand (cons card bk))) + (when (cg-hf--book-valid-p cand) + (cg-rummy--set-hand game s (cg-rummy--remove1 card (cg-rummy--hand game s))) + (setcar (memq bk books) (cg-rummy-sort-hand cand)) + (setq done t) + (throw 'hit t)))))) + done)) + +(defun cg-hf--advance (game s) + "After a play, take up the foot or finish, then pass the turn." + (let ((stage (cg-get game :stage))) + (when (and (= (aref stage s) 0) (null (cg-rummy--hand game s))) + ;; hand exhausted: pick up the foot + (aset stage s 1) + (cg-rummy--set-hand game s (aref (cg-get game :feet) s))) + (if (and (= (aref stage s) 1) (null (cg-rummy--hand game s)) + (cg-hf--can-go-out-p game (cg-hf--team game s))) + (cg-hf--score-round game s) + (cg-put game :turn (mod (1+ s) (cg-get game :nplayers))) + (cg-put game :step 'draw)))) + +(defun cg-hf--can-go-out-p (game team) + "Return non-nil when TEAM owns at least two complete books." + (>= (cl-count-if #'cg-hf--book-complete-p (cg-hf--books game team)) 2)) + +(defun cg-hf--discard (game s card) + "Discard CARD from seat S and end the play portion of the turn." + (cg-rummy--set-hand game s (cg-rummy--remove1 card (cg-rummy--hand game s))) + (cg-put game :discard (cons card (cg-get game :discard))) + (cg-hf--advance game s)) + +(cl-defmethod cg-hf--score-round ((game cg-handfoot-game) outseat) + "Score the round (OUTSEAT went out, or nil if the stock ran dry)." + (let* ((nt (cg-get game :nteams)) (scores (cg-get game :scores))) + (dotimes (team nt) + (let ((pts 0)) + (dolist (bk (cg-hf--books game team)) + (dolist (c bk) (setq pts (+ pts (cg-hf-value c)))) + (when (cg-hf--book-complete-p bk) + (setq pts (+ pts (if (cg-hf--book-clean-p bk) 500 300))))) + (when (and outseat (= (cg-hf--team game outseat) team)) + (setq pts (+ pts 100))) ; going-out bonus + ;; subtract cards left in members' hands and feet + (dotimes (s (cg-get game :nplayers)) + (when (= (cg-hf--team game s) team) + (dolist (c (cg-rummy--hand game s)) (setq pts (- pts (cg-hf-value c)))) + (when (= (aref (cg-get game :stage) s) 0) + (dolist (c (aref (cg-get game :feet) s)) + (setq pts (- pts (cg-hf-value c))))))) + (aset scores team (+ (aref scores team) pts)))) + (let ((win nil) (best most-negative-fixnum)) + (dotimes (team nt) + (when (and (>= (aref scores team) cg-handfoot-target) + (> (aref scores team) best)) + (setq win team best (aref scores team)))) + (cg-put game :phase (if win 'game-over 'round-over)) + (cg-put game :winner (or win (and outseat (cg-hf--team game outseat)))) + (cg-put game :reveal t) + (cg-put game :message + (concat + (if outseat (format "%s goes out! " (aref cg-handfoot--names outseat)) + "Stock exhausted. ") + (if win (format "Team %d wins the game! (n: new game)" win) + (format "Round over. Scores: %s. (n: next round)" + (cg-hf--scores-string game)))))))) + +(defun cg-hf--scores-string (game) + "Return a compact per-team score line for GAME." + (let ((scores (cg-get game :scores)) (parts '())) + (dotimes (team (cg-get game :nteams)) + (push (format "Team %d %d" team (aref scores team)) parts)) + (mapconcat #'identity (nreverse parts) " · "))) + +;;;; AI + +(defun cg-hf--ai-meld (game s) + "Lay down and extend books for seat S as far as is easy." + ;; lay off naturals onto existing incomplete team books + (let ((again t)) + (while again + (setq again nil) + (let ((card (cl-find-if + (lambda (c) + (and (not (cg-hf--wild-p c)) (not (cg-hf--three-p c)) + (cl-find-if + (lambda (bk) (and (not (cg-hf--book-complete-p bk)) + (equal (cg-hf--book-rank bk) (cdr c)))) + (cg-hf--books game (cg-hf--team game s))))) + (cg-rummy--hand game s)))) + (when card (cg-hf--layoff game s card) (setq again t))))) + ;; start new books from ranks with >=3 naturals in hand + (let ((again t)) + (while again + (setq again nil) + (let* ((hand (cg-rummy--hand game s)) + (byrank (make-hash-table :test 'eql)) (target nil)) + (dolist (c hand) + (unless (or (cg-hf--wild-p c) (cg-hf--three-p c)) + (push c (gethash (cdr c) byrank)))) + (maphash (lambda (_r cs) (when (and (not target) (>= (length cs) 3)) + (setq target cs))) + byrank) + (when target + (cg-hf--meld game s (cl-subseq target 0 (min 7 (length target)))) + (setq again t))))) + ;; push a nearly-complete book to seven with a spare wild + (let ((again t)) + (while again + (setq again nil) + (let ((wild (cl-find-if #'cg-hf--wild-p (cg-rummy--hand game s))) + (team (cg-hf--team game s))) + (when wild + (let ((bk (cl-find-if + (lambda (b) + (and (not (cg-hf--book-complete-p b)) + (>= (length b) 5) + (> (cl-count-if-not #'cg-hf--wild-p b) + (cl-count-if #'cg-hf--wild-p b)) + (< (cl-count-if #'cg-hf--wild-p b) 3))) + (cg-hf--books game team)))) + (when bk + (cg-rummy--set-hand game s (cg-rummy--remove1 wild (cg-rummy--hand game s))) + (setcar (memq bk (cg-hf--books game team)) + (cg-rummy-sort-hand (cons wild bk))) + (setq again t)))))))) + +(defun cg-hf--ai-discard-card (game s) + "Return the card seat S should discard." + (let ((hand (cg-rummy--hand game s))) + (or (cl-find-if #'cg-hf--three-p hand) + ;; a high singleton, else the first card + (let ((byrank (make-hash-table :test 'eql)) (best (car hand)) (bestv -1)) + (dolist (c hand) (unless (cg-hf--wild-p c) + (push c (gethash (cdr c) byrank)))) + (maphash (lambda (_r cs) + (when (= (length cs) 1) + (let ((v (cg-hf-value (car cs)))) + (when (> v bestv) (setq best (car cs) bestv v))))) + byrank) + best)))) + +(cl-defmethod cg-hf--ai-turn ((game cg-handfoot-game) s) + "Play seat S's whole turn." + (if (not (cg-hf--draw2 game s)) + (cg-hf--score-round game nil) + (cg-hf--ai-meld game s) + (when (eq (cg-get game :phase) 'play) + ;; if the hand emptied through melding, pick up the foot and meld again + (when (and (= (aref (cg-get game :stage) s) 0) (null (cg-rummy--hand game s))) + (aset (cg-get game :stage) s 1) + (cg-rummy--set-hand game s (aref (cg-get game :feet) s)) + (cg-hf--ai-meld game s)) + (when (eq (cg-get game :phase) 'play) + (if (cg-rummy--hand game s) + (cg-hf--discard game s (cg-hf--ai-discard-card game s)) + (cg-hf--advance game s)))))) + +(defun cg-hf--run (game) + "Advance AI seats until it is your turn or the round ends." + (while (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0)) + (cg-hf--ai-turn game (cg-get game :turn)))) + +;;;; UI + +(defvar-local cg-hf--game nil "The Hand & Foot game in the current buffer.") + +(cl-defmethod cg-render ((game cg-handfoot-game)) + "Return a propertized depiction of the Hand & Foot GAME." + (let* ((out '()) (scores (cg-get game :scores)) + (hand (cg-rummy--hand game 0)) (cursor (cg-get game :cursor))) + (push (format " Hand & Foot target %d\n\n" cg-handfoot-target) out) + (dotimes (team (cg-get game :nteams)) + (push (format " Team %d (score %d):\n" team (aref scores team)) out) + (let ((bks (cg-hf--books game team))) + (if bks + (dolist (bk bks) + (push (format " %s%s\n" + (mapconcat #'cg-rummy-card-string bk " ") + (cond ((cg-hf--book-complete-p bk) + (if (cg-hf--book-clean-p bk) " [clean pile]" " [dirty pile]")) + (t ""))) + out)) + (push " (no books yet)\n" out)))) + (push "\n" out) + (dotimes (s (cg-get game :nplayers)) + (unless (= s 0) + (push (format " %-6s %d in hand%s\n" (aref cg-handfoot--names s) + (length (cg-rummy--hand game s)) + (if (= (aref (cg-get game :stage) s) 1) " (on foot)" "")) + out))) + (push (format "\n Discard: %s Stock: %d\n\n" + (let ((cs (cg-rummy-card-string (cg-rummy--top game))) (tp (cg-rummy--top game))) + (if (and tp (not (cg-rummy-joker-p tp)) (cg-red-suit-p (car tp))) + (propertize cs 'face 'cg-red-suit) cs)) + (length (cg-get game :stock))) + out) + (push (format " Your %s:\n " (if (= (aref (cg-get game :stage) 0) 1) "foot" "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-hf--redisplay () + "Redraw the Hand & Foot buffer." + (let ((game cg-hf--game) (inhibit-read-only t)) + (setq-local mode-line-process + (format " [%s]" (or (cg-get game :step) (cg-get game :phase)))) + (erase-buffer) (insert (cg-render game)) (goto-char (point-min)))) + +(defun cg-hf--clamp (g) + "Keep G's cursor in range and drop stale marks." + (let ((n (length (cg-rummy--hand g 0)))) + (cg-put g :cursor (if (> n 0) (min (cg-get g :cursor) (1- n)) 0)) + (cg-put g :marks (cl-remove-if (lambda (i) (>= i n)) (cg-get g :marks))))) + +(defun cg-hf--my-turn-p (g) + (and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0))) + +(defun cg-hf-left () + "Move the hand cursor left." + (interactive) + (let* ((g cg-hf--game) (n (length (cg-rummy--hand g 0)))) + (when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n))) + (cg-hf--redisplay))) + +(defun cg-hf-right () + "Move the hand cursor right." + (interactive) + (let* ((g cg-hf--game) (n (length (cg-rummy--hand g 0)))) + (when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n))) + (cg-hf--redisplay))) + +(defun cg-hf-mark () + "Toggle a mark on the card under the cursor." + (interactive) + (let* ((g cg-hf--game) (i (cg-get g :cursor)) (marks (cg-get g :marks))) + (cg-put g :marks (if (memq i marks) (delq i marks) (cons i marks))) + (cg-hf--redisplay))) + +(defun cg-hf--marked (g) + "Return the marked cards in G's hand." + (let ((hand (cg-rummy--hand g 0))) + (mapcar (lambda (i) (nth i hand)) (sort (copy-sequence (cg-get g :marks)) #'<)))) + +(defun cg-hf-meld () + "Meld the marked cards as a new book." + (interactive) + (let* ((g cg-hf--game) (cards (cg-hf--marked g))) + (cond + ((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn.")) + ((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s).")) + ((not (cg-hf--book-valid-p cards)) + (cg-put g :message "Not a legal book: 3+ of a rank, 2+ natural, wilds <= naturals.")) + ((cg-hf--meld g 0 cards) + (cg-put g :marks nil) (cg-hf--clamp g) + (when (and (= (aref (cg-get g :stage) 0) 0) (null (cg-rummy--hand g 0))) + (aset (cg-get g :stage) 0 1) + (cg-rummy--set-hand g 0 (aref (cg-get g :feet) 0)) + (cg-hf--clamp g) + (cg-put g :message "Hand cleared -- foot picked up! Keep melding or discard (RET).")) + (unless (and (= (aref (cg-get g :stage) 0) 1) (null (cg-rummy--hand g 0))) + (cg-put g :message "Booked. Meld more, lay off (l), or discard (RET)."))) + (t (cg-put g :message "Could not meld those cards."))) + (cg-hf--redisplay))) + +(defun cg-hf-layoff () + "Lay the cursor card (or marked cards) off onto a team book." + (interactive) + (let* ((g cg-hf--game) (marks (cg-hf--marked g))) + (cond + ((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn.")) + ((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s).")) + (t (let ((cards (or marks (list (nth (cg-get g :cursor) (cg-rummy--hand g 0))))) + (any nil)) + (dolist (c cards) (when (and c (cg-hf--layoff g 0 c)) (setq any t))) + (cg-put g :marks nil) (cg-hf--clamp g) + (cg-put g :message (if any "Laid off." "That card fits none of your books."))))) + (cg-hf--redisplay))) + +(defun cg-hf-draw () + "Draw two cards from the stock." + (interactive) + (let ((g cg-hf--game)) + (cond + ((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn.")) + ((not (eq (cg-get g :step) 'draw)) (cg-put g :message "You already drew.")) + ((cg-hf--draw2 g 0) + (cg-put g :step 'play) (cg-hf--clamp g) + (cg-put g :message "Meld (m), lay off (l), then discard (RET).")) + (t (cg-hf--score-round g nil))) + (cg-hf--redisplay))) + +(defun cg-hf-discard () + "Discard the cursor card and end your turn." + (interactive) + (let* ((g cg-hf--game) (card (nth (cg-get g :cursor) (cg-rummy--hand g 0)))) + (cond + ((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn.")) + ((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s).")) + ((null card) (cg-put g :message "No card selected.")) + (t (cg-hf--discard g 0 card) + (cg-put g :marks nil) + (when (memq (cg-get g :phase) '(play)) + (cg-put g :message "You discarded.") + (cg-hf--run g)))) + (cg-hf--redisplay))) + +(defun cg-hf-new () + "Deal a fresh round, or a new game when one is over." + (interactive) + (let ((g cg-hf--game)) + (when (eq (cg-get g :phase) 'game-over) + (cg-put g :scores (make-vector (cg-get g :nteams) 0))) + (cg-put g :reveal nil) + (cg-hf--deal g) + (cg-hf--run g) + (cg-hf--redisplay))) + +(defun cg-hf-redraw () "Redraw the board." (interactive) (cg-hf--redisplay)) + +(defun cg-hf-help () + "Describe the Hand & Foot controls." + (interactive) + (message "Arrows: choose SPC: mark m: meld l: lay off s: draw 2 RET: discard n: new")) + +(defvar cg-handfoot-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "") #'cg-hf-left) + (define-key map (kbd "") #'cg-hf-right) + (define-key map (kbd "SPC") #'cg-hf-mark) + (define-key map "m" #'cg-hf-meld) + (define-key map "l" #'cg-hf-layoff) + (define-key map "s" #'cg-hf-draw) + (define-key map (kbd "RET") #'cg-hf-discard) + (define-key map "n" #'cg-hf-new) + (define-key map "g" #'cg-hf-redraw) + (define-key map "?" #'cg-hf-help) + map) + "Keymap for `cg-handfoot-mode'.") + +(define-derived-mode cg-handfoot-mode special-mode "Hand&Foot" + "Major mode for Hand & Foot." + (setq-local truncate-lines t)) + +;;;###autoload +(defun cg-handfoot () + "Play Hand & Foot, partnering North against two AI opponents." + (interactive) + (let ((buf (get-buffer-create "*Hand & Foot*"))) + (with-current-buffer buf + (cg-handfoot-mode) + (setq cg-hf--game (cg-handfoot-game)) + (cg-put cg-hf--game :nplayers 4) + (cg-put cg-hf--game :nteams 2) + (cg-put cg-hf--game :scores (make-vector 2 0)) + (cg-hf--deal cg-hf--game) + (cg-hf--run cg-hf--game) + (cg-hf--redisplay)) + (switch-to-buffer buf))) + +;;;###autoload +(defalias 'cg-hand-and-foot #'cg-handfoot) + +(provide 'cg-handfoot) +;;; cg-handfoot.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-rum500.el b/cg-rum500.el new file mode 100644 index 0000000..b96baf6 --- /dev/null +++ b/cg-rum500.el @@ -0,0 +1,519 @@ +;;; cg-rum500.el --- Basic Rummy and Rummy 500 -*- 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 table-meld rummy games sharing one engine, built on the meld +;; finder in cg-rummy.el. +;; +;; In a table-meld game you draw a card, lay melds face-up on the table, +;; lay single cards off onto melds already there, and end your turn by +;; discarding. Empty your hand to go out. +;; +;; `cg-rummy-basic' -- plain Rummy: the first player to meld their whole +;; hand wins the deal and scores the cards left in the others' hands. +;; `cg-rum500' -- Rummy 500: you score the cards you lay down and lose +;; the cards left in your hand; first past 500 wins. +;; +;; You are the South player (seat 0); the rest are simple AI. To meld, +;; mark cards with SPC and press m; to lay a card off, put the cursor on +;; it and press l. + +;;; Code: + +(require 'cl-lib) +(require 'eieio) +(require 'cg-core) +(require 'cg-rummy) + +(defclass cg-tablemeld-game (cg-rummy-game) + ((nplayers :initarg :nplayers :initform 2) + (hand-size :initarg :hand-size :initform 10) + (ace-15 :initarg :ace-15 :initform nil) + (ace-high :initarg :ace-high :initform nil) + (target :initarg :target :initform 100) + (score-style :initarg :score-style :initform 'go-out)) + "Abstract base for table-meld rummy games (Basic Rummy, Rummy 500)." + :abstract t) + +;;;; Engine + +(cl-defmethod cg-tm--deal ((game cg-tablemeld-game)) + "Deal a fresh hand into GAME." + (let* ((n (oref game nplayers)) + (deck (cg-rummy-deck)) + (per (oref game hand-size)) + (hands (make-vector n nil))) + (dotimes (s n) + (aset hands s (cg-rummy-sort-hand (cl-loop repeat per collect (pop deck))))) + (cg-put game :hands hands) + (cg-put game :nplayers n) + (cg-put game :discard (list (pop deck))) + (cg-put game :stock deck) + (cg-put game :table nil) + (cg-put game :laid (make-vector n 0)) + (cg-put game :turn 0) + (cg-put game :step 'draw) + (cg-put game :phase 'play) + (cg-put game :cursor 0) + (cg-put game :marks nil) + (unless (cg-get game :scores) (cg-put game :scores (make-vector n 0))) + (cg-put game :message "Your turn: s draws from stock, t takes the discard.") + game)) + +(defun cg-tm--ace-high (game) (oref game ace-high)) +(defun cg-tm--ace-15 (game) (oref game ace-15)) + +(defun cg-tm--draw (game s) + "Move one stock card to seat S's hand; return it or nil if stock empty." + (let ((stock (cg-get game :stock))) + (when stock + (let ((c (pop stock))) + (cg-put game :stock stock) + (cg-rummy--set-hand game s (cg-rummy-sort-hand + (cons c (cg-rummy--hand game s)))) + c)))) + +(defun cg-tm--take-top (game s) + "Move the discard top to seat S's hand and return it." + (let ((c (cg-rummy--top game))) + (when c + (cg-put game :discard (cdr (cg-get game :discard))) + (cg-rummy--set-hand game s (cg-rummy-sort-hand + (cons c (cg-rummy--hand game s)))) + c))) + +(defun cg-tm--meld-value (game cards) + "Return the total point value of CARDS for GAME's scoring." + (apply #'+ (mapcar (lambda (c) (cg-rummy-value c (cg-tm--ace-15 game))) cards))) + +(cl-defmethod cg-tm--meld ((game cg-tablemeld-game) s cards) + "Have seat S meld CARDS onto the table. Return non-nil on success." + (when (cg-rummy-meld-p cards :min 3 :ace-high (cg-tm--ace-high game) + :distinct-suits t) + (dolist (c cards) (cg-rummy--set-hand game s (remove c (cg-rummy--hand game s)))) + (cg-put game :table (append (cg-get game :table) + (list (cons s (copy-sequence cards))))) + (let ((laid (cg-get game :laid))) + (aset laid s (+ (aref laid s) (cg-tm--meld-value game cards)))) + t)) + +(cl-defmethod cg-tm--layoff ((game cg-tablemeld-game) s card) + "Have seat S lay CARD off onto a matching table meld. Return non-nil on success." + (let ((rec (cl-find-if + (lambda (r) (cg-rummy-meld-p (cons card (cdr r)) :min 3 + :ace-high (cg-tm--ace-high game))) + (cg-get game :table)))) + (when rec + (cg-rummy--set-hand game s (remove card (cg-rummy--hand game s))) + (setcdr rec (cg-rummy-sort-hand (cons card (cdr rec)))) + (let ((laid (cg-get game :laid))) + (aset laid s (+ (aref laid s) (cg-rummy-value card (cg-tm--ace-15 game))))) + t))) + +(cl-defmethod cg-tm--score-hand ((game cg-tablemeld-game) outseat) + "Score the hand ended by OUTSEAT (or nil for a washed-out hand)." + (let* ((n (cg-get game :nplayers)) (scores (cg-get game :scores)) + (style (oref game score-style))) + (cond + ((eq style 'go-out) + (when outseat + (let ((sum 0)) + (dotimes (s n) + (unless (= s outseat) + (dolist (c (cg-rummy--hand game s)) + (setq sum (+ sum (cg-rummy-value c)))))) + (aset scores outseat (+ (aref scores outseat) sum))))) + ((eq style 'meld-points) + (let ((laid (cg-get game :laid))) + (dotimes (s n) + (let ((rem (apply #'+ (mapcar (lambda (c) + (cg-rummy-value c (cg-tm--ace-15 game))) + (cg-rummy--hand game s))))) + (aset scores s (+ (aref scores s) (- (aref laid s) rem)))))))) + ;; decide if the game is over + (let ((win nil) (best most-negative-fixnum)) + (dotimes (s n) + (when (and (>= (aref scores s) (oref game target)) + (> (aref scores s) best)) + (setq win s best (aref scores s)))) + (cg-put game :phase (if win 'game-over 'hand-over)) + (cg-put game :winner (or win outseat)) + (cg-put game :reveal t) + (cg-put game :message + (if win + (format "%s wins the game with %d! (n: new game)" + (cg-tm--who win) (aref scores win)) + (concat (if outseat (format "%s goes out. " (cg-tm--who outseat)) + "Stock exhausted. ") + (format "Scores: %s. (n: next hand)" + (cg-tm--scores-string game)))))))) + +(defun cg-tm--who (s) (if (= s 0) "You" (format "Player %d" s))) + +(defun cg-tm--scores-string (game) + "Return a compact \"You N · P1 N ...\" score line for GAME." + (let ((scores (cg-get game :scores)) (parts '())) + (dotimes (s (cg-get game :nplayers)) + (push (format "%s %d" (if (= s 0) "You" (format "P%d" s)) (aref scores s)) + parts)) + (mapconcat #'identity (nreverse parts) " · "))) + +(cl-defmethod cg-tm--end-turn ((game cg-tablemeld-game) s) + "Finish seat S's turn: go out if the hand is empty, else advance." + (if (null (cg-rummy--hand game s)) + (cg-tm--score-hand game s) + (cg-put game :turn (mod (1+ s) (cg-get game :nplayers))) + (cg-put game :step 'draw))) + +(cl-defmethod cg-tm--discard ((game cg-tablemeld-game) s card) + "Discard CARD from seat S and finish the turn." + (cg-rummy--set-hand game s (remove card (cg-rummy--hand game s))) + (cg-put game :discard (cons card (cg-get game :discard))) + (cg-tm--end-turn game s)) + +;;;; AI + +(defun cg-tm--ai-melds (game s) + "Lay down every meld seat S can, keeping a card back to discard. +Return non-nil if any meld was laid." + (let ((did nil) (again t)) + (while again + (setq again nil) + (let* ((hand (cg-rummy--hand game s)) + (p (cg-rummy-best-partition hand :ace-high (cg-tm--ace-high game) + :ace-15 (cg-tm--ace-15 game))) + (melds (plist-get p :melds)) + ;; keep one card to discard: skip a meld if it would empty the hand + (melded (apply #'+ (mapcar #'length melds)))) + (when (and melds (= melded (length hand))) + (setq melds (cdr (sort melds (lambda (a b) (< (length a) (length b))))))) + (when melds + (cg-tm--meld game s (car melds)) + (setq did t again t)))) + did)) + +(defun cg-tm--ai-layoffs (game s) + "Lay off every fitting card from seat S, keeping a card back to discard." + (let ((again t)) + (while again + (setq again nil) + (when (> (length (cg-rummy--hand game s)) 1) + (let ((card (cl-find-if + (lambda (c) + (cl-find-if + (lambda (r) (cg-rummy-meld-p (cons c (cdr r)) :min 3 + :ace-high (cg-tm--ace-high game))) + (cg-get game :table))) + (cg-rummy--hand game s)))) + (when card (cg-tm--layoff game s card) (setq again t))))))) + +(defun cg-tm--ai-discard-card (game s) + "Return the best card for seat S to discard (highest deadwood)." + (let* ((hand (cg-rummy--hand game s)) + (p (cg-rummy-best-partition hand :ace-high (cg-tm--ace-high game) + :ace-15 (cg-tm--ace-15 game))) + (dead (or (plist-get p :deadwood) hand)) + (best (car dead)) (bestv -1)) + (dolist (c dead best) + (let ((v (cg-rummy-value c (cg-tm--ace-15 game)))) + (when (> v bestv) (setq best c bestv v)))))) + +(cl-defmethod cg-tm--ai-turn ((game cg-tablemeld-game) s) + "Play seat S's whole turn." + (let* ((hand (cg-rummy--hand game s)) + (up (cg-rummy--top game)) + (cur (cg-rummy-deadwood hand (cg-tm--ace-high game) (cg-tm--ace-15 game))) + (with (and up (cg-rummy-deadwood (cons up hand) + (cg-tm--ace-high game) (cg-tm--ace-15 game)))) + (drew (if (and up with (< with cur)) + (cg-tm--take-top game s) + (cg-tm--draw game s)))) + (if (not drew) + (cg-tm--score-hand game nil) + (cg-tm--ai-melds game s) + (cg-tm--ai-layoffs game s) + (when (eq (cg-get game :phase) 'play) + (if (null (cg-rummy--hand game s)) + (cg-tm--end-turn game s) ; melded out, no discard needed + (cg-tm--discard game s (cg-tm--ai-discard-card game s))))))) + +(defun cg-tm--run (game) + "Advance AI seats until it is the human's turn or the hand ends." + (while (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0)) + (cg-tm--ai-turn game (cg-get game :turn)))) + +;;;; UI + +(defvar-local cg-tm--game nil "The table-meld game in the current buffer.") + +(defun cg-tm--layoff-hint (game) + "Return a predicate marking cards that can be laid off in GAME now." + (lambda (c) + (cl-find-if (lambda (r) (cg-rummy-meld-p (cons c (cdr r)) :min 3 + :ace-high (cg-tm--ace-high game))) + (cg-get game :table)))) + +(cl-defmethod cg-render ((game cg-tablemeld-game)) + "Return a propertized depiction of the table-meld GAME." + (let* ((out '()) (scores (cg-get game :scores)) + (laid (cg-get game :laid)) (meldp (oref game score-style)) + (hand (cg-rummy--hand game 0)) (cursor (cg-get game :cursor))) + (push (format " %s target %d\n\n" (oref game vname) (oref game target)) out) + (dotimes (s (cg-get game :nplayers)) + (unless (= s 0) + (push (format " Player %d: %d cards score %d%s\n" + s (length (cg-rummy--hand game s)) (aref scores s) + (if (eq meldp 'meld-points) + (format " (laid %d)" (aref laid s)) "")) + out))) + (push "\n Table:\n" out) + (if (cg-get game :table) + (dolist (rec (cg-get game :table)) + (push (format " [%s] %s\n" (if (= (car rec) 0) "you" (format "P%d" (car rec))) + (mapconcat #'cg-rummy-card-string (cdr rec) " ")) + out)) + (push " (empty)\n" out)) + (push (format "\n Discard: %s Stock: %d\n\n" + (let ((cs (cg-rummy-card-string (cg-rummy--top game))) (tp (cg-rummy--top game))) + (if (and tp (cg-red-suit-p (car tp))) (propertize cs 'face 'cg-red-suit) cs)) + (length (cg-get game :stock))) + out) + (push (format " Your hand%s:\n " + (if (eq meldp 'meld-points) (format " (laid %d, score %d)" + (aref laid 0) (aref scores 0)) + (format " (score %d)" (aref scores 0)))) + out) + (push (cg-rummy--render-cards hand cursor (cg-get game :marks) + (cg-tm--layoff-hint game)) + out) + (push (format "\n\n %s\n" (cg-get game :message)) out) + (apply #'concat (nreverse out)))) + +(defun cg-tm--redisplay () + "Redraw the table-meld buffer." + (let ((game cg-tm--game) (inhibit-read-only t)) + (setq-local mode-line-process + (format " [%s]" (or (cg-get game :step) (cg-get game :phase)))) + (erase-buffer) (insert (cg-render game)) (goto-char (point-min)))) + +(defun cg-tm--clamp-cursor (g) + "Keep G's cursor within the hand and drop stale marks." + (let ((n (length (cg-rummy--hand g 0)))) + (cg-put g :cursor (if (> n 0) (min (cg-get g :cursor) (1- n)) 0)) + (cg-put g :marks (cl-remove-if (lambda (i) (>= i n)) (cg-get g :marks))))) + +(defun cg-tm--my-turn-p (g) + (and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0))) + +(defun cg-tm-left () + "Move the hand cursor left." + (interactive) + (let* ((g cg-tm--game) (n (length (cg-rummy--hand g 0)))) + (when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n))) + (cg-tm--redisplay))) + +(defun cg-tm-right () + "Move the hand cursor right." + (interactive) + (let* ((g cg-tm--game) (n (length (cg-rummy--hand g 0)))) + (when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n))) + (cg-tm--redisplay))) + +(defun cg-tm-mark () + "Toggle a mark on the card under the cursor (for melding)." + (interactive) + (let* ((g cg-tm--game) (i (cg-get g :cursor)) (marks (cg-get g :marks))) + (cg-put g :marks (if (memq i marks) (delq i marks) (cons i marks))) + (cg-tm--redisplay))) + +(defun cg-tm--marked-cards (g) + "Return the cards currently marked in G's hand." + (let ((hand (cg-rummy--hand g 0))) + (mapcar (lambda (i) (nth i hand)) (sort (copy-sequence (cg-get g :marks)) #'<)))) + +(defun cg-tm-meld () + "Meld the marked cards onto the table." + (interactive) + (let* ((g cg-tm--game) (cards (cg-tm--marked-cards g))) + (cond + ((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn.")) + ((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s or t).")) + ((< (length cards) 3) (cg-put g :message "Mark at least three cards (SPC), then m.")) + ((cg-tm--meld g 0 cards) + (cg-put g :marks nil) (cg-tm--clamp-cursor g) + (cg-put g :message "Melded. Lay off with l, meld more, or discard (RET).")) + (t (cg-put g :message "Those cards are not a valid set or run."))) + (cg-tm--redisplay))) + +(defun cg-tm-layoff () + "Lay the cursor card (or marked cards) off onto a table meld." + (interactive) + (let* ((g cg-tm--game) (marks (cg-tm--marked-cards g))) + (cond + ((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn.")) + ((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s or t).")) + (t (let ((cards (or marks (list (nth (cg-get g :cursor) (cg-rummy--hand g 0))))) + (any nil)) + (dolist (c cards) (when (and c (cg-tm--layoff g 0 c)) (setq any t))) + (cg-put g :marks nil) (cg-tm--clamp-cursor g) + (cg-put g :message (if any "Laid off." "That card fits no meld on the table."))))) + (cg-tm--redisplay))) + +(defun cg-tm-draw-stock () + "Draw the top stock card." + (interactive) + (let ((g cg-tm--game)) + (cond + ((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn.")) + ((not (eq (cg-get g :step) 'draw)) (cg-put g :message "You already drew.")) + ((cg-tm--draw g 0) + (cg-put g :step 'play) (cg-tm--clamp-cursor g) + (cg-put g :message "Meld (m), lay off (l), then discard (RET).")) + (t (cg-tm--score-hand g nil))) + (cg-tm--redisplay))) + +(defun cg-tm-take () + "Take the discard top into your hand." + (interactive) + (let ((g cg-tm--game)) + (cond + ((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn.")) + ((not (eq (cg-get g :step) 'draw)) (cg-put g :message "You already drew.")) + ((null (cg-rummy--top g)) (cg-put g :message "The discard pile is empty.")) + (t (let ((c (cg-tm--take-top g 0))) + (cg-put g :step 'play) (cg-tm--clamp-cursor g) + (cg-put g :message (format "Took %s. Meld (m), lay off (l), discard (RET)." + (cg-rummy-card-string c)))))) + (cg-tm--redisplay))) + +(defun cg-tm-discard () + "Discard the cursor card and end your turn." + (interactive) + (let* ((g cg-tm--game) (card (nth (cg-get g :cursor) (cg-rummy--hand g 0)))) + (cond + ((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn.")) + ((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s or t).")) + ((null card) (cg-put g :message "No card selected.")) + (t (cg-tm--discard g 0 card) + (cg-put g :marks nil) + (when (eq (cg-get g :phase) 'play) + (cg-put g :message "You discarded.") + (cg-tm--run g)))) + (cg-tm--redisplay))) + +(defun cg-tm-new () + "Deal a fresh hand, or a new game when one is over." + (interactive) + (let ((g cg-tm--game)) + (when (eq (cg-get g :phase) 'game-over) + (cg-put g :scores (make-vector (oref g nplayers) 0))) + (cg-put g :reveal nil) + (cg-tm--deal g) + (cg-tm--run g) + (cg-tm--redisplay))) + +(defun cg-tm-redraw () "Redraw the board." (interactive) (cg-tm--redisplay)) + +(defun cg-tm-help () + "Describe the table-meld controls." + (interactive) + (message "Arrows: choose SPC: mark m: meld l: lay off s: draw t: take RET: discard n: new")) + +(defvar cg-tm-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "") #'cg-tm-left) + (define-key map (kbd "") #'cg-tm-right) + (define-key map (kbd "SPC") #'cg-tm-mark) + (define-key map "m" #'cg-tm-meld) + (define-key map "l" #'cg-tm-layoff) + (define-key map "s" #'cg-tm-draw-stock) + (define-key map "t" #'cg-tm-take) + (define-key map (kbd "RET") #'cg-tm-discard) + (define-key map "n" #'cg-tm-new) + (define-key map "g" #'cg-tm-redraw) + (define-key map "?" #'cg-tm-help) + map) + "Keymap for `cg-tm-mode'.") + +(define-derived-mode cg-tm-mode special-mode "Rummy" + "Major mode for the table-meld rummy games." + (setq-local truncate-lines t)) + +(defun cg-tm--start (game buffer-name) + "Start GAME in a buffer named BUFFER-NAME." + (let ((buf (get-buffer-create buffer-name))) + (with-current-buffer buf + (cg-tm-mode) + (setq cg-tm--game game) + (cg-tm--deal game) + (cg-tm--run game) + (cg-tm--redisplay)) + (switch-to-buffer buf))) + +;;;; The two games + +(defcustom cg-rummy-basic-players 2 + "Number of players in Basic Rummy, including you (2-4)." + :type '(choice (const 2) (const 3) (const 4)) :group 'card-games) + +(defclass cg-rummy-basic-game (cg-tablemeld-game) + ((vname :initform "Rummy") + (score-style :initform 'go-out) + (target :initform 100)) + "A game of plain Rummy.") + +;;;###autoload +(defun cg-rummy-basic () + "Play Basic Rummy against the computer." + (interactive) + (let ((n (max 2 (min 4 cg-rummy-basic-players)))) + (cg-tm--start (cg-rummy-basic-game :nplayers n :hand-size (if (= n 2) 10 7)) + "*Rummy*"))) + +(defcustom cg-rum500-players 3 + "Number of players in Rummy 500, including you (2-4)." + :type '(choice (const 2) (const 3) (const 4)) :group 'card-games) + +(defclass cg-rum500-game (cg-tablemeld-game) + ((vname :initform "Rummy 500") + (score-style :initform 'meld-points) + (ace-15 :initform t) + (ace-high :initform t) + (target :initform 500)) + "A game of Rummy 500.") + +;;;###autoload +(defun cg-rum500 () + "Play Rummy 500 against the computer." + (interactive) + (let ((n (max 2 (min 4 cg-rum500-players)))) + (cg-tm--start (cg-rum500-game :nplayers n :hand-size (if (= n 2) 13 7)) + "*Rummy 500*"))) + +;;;###autoload +(defalias 'cg-rummy-500 #'cg-rum500) + +(provide 'cg-rum500) +;;; \ No newline at end of file diff --git a/cg-rummy.el b/cg-rummy.el new file mode 100644 index 0000000..bf9ba0e --- /dev/null +++ b/cg-rummy.el @@ -0,0 +1,617 @@ +;;; cg-rummy.el --- Rummy meld engine and Gin Rummy -*- 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: + +;; The shared meld engine for the rummy family, plus Gin Rummy. +;; +;; A "meld" is a list of cards that is either a *set* (three or four cards +;; of the same rank) or a *run* (three or more cards of the same suit in +;; consecutive rank). The engine validates melds, enumerates the melds +;; latent in a hand, and -- the hard part -- finds the layout that leaves +;; the least deadwood, which drives both knock detection and the AI. +;; +;; Cards use the package-standard cons (SUIT . RANK) with SUIT 0 spades, +;; 1 clubs, 2 diamonds, 3 hearts, and RANK 0 (Ace) .. 12 (King). A joker, +;; used only by Hand & Foot, is the cons (joker . 0). +;; +;; Gin Rummy: a two-handed game of ten-card hands. Draw from the stock or +;; take the discard, then discard one card. Knock when your deadwood is +;; ten or less, or go gin with none; your opponent then lays off onto your +;; melds. First to 100 points wins. This file also provides the abstract +;; `cg-rummy-game' base and the rendering helpers reused by the other +;; rummy games (cg-rum500.el, cg-handfoot.el). + +;;; Code: + +(require 'cl-lib) +(require 'eieio) +(require 'cg-core) + +(defconst cg-rummy-ranks + ["A" "2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K"] + "Rank labels indexed 0 (Ace) .. 12 (King).") + +(defface cg-rummy-mark '((t :background "steelblue" :foreground "white")) + "Face for a card the player has marked toward a meld." + :group 'card-games) + +(defun cg-rummy-card-string (card) + "Return a short label for CARD, or a dot for nil." + (cond ((null card) "·") + ((eq (car card) 'joker) (cg-suit-glyph 'joker)) + (t (concat (aref cg-rummy-ranks (cdr card)) (cg-suit-glyph (car card)))))) + +(defun cg-rummy-joker-p (card) + "Return non-nil when CARD is a joker." + (and card (eq (car card) 'joker))) + +(defun cg-rummy-value (card &optional ace-15) + "Return the point value of CARD. +Faces and tens are 10, an Ace is 1 (or 15 when ACE-15 is non-nil), and +other cards their pip value. A joker is worth 0 here; games that use +jokers value them separately." + (cond ((or (null card) (cg-rummy-joker-p card)) 0) + (t (let ((r (cdr card))) + (cond ((= r 0) (if ace-15 15 1)) + ((<= r 8) (1+ r)) + (t 10)))))) + + +;;;; Meld predicates + +(defun cg-rummy--consec-p (ranks) + "Return non-nil when sorted RANKS rise by exactly one with no repeats." + (let ((ok t) (prev nil)) + (dolist (r ranks ok) + (when (and prev (/= r (1+ prev))) (setq ok nil)) + (setq prev r)))) + +(cl-defun cg-rummy-set-p (cards &key (min 3) distinct-suits) + "Return non-nil when CARDS form a set (>= MIN cards of one rank). +With DISTINCT-SUITS, every suit must differ (a single-deck rule)." + (and (>= (length cards) min) + (not (cl-some #'cg-rummy-joker-p cards)) + (let ((r (cdr (car cards)))) + (cl-every (lambda (c) (= (cdr c) r)) cards)) + (or (not distinct-suits) + (let ((suits (mapcar #'car cards))) + (= (length suits) + (length (delete-dups (copy-sequence suits)))))))) + +(cl-defun cg-rummy-run-p (cards &key (min 3) ace-high) + "Return non-nil when CARDS form a run (>= MIN cards, one suit, in sequence). +With ACE-HIGH, an Ace may sit above the King (Q-K-A)." + (and (>= (length cards) min) + (not (cl-some #'cg-rummy-joker-p cards)) + (let ((suit (car (car cards))) + (ranks (sort (mapcar #'cdr cards) #'<))) + (and (cl-every (lambda (c) (= (car c) suit)) cards) + (= (length ranks) (length (delete-dups (copy-sequence ranks)))) + (or (cg-rummy--consec-p ranks) + (and ace-high (eql (car ranks) 0) + (cg-rummy--consec-p (sort (cons 13 (cdr ranks)) #'<)))))))) + +(cl-defun cg-rummy-meld-p (cards &key (min 3) ace-high distinct-suits) + "Return non-nil when CARDS form a valid set or run. +MIN, ACE-HIGH and DISTINCT-SUITS are passed through to the predicates." + (or (cg-rummy-set-p cards :min min :distinct-suits distinct-suits) + (cg-rummy-run-p cards :min min :ace-high ace-high))) + + +;;;; Candidate melds and best partition + +(defun cg-rummy--combinations (lst k) + "Return all K-element combinations of LST, each as a list." + (cond ((= k 0) (list nil)) + ((null lst) nil) + (t (append + (mapcar (lambda (c) (cons (car lst) c)) + (cg-rummy--combinations (cdr lst) (1- k))) + (cg-rummy--combinations (cdr lst) k))))) + +(defun cg-rummy--runs-in (pairs) + "Return index-lists of runs (length >= 3) within PAIRS. +PAIRS is a list of (RANK . INDEX) sorted ascending by RANK." + (let ((res '()) (vec (vconcat pairs))) + (let ((n (length vec))) + (dotimes (i n) + (let ((idxs (list (cdr (aref vec i)))) + (last (car (aref vec i))) + (j (1+ i))) + (while (and (< j n) (= (car (aref vec j)) (1+ last))) + (setq last (car (aref vec j))) + (setq idxs (cons (cdr (aref vec j)) idxs)) + (when (>= (length idxs) 3) + (push (reverse idxs) res)) + (setq j (1+ j)))))) + res)) + +(cl-defun cg-rummy--candidate-melds (cards &key ace-high) + "Return candidate melds for CARDS as a list of index-lists. +Each index-list refers to positions in CARDS. With ACE-HIGH, high runs +ending in an Ace are also generated." + (let* ((vec (vconcat cards)) (n (length vec)) (melds '())) + ;; sets, grouped by rank + (let ((byrank (make-hash-table :test 'eql))) + (dotimes (i n) + (let ((c (aref vec i))) + (unless (cg-rummy-joker-p c) + (push i (gethash (cdr c) byrank))))) + (maphash + (lambda (_r idxs) + (when (>= (length idxs) 3) + (dolist (k '(3 4)) + (dolist (combo (cg-rummy--combinations idxs k)) + (when (cg-rummy-set-p (mapcar (lambda (i) (aref vec i)) combo) + :distinct-suits t) + (push (sort (copy-sequence combo) #'<) melds)))))) + byrank)) + ;; runs, grouped by suit + (let ((bysuit (make-hash-table :test 'eql))) + (dotimes (i n) + (let ((c (aref vec i))) + (unless (cg-rummy-joker-p c) + (push (cons (cdr c) i) (gethash (car c) bysuit))))) + (maphash + (lambda (_s pairs) + (let ((sorted (sort (copy-sequence pairs) + (lambda (a b) (< (car a) (car b)))))) + (dolist (m (cg-rummy--runs-in sorted)) (push (sort m #'<) melds))) + (when (and ace-high (assq 0 pairs)) + (let* ((hi (mapcar (lambda (p) (if (= (car p) 0) (cons 13 (cdr p)) p)) + pairs)) + (sh (sort hi (lambda (a b) (< (car a) (car b)))))) + (dolist (m (cg-rummy--runs-in sh)) (push (sort m #'<) melds))))) + bysuit)) + (delete-dups melds))) + +(cl-defun cg-rummy-best-partition (cards &key ace-high ace-15) + "Return the lowest-deadwood layout of CARDS. +The result is a plist (:melds MELDS :deadwood CARDS :count N) where MELDS +is a list of card-lists, DEADWOOD the unmelded cards and N their value +sum. ACE-HIGH allows Q-K-A runs; ACE-15 scores Aces at 15." + (let* ((vec (vconcat cards)) (n (length vec)) + (cand (cg-rummy--candidate-melds cards :ace-high ace-high)) + (mmasks (mapcar (lambda (m) + (let ((b 0)) (dolist (i m) (setq b (logior b (ash 1 i)))) + b)) + cand)) + (memo (make-hash-table :test 'eql)) + (full (1- (ash 1 n)))) + (cl-labels + ((cval (i) (cg-rummy-value (aref vec i) ace-15)) + (lowbit (avail) + (let ((i 0)) (while (zerop (logand avail (ash 1 i))) (setq i (1+ i))) i)) + (solve (avail) + (if (zerop avail) (cons 0 '()) + (or (gethash avail memo) + (let* ((i (lowbit avail)) + (ibit (ash 1 i)) + (sub0 (solve (logxor avail ibit))) + (best (cons (+ (cval i) (car sub0)) (cdr sub0)))) + (dolist (mask mmasks) + (when (and (/= 0 (logand mask ibit)) + (= mask (logand mask avail))) + (let ((sub (solve (logand avail (lognot mask))))) + (when (< (car sub) (car best)) + (setq best (cons (car sub) (cons mask (cdr sub)))))))) + (puthash avail best memo) + best))))) + (let* ((res (solve full)) (maskmelds (cdr res)) (used 0)) + (dolist (m maskmelds) (setq used (logior used m))) + (list :melds + (mapcar (lambda (mask) + (let ((cl '())) + (dotimes (i n) + (when (/= 0 (logand mask (ash 1 i))) + (push (aref vec i) cl))) + (nreverse cl))) + maskmelds) + :deadwood + (let ((dl '())) + (dotimes (i n) + (when (= 0 (logand used (ash 1 i))) (push (aref vec i) dl))) + (nreverse dl)) + :count (car res)))))) + +(defun cg-rummy-deadwood (cards &optional ace-high ace-15) + "Return the minimum deadwood value of CARDS. +ACE-HIGH and ACE-15 are passed to `cg-rummy-best-partition'." + (plist-get (cg-rummy-best-partition cards :ace-high ace-high :ace-15 ace-15) + :count)) + +(defun cg-rummy-layoff-p (card melds &optional ace-high) + "Return the first meld in MELDS that CARD extends, or nil. +ACE-HIGH allows extending a run with a high Ace." + (cl-find-if (lambda (m) + (cg-rummy-meld-p (cons card m) :min 3 :ace-high ace-high)) + melds)) + + +;;;; Shared deck and base game + +(defun cg-rummy-deck (&optional ndecks jokers) + "Return a shuffled deck of NDECKS standard packs plus JOKERS jokers each. +NDECKS defaults to 1 and JOKERS to 0." + (random t) + (let ((cards '())) + (dotimes (_ (or ndecks 1)) + (dotimes (s 4) (dotimes (r 13) (push (cons s r) cards))) + (dotimes (_ (or jokers 0)) (push (cons 'joker 0) cards))) + (cg-shuffle cards))) + +(defclass cg-rummy-game (cg-game) () + "Abstract base for rummy-style draw-and-discard games." + :abstract t) + +(defsubst cg-rummy--hand (game s) (aref (cg-get game :hands) s)) +(defsubst cg-rummy--set-hand (game s v) (aset (cg-get game :hands) s v)) +(defsubst cg-rummy--top (game) (car (cg-get game :discard))) + +(defun cg-rummy-sort-hand (cards) + "Return CARDS sorted by suit then rank for display, jokers last." + (sort (copy-sequence cards) + (lambda (a b) + (let ((sa (if (cg-rummy-joker-p a) 99 (car a))) + (sb (if (cg-rummy-joker-p b) 99 (car b)))) + (if (= sa sb) (< (cdr a) (cdr b)) (< sa sb)))))) + +(defun cg-rummy--render-cards (cards cursor marks &optional hint-fn) + "Return a propertized row of CARDS. +CURSOR is the highlighted index, MARKS a list of marked indices, and +HINT-FN an optional predicate marking playable cards." + (let ((i 0) (out '())) + (dolist (c cards) + (let ((cs (cg-rummy-card-string c)) (faces nil)) + (when (and (not (cg-rummy-joker-p c)) (cg-red-suit-p (car c))) + (push 'cg-red-suit faces)) + (when (and hint-fn (funcall hint-fn c)) (push 'cg-hint faces)) + (when (memq i marks) (push 'cg-rummy-mark faces)) + (when (eql i cursor) (push 'cg-cursor faces)) + (push (propertize (format "%4s" cs) 'face (or faces 'default)) out)) + (setq i (1+ i))) + (apply #'concat (nreverse out)))) + +(defun cg-rummy--melds-string (melds) + "Return a one-line depiction of MELDS (a list of card-lists)." + (mapconcat (lambda (m) (mapconcat #'cg-rummy-card-string m " ")) + melds " | ")) + + +;;;; Gin Rummy + +(defcustom cg-gin-target 100 + "Points needed to win a game of Gin Rummy." + :type 'integer :group 'card-games) + +(defclass cg-gin-game (cg-rummy-game) + ((vname :initform "Gin Rummy")) + "A two-handed game of Gin Rummy.") + +(cl-defmethod cg-gin--deal ((game cg-gin-game)) + "Deal a fresh Gin 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 10 collect (pop deck))))) + (cg-put game :hands hands) + (cg-put game :discard (list (pop deck))) + (cg-put game :stock deck) + (cg-put game :turn 0) + (cg-put game :step 'draw) + (cg-put game :phase 'play) + (cg-put game :cursor 0) + (unless (cg-get game :scores) (cg-put game :scores (make-vector 2 0))) + (cg-put game :message + "Your turn: s draws from stock, t takes the discard.") + game)) + +(defun cg-gin--deadwood (cards) (cg-rummy-deadwood cards)) + +(defun cg-gin--draw (game s) + "Move one stock card to seat S's hand; return it or nil if stock empty." + (let ((stock (cg-get game :stock))) + (when stock + (let ((c (pop stock))) + (cg-put game :stock stock) + (cg-rummy--set-hand game s (cons c (cg-rummy--hand game s))) + c)))) + +(defun cg-gin--take (game s) + "Move the discard top to seat S's hand and return it." + (let ((c (cg-rummy--top game))) + (cg-put game :discard (cdr (cg-get game :discard))) + (cg-rummy--set-hand game s (cons c (cg-rummy--hand game s))) + c)) + +(defun cg-gin--discard (game s card) + "Discard CARD from seat S's hand onto the pile." + (cg-rummy--set-hand game s (cg-rummy-sort-hand + (remove card (cg-rummy--hand game s)))) + (cg-put game :discard (cons card (cg-get game :discard)))) + +(defun cg-gin--ai-best-discard (game s) + "Return the card seat S should discard to minimise its deadwood." + (let ((hand (cg-rummy--hand game s)) (best nil) (bestv most-positive-fixnum)) + (dolist (c hand best) + (let ((d (cg-gin--deadwood (remove c hand)))) + (when (or (< d bestv) + (and (= d bestv) best + (> (cg-rummy-value c) (cg-rummy-value best)))) + (setq best c bestv d)))))) + +(cl-defmethod cg-gin--ai-turn ((game cg-gin-game) s) + "Play seat S's whole turn, then hand control back." + (let* ((hand (cg-rummy--hand game s)) + (cur (cg-gin--deadwood hand)) + (up (cg-rummy--top game)) + (with (and up (cg-gin--deadwood (cons up hand)))) + ;; take the discard only when it strictly helps + (drew (if (and up with (< with cur)) + (cg-gin--take game s) + (cg-gin--draw game s)))) + (if (not drew) + (cg-gin--exhaust game) ; stock exhausted: wash the hand + (let ((card (cg-gin--ai-best-discard game s))) + (cg-gin--discard game s card) + (let ((dw (cg-gin--deadwood (cg-rummy--hand game s)))) + (if (<= dw 10) + (cg-gin--knock game s) + (cg-put game :turn 0) + (cg-put game :step 'draw) + (cg-put game :message + (format "Opponent discarded %s. s draws, t takes." + (cg-rummy-card-string card))))))))) + +(cl-defmethod cg-gin--knock ((game cg-gin-game) knocker) + "Resolve the hand when KNOCKER knocks; score and end the hand." + (let* ((kpart (cg-rummy-best-partition (cg-rummy--hand game knocker))) + (kmelds (plist-get kpart :melds)) + (kdw (plist-get kpart :count)) + (opp (- 1 knocker)) + (opart (cg-rummy-best-partition (cg-rummy--hand game opp))) + (odead (plist-get opart :deadwood)) + (gin (= kdw 0))) + ;; opponent lays off onto the knocker's melds (not allowed on gin) + (unless gin + (let (remaining) + (dolist (c odead) + (let ((m (cg-rummy-layoff-p c kmelds))) + (if m (setcdr (last m) (list c)) ; extend that meld in place + (push c remaining)))) + (setq odead (nreverse remaining)))) + (let* ((odw (apply #'+ (mapcar #'cg-rummy-value odead))) + (scores (cg-get game :scores)) + (winner knocker) (pts 0) (note "")) + (cond + (gin (setq pts (+ 25 odw) note "Gin!")) + ((< kdw odw) (setq pts (- odw kdw) note "Knock.")) + (t ;; undercut: defender wins + (setq winner opp pts (+ 25 (- kdw odw)) note "Undercut!"))) + (aset scores winner (+ (aref scores winner) pts)) + (cg-put game :phase 'hand-over) + (cg-put game :reveal t) + (cg-put game :winner winner) + (cg-put game :message + (format "%s %s scores %d. %s (n: next hand)" + note + (if (= winner 0) "You" "Opponent") pts + (if (>= (aref scores winner) cg-gin-target) + (progn (cg-put game :phase 'game-over) + (format "%s wins the game!" + (if (= winner 0) "You" "Opponent"))) + (format "Score %d-%d." + (aref scores 0) (aref scores 1)))))))) + +(cl-defmethod cg-gin--exhaust ((game cg-gin-game)) + "End a hand washed out because the stock ran dry." + (cg-put game :phase 'hand-over) + (cg-put game :reveal t) + (cg-put game :message "Stock exhausted -- the hand is a wash. n: next hand.")) + +;;;; Gin UI + +(defvar-local cg-gin--game nil "The Gin Rummy game in the current buffer.") + +(cl-defmethod cg-render ((game cg-gin-game)) + "Return a propertized depiction of the Gin GAME for a text display." + (let* ((out '()) (scores (cg-get game :scores)) + (reveal (cg-get game :reveal)) + (hand (cg-rummy--hand game 0)) (cursor (cg-get game :cursor))) + (push (format " Gin Rummy first to %d\n\n" cg-gin-target) out) + (push (format " Opponent: %d cards score %d\n" + (length (cg-rummy--hand game 1)) (aref scores 1)) out) + (when reveal + (let ((p (cg-rummy-best-partition (cg-rummy--hand game 1)))) + (push (format " melds: %s\n deadwood: %s (%d)\n" + (cg-rummy--melds-string (plist-get p :melds)) + (mapconcat #'cg-rummy-card-string (plist-get p :deadwood) " ") + (plist-get p :count)) + out))) + (push (format "\n Discard: %s Stock: %d\n\n" + (let ((cs (cg-rummy-card-string (cg-rummy--top game)))) + (if (and (cg-rummy--top game) (cg-red-suit-p (car (cg-rummy--top game)))) + (propertize cs 'face 'cg-red-suit) cs)) + (length (cg-get game :stock))) + out) + (push (format " Your hand (deadwood %d, score %d):\n " + (cg-gin--deadwood hand) (aref scores 0)) out) + (push (cg-rummy--render-cards hand cursor nil) out) + (when reveal + (let ((p (cg-rummy-best-partition hand))) + (push (format "\n melds: %s\n deadwood: %s" + (cg-rummy--melds-string (plist-get p :melds)) + (mapconcat #'cg-rummy-card-string (plist-get p :deadwood) " ")) + out))) + (push (format "\n\n %s\n" (cg-get game :message)) out) + (apply #'concat (nreverse out)))) + +(defun cg-gin--redisplay () + "Redraw the Gin Rummy buffer." + (let ((game cg-gin--game) (inhibit-read-only t)) + (setq-local mode-line-process + (format " [%s]" (or (cg-get game :step) (cg-get game :phase)))) + (erase-buffer) (insert (cg-render game)) (goto-char (point-min)))) + +(defun cg-gin--cursor-card () + "Return the card under the cursor in your hand." + (nth (cg-get cg-gin--game :cursor) (cg-rummy--hand cg-gin--game 0))) + +(defun cg-gin-left () + "Move the hand cursor left." + (interactive) + (let* ((g cg-gin--game) (n (length (cg-rummy--hand g 0)))) + (when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n))) + (cg-gin--redisplay))) + +(defun cg-gin-right () + "Move the hand cursor right." + (interactive) + (let* ((g cg-gin--game) (n (length (cg-rummy--hand g 0)))) + (when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n))) + (cg-gin--redisplay))) + +(defun cg-gin--my-turn-p (g) + "Return non-nil when it is your turn to act in G." + (and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0))) + +(defun cg-gin-draw-stock () + "Draw the top stock card into your hand." + (interactive) + (let ((g cg-gin--game)) + (cond + ((not (cg-gin--my-turn-p g)) (cg-put g :message "Not your turn.")) + ((not (eq (cg-get g :step) 'draw)) (cg-put g :message "Discard first (RET).")) + ((cg-gin--draw g 0) + (cg-put g :step 'discard) + (cg-put g :cursor 0) + (cg-put g :message "Choose a card and discard with RET, or knock with k.")) + (t (cg-gin--exhaust g))) + (cg-gin--redisplay))) + +(defun cg-gin-take-discard () + "Take the discard top into your hand." + (interactive) + (let ((g cg-gin--game)) + (cond + ((not (cg-gin--my-turn-p g)) (cg-put g :message "Not your turn.")) + ((not (eq (cg-get g :step) 'draw)) (cg-put g :message "Discard first (RET).")) + ((null (cg-rummy--top g)) (cg-put g :message "The discard pile is empty.")) + (t (let ((c (cg-gin--take g 0))) + (cg-put g :step 'discard) + (cg-put g :cursor 0) + (cg-put g :message + (format "Took %s. Discard with RET, or knock with k." + (cg-rummy-card-string c)))))) + (cg-gin--redisplay))) + +(defun cg-gin--after-discard (g) + "Hand control to the opponent after you discard in G." + (cg-put g :turn 1) + (cg-put g :step 'draw) + (cg-gin--ai-turn g 1) + (cg-gin--redisplay)) + +(defun cg-gin-discard () + "Discard the selected card and end your turn." + (interactive) + (let* ((g cg-gin--game) (card (cg-gin--cursor-card))) + (cond + ((not (cg-gin--my-turn-p g)) (cg-put g :message "Not your turn.") + (cg-gin--redisplay)) + ((not (eq (cg-get g :step) 'discard)) + (cg-put g :message "Draw first (s or t).") (cg-gin--redisplay)) + ((null card) (cg-put g :message "No card selected.") (cg-gin--redisplay)) + (t (cg-gin--discard g 0 card) + (cg-put g :message (format "You discarded %s." (cg-rummy-card-string card))) + (cg-gin--after-discard g))))) + +(defun cg-gin-knock () + "Knock, discarding the selected card, if your deadwood allows." + (interactive) + (let* ((g cg-gin--game) (card (cg-gin--cursor-card))) + (cond + ((not (cg-gin--my-turn-p g)) (cg-put g :message "Not your turn.")) + ((not (eq (cg-get g :step) 'discard)) + (cg-put g :message "Draw first (s or t).")) + ((null card) (cg-put g :message "No card selected.")) + (t (let ((dw (cg-gin--deadwood (remove card (cg-rummy--hand g 0))))) + (if (> dw 10) + (cg-put g :message + (format "Can't knock: that leaves %d deadwood (need <= 10)." dw)) + (cg-gin--discard g 0 card) + (cg-gin--knock g 0))))) + (cg-gin--redisplay))) + +(defun cg-gin-new () + "Deal a fresh hand (or a new game when one is over)." + (interactive) + (let ((g cg-gin--game)) + (when (eq (cg-get g :phase) 'game-over) (cg-put g :scores (make-vector 2 0))) + (cg-put g :reveal nil) + (cg-gin--deal g) + (cg-gin--redisplay))) + +(defun cg-gin-redraw () "Redraw the board." (interactive) (cg-gin--redisplay)) + +(defun cg-gin-help () + "Describe the Gin Rummy controls." + (interactive) + (message "Arrows: choose s: draw stock t: take discard RET: discard k: knock n: new g: redraw")) + +(defvar cg-gin-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "") #'cg-gin-left) + (define-key map (kbd "") #'cg-gin-right) + (define-key map "s" #'cg-gin-draw-stock) + (define-key map "t" #'cg-gin-take-discard) + (define-key map (kbd "RET") #'cg-gin-discard) + (define-key map "k" #'cg-gin-knock) + (define-key map "n" #'cg-gin-new) + (define-key map "g" #'cg-gin-redraw) + (define-key map "?" #'cg-gin-help) + map) + "Keymap for `cg-gin-mode'.") + +(define-derived-mode cg-gin-mode special-mode "Gin" + "Major mode for Gin Rummy." + (setq-local truncate-lines t)) + +;;;###autoload +(defun cg-gin () + "Play Gin Rummy against the computer." + (interactive) + (let ((buf (get-buffer-create "*Gin Rummy*"))) + (with-current-buffer buf + (cg-gin-mode) + (setq cg-gin--game (cg-gin-game)) + (cg-gin--deal cg-gin--game) + (cg-gin--redisplay)) + (switch-to-buffer buf))) + +;;;###autoload +(defalias 'cg-gin-rummy #'cg-gin) + +(provide 'cg-rummy) +;;; cg-rummy.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/runemacs.sh b/runemacs.sh new file mode 100644 index 0000000..534b111 --- /dev/null +++ b/runemacs.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +# Load the card-games package from this directory and open the launcher. +dir="$(cd "$(dirname "$0")" && pwd)" +exec emacs -L "$dir" -l card-games -f card-game "$@" diff --git a/test/card-games-tests.el b/test/card-games-tests.el index 92cf653..62d530f 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -828,3 +828,238 @@ (ert-deftest cgt-pres-render () (let ((g (cg-pres--deal (cg-president-game)))) (should (stringp (cg-render g))))) +;;;; Rummy family + +(ert-deftest cgt-rummy-set-run () + (should (cg-rummy-set-p '((0 . 5) (1 . 5) (2 . 5)) :distinct-suits t)) + (should-not (cg-rummy-set-p '((0 . 5) (0 . 5) (2 . 5)) :distinct-suits t)) + (should (cg-rummy-run-p '((0 . 3) (0 . 4) (0 . 5)))) + (should-not (cg-rummy-run-p '((0 . 3) (1 . 4) (0 . 5)))) + (should (cg-rummy-run-p '((0 . 10) (0 . 11) (0 . 12) (0 . 0)) :ace-high t)) + (should-not (cg-rummy-run-p '((0 . 11) (0 . 12) (0 . 0)))) + (should (cg-rummy-run-p '((0 . 0) (0 . 1) (0 . 2))))) + +(ert-deftest cgt-rummy-best-partition () + (let* ((hand '((0 . 2)(0 . 3)(0 . 4) (0 . 6)(1 . 6)(2 . 6) + (3 . 8)(3 . 9)(3 . 10) (3 . 12))) + (p (cg-rummy-best-partition hand))) + (should (= 3 (length (plist-get p :melds)))) + (should (= 10 (plist-get p :count)))) + (should (= 0 (cg-rummy-deadwood + '((0 . 0)(0 . 1)(0 . 2) (1 . 4)(1 . 5)(1 . 6) + (2 . 8)(2 . 9)(2 . 10)(2 . 11)))))) + +(ert-deftest cgt-rummy-layoff () + (should (cg-rummy-layoff-p '(3 . 11) '(((3 . 8)(3 . 9)(3 . 10))))) + (should-not (cg-rummy-layoff-p '(0 . 4) '(((3 . 8)(3 . 9)(3 . 10)))))) + +(ert-deftest cgt-gin-full-game () + (let ((g (cg-gin-game)) (turns 0)) + (cg-gin--deal g) + (while (and (not (eq (cg-get g :phase) 'game-over)) (< turns 100000)) + (if (eq (cg-get g :phase) 'hand-over) + (progn (cg-put g :reveal nil) (cg-gin--deal g)) + (cg-gin--ai-turn g (cg-get g :turn)) (cl-incf turns))) + (should (eq (cg-get g :phase) 'game-over)) + (should (>= (apply #'max (append (cg-get g :scores) nil)) cg-gin-target)))) + +(ert-deftest cgt-gin-render () (let ((g (cg-gin--deal (cg-gin-game)))) + (should (stringp (cg-render g))))) + +(ert-deftest cgt-tablemeld-games () + (dolist (mk (list (lambda () (cg-rummy-basic-game :nplayers 3 :hand-size 7)) + (lambda () (cg-rum500-game :nplayers 3 :hand-size 7)))) + (let ((g (funcall mk)) (turns 0)) + (cg-tm--deal g) + (while (and (not (eq (cg-get g :phase) 'game-over)) (< turns 200000)) + (if (eq (cg-get g :phase) 'hand-over) + (progn (cg-put g :reveal nil) (cg-tm--deal g)) + (cg-tm--ai-turn g (cg-get g :turn)) (cl-incf turns))) + (should (eq (cg-get g :phase) 'game-over)) + (should (stringp (cg-render g)))))) + +(ert-deftest cgt-tablemeld-conservation () + (let ((g (cg-rum500-game :nplayers 3 :hand-size 7))) + (cg-tm--deal g) + (dotimes (_ 30) (when (eq (cg-get g :phase) 'play) + (cg-tm--ai-turn g (cg-get g :turn)))) + (let ((tot (+ (length (cg-get g :stock)) (length (cg-get g :discard)) + (apply #'+ (mapcar (lambda (r) (length (cdr r))) (cg-get g :table)))))) + (dotimes (s 3) (setq tot (+ tot (length (cg-rummy--hand g s))))) + (should (= tot 52))))) + +(ert-deftest cgt-handfoot-book () + (should (cg-hf--book-valid-p '((0 . 7)(1 . 7)(2 . 7)))) + (should (cg-hf--book-valid-p '((0 . 7)(1 . 7)(joker . 0)))) ; dirty + (should-not (cg-hf--book-valid-p '((0 . 7)(joker . 0)(joker . 0)))) ; wilds > nats + (should-not (cg-hf--book-valid-p '((0 . 2)(1 . 2)(2 . 2)))) ; threes + (should (cg-hf--book-complete-p '(a b c d e f g))) + (should (cg-hf--book-clean-p '((0 . 7)(1 . 7)(2 . 7)))) + (should-not (cg-hf--book-clean-p '((0 . 7)(1 . 7)(joker . 0))))) + +(ert-deftest cgt-handfoot-full-game () + (let ((g (cg-handfoot-game)) (rounds 0) (turns 0) (expect (* 5 54))) + (cg-put g :nplayers 4) (cg-put g :nteams 2) (cg-put g :scores (make-vector 2 0)) + (cg-hf--deal g) + (while (and (not (eq (cg-get g :phase) 'game-over)) (< rounds 60)) + (cond ((eq (cg-get g :phase) 'round-over) + (cg-put g :reveal nil) (cg-hf--deal g) (cl-incf rounds)) + (t (cg-hf--ai-turn g (cg-get g :turn)) (cl-incf turns) + (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))))) +;;;; Bridge + +(ert-deftest cgt-bridge-score () + (cl-flet ((b (l s d v tk) (plist-get (cg-bridge--deal-score l s d v tk) :below)) + (a (l s d v tk) (plist-get (cg-bridge--deal-score l s d v tk) :datk)) + (f (l s d v tk) (plist-get (cg-bridge--deal-score l s d v tk) :defend))) + (should (= 100 (b 3 4 0 nil 9))) ; 3NT made + (should (= 120 (b 4 3 0 nil 10))) ; 4 spades made + (should (= 180 (b 6 2 0 nil 12))) ; 6 hearts made + (should (= 500 (a 6 2 0 nil 12))) ; small slam bonus + (should (= 50 (a 1 4 1 nil 7))) ; 1NT doubled, insult + (should (= 100 (f 4 3 0 nil 8))) ; down two undoubled + (should (= 500 (f 4 3 1 t 8)))) ; down two doubled vulnerable + (should (= 1 (cg-bridge--trick-winner + '((0 . (0 . 12)) (1 . (3 . 0)) (2 . (0 . 2)) (3 . (0 . 5))) 3)))) + +(ert-deftest cgt-bridge-full () + (let ((scored 0) (passed 0)) + (dotimes (i 12) + (let ((g (cg-bridge-game)) (guard 0)) + (cg-put g :dealer (mod i 4)) + (cg-bridge--deal g) + (while (and (eq (cg-get g :phase) 'auction) (< guard 60)) + (cl-incf guard) + (let* ((s (cg-get g :bidder)) (call (cg-bridge--ai-call g s))) + (unless (cg-bridge--legal-call-p g call) (setq call 'pass)) + (cg-bridge--apply-call g s call) + (cg-bridge--auction-done-p g))) + (if (eq (cg-get g :phase) 'passed-out) (cl-incf passed) + (let ((p 0)) + (while (and (eq (cg-get g :phase) 'play) (< p 60)) + (cl-incf p) + (cg-bridge--play-card g (cg-get g :turn) (cg-bridge--ai-play g (cg-get g :turn))))) + (when (eq (cg-get g :phase) 'scored) + (cl-incf scored) + (should (cl-every #'null (append (cg-get g :hands) nil))))) + (should (memq (cg-get g :phase) '(scored passed-out))) + (should (stringp (cg-render g))))) + (should (> scored 0))))