diff --git a/Makefile b/Makefile index d77e1ff..ecc7d0c 100644 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ EMACS ?= emacs PKG = card-games VERSION = 1.0.60 # Source files in dependency order (cg-core first). -EL = cg-core.el cg-svg.el cg-render.el cg-net.el cg-bid.el cg-gaps.el cg-bid-ui.el cg-bid-net.el cg-solitaire.el cg-trick.el cg-eights.el cg-patience.el cg-president.el cg-rummy.el cg-rum500.el cg-handfoot.el cg-match.el cg-cribbage.el cg-scopa.el cg-trick-ext.el cg-spite.el cg-bridge.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 card-games.el ELC = $(EL:.el=.elc) PKGDESC = $(PKG)-pkg.el TARDIR = $(PKG)-$(VERSION) diff --git a/README.org b/README.org index 1cdbfa1..1fadacb 100644 --- a/README.org +++ b/README.org @@ -60,57 +60,6 @@ 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 b9b783b..de17e2b 100644 --- a/card-games.el +++ b/card-games.el @@ -49,15 +49,6 @@ (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 @@ -97,35 +88,7 @@ ("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.") - ("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.")) + "Climbing: shed your hand; first out rules, last out scrubs.")) "Registry of playable games. Each entry is (NAME COMMAND DESCRIPTION); `card-game' lists them.") diff --git a/cg-bridge.el b/cg-bridge.el deleted file mode 100644 index d3b7379..0000000 --- a/cg-bridge.el +++ /dev/null @@ -1,730 +0,0 @@ -;;; 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 deleted file mode 100644 index 921b3a9..0000000 --- a/cg-cribbage.el +++ /dev/null @@ -1,437 +0,0 @@ -;;; 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 deleted file mode 100644 index 33e3a97..0000000 --- a/cg-handfoot.el +++ /dev/null @@ -1,535 +0,0 @@ -;;; 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 deleted file mode 100644 index 02bf7b2..0000000 --- a/cg-match.el +++ /dev/null @@ -1,481 +0,0 @@ -;;; 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 deleted file mode 100644 index b96baf6..0000000 --- a/cg-rum500.el +++ /dev/null @@ -1,519 +0,0 @@ -;;; 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 deleted file mode 100644 index bf9ba0e..0000000 --- a/cg-rummy.el +++ /dev/null @@ -1,617 +0,0 @@ -;;; 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 deleted file mode 100644 index 5b884ef..0000000 --- a/cg-scopa.el +++ /dev/null @@ -1,404 +0,0 @@ -;;; 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 deleted file mode 100644 index 56d8a46..0000000 --- a/cg-spite.el +++ /dev/null @@ -1,426 +0,0 @@ -;;; 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 deleted file mode 100644 index a8997be..0000000 --- a/cg-trick-ext.el +++ /dev/null @@ -1,501 +0,0 @@ -;;; 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 deleted file mode 100644 index 534b111..0000000 --- a/runemacs.sh +++ /dev/null @@ -1,4 +0,0 @@ -#!/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 62d530f..92cf653 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -828,238 +828,3 @@ (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))))