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

Add 16 games and known-games research; bump to 1.0.60

Browse source 
Console UNICODE games on the cg-core EIEIO engine, all ERT-tested (88/88):
- Tableau solitaire (cg-solitaire.el): Klondike, FreeCell, Spider, Yukon,
  Canfield, Forty Thieves, Scorpion.
- Pile solitaire (cg-patience.el): Golf, TriPeaks, Pyramid.
- Trick-taking (cg-trick.el): Hearts, Spades, Whist, Oh Hell.
- Shedding/climbing: Crazy Eights (cg-eights.el), President (cg-president.el).

Wire all into the card-game chooser, Makefile, and README; add
known-games.org research collation; bump every file to 1.0.60.
This commit is contained in:
Corwin Brust 2026-06-25 01:58:24 -05:00
parent 2345f7e1a6
commit b5410e1830
19 changed files with 4466 additions and 22 deletions
Download patch file Download diff file Expand all files Collapse all files

4
Makefile
View file

@ -1,9 +1,9 @@
# Makefile for card-games -- byte-compile, test, and package.
EMACS ?= emacs
PKG = card-games
VERSION = 1.0.50
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 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)

62
README.org
View file

@ -8,21 +8,57 @@ available. The default (UNICODE) symbols maybe customized by
configuring ~card-game-symbols~.
* Games
- *500 (Bid)* -- the four-handed partnership trick-taking game, against
three computer opponents (~M-x cg-bid~).
- *Gaps / Hell's Half-Acre* -- solitaire; sort each row into one suit
running 2..K (~M-x cg-gaps~).
To open the game menu type ~M-x card-game~, or start a game directly
with its command:
with its command.
** Trick-taking
- ~cg-bid~ -- 500 (Bid). Win the auction, name the trump suit, then take
tricks with your partner to reach 500 points before the opposing pair.
Also playable live over the network (~M-x cg-bid-host~ / ~cg-bid-join~).
- ~cg-hearts~ -- Hearts. Avoid taking hearts and the Queen of Spades, or
take them all to "shoot the moon"; lowest score loses.
- ~cg-spades~ -- Spades. Partnership bidding to 500; spades are always
trump. Make your side's combined bid, mind the bags, dare a nil.
- ~cg-whist~ -- Whist. Trump is the turned card, there is no bidding;
score one point for each trick past the book of six.
- ~cg-ohhell~ -- Oh Hell. The hand shrinks each round; bid the exact
number of tricks you will take, no more and no fewer.
** Solitaire
- ~cg-montana~ -- Montana (also called Gaps). Each row is anchored by a
Two and built upward in one suit, 2 through King; slide cards into the
gaps until all four rows are sorted.
- ~cg-gaps~ -- an alias for ~cg-montana~.
- ~cg-hells-half-acre~ -- the build-down variant: each row is anchored by
a King and built downward, King through 2.
- ~cg-bid~ -- 500 (Bid). Win the auction, name the trump suit, then take
tricks with your partner to reach 500 points before the opposing pair.
- ~cg-klondike~ -- Klondike, the classic "Solitaire": build the four
foundations up by suit from the Ace.
- ~cg-freecell~ -- FreeCell: every card in view, four free cells, a game
of nearly pure skill.
- ~cg-spider~ -- Spider (two decks): build down regardless of suit, but
only same-suit runs move; clear eight King-to-Ace runs.
- ~cg-yukon~ -- Yukon: Klondike's layout dealt mostly face up, with any
buried group movable and no stock.
- ~cg-canfield~ -- Canfield: a 13-card reserve and a foundation base rank
set by the deal; foundations wrap King to Ace.
- ~cg-forty-thieves~ -- Forty Thieves: two decks, ten columns, eight
foundations, build down by suit, and no second pass through the stock.
- ~cg-scorpion~ -- Scorpion: build down by suit and free any buried group
to assemble four King-to-Ace runs.
- ~cg-golf~ -- Golf: clear the layout by playing exposed cards one rank
above or below the waste top.
- ~cg-tripeaks~ -- TriPeaks: the same, on three overlapping peaks, with
Ace-King wrapping for long chains.
- ~cg-pyramid~ -- Pyramid: remove pairs of exposed cards whose ranks sum
to thirteen; Kings go alone.
** Shedding and climbing
- ~cg-eights~ -- Crazy Eights. Match the suit or rank of the discard;
eights are wild and let you name the next suit.
- ~cg-president~ -- President (Scum). Climb: play one to four of a rank,
beat it or pass; first out rules, last out scrubs, and the roles trade
cards on the next deal.
* TODO
- [X] make the suit symbols customizable (~cg-symbols~) and obey them
@ -35,9 +71,9 @@ with its command:
* Install
** From the package tarball
#+begin_src
make package # builds card-games-1.0.50.tar
make package # builds card-games-1.0.60.tar
#+end_src
Then in Emacs: ~M-x package-install-file RET card-games-1.0.50.tar~.
Then in Emacs: ~M-x package-install-file RET card-games-1.0.60.tar~.
** From a local ELPA archive
#+begin_src
@ -61,6 +97,14 @@ graphical display.
~n~ next hand / new game, ~?~ help.
- Gaps: arrows to move (or ~hjkl~ when ~cg-keys~ is ~classic~), ~RET~ to
fill a gap (or click it), ~r~ redeal, ~u~ undo, ~n~ new, ~?~ help.
- Klondike / FreeCell / Spider / Yukon: arrows move between piles, ~RET~
picks up a movable run and drops it, ~f~ sends a card to a foundation,
~a~ auto-plays everything it can, ~u~ undo, ~n~ new, ~?~ help. On the
stock pile, ~RET~ deals or recycles.
- Hearts / Spades: arrows choose a card, ~RET~ plays it (in Hearts, ~RET~
marks a card to pass and ~p~ sends the three), ~n~ new match, ~?~ help.
- Crazy Eights: arrows choose, ~RET~ plays, ~d~ draws, ~x~ passes, ~n~
new deal, ~?~ help.
On a graphical display, ~v~ toggles the full-window SVG table and
~+~ / ~-~ / ~0~ (Emacs ~text-scale-adjust~) resize the cards.

2
card-games-pkg.el
View file

@ -1,5 +1,5 @@
;;; card-games-pkg.el --- Package metadata -*- no-byte-compile: t; -*-
(define-package "card-games" "1.0.50"
(define-package "card-games" "1.0.60"
"Play card games in Emacs (console UNICODE and graphical SVG)."
'((emacs "26.1"))
:keywords '("games")

41
card-games.el
View file

@ -4,7 +4,7 @@
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.50
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el
@ -44,6 +44,11 @@
(require 'cg-gaps)
(require 'cg-bid-ui)
(require 'cg-bid-net)
(require 'cg-solitaire)
(require 'cg-trick)
(require 'cg-eights)
(require 'cg-patience)
(require 'cg-president)
(defvar card-games-list
'(("500 (Bid)" cg-bid
@ -51,7 +56,39 @@
("Gaps (Montana)" cg-montana
"Solitaire: a Two anchors each row; build up 2 through King.")
("Hell's Half-Acre" cg-hells-half-acre
"Solitaire: a King anchors each row; build down King through 2."))
"Solitaire: a King anchors each row; build down King through 2.")
("Klondike" cg-klondike
"Solitaire: the classic; build the foundations up by suit from the Ace.")
("FreeCell" cg-freecell
"Solitaire: every card in view, four free cells, a game of skill.")
("Spider" cg-spider
"Solitaire: two decks; build down and clear eight same-suit runs.")
("Yukon" cg-yukon
"Solitaire: Klondike's layout, all face up; move any buried group.")
("Hearts" cg-hearts
"Trick-taking: dodge every heart and the Queen of Spades.")
("Spades" cg-spades
"Trick-taking: partnership bidding to 500; spades are always trump.")
("Crazy Eights" cg-eights
"Shedding: match the suit or rank; eights are wild.")
("Canfield" cg-canfield
"Solitaire: a 13-card reserve and a shifting foundation base rank.")
("Forty Thieves" cg-forty-thieves
"Solitaire: two decks, ten columns, eight foundations, no redeal.")
("Scorpion" cg-scorpion
"Solitaire: build down by suit and free four buried King-to-Ace runs.")
("Golf" cg-golf
"Solitaire: clear the layout one rank at a time onto the waste.")
("TriPeaks" cg-tripeaks
"Solitaire: clear three peaks with Ace-King wrapping chains.")
("Pyramid" cg-pyramid
"Solitaire: remove pairs of cards that sum to thirteen.")
("Whist" cg-whist
"Trick-taking: fixed trump, no bidding, race past the book of six.")
("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."))
"Registry of playable games.
Each entry is (NAME COMMAND DESCRIPTION); `card-game' lists them.")

2
cg-bid-net.el
View file

@ -4,7 +4,7 @@
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.50
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el

2
cg-bid-ui.el
View file

@ -4,7 +4,7 @@
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.50
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el

2
cg-bid.el
View file

@ -4,7 +4,7 @@
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.50
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el

2
cg-core.el
View file

@ -4,7 +4,7 @@
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.50
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el

352
cg-eights.el Normal file
View file

@ -0,0 +1,352 @@
;;; cg-eights.el --- Crazy Eights, a shedding card game -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Corwin Brust
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Crazy Eights: shed your whole hand by matching the suit or rank of the
;; card on top of the discard pile. Eights are wild -- play one any time
;; and name the suit that must follow. If you cannot play, draw a card.
;; You are the South player; the others are simple AI. This is the direct
;; ancestor of UNO, and the shedding engine generalises to climbing games
;; such as President.
;;
;; Cards are the package-standard cons (SUIT . RANK) with SUIT 0 spades,
;; 1 clubs, 2 diamonds, 3 hearts and RANK 0 (the Two) .. 12 (the Ace).
;;; Code:
(require 'cl-lib)
(require 'eieio)
(require 'cg-core)
(defconst cg-eights-ranks
["2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K" "A"]
"Rank labels indexed 0 (Two) .. 12 (Ace).")
(defconst cg-eights--wild 6 "Rank index of the wild Eight.")
(defcustom cg-eights-players 3
"Number of players in Crazy Eights, including you (2-4)."
:type '(choice (const 2) (const 3) (const 4)) :group 'card-games)
(defun cg-eights-card-string (card)
"Return a short string for CARD."
(if (null card) "·"
(concat (aref cg-eights-ranks (cdr card)) (cg-suit-glyph (car card)))))
(defsubst cg-eights-red-p (card) (and card (cg-red-suit-p (car card))))
(defun cg-eights--value (card)
"Return the scoring value of CARD held at the end of a hand."
(cond ((= (cdr card) cg-eights--wild) 50)
((>= (cdr card) 9) 10) ; J Q K
((= (cdr card) 12) 1) ; (Ace handled above by >=9? no)
(t (+ 2 (cdr card)))))
(defun cg-eights--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)))))
(defclass cg-eights-game (cg-game)
((vname :initform "Crazy Eights"))
"A game of Crazy Eights.")
(defsubst cg-eights--hand (game s) (aref (cg-get game :hands) s))
(defsubst cg-eights--set-hand (game s v) (aset (cg-get game :hands) s v))
(defsubst cg-eights--top (game) (car (cg-get game :discard)))
(cl-defmethod cg-eights--deal ((game cg-eights-game))
"Deal a fresh Crazy Eights hand into GAME."
(let* ((n (max 2 (min 4 cg-eights-players)))
(deck (cg-eights--deck))
(per (if (= n 2) 7 5))
(hands (make-vector n nil)))
(dotimes (s n)
(aset hands s (cl-loop repeat per collect (pop deck))))
;; turn up a starter that is not an eight
(let ((start (pop deck)))
(while (= (cdr start) cg-eights--wild)
(setq deck (append deck (list start)) start (pop deck)))
(cg-put game :discard (list start))
(cg-put game :suit (car start)))
(cg-put game :stock deck)
(cg-put game :hands hands)
(cg-put game :nplayers n)
(cg-put game :turn 0)
(cg-put game :phase 'play)
(cg-put game :passes 0)
(cg-put game :cursor 0)
(unless (cg-get game :scores) (cg-put game :scores (make-vector n 0)))
(cg-put game :message "Match the suit or rank; eights are wild. d draws.")
game))
(cl-defmethod cg-eights--legal-p ((game cg-eights-game) card)
"Return non-nil when CARD may be played onto the discard now."
(or (= (cdr card) cg-eights--wild)
(= (car card) (cg-get game :suit))
(= (cdr card) (cdr (cg-eights--top game)))))
(defun cg-eights--legal-moves (game s)
"Return the cards in seat S's hand that may be played now."
(cl-remove-if-not (lambda (c) (cg-eights--legal-p game c))
(cg-eights--hand game s)))
(defun cg-eights--best-suit (game s)
"Return the suit seat S holds most of (ignoring eights)."
(let ((counts (make-vector 4 0)))
(dolist (c (cg-eights--hand game s))
(unless (= (cdr c) cg-eights--wild)
(aset counts (car c) (1+ (aref counts (car c))))))
(let ((best 0))
(dotimes (i 4) (when (> (aref counts i) (aref counts best)) (setq best i)))
best)))
(cl-defmethod cg-eights--play ((game cg-eights-game) s card &optional suit)
"Have seat S play CARD; SUIT names the next suit for a wild eight."
(cg-eights--set-hand game s (remove card (cg-eights--hand game s)))
(cg-put game :discard (cons card (cg-get game :discard)))
(cg-put game :suit (if (= (cdr card) cg-eights--wild)
(or suit (cg-eights--best-suit game s))
(car card)))
(cg-put game :passes 0)
(if (null (cg-eights--hand game s))
(cg-eights--finish game s)
(cg-put game :turn (mod (1+ s) (cg-get game :nplayers)))))
(defun cg-eights--draw-card (game s)
"Move one card from the stock to seat S's hand, recycling if needed.
Return the drawn card, or nil when none is available."
(when (and (null (cg-get game :stock)) (cdr (cg-get game :discard)))
(let ((top (car (cg-get game :discard))))
(cg-put game :stock (cg-shuffle (cdr (cg-get game :discard))))
(cg-put game :discard (list top))))
(let ((stock (cg-get game :stock)))
(when stock
(let ((card (car stock)))
(cg-put game :stock (cdr stock))
(cg-eights--set-hand game s (cons card (cg-eights--hand game s)))
card))))
(cl-defmethod cg-eights--finish ((game cg-eights-game) winner)
"Record WINNER going out and score the other hands against them."
(let ((sum 0))
(dotimes (s (cg-get game :nplayers))
(unless (= s winner)
(dolist (c (cg-eights--hand game s))
(setq sum (+ sum (cg-eights--value c))))))
(aset (cg-get game :scores) winner (+ (aref (cg-get game :scores) winner) sum))
(cg-put game :phase 'game-over)
(cg-put game :winner winner)
(cg-put game :message
(format "%s goes out and scores %d. Press n for a new deal."
(if (= winner 0) "You" (format "Player %d" winner)) sum))))
(cl-defmethod cg-eights--ai-turn ((game cg-eights-game) s)
"Take seat S's whole turn: play if able, otherwise draw then play or pass."
(let ((moves (cg-eights--legal-moves game s)))
(unless moves
;; draw up to a small limit looking for a play
(let ((tries 0))
(while (and (not moves) (< tries 60) (cg-eights--draw-card game s))
(setq moves (cg-eights--legal-moves game s) tries (1+ tries)))))
(if moves
;; prefer a non-eight of lowest value; keep eights for later
(let* ((non (cl-remove-if (lambda (c) (= (cdr c) cg-eights--wild)) moves))
(pick (car (sort (copy-sequence (or non moves))
(lambda (a b) (< (cg-eights--value a)
(cg-eights--value b)))))))
(cg-eights--play game s pick))
;; truly stuck: pass
(cg-put game :passes (1+ (cg-get game :passes)))
(cg-put game :turn (mod (1+ s) (cg-get game :nplayers))))))
(defun cg-eights--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-get game :passes) (cg-get game :nplayers)))
(cg-eights--ai-turn game (cg-get game :turn)))
(when (>= (cg-get game :passes) (cg-get game :nplayers))
(cg-eights--deadlock game)))
(cl-defmethod cg-eights--deadlock ((game cg-eights-game))
"End a hand in which everyone passed; lowest hand value wins."
(let ((best 0) (bestv most-positive-fixnum))
(dotimes (s (cg-get game :nplayers))
(let ((v (apply #'+ (mapcar #'cg-eights--value (cg-eights--hand game s)))))
(when (< v bestv) (setq bestv v best s))))
(cg-eights--finish game best)))
;;;; UI
(defvar-local cg-eights--game nil "The Crazy Eights game in the current buffer.")
(cl-defmethod cg-render ((game cg-eights-game))
"Return a propertized string depicting GAME for a text display."
(let* ((out (list)) (top (cg-eights--top game))
(hand (cg-eights--hand game 0)) (cursor (cg-get game :cursor)))
(push (format " Crazy Eights\n\n") out)
(dotimes (s (cg-get game :nplayers))
(unless (= s 0)
(push (format " Player %d: %d cards (score %d)\n"
s (length (cg-eights--hand game s))
(aref (cg-get game :scores) s)) out)))
(push (format "\n Discard top: %s Suit in play: %s Stock: %d\n\n"
(let ((cs (cg-eights-card-string top)))
(if (cg-eights-red-p top) (propertize cs 'face 'cg-red-suit) cs))
(cg-suit-glyph (cg-get game :suit))
(length (cg-get game :stock)))
out)
(push (format " Your hand (score %d):\n " (aref (cg-get game :scores) 0)) out)
(let ((i 0))
(dolist (c hand)
(let ((cs (cg-eights-card-string c)) (faces nil))
(when (cg-eights-red-p c) (push 'cg-red-suit faces))
(when (cg-eights--legal-p game 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 (format "\n\n %s\n" (cg-get game :message)) out)
(apply #'concat (nreverse out))))
(defun cg-eights--redisplay ()
"Redraw the Crazy Eights buffer."
(let ((game cg-eights--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-eights--cursor-card (game)
(nth (cg-get game :cursor) (cg-eights--hand game 0)))
(defun cg-eights-left ()
"Move the hand cursor left."
(interactive)
(let* ((game cg-eights--game) (n (length (cg-eights--hand game 0))))
(when (> n 0) (cg-put game :cursor (mod (1- (cg-get game :cursor)) n)))
(cg-eights--redisplay)))
(defun cg-eights-right ()
"Move the hand cursor right."
(interactive)
(let* ((game cg-eights--game) (n (length (cg-eights--hand game 0))))
(when (> n 0) (cg-put game :cursor (mod (1+ (cg-get game :cursor)) n)))
(cg-eights--redisplay)))
(defun cg-eights--choose-suit (game)
"Return a suit the human names for a wild eight."
(if noninteractive (cg-eights--best-suit game 0)
(let* ((names (mapcar (lambda (i) (cons (aref cg-suit-names i) i)) '(0 1 2 3)))
(pick (completing-read "Name the suit: " (mapcar #'car names) nil t)))
(cdr (assoc pick names)))))
(defun cg-eights-act ()
"Play the selected card if it is legal."
(interactive)
(let* ((game cg-eights--game) (card (cg-eights--cursor-card game)))
(cond
((not (eq (cg-get game :phase) 'play)) (cg-put game :message "Press n for a new deal."))
((/= (cg-get game :turn) 0) (cg-put game :message "Not your turn."))
((null card) (cg-put game :message "No card selected."))
((not (cg-eights--legal-p game card))
(cg-put game :message "That card does not match — draw with d if stuck."))
(t (let ((suit (and (= (cdr card) cg-eights--wild) (cg-eights--choose-suit game))))
(cg-eights--play game 0 card suit)
(cg-put game :cursor 0)
(cg-eights--run game))))
(cg-eights--redisplay)))
(defun cg-eights-draw ()
"Draw a card; if the stock cannot help, pass your turn."
(interactive)
(let ((game cg-eights--game))
(when (eq (cg-get game :phase) 'play)
(if (= (cg-get game :turn) 0)
(let ((card (cg-eights--draw-card game 0)))
(if card
(cg-put game :message (format "You drew %s." (cg-eights-card-string card)))
(cg-put game :passes (1+ (cg-get game :passes)))
(cg-put game :turn (mod 1 (cg-get game :nplayers)))
(cg-put game :message "Nothing to draw — you pass.")
(cg-eights--run game)))
(cg-put game :message "Not your turn.")))
(cg-eights--redisplay)))
(defun cg-eights-pass ()
"Pass your turn (only sensible after drawing with an empty stock)."
(interactive)
(let ((game cg-eights--game))
(when (and (eq (cg-get game :phase) 'play) (= (cg-get game :turn) 0))
(cg-put game :passes (1+ (cg-get game :passes)))
(cg-put game :turn (mod 1 (cg-get game :nplayers)))
(cg-eights--run game))
(cg-eights--redisplay)))
(defun cg-eights-new ()
"Deal a fresh hand."
(interactive)
(cg-eights--deal cg-eights--game)
(cg-eights--run cg-eights--game)
(cg-eights--redisplay))
(defun cg-eights-redraw () "Redraw." (interactive) (cg-eights--redisplay))
(defun cg-eights-help ()
"Describe the controls."
(interactive)
(message "Arrows: choose RET: play d: draw x: pass n: new deal g: redraw"))
(defvar cg-eights-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "<left>") #'cg-eights-left)
(define-key map (kbd "<right>") #'cg-eights-right)
(define-key map (kbd "RET") #'cg-eights-act)
(define-key map (kbd "SPC") #'cg-eights-act)
(define-key map "d" #'cg-eights-draw)
(define-key map "x" #'cg-eights-pass)
(define-key map "n" #'cg-eights-new)
(define-key map "g" #'cg-eights-redraw)
(define-key map "?" #'cg-eights-help)
map)
"Keymap for `cg-eights-mode'.")
(define-derived-mode cg-eights-mode special-mode "Crazy8"
"Major mode for Crazy Eights."
(setq-local truncate-lines t))
;;;###autoload
(defun cg-eights ()
"Play Crazy Eights against the computer."
(interactive)
(let ((buf (get-buffer-create "*Crazy Eights*")))
(with-current-buffer buf
(cg-eights-mode)
(setq cg-eights--game (cg-eights-game))
(cg-eights--deal cg-eights--game)
(cg-eights--run cg-eights--game)
(cg-eights--redisplay))
(switch-to-buffer buf)))
(provide 'cg-eights)
;;; cg-eights.el ends here

2
cg-gaps.el
View file

@ -4,7 +4,7 @@
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.50
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el

2
cg-net.el
View file

@ -4,7 +4,7 @@
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.50
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el

370
cg-patience.el Normal file
View file

@ -0,0 +1,370 @@
;;; cg-patience.el --- Pile solitaires (Golf, TriPeaks, Pyramid) -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Corwin Brust
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Three "pile" solitaires that clear a fixed layout of cards rather than
;; building tableau columns:
;;
;; `cg-golf' -- move an exposed card to the waste when it is one rank
;; above or below the waste's top card; deal when stuck.
;; `cg-tripeaks' -- the same, on three overlapping peaks, with Ace-King
;; wrapping so long chains are possible.
;; `cg-pyramid' -- remove pairs of exposed cards whose ranks sum to 13
;; (Kings go alone); deal from the stock to help.
;;
;; A board is a vector of card slots; each slot lists the slots that cover
;; it, and a slot is "exposed" (playable) once all its coverers are gone.
;; Cards are the package-standard cons (SUIT . RANK) with RANK 0 Ace .. 12
;; King; a rank's value for the sum-of-13 rule is RANK + 1.
;;; Code:
(require 'cl-lib)
(require 'eieio)
(require 'cg-core)
(defconst cg-pat-ranks
["A" "2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K"]
"Rank labels indexed 0 (Ace) .. 12 (King).")
(defun cg-pat-card-string (card)
"Return a short string for CARD, or a dot for an empty slot."
(if (null card) "·"
(concat (aref cg-pat-ranks (cdr card)) (cg-suit-glyph (car card)))))
(defsubst cg-pat-red-p (card) (and card (cg-red-suit-p (car card))))
(defun cg-pat--deck () (cg-shuffle (cl-loop for s below 4 append
(cl-loop for r below 13 collect (cons s r)))))
;;;; Classes
(defclass cg-patience-game (cg-game)
((mode :initform 'build :documentation "Play mode: build (waste) or sum13.")
(wrap :initform nil :documentation "Whether Ace-King wrap in build mode.")
(vname :initform "Patience"))
"Abstract base for the pile solitaires."
:abstract t)
(defclass cg-golf-game (cg-patience-game)
((mode :initform 'build) (wrap :initform nil) (vname :initform "Golf")))
(defclass cg-tripeaks-game (cg-patience-game)
((mode :initform 'build) (wrap :initform t) (vname :initform "TriPeaks")))
(defclass cg-pyramid-game (cg-patience-game)
((mode :initform 'sum13) (vname :initform "Pyramid")))
;;;; Layouts -- return (CARDS-VECTOR COVER-VECTOR ROWS), ROWS for display.
(cl-defgeneric cg-pat--layout (game deck)
"Build GAME's board from DECK; return (CARDS COVER ROWS STOCK WASTE).")
(cl-defmethod cg-pat--layout ((_ cg-golf-game) deck)
(let ((cards (make-vector 35 nil)) (cover (make-vector 35 nil)) (rows nil))
(dotimes (c 7) (dotimes (r 5)
(let ((i (+ (* c 5) r)))
(aset cards i (pop deck))
(when (< r 4) (aset cover i (list (+ i 1)))))))
(dotimes (r 5) (push (cl-loop for c below 7 collect (+ (* c 5) r)) rows))
(let ((waste (list (pop deck))))
(list cards cover (nreverse rows) deck waste))))
(cl-defmethod cg-pat--layout ((_ cg-tripeaks-game) deck)
(let ((cards (make-vector 28 nil))
(cover (vector '(3 4) '(5 6) '(7 8)
'(9 10) '(10 11) '(12 13) '(13 14) '(15 16) '(16 17)
'(18 19) '(19 20) '(20 21) '(21 22) '(22 23) '(23 24)
'(24 25) '(25 26) '(26 27)
nil nil nil nil nil nil nil nil nil nil))
(rows (list '(0 1 2) '(3 4 5 6 7 8)
'(9 10 11 12 13 14 15 16 17)
'(18 19 20 21 22 23 24 25 26 27))))
(dotimes (i 28) (aset cards i (pop deck)))
(let ((waste (list (pop deck))))
(list cards cover rows deck waste))))
(cl-defmethod cg-pat--layout ((_ cg-pyramid-game) deck)
(let ((cards (make-vector 28 nil)) (cover (make-vector 28 nil)) (rows nil))
(dotimes (r 7)
(let ((start (/ (* r (1+ r)) 2)) (row nil))
(dotimes (i (1+ r))
(let ((idx (+ start i)))
(aset cards idx (pop deck))
(push idx row)
(when (< r 6)
(let ((below (/ (* (1+ r) (+ r 2)) 2)))
(aset cover idx (list (+ below i) (+ below i 1)))))))
(push (nreverse row) rows)))
(list cards cover (nreverse rows) deck nil)))
;;;; Engine
(cl-defmethod cg-pat--deal ((game cg-patience-game))
"Deal a fresh board into GAME."
(random t)
(cl-destructuring-bind (cards cover rows stock waste) (cg-pat--layout game (cg-pat--deck))
(cg-put game :cards cards)
(cg-put game :cover cover)
(cg-put game :rows rows)
(cg-put game :stock stock)
(cg-put game :waste waste)
(cg-put game :marks nil)
(cg-put game :cursor 0)
(cg-put game :moves 0)
(cg-put game :history nil)
(cg-put game :message
(if (eq (oref game mode) 'sum13)
"Remove pairs summing to 13; Kings go alone. RET marks, stock deals."
"Move a card one rank from the waste top. RET plays; stock deals."))
game))
(defun cg-pat--exposed-p (game i)
"Return non-nil when board slot I is present and uncovered."
(let ((cards (cg-get game :cards)))
(and (aref cards i)
(cl-every (lambda (j) (null (aref cards j))) (aref (cg-get game :cover) i)))))
(defun cg-pat--exposed (game)
"Return the list of exposed board slot indices."
(cl-loop for i below (length (cg-get game :cards))
when (cg-pat--exposed-p game i) collect i))
(defun cg-pat--spots (game)
"Return the ordered spots the cursor can visit."
(append (mapcar (lambda (i) (cons 'slot i)) (cg-pat--exposed game))
'((waste . 0) (stock . 0))))
(defun cg-pat--waste-top (game) (car (last (cg-get game :waste))))
(defun cg-pat--board-empty-p (game)
"Return non-nil when every board slot has been cleared."
(cl-every #'null (append (cg-get game :cards) nil)))
(cl-defmethod cg-won-p ((game cg-patience-game))
"Return non-nil when the board has been cleared."
(cg-pat--board-empty-p game))
(defun cg-pat--adjacent (a b wrap)
"Return non-nil when ranks A and B differ by one (or wrap Ace-King)."
(let ((d (abs (- a b)))) (or (= d 1) (and wrap (= d 12)))))
(defun cg-pat--snapshot (game)
"Record an undo snapshot of GAME."
(cg-put game :history
(cons (list (copy-sequence (cg-get game :cards))
(copy-sequence (cg-get game :stock))
(copy-sequence (cg-get game :waste))
(cg-get game :moves))
(cg-get game :history))))
(defun cg-pat--restore (game)
"Undo the last move of GAME, if any."
(let ((h (cg-get game :history)))
(when h
(cl-destructuring-bind (cards stock waste moves) (car h)
(cg-put game :cards cards) (cg-put game :stock stock)
(cg-put game :waste waste) (cg-put game :moves moves))
(cg-put game :history (cdr h))
(cg-put game :marks nil)
t)))
(defun cg-pat--deal-stock (game)
"Turn one card from the stock to the waste."
(let ((stock (cg-get game :stock)))
(if (null stock)
(cg-put game :message "The stock is empty.")
(cg-pat--snapshot game)
(cg-put game :waste (append (cg-get game :waste) (last stock 1)))
(cg-put game :stock (butlast stock 1))
(cg-put game :marks nil)
(cg-put game :message "Dealt a card."))))
(defun cg-pat--value (card) "Sum-of-13 value of CARD." (1+ (cdr card)))
(defun cg-pat--remove-slot (game i)
"Clear board slot I."
(aset (cg-get game :cards) i nil))
;;;; Interaction
(defvar-local cg-pat--game nil "The pile-solitaire game in the current buffer.")
(defun cg-pat--cur-spot (game)
(let ((spots (cg-pat--spots game)))
(nth (min (cg-get game :cursor) (1- (length spots))) spots)))
(defun cg-pat-act ()
"Play the spot under the cursor (build move, sum-13 mark, or deal)."
(interactive)
(let* ((game cg-pat--game) (spot (cg-pat--cur-spot game)))
(pcase (car spot)
('stock (cg-pat--deal-stock game))
('waste (when (eq (oref game mode) 'sum13) (cg-pat--toggle-mark game (cons 'waste 0))))
('slot
(let* ((i (cdr spot)) (card (aref (cg-get game :cards) i)))
(if (eq (oref game mode) 'build)
(let ((top (cg-pat--waste-top game)))
(if (and top (cg-pat--adjacent (cdr card) (cdr top) (oref game wrap)))
(progn (cg-pat--snapshot game)
(cg-put game :waste (append (cg-get game :waste) (list card)))
(cg-pat--remove-slot game i)
(cg-put game :moves (1+ (cg-get game :moves)))
(cg-put game :message "Played."))
(cg-put game :message "That card is not adjacent to the waste top.")))
;; sum13
(if (= 13 (cg-pat--value card))
(progn (cg-pat--snapshot game) (cg-pat--remove-slot game i)
(cg-put game :moves (1+ (cg-get game :moves)))
(cg-put game :marks nil)
(cg-put game :message "King removed."))
(cg-pat--toggle-mark game (cons 'slot i)))))))
(cg-pat--after game)))
(defun cg-pat--mark-value (game m)
"Return the card value of mark M (a slot or the waste)."
(pcase (car m)
('slot (cg-pat--value (aref (cg-get game :cards) (cdr m))))
('waste (let ((w (cg-pat--waste-top game))) (and w (cg-pat--value w))))))
(defun cg-pat--toggle-mark (game m)
"Toggle mark M; when two marks sum to 13, remove both."
(if (member m (cg-get game :marks))
(cg-put game :marks (remove m (cg-get game :marks)))
(cg-put game :marks (cons m (cg-get game :marks))))
(let ((marks (cg-get game :marks)))
(when (= 2 (length marks))
(if (= 13 (+ (cg-pat--mark-value game (nth 0 marks))
(cg-pat--mark-value game (nth 1 marks))))
(progn (cg-pat--snapshot game)
(dolist (mm marks)
(pcase (car mm)
('slot (cg-pat--remove-slot game (cdr mm)))
('waste (cg-put game :waste (butlast (cg-get game :waste) 1)))))
(cg-put game :moves (1+ (cg-get game :moves)))
(cg-put game :marks nil)
(cg-put game :message "Pair removed."))
(cg-put game :marks nil)
(cg-put game :message "Those do not sum to 13.")))))
(defun cg-pat--after (game)
"Redisplay GAME and announce a win."
(cg-pat--redisplay)
(when (cg-won-p game)
(cg-put game :message "Board cleared -- you won! Press n for a new game.")
(cg-pat--redisplay)
(message "Solved!")))
(defun cg-pat--move (delta)
(let* ((game cg-pat--game) (n (length (cg-pat--spots game))))
(cg-put game :cursor (mod (+ (cg-get game :cursor) delta) n))
(cg-pat--redisplay)))
(defun cg-pat-left () "Cursor left." (interactive) (cg-pat--move -1))
(defun cg-pat-right () "Cursor right." (interactive) (cg-pat--move 1))
(defun cg-pat-undo () "Undo." (interactive)
(let ((game cg-pat--game))
(cg-put game :message (if (cg-pat--restore game) "Undid a move." "Nothing to undo."))
(cg-pat--redisplay)))
(defun cg-pat-new () "New deal." (interactive)
(cg-pat--deal cg-pat--game) (cg-pat--redisplay))
(defun cg-pat-redraw () "Redraw." (interactive) (cg-pat--redisplay))
(defun cg-pat-help () "Controls." (interactive)
(message "Arrows: move RET: play/mark/deal u: undo n: new g: redraw"))
;;;; Rendering
(defun cg-pat--render-card (card &optional exposed marked cursor)
(let ((s (cg-pat-card-string card)) (faces nil))
(when (cg-pat-red-p card) (push 'cg-red-suit faces))
(when (and card (not exposed)) (push 'cg-gap faces))
(when marked (push 'cg-hint faces))
(when cursor (push 'cg-cursor faces))
(propertize (format "%4s" s) 'face (or faces 'default))))
(cl-defmethod cg-render ((game cg-patience-game))
"Return a propertized string depicting GAME for a text display."
(let* ((cur (cg-pat--cur-spot game)) (marks (cg-get game :marks)) (out (list)))
(push (format " %s Moves: %d\n\n" (oref game vname) (cg-get game :moves)) out)
(dolist (row (cg-get game :rows))
(push " " out)
(dolist (i row)
(let* ((card (aref (cg-get game :cards) i))
(exp (cg-pat--exposed-p game i))
(mk (member (cons 'slot i) marks))
(cz (equal cur (cons 'slot i))))
(push (if card (cg-pat--render-card card exp mk cz) " ") out)))
(push "\n" out))
(push (format "\n Waste: %s Stock: %d\n"
(let ((w (cg-pat--waste-top game)))
(cg-pat--render-card w t (member '(waste . 0) marks)
(equal cur '(waste . 0))))
(length (cg-get game :stock)))
out)
(push (format " %s\n" (if (equal cur '(stock . 0))
(propertize "[stock]" 'face 'cg-cursor) "")) out)
(push (format "\n %s\n" (cg-get game :message)) out)
(apply #'concat (nreverse out))))
(defun cg-pat--redisplay ()
(let ((game cg-pat--game) (inhibit-read-only t))
(setq-local mode-line-process (format " [%s]" (if (cg-won-p game) "solved" "playing")))
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
;;;; Mode and commands
(defvar cg-pat-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "<left>") #'cg-pat-left)
(define-key map (kbd "<right>") #'cg-pat-right)
(define-key map (kbd "<up>") #'cg-pat-left)
(define-key map (kbd "<down>") #'cg-pat-right)
(define-key map (kbd "RET") #'cg-pat-act)
(define-key map (kbd "SPC") #'cg-pat-act)
(define-key map "u" #'cg-pat-undo)
(define-key map "n" #'cg-pat-new)
(define-key map "g" #'cg-pat-redraw)
(define-key map "?" #'cg-pat-help)
map)
"Keymap for `cg-pat-mode'.")
(define-derived-mode cg-pat-mode special-mode "Patience"
"Major mode for the pile solitaires."
(setq-local truncate-lines t))
(defun cg-pat--play (class)
(let* ((game (cg-pat--deal (make-instance class)))
(buf (get-buffer-create (format "*%s*" (oref game vname)))))
(with-current-buffer buf
(cg-pat-mode) (setq cg-pat--game game) (cg-pat--redisplay))
(switch-to-buffer buf)))
;;;###autoload
(defun cg-golf () "Play Golf solitaire." (interactive) (cg-pat--play 'cg-golf-game))
;;;###autoload
(defun cg-tripeaks () "Play TriPeaks solitaire." (interactive) (cg-pat--play 'cg-tripeaks-game))
;;;###autoload
(defun cg-pyramid () "Play Pyramid solitaire." (interactive) (cg-pat--play 'cg-pyramid-game))
(provide 'cg-patience)
;;; cg-patience.el ends here

378
cg-president.el Normal file
View file

@ -0,0 +1,378 @@
;;; cg-president.el --- President (Scum), a climbing card game -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Corwin Brust
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; President (also Scum, Asshole, Daihinmin): a climbing/shedding game.
;; The leader plays one to four cards of a single rank; each player in turn
;; must beat it with the same number of a higher rank or pass. Once all but
;; one have passed, the pile clears and the last player to play leads again.
;; The first player out is President, the last is Scum; on the next deal the
;; Scum hands the President their two best cards and gets two junk cards back.
;;
;; You are the South player (seat 0); the rest are simple AI. Card power
;; runs 3 (low) .. K, A, then the Two (highest). Cards are the package
;; cons (SUIT . RANK) with RANK 0 (the Two) .. 12 (the Ace).
;;; Code:
(require 'cl-lib)
(require 'eieio)
(require 'cg-core)
(defconst cg-pres-ranks
["2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K" "A"]
"Rank labels indexed 0 (Two) .. 12 (Ace).")
(defconst cg-pres-titles ["President" "Vice-President" "Citizen"
"Vice-Scum" "Scum"]
"Finishing titles from first out to last.")
(defcustom cg-president-players 4
"Number of players in President, including you (3-6)."
:type 'integer :group 'card-games)
(defun cg-pres--power (rank)
"Return the climbing power of RANK; the Two (RANK 0) is highest."
(if (= rank 0) 13 rank))
(defun cg-pres-card-string (card)
(if (null card) "·"
(concat (aref cg-pres-ranks (cdr card)) (cg-suit-glyph (car card)))))
(defsubst cg-pres-red-p (card) (and card (cg-red-suit-p (car card))))
(defun cg-pres--deck ()
(cg-shuffle (cl-loop for s below 4 append
(cl-loop for r below 13 collect (cons s r)))))
(defun cg-pres--sort (cards)
"Sort CARDS by climbing power then suit."
(sort (copy-sequence cards)
(lambda (a b) (if (= (cg-pres--power (cdr a)) (cg-pres--power (cdr b)))
(< (car a) (car b))
(< (cg-pres--power (cdr a)) (cg-pres--power (cdr b)))))))
(defclass cg-president-game (cg-game)
((vname :initform "President"))
"A game of President (Scum).")
(defsubst cg-pres--hand (game s) (aref (cg-get game :hands) s))
(defsubst cg-pres--set-hand (game s v) (aset (cg-get game :hands) s v))
(defsubst cg-pres--name (_game s)
(if (= s 0) "You" (format "Player %d" s)))
;;;; Dealing and the inter-game exchange
(cl-defmethod cg-pres--deal ((game cg-president-game))
(let* ((n (max 3 (min 6 cg-president-players)))
(deck (cg-pres--deck))
(hands (make-vector n nil))
(s 0))
(while deck
(push (pop deck) (aref hands (mod s n)))
(cl-incf s))
(dotimes (i n) (aset hands i (cg-pres--sort (aref hands i))))
(cg-put game :hands hands)
(cg-put game :nplayers n)
(cg-pres--exchange game) ; carry out roles from the last deal
(cg-put game :count 0)
(cg-put game :top -1)
(cg-put game :passed (make-vector n nil))
(cg-put game :out nil)
(cg-put game :last-player nil)
(cg-put game :turn 0)
(cg-put game :phase 'play)
(cg-put game :cursor 0)
(unless (cg-get game :games) (cg-put game :games 0))
(cg-put game :message
"Lead any rank; others beat it with a higher one or pass. p passes.")
game))
(defun cg-pres--best (hand k) "The K highest-power cards of HAND." (last (cg-pres--sort hand) k))
(defun cg-pres--worst (hand k) "The K lowest-power cards of HAND." (cl-subseq (cg-pres--sort hand) 0 k))
(cl-defmethod cg-pres--exchange ((game cg-president-game))
"Trade cards by rank from the previous deal's finishing order, if any."
(let ((order (cg-get game :order)) (n (cg-get game :nplayers)))
(when (and order (= (length order) n) (>= n 4))
(let* ((prez (nth 0 order)) (scum (nth (1- n) order))
(vp (nth 1 order)) (vice (nth (- n 2) order)))
(cg-pres--give game scum prez 2) ; scum's 2 best -> president
(cg-pres--give game prez scum 2 t) ; president's 2 worst -> scum
(cg-pres--give game vice vp 1)
(cg-pres--give game vp vice 1 t)))))
(defun cg-pres--give (game from to k &optional worst)
"Move K cards (best, or WORST) from seat FROM to seat TO."
(let* ((cards (if worst (cg-pres--worst (cg-pres--hand game from) k)
(cg-pres--best (cg-pres--hand game from) k))))
(cg-pres--set-hand game from
(cl-set-difference (cg-pres--hand game from) cards :test #'equal))
(cg-pres--set-hand game to
(cg-pres--sort (append (cg-pres--hand game to) cards)))))
;;;; Move logic
(defun cg-pres--rank-counts (game s)
"Return an alist (RANK . COUNT) for seat S's hand."
(let ((tbl nil))
(dolist (c (cg-pres--hand game s))
(setf (alist-get (cdr c) tbl 0) (1+ (alist-get (cdr c) tbl 0))))
tbl))
(defun cg-pres--legal-ranks (game s)
"Return the ranks seat S may legally play now."
(let ((cnt (cg-get game :count)) (top (cg-get game :top)))
(cl-loop for (r . c) in (cg-pres--rank-counts game s)
when (if (= cnt 0) t (and (>= c cnt) (> (cg-pres--power r) top)))
collect r)))
(defun cg-pres--remove-n (hand rank n)
"Remove N cards of RANK from HAND."
(let ((out nil) (left n))
(dolist (c hand) (if (and (> left 0) (= (cdr c) rank))
(cl-decf left) (push c out)))
(nreverse out)))
(defun cg-pres--in-game (game)
"Seats that still hold cards."
(cl-loop for s below (cg-get game :nplayers)
unless (memq s (cg-get game :out)) collect s))
(defun cg-pres--round-active (game)
"Seats that can still act on the current pile."
(cl-loop for s below (cg-get game :nplayers)
unless (or (memq s (cg-get game :out)) (aref (cg-get game :passed) s))
collect s))
(defun cg-pres--next (game from)
"Next seat after FROM that is still in the round."
(let ((n (cg-get game :nplayers)) (s from) (res nil))
(dotimes (_ n)
(setq s (mod (1+ s) n))
(when (and (not res)
(not (memq s (cg-get game :out)))
(not (aref (cg-get game :passed) s)))
(setq res s)))
(or res from)))
(defun cg-pres--clear (game)
"Clear the pile; the last player to play leads (or the next active seat)."
(cg-put game :count 0) (cg-put game :top -1)
(cg-put game :passed (make-vector (cg-get game :nplayers) nil))
(let ((last (cg-get game :last-player)))
(cg-put game :turn (if (and last (not (memq last (cg-get game :out)))) last
(cg-pres--next game (or last 0)))))
(cg-put game :message "Pile cleared."))
(defun cg-pres--check-finish (game)
"End the game when only one player still holds cards (the Scum)."
(let ((in (cg-pres--in-game game)))
(when (<= (length in) 1)
(when in (cg-put game :out (append (cg-get game :out) in)))
(cg-put game :order (cg-get game :out))
(cg-put game :games (1+ (or (cg-get game :games) 0)))
(cg-put game :phase 'game-over)
(cg-put game :message (cg-pres--result game))
t)))
(defun cg-pres--advance (game)
"Decide the next turn or clear the pile after a move."
(unless (cg-pres--check-finish game)
(let* ((active (cg-pres--round-active game))
(last (cg-get game :last-player))
(others (and last (cl-remove last active))))
(if (and (> (cg-get game :count) 0) (null others))
(cg-pres--clear game)
(cg-put game :turn (cg-pres--next game (cg-get game :turn)))))))
(defun cg-pres--play (game seat rank n)
"Seat SEAT plays N cards of RANK."
(cg-pres--set-hand game seat (cg-pres--remove-n (cg-pres--hand game seat) rank n))
(cg-put game :count n) (cg-put game :top (cg-pres--power rank))
(cg-put game :last-player seat)
(when (null (cg-pres--hand game seat))
(cg-put game :out (append (cg-get game :out) (list seat))))
(cg-put game :message (format "%s plays %d × %s" (cg-pres--name game seat)
n (aref cg-pres-ranks rank)))
(cg-pres--advance game))
(defun cg-pres--pass (game seat)
"Seat SEAT passes for the current pile."
(aset (cg-get game :passed) seat t)
(cg-put game :message (format "%s passes." (cg-pres--name game seat)))
(cg-pres--advance game))
(defun cg-pres--ai-move (game seat)
"Make seat SEAT's move: lead low, beat low, or pass."
(let* ((cnt (cg-get game :count)) (top (cg-get game :top))
(counts (cg-pres--rank-counts game seat)))
(if (= cnt 0)
(let ((r (caar (cl-sort counts #'< :key (lambda (x) (cg-pres--power (car x)))))))
(cg-pres--play game seat r 1))
(let ((cand (cl-loop for (r . c) in counts
when (and (>= c cnt) (> (cg-pres--power r) top)) collect r)))
(if cand
(cg-pres--play game seat
(car (cl-sort cand #'< :key #'cg-pres--power)) cnt)
(cg-pres--pass game seat))))))
(defun cg-pres--result (game)
"Return a finishing summary string."
(let* ((order (cg-get game :order)) (n (length order)) (parts nil))
(dotimes (i n)
(let ((title (cond ((= i 0) "President") ((= i (1- n)) "Scum")
((= i 1) "Vice-President") ((= i (- n 2)) "Vice-Scum")
(t "Citizen"))))
(push (format "%s: %s" title (cg-pres--name game (nth i order))) parts)))
(concat "Game over -- " (mapconcat #'identity (nreverse parts) ", ")
". Press n for the next deal.")))
;;;; UI
(defvar-local cg-pres--game nil "The President game in the current buffer.")
(defun cg-pres--run (game)
"Advance AI seats until it is the human's turn or the game ends."
(while (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0))
(cg-pres--ai-move game (cg-get game :turn))))
(defun cg-pres--hand-ranks (game)
"Distinct ranks in seat 0's hand, ordered by power."
(let ((rs (delete-dups (mapcar #'cdr (cg-pres--hand game 0)))))
(cl-sort rs #'< :key #'cg-pres--power)))
(defun cg-pres-act (&optional count)
"Play the selected rank. With prefix COUNT, lead that many of it."
(interactive "P")
(let* ((game cg-pres--game)
(ranks (cg-pres--hand-ranks game)))
(cond
((not (eq (cg-get game :phase) 'play)) (cg-put game :message "Press n for a new deal."))
((/= (cg-get game :turn) 0) (cg-put game :message "Not your turn."))
((null ranks) (cg-put game :message "You are out."))
(t (let* ((rank (nth (min (cg-get game :cursor) (1- (length ranks))) ranks))
(have (cl-count rank (mapcar #'cdr (cg-pres--hand game 0))))
(need (cg-get game :count)))
(if (= need 0)
(let ((n (min have (max 1 (prefix-numeric-value (or count 1))))))
(cg-pres--play game 0 rank n)
(cg-put game :cursor 0)
(cg-pres--run game))
(if (and (>= have need) (> (cg-pres--power rank) (cg-get game :top)))
(progn (cg-pres--play game 0 rank need)
(cg-put game :cursor 0)
(cg-pres--run game))
(cg-put game :message
(format "Need %d of a rank higher than the pile." need)))))))
(cg-pres--redisplay)))
(defun cg-pres-pass ()
"Pass for the current pile."
(interactive)
(let ((game cg-pres--game))
(cond
((/= (cg-get game :turn) 0) (cg-put game :message "Not your turn."))
((= (cg-get game :count) 0) (cg-put game :message "You lead -- you must play."))
(t (cg-pres--pass game 0) (cg-pres--run game)))
(cg-pres--redisplay)))
(defun cg-pres-left () "Cursor left." (interactive)
(let* ((g cg-pres--game) (n (length (cg-pres--hand-ranks g))))
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n))) (cg-pres--redisplay)))
(defun cg-pres-right () "Cursor right." (interactive)
(let* ((g cg-pres--game) (n (length (cg-pres--hand-ranks g))))
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n))) (cg-pres--redisplay)))
(defun cg-pres-new () "New deal." (interactive)
(cg-pres--deal cg-pres--game) (cg-pres--run cg-pres--game) (cg-pres--redisplay))
(defun cg-pres-redraw () "Redraw." (interactive) (cg-pres--redisplay))
(defun cg-pres-help () "Controls." (interactive)
(message "Arrows: choose rank RET: play (C-u N to lead N) p: pass n: new g: redraw"))
(cl-defmethod cg-render ((game cg-president-game))
"Return a propertized string depicting GAME for a text display."
(let* ((out (list)) (ranks (cg-pres--hand-ranks game))
(cur (cg-get game :cursor)))
(push (format " President\n\n") out)
(dotimes (s (cg-get game :nplayers))
(unless (= s 0)
(push (format " Player %d: %d cards%s\n" s (length (cg-pres--hand game s))
(if (memq s (cg-get game :out)) " (out)" "")) out)))
(push (format "\n Pile: %s\n\n"
(if (> (cg-get game :count) 0)
(format "%d × power-%d (last: %s)"
(cg-get game :count) (cg-get game :top)
(cg-pres--name game (cg-get game :last-player)))
"empty -- your lead"))
out)
(push " Your hand (by rank):\n " out)
(let ((i 0))
(dolist (r ranks)
(let* ((cnt (cl-count r (mapcar #'cdr (cg-pres--hand game 0))))
(str (format "%s×%d" (aref cg-pres-ranks r) cnt))
(faces nil))
(when (= i cur) (push 'cg-cursor faces))
(push (propertize (format "%6s" str) 'face (or faces 'default)) out))
(cl-incf i)))
(push (format "\n\n %s\n" (cg-get game :message)) out)
(apply #'concat (nreverse out))))
(defun cg-pres--redisplay ()
(let ((game cg-pres--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))))
(defvar cg-pres-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "<left>") #'cg-pres-left)
(define-key map (kbd "<right>") #'cg-pres-right)
(define-key map (kbd "RET") #'cg-pres-act)
(define-key map (kbd "SPC") #'cg-pres-act)
(define-key map "p" #'cg-pres-pass)
(define-key map "n" #'cg-pres-new)
(define-key map "g" #'cg-pres-redraw)
(define-key map "?" #'cg-pres-help)
map)
"Keymap for `cg-pres-mode'.")
(define-derived-mode cg-pres-mode special-mode "President"
"Major mode for President."
(setq-local truncate-lines t))
;;;###autoload
(defun cg-president ()
"Play President (Scum) against the computer."
(interactive)
(let ((buf (get-buffer-create "*President*")))
(with-current-buffer buf
(cg-pres-mode)
(setq cg-pres--game (cg-president-game))
(cg-pres--deal cg-pres--game)
(cg-pres--run cg-pres--game)
(cg-pres--redisplay))
(switch-to-buffer buf)))
(provide 'cg-president)
;;; cg-president.el ends here

2
cg-render.el
View file

@ -4,7 +4,7 @@
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.50
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el

844
cg-solitaire.el Normal file
View file

@ -0,0 +1,844 @@
;;; cg-solitaire.el --- Tableau solitaires (Klondike, FreeCell, Spider, Yukon) -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Corwin Brust
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; A shared engine for tableau solitaires, with four games built on it:
;;
;; `cg-klondike' -- the classic "Solitaire": seven columns, a stock and
;; waste, build the foundations up by suit from the Ace.
;; `cg-freecell' -- all cards dealt face up, four free cells, no stock;
;; a game of nearly pure skill.
;; `cg-spider' -- two decks, ten columns; build down regardless of suit
;; but only same-suit runs move; clear eight K..A runs.
;; `cg-yukon' -- Klondike's layout, all face up, move any buried group.
;;
;; Cards are the package-standard cons (SUIT . RANK) with SUIT 0 spades,
;; 1 clubs, 2 diamonds, 3 hearts and RANK 0 Ace .. 12 King. Each tableau
;; column is a list ordered bottom (screen top) to top (the accessible
;; card); a per-column face-down count tracks the hidden prefix.
;;
;; Play is by keyboard: move the cursor between piles with the arrow keys
;; and press RET to pick up the movable run from a pile, then RET again on
;; a destination to drop it. `f' sends a card to a foundation, `a' auto-
;; plays everything it can, and the stock pile deals or recycles on RET.
;;; Code:
(require 'cl-lib)
(require 'eieio)
(require 'cg-core)
;;;; Cards
(defconst cg-sol-ranks
["A" "2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K"]
"Rank labels indexed 0..12 (Ace through King).")
(defun cg-sol-card-string (card &optional down)
"Return a short string for CARD.
With DOWN non-nil, draw a face-down back instead. A nil CARD draws an
empty-slot dot."
(cond (down "##")
((null card) "·")
(t (concat (aref cg-sol-ranks (cdr card)) (cg-suit-glyph (car card))))))
(defsubst cg-sol-red-p (card)
"Return non-nil when CARD is a red suit."
(and card (cg-red-suit-p (car card))))
(defun cg-sol--make-deck (ndecks)
"Return a shuffled list of NDECKS standard 52-card decks."
(random t)
(let ((cards nil))
(dotimes (_ ndecks)
(dotimes (s 4)
(dotimes (r 13)
(push (cons s r) cards))))
(cg-shuffle cards)))
;;;; Game classes
(defclass cg-solitaire-game (cg-game)
((ncols :initform 7 :documentation "Number of tableau columns.")
(ndecks :initform 1 :documentation "Number of 52-card decks used.")
(nfound :initform 4 :documentation "Number of foundation piles.")
(nfree :initform 0 :documentation "Number of free cells.")
(has-stock :initform nil :documentation "Whether a stock pile exists.")
(has-waste :initform nil :documentation "Whether a waste pile exists.")
(build :initform 'alt :documentation "Tableau placement rule: alt, suit, any.")
(run-rule :initform 'alt :documentation "Movable-run cohesion: alt, suit, any.")
(empty-rule :initform 'king :documentation "Empty-column rule: king or any.")
(redeal :initform t :documentation "Whether an empty stock recycles the waste.")
(draw :initform 1 :documentation "Cards turned from the stock to the waste.")
(target-sets :initform 8 :documentation "Completed runs to win when NFOUND is 0.")
(base :initform 0 :documentation "Foundation base rank (0 = Ace).")
(wrap :initform nil :documentation "Whether foundations wrap King to Ace.")
(has-reserve :initform nil :documentation "Whether a reserve pile exists (Canfield).")
(vname :initform "Solitaire" :documentation "Display name."))
"Abstract base for tableau solitaires."
:abstract t)
(defclass cg-klondike-game (cg-solitaire-game)
((has-stock :initform t) (has-waste :initform t)
(vname :initform "Klondike"))
"Klondike: seven columns, stock and waste, foundations up by suit.")
(defclass cg-freecell-game (cg-solitaire-game)
((ncols :initform 8) (nfree :initform 4) (empty-rule :initform 'any)
(vname :initform "FreeCell"))
"FreeCell: eight columns dealt face up, four free cells, no stock.")
(defclass cg-yukon-game (cg-solitaire-game)
((run-rule :initform 'any) (vname :initform "Yukon"))
"Yukon: Klondike layout dealt mostly face up; move any buried group.")
(defclass cg-spider-game (cg-solitaire-game)
((ncols :initform 10) (ndecks :initform 2) (nfound :initform 0)
(has-stock :initform t) (build :initform 'any) (run-rule :initform 'suit)
(empty-rule :initform 'any) (vname :initform "Spider"))
"Spider: two decks, ten columns; clear eight K..A same-suit runs.")
;;;; Rules (predicates)
(defun cg-sol--diff-color-p (a b)
"Return non-nil when cards A and B are of opposite colours."
(not (eq (cg-red-suit-p (car a)) (cg-red-suit-p (car b)))))
(cl-defmethod cg-sol--link-p ((game cg-solitaire-game) upper lower)
"Return non-nil when LOWER may rest directly on UPPER within a run."
(pcase (oref game run-rule)
('any t)
('suit (and (= (cdr lower) (1- (cdr upper))) (= (car lower) (car upper))))
(_ (and (= (cdr lower) (1- (cdr upper))) (cg-sol--diff-color-p upper lower)))))
(cl-defmethod cg-sol--place-p ((game cg-solitaire-game) top card)
"Return non-nil when CARD may be placed on a column whose top is TOP."
(pcase (oref game build)
('any (= (cdr card) (1- (cdr top))))
('suit (and (= (cdr card) (1- (cdr top))) (= (car card) (car top))))
(_ (and (= (cdr card) (1- (cdr top))) (cg-sol--diff-color-p top card)))))
(cl-defmethod cg-sol--empty-accepts ((game cg-solitaire-game) card)
"Return non-nil when CARD may be placed on an empty column."
(pcase (oref game empty-rule)
('king (= (cdr card) 12))
(_ t)))
;;;; Layout and dealing
(cl-defgeneric cg-sol--layout (game)
"Return a list of (DOWN . UP) card counts, one per tableau column.")
(cl-defmethod cg-sol--layout ((_ cg-klondike-game))
(cl-loop for i below 7 collect (cons i 1)))
(cl-defmethod cg-sol--layout ((_ cg-yukon-game))
(cons (cons 0 1) (cl-loop for i from 1 below 7 collect (cons i 5))))
(cl-defmethod cg-sol--layout ((_ cg-freecell-game))
(append (make-list 4 (cons 0 7)) (make-list 4 (cons 0 6))))
(cl-defmethod cg-sol--layout ((_ cg-spider-game))
(append (make-list 4 (cons 5 1)) (make-list 6 (cons 4 1))))
(cl-defmethod cg-sol--deal ((game cg-solitaire-game))
"Deal a fresh layout into GAME and initialise its environment."
(let* ((deck (cg-sol--make-deck (oref game ndecks)))
(nc (oref game ncols))
(layout (cg-sol--layout game))
(tableau (make-vector nc nil))
(down (make-vector nc 0)))
(dotimes (c nc)
(let* ((spec (nth c layout))
(col nil))
(dotimes (_ (+ (car spec) (cdr spec)))
(push (pop deck) col))
(aset tableau c (nreverse col))
(aset down c (car spec))))
(cg-put game :tableau tableau)
(cg-put game :down down)
(cg-put game :found (make-vector (oref game nfound) nil))
(cg-put game :free (make-vector (oref game nfree) nil))
(cg-put game :stock deck)
(cg-put game :waste nil)
(cg-put game :sets 0)
(cg-put game :moves 0)
(cg-put game :cursor 0)
(cg-put game :sel nil)
(cg-put game :sel-n 0)
(cg-put game :history nil)
(cg-put game :message
(format "%s. Arrows move; RET picks up/drops; f=foundation; a=auto; ?=help."
(oref game vname)))
game))
;;;; Spots (the cursor visits piles)
(cl-defmethod cg-sol--spots ((game cg-solitaire-game))
"Return the ordered list of (TYPE . INDEX) piles the cursor can visit."
(append
(when (oref game has-stock) '((stock . 0)))
(when (oref game has-waste) '((waste . 0)))
(when (oref game has-reserve) '((reserve . 0)))
(cl-loop for i below (oref game nfree) collect (cons 'free i))
(cl-loop for i below (oref game nfound) collect (cons 'found i))
(cl-loop for i below (oref game ncols) collect (cons 'col i))))
(defun cg-sol--cur-spot (game)
"Return the (TYPE . INDEX) spot currently under the cursor."
(nth (cg-get game :cursor) (cg-sol--spots game)))
;;;; Pile access helpers
(defun cg-sol--col (game c) "Column C of GAME (a list)." (aref (cg-get game :tableau) c))
(defun cg-sol--set-col (game c v) (aset (cg-get game :tableau) c v))
(defun cg-sol--down (game c) "Face-down count of column C." (aref (cg-get game :down) c))
(defun cg-sol--set-down (game c v) (aset (cg-get game :down) c v))
(defun cg-sol--col-top (game c)
"Return the top (accessible) card of column C, or nil."
(car (last (cg-sol--col game c))))
(defun cg-sol--exposed (game c)
"Return the face-up cards of column C (bottom..top order)."
(nthcdr (cg-sol--down game c) (cg-sol--col game c)))
(cl-defmethod cg-sol--top-run ((game cg-solitaire-game) c)
"Return the longest movable run from the top of column C (bottom..top)."
(let ((top->bottom (reverse (cg-sol--exposed game c))))
(if (null top->bottom)
nil
(let ((run (list (car top->bottom)))
(prev (car top->bottom)))
(catch 'done
(dolist (card (cdr top->bottom))
(if (cg-sol--link-p game card prev)
(progn (push card run) (setq prev card))
(throw 'done nil))))
run))))
(defun cg-sol--spot-top (game spot)
"Return the top card available at SPOT, or nil."
(pcase (car spot)
('col (cg-sol--col-top game (cdr spot)))
('waste (car (last (cg-get game :waste))))
('free (aref (cg-get game :free) (cdr spot)))
('found (car (last (aref (cg-get game :found) (cdr spot)))))
('reserve (car (last (cg-get game :reserve))))
(_ nil)))
;;;; Foundations
(defun cg-sol--found-accepts (game i card)
"Return non-nil when CARD may go onto foundation I of GAME."
(and card
(let ((f (aref (cg-get game :found) i)))
(if (null f)
(= (cdr card) (oref game base)) ; empty foundation takes the base rank
(let* ((top (car (last f)))
(need (if (oref game wrap) (mod (1+ (cdr top)) 13) (1+ (cdr top)))))
(and (= (car card) (car top))
(= (cdr card) need)))))))
(defun cg-sol--found-for (game card)
"Return the index of a foundation that would accept CARD, or nil."
(cl-loop for i below (oref game nfound)
when (cg-sol--found-accepts game i card) return i))
;;;; Move primitives
(defun cg-sol--snapshot (game)
"Push a deep-ish copy of GAME's mutable state onto the undo history."
(let ((tab (cg-get game :tableau))
(frv (cg-get game :found))
(fre (cg-get game :free)))
(cg-put game :history
(cons (list (vconcat (mapcar #'copy-sequence tab))
(copy-sequence (cg-get game :down))
(vconcat (mapcar #'copy-sequence frv))
(copy-sequence fre)
(copy-sequence (cg-get game :stock))
(copy-sequence (cg-get game :waste))
(cg-get game :sets)
(cg-get game :moves)
(copy-sequence (cg-get game :reserve)))
(cg-get game :history)))))
(defun cg-sol--restore (game)
"Pop and restore the most recent undo snapshot of GAME, if any."
(let ((h (cg-get game :history)))
(when h
(cl-destructuring-bind (tab down frv fre stock waste sets moves reserve) (car h)
(cg-put game :tableau tab)
(cg-put game :down down)
(cg-put game :found frv)
(cg-put game :free fre)
(cg-put game :stock stock)
(cg-put game :waste waste)
(cg-put game :sets sets)
(cg-put game :moves moves)
(cg-put game :reserve reserve))
(cg-put game :history (cdr h))
(cg-put game :sel nil)
t)))
(defun cg-sol--flip (game c)
"Flip the top of column C face up if it is face down."
(let ((len (length (cg-sol--col game c)))
(d (cg-sol--down game c)))
(when (and (> len 0) (>= d len))
(cg-sol--set-down game c (1- len)))))
(defun cg-sol--take (game spot n)
"Remove and return the top N cards (bottom..top order) from SPOT."
(pcase (car spot)
('col (let* ((c (cdr spot)) (col (cg-sol--col game c))
(run (last col n)))
(cg-sol--set-col game c (butlast col n))
(let ((len (length (cg-sol--col game c))))
(when (> (cg-sol--down game c) len)
(cg-sol--set-down game c len)))
(cg-sol--flip game c)
run))
('waste (let ((w (cg-get game :waste)))
(cg-put game :waste (butlast w 1)) (last w 1)))
('free (let ((card (aref (cg-get game :free) (cdr spot))))
(aset (cg-get game :free) (cdr spot) nil) (list card)))
('found (let* ((i (cdr spot)) (f (aref (cg-get game :found) i)))
(aset (cg-get game :found) i (butlast f 1)) (last f 1)))
('reserve (let ((r (cg-get game :reserve)))
(cg-put game :reserve (butlast r 1)) (last r 1)))
(_ nil)))
(defun cg-sol--can-drop (game spot cards)
"Return non-nil when the run CARDS (bottom..top) may drop on SPOT."
(and cards
(pcase (car spot)
('col (let* ((c (cdr spot)) (top (cg-sol--col-top game c)))
(if top
(cg-sol--place-p game top (car cards))
(cg-sol--empty-accepts game (car cards)))))
('found (and (= 1 (length cards))
(cg-sol--found-accepts game (cdr spot) (car cards))))
('free (and (= 1 (length cards))
(null (aref (cg-get game :free) (cdr spot)))))
(_ nil))))
(defun cg-sol--drop (game spot cards)
"Place the run CARDS (bottom..top) onto SPOT."
(pcase (car spot)
('col (let ((c (cdr spot)))
(cg-sol--set-col game c (append (cg-sol--col game c) cards))))
('found (let ((i (cdr spot)))
(aset (cg-get game :found) i
(append (aref (cg-get game :found) i) cards))))
('free (aset (cg-get game :free) (cdr spot) (car cards)))))
;;;; Spider: complete-run removal
(cl-defmethod cg-sol--harvest ((game cg-solitaire-game))
"Remove any complete K..A same-suit run from a column top; bump :sets.
Only games without foundations (NFOUND 0: Spider, Scorpion) harvest runs."
(when (= 0 (oref game nfound))
(dotimes (c (oref game ncols))
(let* ((col (cg-sol--col game c))
(exp (cg-sol--exposed game c)))
(when (>= (length exp) 13)
(let ((run (last exp 13)) (ok t) (suit (car (nth 0 (last exp 13)))))
(cl-loop for k below 13
for card = (nth k run)
unless (and (= (car card) suit) (= (cdr card) (- 12 k)))
do (setq ok nil))
(when ok
(cg-sol--set-col game c (butlast col 13))
(let ((len (length (cg-sol--col game c))))
(when (> (cg-sol--down game c) len) (cg-sol--set-down game c len)))
(cg-sol--flip game c)
(cg-put game :sets (1+ (cg-get game :sets))))))))))
;;;; Stock action
(defcustom cg-sol-klondike-draw 1
"Number of cards turned from the stock to the waste in Klondike."
:type '(choice (const :tag "Draw one" 1) (const :tag "Draw three" 3))
:group 'card-games)
(cl-defmethod cg-sol--stock-action ((game cg-solitaire-game))
"Deal `draw' cards to the waste, recycling the waste when `redeal'."
(if (not (oref game has-waste))
(cg-put game :message "No stock to deal.")
(cg-sol--snapshot game)
(let ((stock (cg-get game :stock)) (waste (cg-get game :waste)))
(if stock
(let ((n (min (oref game draw) (length stock))))
(dotimes (_ n)
(setq waste (append waste (last stock 1)))
(setq stock (butlast stock 1)))
(cg-put game :stock stock) (cg-put game :waste waste)
(cg-put game :message "Dealt from stock."))
(if (and (oref game redeal) waste)
(progn (cg-put game :stock (reverse waste)) (cg-put game :waste nil)
(cg-put game :message "Recycled the waste into the stock."))
(cg-put game :message "The stock is empty."))))))
(cl-defmethod cg-sol--stock-action ((game cg-klondike-game))
(cg-sol--snapshot game)
(let ((stock (cg-get game :stock)) (waste (cg-get game :waste)))
(if stock
(let ((n (min cg-sol-klondike-draw (length stock))))
(dotimes (_ n)
(setq waste (append waste (last stock 1)))
(setq stock (butlast stock 1)))
(cg-put game :stock stock) (cg-put game :waste waste)
(cg-put game :message "Dealt from stock."))
(if waste
(progn (cg-put game :stock (reverse waste)) (cg-put game :waste nil)
(cg-put game :message "Recycled the waste into the stock."))
(cg-put game :message "Stock and waste are both empty.")))))
(cl-defmethod cg-sol--stock-action ((game cg-spider-game))
(let ((stock (cg-get game :stock)))
(cond
((null stock) (cg-put game :message "The stock is empty."))
((cl-loop for c below (oref game ncols)
thereis (null (cg-sol--col game c)))
(cg-put game :message "Fill every column before dealing from the stock."))
(t (cg-sol--snapshot game)
(dotimes (c (oref game ncols))
(cg-sol--set-col game c (append (cg-sol--col game c) (last stock 1)))
(setq stock (butlast stock 1)))
(cg-put game :stock stock)
(cg-sol--harvest game)
(cg-put game :message "Dealt a row from the stock.")))))
;;;; Win
(cl-defmethod cg-won-p ((game cg-solitaire-game))
"Return non-nil when GAME is solved."
(if (= 0 (oref game nfound))
(>= (cg-get game :sets) (oref game target-sets))
(cl-every (lambda (f) (= 13 (length f)))
(append (cg-get game :found) nil))))
;;;; Interaction
(defvar-local cg-sol--game nil "The solitaire game in the current buffer.")
(cl-defmethod cg-sol--selectable ((game cg-solitaire-game) spot)
"Return the run (bottom..top) GAME would pick up from SPOT, or nil."
(pcase (car spot)
('col (cg-sol--top-run game (cdr spot)))
('waste (let ((c (cg-sol--spot-top game spot))) (and c (list c))))
('free (let ((c (cg-sol--spot-top game spot))) (and c (list c))))
('found (let ((c (cg-sol--spot-top game spot))) (and c (list c))))
('reserve (let ((c (cg-sol--spot-top game spot))) (and c (list c))))
(_ nil)))
(defun cg-sol-act (&optional count)
"Pick up from, or drop onto, the pile under the cursor.
With prefix COUNT, pick up exactly COUNT cards from a column."
(interactive "P")
(let* ((game cg-sol--game)
(spot (cg-sol--cur-spot game))
(sel (cg-get game :sel)))
(cond
((eq (car spot) 'stock)
(cg-put game :sel nil)
(cg-sol--stock-action game))
((null sel)
(let ((run (cg-sol--selectable game spot)))
(cond
((null run) (cg-put game :message "Nothing to pick up there."))
(t (when (and count (eq (car spot) 'col))
(setq run (last run (min (prefix-numeric-value count) (length run)))))
(cg-put game :sel spot)
(cg-put game :sel-n (length run))
(cg-put game :message
(format "Picked up %d card%s. RET on a destination."
(length run) (if (= 1 (length run)) "" "s")))))))
((equal sel spot)
(cg-put game :sel nil) (cg-put game :message "Cancelled."))
(t
(let* ((n (cg-get game :sel-n))
(cards (last (pcase (car sel)
('col (cg-sol--col game (cdr sel)))
('waste (cg-get game :waste))
('found (aref (cg-get game :found) (cdr sel)))
('free (list (aref (cg-get game :free) (cdr sel)))))
n)))
(if (cg-sol--can-drop game spot cards)
(progn (cg-sol--snapshot game)
(cg-sol--take game sel n)
(cg-sol--drop game spot cards)
(cg-put game :moves (1+ (cg-get game :moves)))
(cg-sol--harvest game)
(cg-put game :sel nil)
(cg-put game :message "Moved."))
(cg-put game :sel nil)
(cg-put game :message "That move is not allowed."))))))
(cg-sol--after cg-sol--game))
(defun cg-sol-to-foundation ()
"Send the top card of the pile under the cursor to a foundation."
(interactive)
(let* ((game cg-sol--game)
(spot (cg-sol--cur-spot game))
(card (cg-sol--spot-top game spot)))
(if (and card (memq (car spot) '(col waste free reserve)))
(let ((i (cg-sol--found-for game card)))
(if i
(progn (cg-sol--snapshot game)
(cg-sol--take game spot 1)
(cg-sol--drop game (cons 'found i) (list card))
(cg-put game :moves (1+ (cg-get game :moves)))
(cg-put game :sel nil)
(cg-put game :message "To the foundation."))
(cg-put game :message "No foundation will take that card.")))
(cg-put game :message "Nothing to send to a foundation.")))
(cg-sol--after cg-sol--game))
(defun cg-sol-auto ()
"Repeatedly send any eligible card to the foundations."
(interactive)
(let ((game cg-sol--game) (moved 0))
(when (> (oref game nfound) 0)
(cg-sol--snapshot game)
(let (again)
(cl-loop
do (setq again nil)
(dolist (spot (cg-sol--spots game))
(when (memq (car spot) '(col waste free reserve))
(let* ((card (cg-sol--spot-top game spot))
(i (and card (cg-sol--found-for game card))))
(when i
(cg-sol--take game spot 1)
(cg-sol--drop game (cons 'found i) (list card))
(setq moved (1+ moved) again t)))))
while again))
(if (> moved 0)
(progn (cg-put game :moves (+ moved (cg-get game :moves)))
(cg-put game :sel nil)
(cg-put game :message (format "Auto-played %d card%s."
moved (if (= 1 moved) "" "s"))))
(cg-put game :history (cdr (cg-get game :history)))
(cg-put game :message "Nothing to auto-play."))))
(cg-sol--after cg-sol--game))
(defun cg-sol-undo ()
"Undo the last move."
(interactive)
(let ((game cg-sol--game))
(if (cg-sol--restore game)
(cg-put game :message "Undid a move.")
(cg-put game :message "Nothing to undo."))
(cg-sol--redisplay)))
(defun cg-sol--move (delta)
"Move the cursor by DELTA spots."
(let* ((game cg-sol--game)
(n (length (cg-sol--spots game)))
(cur (cg-get game :cursor)))
(cg-put game :cursor (mod (+ cur delta) n))
(cg-sol--redisplay)))
(defun cg-sol-left () "Move cursor left." (interactive) (cg-sol--move -1))
(defun cg-sol-right () "Move cursor right." (interactive) (cg-sol--move 1))
(defun cg-sol-up () "Move cursor left (previous pile)." (interactive) (cg-sol--move -1))
(defun cg-sol-down () "Move cursor right (next pile)." (interactive) (cg-sol--move 1))
(defun cg-sol--after (game)
"Fill empty columns from the reserve, redisplay GAME, and announce a win."
(cg-sol--autofill game)
(cg-sol--redisplay)
(when (cg-won-p game)
(cg-put game :message "You won! Press n for a new game.")
(cg-sol--redisplay)
(message "Solved! Well played.")))
(defun cg-sol-new ()
"Start a fresh deal of the same game."
(interactive)
(let ((game cg-sol--game))
(cg-sol--deal game)
(cg-sol--redisplay)))
(defun cg-sol-help ()
"Describe the controls."
(interactive)
(message "Arrows: move RET: pick up/drop f: to foundation a: auto u: undo n: new g: redraw"))
(defun cg-sol-redraw () "Redraw the board." (interactive) (cg-sol--redisplay))
;;;; Rendering (console)
(defun cg-sol--render-card (card down sel cursor)
"Return a propertized 3-column cell for CARD (DOWN, SEL, CURSOR flags)."
(let* ((s (cg-sol-card-string card down))
(faces nil))
(when (and card (not down) (cg-sol-red-p card)) (push 'cg-red-suit faces))
(when down (push 'cg-gap faces))
(when sel (push 'cg-hint faces))
(when cursor (push 'cg-cursor faces))
(propertize (format "%3s " s) 'face (or faces 'default))))
(cl-defmethod cg-render ((game cg-solitaire-game))
"Return a propertized string depicting GAME for a text display."
(let* ((spots (cg-sol--spots game))
(cur (cg-get game :cursor))
(cur-spot (nth cur spots))
(sel (cg-get game :sel))
(sel-n (cg-get game :sel-n))
(out (list)))
(push (format " %s Moves: %d%s\n\n"
(oref game vname) (cg-get game :moves)
(if (> (oref game nfound) 0) ""
(format " Sets: %d/%d" (cg-get game :sets) (oref game target-sets))))
out)
;; Top line: stock / waste / free cells / foundations.
(let ((line " "))
(when (oref game has-stock)
(let ((on (equal cur-spot '(stock . 0))))
(setq line (concat line "Stock:"
(propertize (format "%-4s"
(if (cg-get game :stock) "##" "·"))
'face (if on 'cg-cursor 'default))
(format "(%d) " (length (cg-get game :stock))))) ))
(when (oref game has-waste)
(let ((on (equal cur-spot '(waste . 0))) (w (car (last (cg-get game :waste)))))
(setq line (concat line "Waste:"
(cg-sol--render-card w nil nil on)))))
(when (oref game has-reserve)
(let ((on (equal cur-spot '(reserve . 0))) (r (car (last (cg-get game :reserve)))))
(setq line (concat line "Reserve:"
(cg-sol--render-card r nil nil on)
(format "(%d) " (length (cg-get game :reserve)))))))
(dotimes (i (oref game nfree))
(let ((on (equal cur-spot (cons 'free i))) (c (aref (cg-get game :free) i)))
(setq line (concat line (format "F%d:" (1+ i))
(cg-sol--render-card c nil nil on)))))
(dotimes (i (oref game nfound))
(let ((on (equal cur-spot (cons 'found i)))
(c (car (last (aref (cg-get game :found) i)))))
(setq line (concat line (format "%d:" (1+ i))
(cg-sol--render-card c nil nil on)))))
(push (concat line "\n\n") out))
;; Column headers.
(let ((hdr " "))
(dotimes (c (oref game ncols))
(let ((on (equal cur-spot (cons 'col c))))
(setq hdr (concat hdr (propertize (format "%2d " (1+ c))
'face (if on 'cg-cursor 'default))))))
(push (concat hdr "\n") out))
;; Column bodies, row by row.
(let* ((tab (cg-get game :tableau))
(maxlen (apply #'max 1 (mapcar #'length (append tab nil)))))
(dotimes (r maxlen)
(let ((row " "))
(dotimes (c (oref game ncols))
(let* ((col (aref tab c))
(len (length col))
(card (and (< r len) (nth r col)))
(down (and card (< r (cg-sol--down game c))))
(selp (and (equal sel (cons 'col c))
card (>= r (- len sel-n))))
(cursorp (and (equal cur-spot (cons 'col c)) (= r (1- len)))))
(setq row (concat row
(if (< r len)
(cg-sol--render-card card down selp cursorp)
" ")))))
(push (concat row "\n") out))))
(push (format "\n %s\n" (cg-get game :message)) out)
(apply #'concat (nreverse out))))
(defun cg-sol--redisplay ()
"Redraw the current solitaire buffer."
(let ((game cg-sol--game)
(inhibit-read-only t))
(setq-local mode-line-process
(format " [%s]" (if (cg-won-p game) "solved"
(let ((s (cg-get game :sel)))
(if s "carrying" "playing")))))
(erase-buffer)
(insert (cg-render game))
(goto-char (point-min))))
;;;; Mode and commands
(defvar cg-sol-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "<left>") #'cg-sol-left)
(define-key map (kbd "<right>") #'cg-sol-right)
(define-key map (kbd "<up>") #'cg-sol-up)
(define-key map (kbd "<down>") #'cg-sol-down)
(define-key map (kbd "RET") #'cg-sol-act)
(define-key map (kbd "SPC") #'cg-sol-act)
(define-key map "f" #'cg-sol-to-foundation)
(define-key map "a" #'cg-sol-auto)
(define-key map "u" #'cg-sol-undo)
(define-key map "n" #'cg-sol-new)
(define-key map "g" #'cg-sol-redraw)
(define-key map "?" #'cg-sol-help)
map)
"Keymap for `cg-sol-mode'.")
(defun cg-sol--classic-keymap ()
"Return a copy of `cg-sol-mode-map' with vi-style hjkl added."
(let ((map (copy-keymap cg-sol-mode-map)))
(define-key map "h" #'cg-sol-left)
(define-key map "l" #'cg-sol-right)
(define-key map "j" #'cg-sol-down)
(define-key map "k" #'cg-sol-up)
map))
(define-derived-mode cg-sol-mode special-mode "Solitaire"
"Major mode for the tableau solitaires."
(setq-local truncate-lines t)
(when (eq cg-keys 'classic)
(use-local-map (cg-sol--classic-keymap))))
(defun cg-sol--play (class)
"Start a solitaire game of CLASS in its own buffer."
(let* ((game (cg-sol--deal (make-instance class)))
(buf (get-buffer-create (format "*%s*" (oref game vname)))))
(with-current-buffer buf
(cg-sol-mode)
(setq cg-sol--game game)
(cg-sol--redisplay))
(switch-to-buffer buf)))
;;;###autoload
(defun cg-klondike ()
"Play Klondike, the classic solitaire."
(interactive) (cg-sol--play 'cg-klondike-game))
;;;###autoload
(defun cg-freecell ()
"Play FreeCell solitaire."
(interactive) (cg-sol--play 'cg-freecell-game))
;;;###autoload
(defun cg-spider ()
"Play Spider solitaire (two decks)."
(interactive) (cg-sol--play 'cg-spider-game))
;;;###autoload
(defun cg-yukon ()
"Play Yukon solitaire."
(interactive) (cg-sol--play 'cg-yukon-game))
;;;; More games: Forty Thieves, Scorpion, Canfield
(defclass cg-forty-game (cg-solitaire-game)
((ncols :initform 10) (ndecks :initform 2) (nfound :initform 8)
(has-stock :initform t) (has-waste :initform t) (redeal :initform nil)
(build :initform 'suit) (run-rule :initform 'suit) (empty-rule :initform 'any)
(vname :initform "Forty Thieves"))
"Forty Thieves: two decks, ten columns, eight foundations, no redeal.")
(cl-defmethod cg-sol--layout ((_ cg-forty-game))
(make-list 10 (cons 0 4)))
(defclass cg-scorpion-game (cg-solitaire-game)
((ncols :initform 7) (nfound :initform 0) (has-stock :initform t)
(build :initform 'suit) (run-rule :initform 'any) (empty-rule :initform 'king)
(target-sets :initform 4) (vname :initform "Scorpion"))
"Scorpion: build down by suit, move any buried group, clear four runs.")
(cl-defmethod cg-sol--layout ((_ cg-scorpion-game))
(append (make-list 4 (cons 3 4)) (make-list 3 (cons 0 7))))
(cl-defmethod cg-sol--stock-action ((game cg-scorpion-game))
"Deal the three stock cards onto the first three columns."
(let ((stock (cg-get game :stock)))
(if (null stock)
(cg-put game :message "The stock is empty.")
(cg-sol--snapshot game)
(dotimes (c (min 3 (length stock)))
(cg-sol--set-col game c (append (cg-sol--col game c) (last stock 1)))
(setq stock (butlast stock 1)))
(cg-put game :stock stock)
(cg-sol--harvest game)
(cg-put game :message "Dealt the stock onto the first columns."))))
(defclass cg-canfield-game (cg-solitaire-game)
((ncols :initform 4) (nfound :initform 4) (has-stock :initform t)
(has-waste :initform t) (has-reserve :initform t) (draw :initform 3)
(redeal :initform t) (build :initform 'alt) (run-rule :initform 'alt)
(empty-rule :initform 'any) (wrap :initform t) (vname :initform "Canfield"))
"Canfield: a 13-card reserve and a variable foundation base rank.")
(cl-defmethod cg-sol--deal ((game cg-canfield-game))
"Deal a Canfield layout: reserve, base foundation, four columns, stock."
(let* ((deck (cg-sol--make-deck 1))
(reserve (cl-loop repeat 13 collect (pop deck)))
(first (pop deck))
(found (make-vector 4 nil))
(tableau (make-vector 4 nil))
(down (make-vector 4 0)))
(oset game base (cdr first))
(aset found 0 (list first))
(dotimes (c 4) (aset tableau c (list (pop deck))))
(cg-put game :reserve reserve)
(cg-put game :tableau tableau)
(cg-put game :down down)
(cg-put game :found found)
(cg-put game :free (make-vector 0 nil))
(cg-put game :stock deck)
(cg-put game :waste nil)
(cg-put game :sets 0)
(cg-put game :moves 0)
(cg-put game :cursor 0)
(cg-put game :sel nil)
(cg-put game :sel-n 0)
(cg-put game :history nil)
(cg-put game :message
(format "Canfield. Foundations build up from %s (wrapping). RET deals three."
(aref cg-sol-ranks (cdr first))))
game))
(cl-defmethod cg-sol--autofill ((_ cg-solitaire-game)) nil)
(cl-defmethod cg-sol--autofill ((game cg-canfield-game))
"Fill empty columns from the reserve, as Canfield requires."
(dotimes (c (oref game ncols))
(when (and (null (cg-sol--col game c)) (cg-get game :reserve))
(let ((card (car (last (cg-get game :reserve)))))
(cg-put game :reserve (butlast (cg-get game :reserve) 1))
(cg-sol--set-col game c (list card))))))
;;;###autoload
(defun cg-forty-thieves ()
"Play Forty Thieves solitaire (two decks)."
(interactive) (cg-sol--play 'cg-forty-game))
;;;###autoload
(defun cg-scorpion ()
"Play Scorpion solitaire."
(interactive) (cg-sol--play 'cg-scorpion-game))
;;;###autoload
(defun cg-canfield ()
"Play Canfield solitaire."
(interactive) (cg-sol--play 'cg-canfield-game))
(provide 'cg-solitaire)
;;; cg-solitaire.el ends here

2
cg-svg.el
View file

@ -4,7 +4,7 @@
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.50
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el

810
cg-trick.el Normal file
View file

@ -0,0 +1,810 @@
;;; cg-trick.el --- Four-hand trick-taking games (Hearts, Spades) -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Corwin Brust
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; A small four-handed trick-taking engine and two games built on it:
;;
;; `cg-hearts' -- the classic avoidance game; dodge every heart and the
;; Queen of Spades, or take them all to "shoot the moon".
;; `cg-spades' -- partnership bidding; spades are always trump; make your
;; side's combined bid, beware of bags, and dare a nil.
;;
;; You sit South (seat 0); the other three seats are played by simple but
;; legal AI. Cards are the package-standard cons (SUIT . RANK) with SUIT
;; 0 spades, 1 clubs, 2 diamonds, 3 hearts and RANK 0 (the Two) .. 12 (the
;; Ace); within a suit the higher rank wins, with the trump suit beating
;; every plain suit.
;;; Code:
(require 'cl-lib)
(require 'eieio)
(require 'cg-core)
;;;; Cards
(defconst cg-trick-ranks
["2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K" "A"]
"Rank labels indexed 0 (Two) .. 12 (Ace).")
(defconst cg-trick-seat-names ["South" "West" "North" "East"]
"Seat names indexed 0..3, going clockwise from the human player.")
(defun cg-trick-card-string (card)
"Return a short string for CARD."
(if (null card) "·"
(concat (aref cg-trick-ranks (cdr card)) (cg-suit-glyph (car card)))))
(defsubst cg-trick-red-p (card) (and card (cg-red-suit-p (car card))))
(defun cg-trick--full-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)))))
(defun cg-trick--sort (cards)
"Return CARDS sorted by suit then rank for display."
(sort (copy-sequence cards)
(lambda (a b) (if (= (car a) (car b)) (< (cdr a) (cdr b))
(< (car a) (car b))))))
;;;; Classes
(defclass cg-trick-game (cg-game)
((trump :initform nil :documentation "Trump suit index, or nil for none.")
(restricted :initform 3 :documentation "Suit that cannot be led until broken.")
(target :initform 100 :documentation "Score that ends the game.")
(hand-size :initform 13 :documentation "Cards dealt to each seat per hand.")
(vname :initform "Trick game"))
"Abstract base for four-handed trick-taking games."
:abstract t)
(defclass cg-hearts-game (cg-trick-game)
((trump :initform nil) (restricted :initform 3) (target :initform 100)
(vname :initform "Hearts"))
"Hearts: no trump; avoid hearts and the Queen of Spades.")
(defclass cg-spades-game (cg-trick-game)
((trump :initform 0) (restricted :initform 0) (target :initform 500)
(vname :initform "Spades"))
"Spades: spades are trump; partnership bidding to 500.")
;;;; Dealing
(cl-defmethod cg-trick--deal ((game cg-trick-game))
"Deal a fresh hand into GAME."
(let ((deck (cg-trick--full-deck))
(hands (make-vector 4 nil))
(hs (oref game hand-size))
(last nil))
(dotimes (s 4)
(let ((h nil))
(dotimes (_ hs) (setq last (pop deck)) (push last h))
(aset hands s (cg-trick--sort h))))
(cg-put game :hands hands)
(cg-put game :deck deck)
(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 nil)
(cg-put game :trick-no 0)
game))
(defsubst cg-trick--hand (game s) (aref (cg-get game :hands) s))
(defsubst cg-trick--set-hand (game s v) (aset (cg-get game :hands) s v))
(defsubst cg-trick--partner (s) (mod (+ s 2) 4))
(defsubst cg-trick--team (s) (mod s 2))
;;;; Trick mechanics
(defun cg-trick--led-suit (game)
"Return the suit led to the current trick, or nil if none yet."
(let ((tr (cg-get game :trick)))
(and tr (car (cdr (car (last tr))))))) ; first entry played
(defun cg-trick--first-play (game)
"Return the (SEAT . CARD) led to the current trick, or nil."
(car (last (cg-get game :trick))))
(cl-defmethod cg-trick--has-points-only-p ((_ cg-trick-game) _hand) nil)
(cl-defmethod cg-trick--legal-p ((game cg-trick-game) seat card)
"Return non-nil when SEAT may legally play CARD now."
(let* ((hand (cg-trick--hand game seat))
(trick (cg-get game :trick))
(restricted (oref game restricted))
(broken (cg-get game :broken)))
(and (member card hand)
(if trick
;; following: must follow the led suit if able
(let ((led (cg-trick--led-suit game)))
(if (cl-some (lambda (c) (= (car c) led)) hand)
(= (car card) led)
t))
;; leading: cannot lead the restricted suit until broken,
;; unless the hand holds nothing else
(if (and (= (car card) restricted) (not broken))
(cl-every (lambda (c) (= (car c) restricted)) hand)
t)))))
(defun cg-trick--legal-moves (game seat)
"Return the list of cards SEAT may legally play now."
(cl-remove-if-not (lambda (c) (cg-trick--legal-p game seat c))
(cg-trick--hand game seat)))
(cl-defmethod cg-trick--winner ((game cg-trick-game))
"Return the seat that wins the now-complete current trick."
(let* ((trick (reverse (cg-get game :trick))) ; play order
(led (car (cdr (car trick))))
(trump (oref game trump))
(best (car trick)))
(dolist (play (cdr trick))
(let ((bc (cdr best)) (pc (cdr play)))
(cond
((and trump (= (car pc) trump) (not (= (car bc) trump)))
(setq best play))
((and (= (car pc) (car bc)) (> (cdr pc) (cdr bc)))
(setq best play))
((and trump (not (= (car bc) trump)) (= (car pc) led)
(> (cdr pc) (cdr bc)))
(setq best play)))))
(car best)))
(cl-defmethod cg-trick--play ((game cg-trick-game) seat card)
"Have SEAT play CARD, resolving the trick when it completes."
(cg-trick--set-hand game seat (remove card (cg-trick--hand game seat)))
(when (= (car card) (oref game restricted)) (cg-put game :broken t))
(cg-put game :trick (cons (cons seat card) (cg-get game :trick)))
(if (= 4 (length (cg-get game :trick)))
(let* ((w (cg-trick--winner game))
(cards (mapcar #'cdr (cg-get game :trick))))
(aset (cg-get game :tricks) w (1+ (aref (cg-get game :tricks) w)))
(aset (cg-get game :taken) w (append cards (aref (cg-get game :taken) w)))
(cg-put game :trick nil)
(cg-put game :trick-no (1+ (cg-get game :trick-no)))
(cg-put game :leader w)
(cg-put game :turn w)
w)
(cg-put game :turn (mod (1+ seat) 4))
nil))
(defun cg-trick--hand-over-p (game)
"Return non-nil when all 13 tricks of the hand have been played."
(and (null (cg-get game :trick))
(cl-every #'null (append (cg-get game :hands) nil))))
;;;; Hearts specifics
(defun cg-hearts--card-points (card)
"Return the penalty points for CARD in Hearts."
(cond ((equal card '(0 . 10)) 13) ; Queen of Spades
((= (car card) 3) 1) ; any heart
(t 0)))
(cl-defmethod cg-trick--legal-p ((game cg-hearts-game) seat card)
"Hearts legality, adding the first-trick rules to the base."
(and (cl-call-next-method)
(let ((trick (cg-get game :trick))
(hand (cg-trick--hand game seat))
(first (= 0 (cg-get game :trick-no))))
(cond
;; the very first card of the hand must be the Two of Clubs
((and first (null trick))
(equal card '(1 . 0)))
;; no points on the first trick unless that is all one holds
((and first trick (> (cg-hearts--card-points card) 0))
(cl-every (lambda (c) (> (cg-hearts--card-points c) 0)) hand))
(t t)))))
(cl-defmethod cg-trick--leader-init ((game cg-hearts-game))
"Hearts: the holder of the Two of Clubs leads first."
(let (seat)
(dotimes (s 4)
(when (member '(1 . 0) (cg-trick--hand game s)) (setq seat s)))
(cg-put game :leader seat) (cg-put game :turn seat)))
(cl-defmethod cg-trick--leader-init ((game cg-spades-game))
"Spades: the player left of the dealer leads first."
(let ((s (mod (1+ (or (cg-get game :dealer) 3)) 4)))
(cg-put game :leader s) (cg-put game :turn s)))
(cl-defmethod cg-trick--score-hand ((game cg-hearts-game))
"Score a finished Hearts hand into the cumulative scores."
(let ((pts (make-vector 4 0)) (scores (cg-get game :scores)))
(dotimes (s 4)
(aset pts s (apply #'+ (mapcar #'cg-hearts--card-points
(aref (cg-get game :taken) s)))))
;; shooting the moon
(let ((moon (cl-position 26 (append pts nil))))
(if moon
(dotimes (s 4) (unless (= s moon)
(aset scores s (+ (aref scores s) 26))))
(dotimes (s 4) (aset scores s (+ (aref scores s) (aref pts s))))))
(cg-put game :last-points pts)))
(cl-defmethod cg-trick--game-over-p ((game cg-hearts-game))
"Hearts ends when any score reaches the target."
(cl-some (lambda (s) (>= s (oref game target))) (append (cg-get game :scores) nil)))
(cl-defmethod cg-trick--winner-seat ((game cg-hearts-game))
"Return the winning seat (lowest score) for a finished Hearts game."
(let ((best 0))
(dotimes (s 4) (when (< (aref (cg-get game :scores) s)
(aref (cg-get game :scores) best))
(setq best s)))
best))
;;;; Spades specifics
(cl-defmethod cg-trick--score-hand ((game cg-spades-game))
"Score a finished Spades hand into the cumulative team scores."
(let ((scores (cg-get game :scores))
(bags (cg-get game :bags))
(bids (cg-get game :bids))
(tricks (cg-get game :tricks)))
(dotimes (team 2)
(let* ((a team) (b (+ team 2))
(teambid 0) (teamtricks (+ (aref tricks a) (aref tricks b)))
(delta 0))
;; nil bids handled per player
(dolist (s (list a b))
(if (= (aref bids s) 0)
(setq delta (+ delta (if (= (aref tricks s) 0) 100 -100)))
(setq teambid (+ teambid (aref bids s)))))
(if (>= teamtricks teambid)
(let ((over (- teamtricks teambid)))
;; overtricks beyond nil winners count as bags
(setq delta (+ delta (* 10 teambid) over))
(aset bags team (+ (aref bags team) over))
(when (>= (aref bags team) 10)
(setq delta (- delta 100))
(aset bags team (- (aref bags team) 10))))
(setq delta (- delta (* 10 teambid))))
(aset scores a (+ (aref scores a) delta))
(aset scores b (aref scores a))))
(cg-put game :scores scores)))
(cl-defmethod cg-trick--game-over-p ((game cg-spades-game))
"Spades ends when a team reaches the target (or falls badly behind)."
(cl-some (lambda (s) (>= s (oref game target))) (append (cg-get game :scores) nil)))
(cl-defmethod cg-trick--winner-seat ((game cg-spades-game))
"Return a member seat of the winning team for a finished Spades game."
(if (>= (aref (cg-get game :scores) 0) (aref (cg-get game :scores) 1)) 0 1))
;;;; AI
(cl-defmethod cg-trick--ai-bid ((game cg-spades-game) seat)
"Return a simple trick estimate (bid) for SEAT in Spades."
(let ((hand (cg-trick--hand game seat)) (bid 0))
(dolist (c hand)
(cond
((= (cdr c) 12) (setq bid (1+ bid))) ; aces
((and (= (cdr c) 11)) (setq bid (1+ bid))) ; kings
((and (= (car c) 0) (>= (cdr c) 9)) (setq bid (1+ bid))))) ; high spades
;; long spades add tricks
(let ((nsp (cl-count-if (lambda (c) (= (car c) 0)) hand)))
(when (> nsp 4) (setq bid (+ bid (- nsp 4)))))
(max 1 (min 13 bid))))
(cl-defmethod cg-trick--ai-play ((game cg-hearts-game) seat)
"Choose a legal Hearts card for SEAT, avoiding points."
(let* ((moves (cg-trick--legal-moves game seat))
(trick (cg-get game :trick)))
(or
(if (null trick)
;; leading: play a low non-point card
(car (sort (copy-sequence moves)
(lambda (a b) (< (+ (* 4 (cg-hearts--card-points a)) (cdr a))
(+ (* 4 (cg-hearts--card-points b)) (cdr b))))))
;; following: if we can duck under the current winner, play highest
;; safe card; else dump the most dangerous card
(let* ((led (cg-trick--led-suit game))
(winrank (apply #'max (cons -1 (mapcar (lambda (p) (if (= (car (cdr p)) led)
(cdr (cdr p)) -1))
trick))))
(under (cl-remove-if-not (lambda (c) (and (= (car c) led)
(< (cdr c) winrank)))
moves)))
(cond
(under (car (last (cg-trick--sort under)))) ; highest still safe
((cl-some (lambda (c) (/= (car c) led)) moves) ; void: dump worst
(car (sort (copy-sequence moves)
(lambda (a b) (> (+ (* 4 (cg-hearts--card-points a)) (cdr a))
(+ (* 4 (cg-hearts--card-points b)) (cdr b)))))))
(t (car (sort (copy-sequence moves) ; must follow & take: lowest
(lambda (a b) (< (cdr a) (cdr b)))))))))
(car moves))))
(cl-defmethod cg-trick--ai-play ((game cg-spades-game) seat)
"Choose a legal Spades card for SEAT."
(let* ((moves (cg-trick--legal-moves game seat))
(trick (cg-get game :trick))
(trump (oref game trump)))
(or
(if (null trick)
;; lead a high non-spade if possible, else lowest
(let ((non (cl-remove-if (lambda (c) (= (car c) trump)) moves)))
(if non (car (last (cg-trick--sort non)))
(car (cg-trick--sort moves))))
(let* ((led (cg-trick--led-suit game))
(cur (cg-get game :trick))
;; current winning play
(winner (cg-trick--winner-of game cur))
(partner-winning (and winner (= (cg-trick--team winner)
(cg-trick--team seat)))))
(if partner-winning
(car (cg-trick--sort moves)) ; let partner have it: play low
;; try to win cheaply
(let* ((followers (cl-remove-if-not (lambda (c) (= (car c) led)) moves)))
(or (car (cg-trick--sort followers))
(car (cg-trick--sort moves)))))))
(car moves))))
(defun cg-trick--winner-of (game trick)
"Return the seat currently winning the partial TRICK of GAME."
(when trick
(let* ((order (reverse trick))
(led (car (cdr (car order))))
(trump (oref game trump))
(best (car order)))
(dolist (play (cdr order))
(let ((bc (cdr best)) (pc (cdr play)))
(cond
((and trump (= (car pc) trump) (not (= (car bc) trump))) (setq best play))
((and (= (car pc) (car bc)) (> (cdr pc) (cdr bc))) (setq best play))
((and trump (not (= (car bc) trump)) (= (car pc) led)
(> (cdr pc) (cdr bc))) (setq best play)))))
(car best))))
;;;; Game driver (logic; UI layered on top)
(cl-defmethod cg-trick--start-hand ((game cg-trick-game))
"Deal and prepare a new hand, leaving GAME ready for the first lead."
(cg-trick--deal game)
(cg-trick--leader-init game)
game)
(defun cg-trick--simulate-hand (game)
"Play a whole hand with AI for every seat (used by tests)."
(while (not (cg-trick--hand-over-p game))
(let ((seat (cg-get game :turn)))
(cg-trick--play game seat (cg-trick--ai-play game seat))))
(cg-trick--score-hand game))
;;;; New-game / hand lifecycle
(defvar-local cg-trick--game nil "The trick-taking game in the current buffer.")
(defconst cg-trick--pass-dirs [1 3 2 0]
"Pass directions by hand: left, right, across, hold (then repeat).")
(defun cg-trick--dir-name (dir)
"Return a human label for pass direction DIR."
(pcase dir (1 "left") (3 "right") (2 "across") (_ "hold")))
(cl-defgeneric cg-trick--begin-hand (game)
"Deal and set up a new hand of GAME, then run AI up to the human's turn.")
(cl-defmethod cg-trick--begin-hand ((game cg-hearts-game))
(cg-trick--deal game)
(cg-put game :hand-no (1+ (or (cg-get game :hand-no) 0)))
(cg-put game :cursor 0) (cg-put game :marks nil)
(let ((dir (aref cg-trick--pass-dirs (mod (1- (cg-get game :hand-no)) 4))))
(cg-put game :pass-dir dir)
(if (= dir 0)
(progn (cg-trick--leader-init game)
(cg-put game :phase 'play)
(cg-put game :message "No passing this hand. Play begins.")
(cg-trick--run game))
(cg-put game :phase 'pass)
(cg-put game :message
(format "Pass three cards %s. RET marks a card; p sends them."
(cg-trick--dir-name dir))))))
(cl-defmethod cg-trick--begin-hand ((game cg-spades-game))
(cg-trick--deal game)
(cg-put game :dealer (mod (1+ (or (cg-get game :dealer) 3)) 4))
(cg-put game :cursor 0)
(let ((bids (make-vector 4 0)))
(dotimes (s 4) (unless (= s 0) (aset bids s (cg-trick--ai-bid game s))))
(aset bids 0 (if noninteractive (cg-trick--ai-bid game 0)
(let ((sug (cg-trick--ai-bid game 0)))
(max 0 (min 13 (read-number
(format "Your bid (0 = nil) [suggest %d]: " sug)
sug))))))
(cg-put game :bids bids))
(cg-trick--leader-init game)
(cg-put game :phase 'play)
(cg-put game :message
(format "You bid %d. Make your side's combined bid."
(aref (cg-get game :bids) 0)))
(cg-trick--run game))
(defun cg-trick--new (game)
"Initialise GAME for a fresh match and deal the first hand."
(cg-put game :scores (make-vector 4 0))
(cg-put game :bags (make-vector 2 0))
(cg-put game :dealer 3)
(cg-put game :hand-no 0)
(cg-put game :round 0)
(cg-trick--begin-hand game)
game)
(defun cg-trick--run (game)
"Advance AI seats until it is the human's turn or the hand ends."
(while (and (eq (cg-get game :phase) 'play)
(not (cg-trick--hand-over-p game))
(/= (cg-get game :turn) 0))
(let ((s (cg-get game :turn)))
(cg-trick--play game s (cg-trick--ai-play game s))))
(when (and (eq (cg-get game :phase) 'play) (cg-trick--hand-over-p game))
(cg-trick--finish-hand game)))
(defun cg-trick--finish-hand (game)
"Score the finished hand of GAME and start the next, or end the match."
(cg-trick--score-hand game)
(if (cg-trick--game-over-p game)
(progn (cg-put game :phase 'game-over)
(cg-put game :message
(format "Game over. %s. Press n for a new match."
(cg-trick--result-string game))))
(cg-trick--begin-hand game)))
(cl-defmethod cg-trick--result-string ((game cg-hearts-game))
(format "%s wins with the lowest score"
(aref cg-trick-seat-names (cg-trick--winner-seat game))))
(cl-defmethod cg-trick--result-string ((game cg-spades-game))
(let ((w (cg-trick--winner-seat game)))
(format "%s win" (if (= w 0) "You and North" "West and East"))))
;;;; AI passing
(cl-defmethod cg-trick--ai-pass ((_ cg-hearts-game) hand)
"Return three cards to pass from HAND (shed the most dangerous)."
(let ((danger (lambda (c) (+ (* 6 (cg-hearts--card-points c))
(if (and (= (car c) 0) (>= (cdr c) 10)) 5 0)
(cdr c)))))
(cl-subseq (sort (copy-sequence hand)
(lambda (a b) (> (funcall danger a) (funcall danger b))))
0 3)))
(defun cg-trick--do-pass (game)
"Exchange the chosen passing cards among the four seats of GAME."
(let* ((dir (cg-get game :pass-dir))
(sel (make-vector 4 nil))
(kept (make-vector 4 nil)))
(aset sel 0 (copy-sequence (cg-get game :marks)))
(dotimes (s 4)
(unless (= s 0)
(aset sel s (copy-sequence (cg-trick--ai-pass game (cg-trick--hand game s))))))
;; what each seat keeps (its hand minus the cards it gives away)
(dotimes (s 4)
(aset kept s (cl-remove-if (lambda (c) (member c (aref sel s)))
(cg-trick--hand game s))))
;; deal each seat's three cards to the seat DIR places along
(dotimes (s 4)
(let ((r (mod (+ s dir) 4)))
(aset kept r (append (aref kept r) (aref sel s)))))
(dotimes (s 4)
(cg-trick--set-hand game s (cg-trick--sort (aref kept s))))
(cg-trick--leader-init game)
(cg-put game :phase 'play)
(cg-put game :marks nil)
(cg-put game :message "Cards passed. Play begins.")
(cg-trick--run game)))
(defun cg-trick--seat-line (game s)
"Return a status line for opponent seat S of GAME."
(let* ((n (length (cg-trick--hand game s)))
(bid (and (cg-get game :bids) (aref (cg-get game :bids) s)))
(won (and (cg-get game :tricks) (aref (cg-get game :tricks) s))))
(format " %-6s %2d cards%s%s\n" (aref cg-trick-seat-names s) n
(if bid (format " bid %d" bid) "")
(if won (format " won %d" won) ""))))
(cl-defmethod cg-render ((game cg-trick-game))
"Return a propertized string depicting GAME for a text display."
(let* ((out (list))
(scores (cg-get game :scores))
(marks (cg-get game :marks))
(cursor (cg-get game :cursor))
(hand (cg-trick--sort (cg-trick--hand game 0))))
(push (format " %s\n" (oref game vname)) out)
(when scores
(push (format " Scores: South %d West %d North %d East %d\n\n"
(aref scores 0) (aref scores 1) (aref scores 2) (aref scores 3))
out))
(dolist (s '(2 1 3)) ; North, West, East
(push (cg-trick--seat-line game s) out))
;; current trick
(push "\n Trick: " out)
(if (cg-get game :trick)
(dolist (play (reverse (cg-get game :trick)))
(push (format "%s:%s " (aref cg-trick-seat-names (car play))
(let ((cs (cg-trick-card-string (cdr play))))
(if (cg-trick-red-p (cdr play))
(propertize cs 'face 'cg-red-suit) cs)))
out))
(push "(empty)" out))
(push "\n\n Your hand (South):\n " out)
(let ((i 0))
(dolist (c hand)
(let* ((cs (cg-trick-card-string c))
(faces nil))
(when (cg-trick-red-p c) (push 'cg-red-suit faces))
(when (member c marks) (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 (format "\n\n %s\n" (cg-get game :message)) out)
(apply #'concat (nreverse out))))
(defun cg-trick--redisplay ()
"Redraw the current trick-game buffer."
(let ((game cg-trick--game) (inhibit-read-only t))
(setq-local mode-line-process
(format " [%s]" (or (cg-get game :phase) "play")))
(erase-buffer)
(insert (cg-render game))
(goto-char (point-min))))
;;;; Commands
(defun cg-trick--cursor-card (game)
"Return the South card currently under the cursor."
(nth (cg-get game :cursor) (cg-trick--sort (cg-trick--hand game 0))))
(defun cg-trick-left ()
"Move the hand cursor left."
(interactive)
(let* ((game cg-trick--game) (n (length (cg-trick--hand game 0))))
(when (> n 0) (cg-put game :cursor (mod (1- (cg-get game :cursor)) n)))
(cg-trick--redisplay)))
(defun cg-trick-right ()
"Move the hand cursor right."
(interactive)
(let* ((game cg-trick--game) (n (length (cg-trick--hand game 0))))
(when (> n 0) (cg-put game :cursor (mod (1+ (cg-get game :cursor)) n)))
(cg-trick--redisplay)))
(defun cg-trick-act ()
"Play, or (during the Hearts pass) mark, the selected card."
(interactive)
(let* ((game cg-trick--game)
(phase (cg-get game :phase))
(card (cg-trick--cursor-card game)))
(pcase phase
('play
(cond
((/= (cg-get game :turn) 0) (cg-put game :message "Not your turn."))
((not (cg-trick--legal-p game 0 card))
(cg-put game :message "Illegal play — you must follow suit."))
(t (cg-trick--play game 0 card)
(cg-put game :cursor (max 0 (min (cg-get game :cursor)
(1- (length (cg-trick--hand game 0))))))
(cg-trick--run game))))
('pass
(if (member card (cg-get game :marks))
(cg-put game :marks (remove card (cg-get game :marks)))
(if (>= (length (cg-get game :marks)) 3)
(cg-put game :message "Three already marked — press p to pass.")
(cg-put game :marks (cons card (cg-get game :marks))))))
(_ (cg-put game :message "Press n for a new match.")))
(cg-trick--redisplay)))
(defun cg-trick-pass ()
"Confirm the Hearts pass once three cards are marked."
(interactive)
(let ((game cg-trick--game))
(if (and (eq (cg-get game :phase) 'pass) (= 3 (length (cg-get game :marks))))
(cg-trick--do-pass game)
(cg-put game :message "Mark exactly three cards first."))
(cg-trick--redisplay)))
(defun cg-trick-new ()
"Start a fresh match in this buffer."
(interactive)
(cg-trick--new cg-trick--game)
(cg-trick--redisplay))
(defun cg-trick-redraw () "Redraw the table." (interactive) (cg-trick--redisplay))
(defun cg-trick-help ()
"Describe the controls."
(interactive)
(message "Arrows: choose card RET: play/mark p: pass (Hearts) n: new g: redraw"))
(defvar cg-trick-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "<left>") #'cg-trick-left)
(define-key map (kbd "<right>") #'cg-trick-right)
(define-key map (kbd "RET") #'cg-trick-act)
(define-key map (kbd "SPC") #'cg-trick-act)
(define-key map "p" #'cg-trick-pass)
(define-key map "n" #'cg-trick-new)
(define-key map "g" #'cg-trick-redraw)
(define-key map "?" #'cg-trick-help)
map)
"Keymap for `cg-trick-mode'.")
(define-derived-mode cg-trick-mode special-mode "Trick"
"Major mode for the four-handed trick-taking games."
(setq-local truncate-lines t))
(defun cg-trick--play-game (class)
"Start a trick game of CLASS in its own buffer."
(let* ((game (make-instance class))
(buf (get-buffer-create (format "*%s*" (oref game vname)))))
(with-current-buffer buf
(cg-trick-mode)
(setq cg-trick--game game)
(cg-trick--new game)
(cg-trick--redisplay))
(switch-to-buffer buf)))
;;;###autoload
(defun cg-hearts ()
"Play Hearts against three computer opponents."
(interactive) (cg-trick--play-game 'cg-hearts-game))
;;;###autoload
(defun cg-spades ()
"Play Spades (partnership) against three computer opponents."
(interactive) (cg-trick--play-game 'cg-spades-game))
;;;; Whist and Oh Hell
(defclass cg-whist-game (cg-trick-game)
((restricted :initform -1) (target :initform 5) (vname :initform "Whist"))
"Whist: trump set by the turned card, no bidding, score tricks over six.")
(defclass cg-ohhell-game (cg-trick-game)
((restricted :initform -1) (target :initform 0) (vname :initform "Oh Hell"))
"Oh Hell: hand size shrinks each round; bid the exact tricks you will take.")
(cl-defmethod cg-trick--leader-init ((game cg-whist-game))
(let ((s (mod (1+ (or (cg-get game :dealer) 3)) 4)))
(cg-put game :leader s) (cg-put game :turn s)))
(cl-defmethod cg-trick--leader-init ((game cg-ohhell-game))
(let ((s (mod (1+ (or (cg-get game :dealer) 3)) 4)))
(cg-put game :leader s) (cg-put game :turn s)))
(defun cg-trick--ai-trump-play (game seat)
"A generic legal trump-game play for SEAT: follow and win cheaply, else low."
(let* ((moves (cg-trick--legal-moves game seat))
(trick (cg-get game :trick)))
(or
(if (null trick)
(car (last (cg-trick--sort moves)))
(let* ((winner (cg-trick--winner-of game trick))
(partner-winning (and winner (= (cg-trick--team winner)
(cg-trick--team seat))))
(led (cg-trick--led-suit game)))
(if partner-winning
(car (cg-trick--sort moves))
(let ((follow (cl-remove-if-not (lambda (c) (= (car c) led)) moves)))
(or (car (last (cg-trick--sort follow)))
(car (cg-trick--sort moves)))))))
(car moves))))
(cl-defmethod cg-trick--ai-play ((game cg-whist-game) seat)
(cg-trick--ai-trump-play game seat))
(cl-defmethod cg-trick--ai-play ((game cg-ohhell-game) seat)
(cg-trick--ai-trump-play game seat))
;; Whist
(cl-defmethod cg-trick--begin-hand ((game cg-whist-game))
(cg-trick--deal game)
(cg-put game :dealer (mod (1+ (or (cg-get game :dealer) 3)) 4))
(oset game trump (car (cg-get game :last-card))) ; dealer's last card turns trump
(cg-put game :cursor 0)
(cg-trick--leader-init game)
(cg-put game :phase 'play)
(cg-put game :message (format "Trump is %s. Take tricks past the book of six."
(cg-suit-glyph (oref game trump))))
(cg-trick--run game))
(cl-defmethod cg-trick--score-hand ((game cg-whist-game))
(let ((scores (cg-get game :scores)) (tricks (cg-get game :tricks)))
(dotimes (team 2)
(let ((over (max 0 (- (+ (aref tricks team) (aref tricks (+ team 2))) 6))))
(aset scores team (+ (aref scores team) over))
(aset scores (+ team 2) (aref scores team))))
(cg-put game :scores scores)))
(cl-defmethod cg-trick--game-over-p ((game cg-whist-game))
(cl-some (lambda (s) (>= s (oref game target))) (append (cg-get game :scores) nil)))
(cl-defmethod cg-trick--winner-seat ((game cg-whist-game))
(if (>= (aref (cg-get game :scores) 0) (aref (cg-get game :scores) 1)) 0 1))
(cl-defmethod cg-trick--result-string ((game cg-whist-game))
(format "%s win" (if (= 0 (cg-trick--winner-seat game)) "You and North" "West and East")))
;; Oh Hell
(defconst cg-ohhell--sizes [7 6 5 4 3 2 1]
"Hand sizes dealt in successive Oh Hell rounds.")
(cl-defmethod cg-trick--ai-bid ((game cg-ohhell-game) seat)
(let ((hand (cg-trick--hand game seat)) (trump (oref game trump)) (bid 0))
(dolist (c hand)
(cond ((= (cdr c) 12) (cl-incf bid))
((and (= (car c) trump) (>= (cdr c) 9)) (cl-incf bid))))
(min bid (length hand))))
(cl-defmethod cg-trick--begin-hand ((game cg-ohhell-game))
(let* ((round (or (cg-get game :round) 0))
(hs (aref cg-ohhell--sizes (min round (1- (length cg-ohhell--sizes))))))
(oset game hand-size hs)
(cg-trick--deal game)
(cg-put game :dealer (mod (1+ (or (cg-get game :dealer) 3)) 4))
(let ((up (car (cg-get game :deck))))
(oset game trump (if up (car up) 0)))
(cg-put game :cursor 0)
(let ((bids (make-vector 4 0)))
(dotimes (s 4) (unless (= s 0) (aset bids s (cg-trick--ai-bid game s))))
(aset bids 0 (if noninteractive (cg-trick--ai-bid game 0)
(max 0 (min hs (read-number
(format "Round %d (trump %s) -- your bid (0-%d): "
(1+ round) (cg-suit-glyph (oref game trump)) hs)
(cg-trick--ai-bid game 0))))))
(cg-put game :bids bids))
(cg-trick--leader-init game)
(cg-put game :phase 'play)
(cg-put game :message (format "Round %d: make EXACTLY your bid (trump %s)."
(1+ round) (cg-suit-glyph (oref game trump))))
(cg-trick--run game)))
(cl-defmethod cg-trick--score-hand ((game cg-ohhell-game))
(let ((scores (cg-get game :scores)) (bids (cg-get game :bids))
(tricks (cg-get game :tricks)))
(dotimes (s 4)
(when (= (aref tricks s) (aref bids s))
(aset scores s (+ (aref scores s) 10 (aref bids s)))))
(cg-put game :scores scores)
(cg-put game :round (1+ (or (cg-get game :round) 0)))))
(cl-defmethod cg-trick--game-over-p ((game cg-ohhell-game))
(>= (or (cg-get game :round) 0) (length cg-ohhell--sizes)))
(cl-defmethod cg-trick--winner-seat ((game cg-ohhell-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-ohhell-game))
(format "%s wins" (aref cg-trick-seat-names (cg-trick--winner-seat game))))
;;;###autoload
(defun cg-whist () "Play Whist against three computer opponents."
(interactive) (cg-trick--play-game 'cg-whist-game))
;;;###autoload
(defun cg-ohhell () "Play Oh Hell against three computer opponents."
(interactive) (cg-trick--play-game 'cg-ohhell-game))
(provide 'cg-trick)
;;; cg-trick.el ends here

1113
known-games.org Normal file
View file

File diff suppressed because it is too large Load diff

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

@ -332,3 +332,499 @@
(should (aref (cg-get hgame :passed) 1)))
(cg-net-disconnect)
(cg-net-host-stop)))))
;;;; --- New games added 2026-06-24: solitaires, trick games, Crazy Eights ---
(ert-deftest cgt-sol-deck ()
(should (= 52 (length (cg-sol--make-deck 1))))
(should (= 104 (length (cg-sol--make-deck 2)))))
(ert-deftest cgt-sol-klondike-deal ()
(let* ((g (cg-sol--deal (cg-klondike-game))))
(should (= 7 (oref g ncols)))
(dotimes (c 7)
(should (= (1+ c) (length (cg-sol--col g c))))
(should (= c (cg-sol--down g c)))
;; top card is face up
(should (cg-sol--col-top g c)))
(should (= 24 (length (cg-get g :stock))))
(should (cl-every #'null (append (cg-get g :found) nil)))))
(ert-deftest cgt-sol-freecell-deal ()
(let* ((g (cg-sol--deal (cg-freecell-game)))
(total 0))
(should (= 8 (oref g ncols)))
(dotimes (c 8) (cl-incf total (length (cg-sol--col g c)))
(should (= 0 (cg-sol--down g c))))
(should (= 52 total))
(should (null (cg-get g :stock)))
(should (= 4 (length (cg-get g :free))))))
(ert-deftest cgt-sol-spider-deal ()
(let* ((g (cg-sol--deal (cg-spider-game)))
(total 0))
(should (= 10 (oref g ncols)))
(dotimes (c 10) (cl-incf total (length (cg-sol--col g c))))
(should (= 54 total))
(should (= 50 (length (cg-get g :stock))))
(dotimes (c 4) (should (= 6 (length (cg-sol--col g c)))))
(dotimes (k 6) (should (= 5 (length (cg-sol--col g (+ 4 k))))))))
(ert-deftest cgt-sol-rules-alt ()
(let ((g (cg-klondike-game)))
;; red 6 onto black 7 ok; black 6 onto black 7 no
(should (cg-sol--place-p g '(0 . 6) '(3 . 5))) ; 7s under 6h
(should-not (cg-sol--place-p g '(0 . 6) '(1 . 5))) ; 6c on 7s same color
(should (cg-sol--empty-accepts g '(0 . 12))) ; king
(should-not (cg-sol--empty-accepts g '(0 . 11))))) ; queen
(ert-deftest cgt-sol-rules-spider ()
(let ((g (cg-spider-game)))
;; build down any suit
(should (cg-sol--place-p g '(0 . 6) '(3 . 5)))
(should (cg-sol--place-p g '(0 . 6) '(1 . 5)))
;; run cohesion requires same suit
(should (cg-sol--link-p g '(0 . 6) '(0 . 5)))
(should-not (cg-sol--link-p g '(0 . 6) '(1 . 5)))
(should (cg-sol--empty-accepts g '(0 . 3)))))
(ert-deftest cgt-sol-top-run ()
(let ((g (cg-klondike-game)))
(cg-put g :tableau (vector (list '(0 . 9) '(2 . 8) '(1 . 7)))) ; 9s 8d 7c
(cg-put g :down (vector 0))
;; 9s(black) 8d(red) 7c(black) is a valid alt run of 3
(should (= 3 (length (cg-sol--top-run g 0))))
;; break color: 9s 8d 7d -> only 8d 7d? 7d red on 8d red invalid -> run is just 7d
(cg-put g :tableau (vector (list '(0 . 9) '(2 . 8) '(2 . 7))))
(should (= 1 (length (cg-sol--top-run g 0))))))
(ert-deftest cgt-sol-move-col ()
(let ((g (cg-sol--deal (cg-klondike-game))))
;; craft: col0 top = 7c(black), col1 top = 6h(red); move 6h onto 7c
(cg-put g :tableau (vector (list '(1 . 7)) (list '(3 . 6)) nil nil nil nil nil))
(cg-put g :down (vector 0 0 0 0 0 0 0))
(let ((cards (last (cg-sol--col g 1) 1)))
(should (cg-sol--can-drop g '(col . 0) cards))
(cg-sol--take g '(col . 1) 1)
(cg-sol--drop g '(col . 0) cards))
(should (equal '((1 . 7) (3 . 6)) (cg-sol--col g 0)))
(should (null (cg-sol--col g 1)))))
(ert-deftest cgt-sol-foundation-and-win ()
(let ((g (cg-sol--deal (cg-klondike-game))))
;; empty foundations: place an Ace then a 2 of same suit
(should (cg-sol--found-accepts g 0 '(0 . 0)))
(cg-sol--drop g '(found . 0) (list '(0 . 0)))
(should (cg-sol--found-accepts g 0 '(0 . 1)))
(should-not (cg-sol--found-accepts g 0 '(1 . 1)))
;; build a winning state: fill all four foundations A..K
(let ((found (make-vector 4 nil)))
(dotimes (s 4)
(aset found s (cl-loop for r below 13 collect (cons s r))))
(cg-put g :found found))
(should (cg-won-p g))))
(ert-deftest cgt-sol-spider-harvest ()
(let ((g (cg-sol--deal (cg-spider-game))))
;; put a complete K..A spade run as the whole of column 0
(cg-put g :tableau (let ((v (cg-get g :tableau)))
(aset v 0 (cl-loop for r from 12 downto 0 collect (cons 0 r)))
v))
(cg-put g :down (let ((v (cg-get g :down))) (aset v 0 0) v))
(cg-put g :sets 0)
(cg-sol--harvest g)
(should (= 1 (cg-get g :sets)))
(should (null (cg-sol--col g 0)))))
(ert-deftest cgt-sol-undo ()
(let ((g (cg-sol--deal (cg-klondike-game))))
(cg-put g :tableau (vector (list '(1 . 7)) (list '(3 . 6)) nil nil nil nil nil))
(cg-put g :down (vector 0 0 0 0 0 0 0))
(cg-sol--snapshot g)
(let ((cards (last (cg-sol--col g 1) 1)))
(cg-sol--take g '(col . 1) 1)
(cg-sol--drop g '(col . 0) cards))
(should (null (cg-sol--col g 1)))
(should (cg-sol--restore g))
(should (equal '((3 . 6)) (cg-sol--col g 1)))))
(ert-deftest cgt-sol-render-builds ()
(dolist (cls '(cg-klondike-game cg-freecell-game cg-spider-game cg-yukon-game))
(let ((g (cg-sol--deal (make-instance cls))))
(should (stringp (cg-render g))))))
(defun cgt--init-hearts ()
(let ((g (cg-hearts-game)))
(cg-put g :scores (make-vector 4 0))
(cg-trick--start-hand g) g))
(defun cgt--init-spades ()
(let ((g (cg-spades-game)))
(cg-put g :scores (make-vector 4 0))
(cg-put g :bags (make-vector 2 0))
(cg-put g :dealer 3)
(cg-trick--deal g)
(cg-put g :bids (let ((v (make-vector 4 0)))
(dotimes (s 4) (aset v s (cg-trick--ai-bid g s))) v))
(cg-trick--leader-init g) g))
(ert-deftest cgt-trick-deal ()
(let ((g (cg-trick--deal (cg-hearts-game))))
(let ((tot 0))
(dotimes (s 4) (cl-incf tot (length (cg-trick--hand g s))))
(should (= 52 tot)))
(dotimes (s 4) (should (= 13 (length (cg-trick--hand g s)))))))
(ert-deftest cgt-trick-winner-trump ()
(let ((g (cg-spades-game)))
;; play order: S leads 10h, W 13h(K), N 2s(trump), E 12h
(cg-put g :trick (list (cons 3 '(3 . 11)) (cons 2 '(0 . 0))
(cons 1 '(3 . 12)) (cons 0 '(3 . 8))))
;; :trick is stored reversed (newest first); winner = North (trump)
(should (= 2 (cg-trick--winner g)))))
(ert-deftest cgt-trick-winner-notrump ()
(let ((g (cg-hearts-game)))
;; led hearts; highest heart wins (no trump)
(cg-put g :trick (list (cons 3 '(1 . 12)) (cons 2 '(3 . 12))
(cons 1 '(3 . 5)) (cons 0 '(3 . 8))))
;; North played Ace of hearts (3 . 12) -> winner North
(should (= 2 (cg-trick--winner g)))))
(ert-deftest cgt-hearts-first-must-be-2c ()
(let* ((g (cgt--init-hearts))
(leader (cg-get g :turn)))
(let ((moves (cg-trick--legal-moves g leader)))
(should (equal moves '((1 . 0)))))))
(ert-deftest cgt-hearts-full-hand ()
(let ((g (cgt--init-hearts)))
(cg-trick--simulate-hand g)
;; 13 tricks distributed
(should (= 13 (apply #'+ (append (cg-get g :tricks) nil))))
;; total points across players is 26 (no moon) or 78 (moon: 3*26)
(let ((tot (apply #'+ (append (cg-get g :scores) nil))))
(should (memq tot '(26 78))))))
(ert-deftest cgt-hearts-many-hands ()
(let ((g (cgt--init-hearts)) (n 0))
(while (and (not (cg-trick--game-over-p g)) (< n 60))
(cg-trick--simulate-hand g)
(cl-incf n)
(unless (cg-trick--game-over-p g) (cg-trick--start-hand g)))
(should (cg-trick--game-over-p g))
(should (integerp (cg-trick--winner-seat g)))))
(ert-deftest cgt-spades-bid-range ()
(let ((g (cg-trick--deal (cg-spades-game))))
(dotimes (s 4)
(let ((b (cg-trick--ai-bid g s)))
(should (and (>= b 1) (<= b 13)))))))
(ert-deftest cgt-spades-full-hand ()
(let ((g (cgt--init-spades)))
(cg-trick--simulate-hand g)
(should (= 13 (apply #'+ (append (cg-get g :tricks) nil))))
;; teammates share a score
(should (= (aref (cg-get g :scores) 0) (aref (cg-get g :scores) 2)))
(should (= (aref (cg-get g :scores) 1) (aref (cg-get g :scores) 3)))))
(ert-deftest cgt-spades-full-game ()
(let ((g (cgt--init-spades)) (n 0))
(while (and (not (cg-trick--game-over-p g)) (< n 80))
(cg-trick--simulate-hand g)
(cl-incf n)
(unless (cg-trick--game-over-p g)
(cg-trick--deal g)
(cg-put g :bids (let ((v (make-vector 4 0)))
(dotimes (s 4) (aset v s (cg-trick--ai-bid g s))) v))
(cg-trick--leader-init g)))
(should (cg-trick--game-over-p g))))
(ert-deftest cgt-trick-ui-new-and-render ()
(dolist (cls '(cg-hearts-game cg-spades-game))
(let ((noninteractive t)
(g (make-instance cls)))
(cg-trick--new g) ; spades bids via ai (noninteractive), hearts -> pass phase
(should (stringp (cg-render g)))
(should (memq (cg-get g :phase) '(pass play))))))
(ert-deftest cgt-trick-ui-hearts-pass ()
(let* ((noninteractive t) (g (make-instance 'cg-hearts-game)))
(cg-trick--new g)
;; hand 1 passes left; mark 3 cards from South and pass
(when (eq (cg-get g :phase) 'pass)
(cg-put g :marks (cl-subseq (cg-trick--sort (cg-trick--hand g 0)) 0 3))
(cg-trick--do-pass g)
(should (eq (cg-get g :phase) 'play))
;; cards are conserved: hands plus the cards already played this trick
(let ((tot (length (cg-get g :trick))))
(dotimes (s 4) (cl-incf tot (length (cg-trick--hand g s))))
(should (= 52 tot))))))
(ert-deftest cgt-trick-ui-spades-human-play ()
(let* ((noninteractive t) (g (make-instance 'cg-spades-game)))
(cg-trick--new g) ; runs AI until South's turn
(should (eq (cg-get g :phase) 'play))
(should (= 0 (cg-get g :turn)))
;; play a legal card for South, then run; eventually hand completes/scores
(let ((guard 0))
(while (and (eq (cg-get g :phase) 'play) (< guard 20)
(= 0 (cg-get g :turn)))
(let ((card (car (cg-trick--legal-moves g 0))))
(cg-trick--play g 0 card)
(cg-trick--run g))
(cl-incf guard)))
(should (vectorp (cg-get g :scores)))))
(ert-deftest cgt-eights-deal ()
(let* ((cg-eights-players 3) (g (cg-eights--deal (cg-eights-game))))
(should (= 3 (cg-get g :nplayers)))
(dotimes (s 3) (should (= 5 (length (cg-eights--hand g s)))))
(should (cg-eights--top g))
(should-not (= cg-eights--wild (cdr (cg-eights--top g)))))) ; starter not an eight
(ert-deftest cgt-eights-legal ()
(let ((g (cg-eights-game)))
(cg-put g :discard (list '(0 . 3))) (cg-put g :suit 0)
(should (cg-eights--legal-p g '(0 . 8))) ; same suit (spades)
(should (cg-eights--legal-p g '(1 . 3))) ; same rank
(should (cg-eights--legal-p g '(2 . 6))) ; eight (wild)
(should-not (cg-eights--legal-p g '(1 . 4))))) ; neither
(ert-deftest cgt-eights-full-game ()
(let* ((cg-eights-players 4) (noninteractive t) (g (cg-eights--deal (cg-eights-game)))
(guard 0))
;; drive entirely by AI from every seat
(while (and (eq (cg-get g :phase) 'play) (< guard 2000))
(cg-eights--ai-turn g (cg-get g :turn))
(when (>= (cg-get g :passes) (cg-get g :nplayers)) (cg-eights--deadlock g))
(cl-incf guard))
(should (eq (cg-get g :phase) 'game-over))
(should (integerp (cg-get g :winner)))))
(ert-deftest cgt-eights-wild-sets-suit ()
(let* ((cg-eights-players 2) (g (cg-eights--deal (cg-eights-game))))
(cg-eights--set-hand g 0 (list '(3 . 6))) ; the human holds only an eight
(cg-put g :discard (list '(0 . 3))) (cg-put g :suit 0)
(cg-eights--play g 0 '(3 . 6) 2) ; play it, name diamonds (2)
(should (= 2 (cg-get g :suit)))
(should (eq (cg-get g :phase) 'game-over))))
;;;; --- Wave 2 (2026-06-24): Forty Thieves/Scorpion/Canfield, Golf/TriPeaks/Pyramid, Whist/Oh Hell, President ---
(ert-deftest cgt-sol-forty-deal ()
(let ((g (cg-sol--deal (cg-forty-game))) (tot 0))
(should (= 10 (oref g ncols)))
(dotimes (c 10) (should (= 4 (length (cg-sol--col g c)))) (cl-incf tot 4))
(should (= 8 (oref g nfound)))
(should (= 64 (length (cg-get g :stock))))
(should (= 104 (+ tot (length (cg-get g :stock)))))))
(ert-deftest cgt-sol-forty-no-redeal ()
(let ((g (cg-sol--deal (cg-forty-game))))
(cg-put g :stock nil) (cg-put g :waste '((0 . 0) (1 . 1)))
(cg-sol--stock-action g) ; redeal nil -> stays empty
(should (null (cg-get g :stock)))))
(ert-deftest cgt-sol-forty-win ()
(let ((g (cg-sol--deal (cg-forty-game))) (found (make-vector 8 nil)))
(dotimes (i 8) (aset found i (cl-loop for r below 13 collect (cons (mod i 4) r))))
(cg-put g :found found)
(should (cg-won-p g))))
(ert-deftest cgt-sol-scorpion-deal ()
(let ((g (cg-sol--deal (cg-scorpion-game))) (tot 0))
(should (= 7 (oref g ncols)))
(dotimes (c 7) (should (= 7 (length (cg-sol--col g c)))) (cl-incf tot 7))
(dotimes (c 4) (should (= 3 (cg-sol--down g c))))
(dotimes (k 3) (should (= 0 (cg-sol--down g (+ 4 k)))))
(should (= 3 (length (cg-get g :stock))))
(should (= 0 (oref g nfound)))))
(ert-deftest cgt-sol-scorpion-harvest-win ()
(let ((g (cg-sol--deal (cg-scorpion-game))))
(cg-put g :sets 3)
;; place a complete K..A clubs run as column 0
(aset (cg-get g :tableau) 0 (cl-loop for r from 12 downto 0 collect (cons 1 r)))
(aset (cg-get g :down) 0 0)
(cg-sol--harvest g)
(should (= 4 (cg-get g :sets)))
(should (cg-won-p g))))
(ert-deftest cgt-sol-canfield-deal ()
(let ((g (cg-sol--deal (cg-canfield-game))))
(should (= 13 (length (cg-get g :reserve))))
(should (= 1 (length (aref (cg-get g :found) 0))))
(dotimes (c 4) (should (= 1 (length (cg-sol--col g c)))))
(should (= 34 (length (cg-get g :stock))))
;; base equals the rank of the first foundation card
(should (= (oref g base) (cdr (car (aref (cg-get g :found) 0)))))))
(ert-deftest cgt-sol-canfield-base-wrap ()
(let ((g (cg-canfield-game)))
(oset g base 5) (oset g wrap t)
(cg-put g :found (make-vector 4 nil))
(should (cg-sol--found-accepts g 1 '(2 . 5))) ; empty -> base rank 5
(should-not (cg-sol--found-accepts g 1 '(2 . 6)))
;; wrap: a King on top accepts the Ace next
(aset (cg-get g :found) 0 (list '(0 . 12)))
(should (cg-sol--found-accepts g 0 '(0 . 0)))))
(ert-deftest cgt-sol-canfield-autofill ()
(let ((g (cg-sol--deal (cg-canfield-game))))
(let ((rlen (length (cg-get g :reserve))))
(aset (cg-get g :tableau) 0 nil) ; empty a column
(cg-sol--autofill g)
(should (= 1 (length (cg-sol--col g 0))))
(should (= (1- rlen) (length (cg-get g :reserve)))))))
(ert-deftest cgt-pat-golf-deal ()
(let ((g (cg-pat--deal (cg-golf-game))))
(should (= 35 (length (cg-get g :cards))))
(should (= 16 (length (cg-get g :stock))))
(should (= 1 (length (cg-get g :waste))))
(should (= 7 (length (cg-pat--exposed g)))))) ; one per column (r=4)
(ert-deftest cgt-pat-tripeaks-deal ()
(let ((g (cg-pat--deal (cg-tripeaks-game))))
(should (= 28 (length (cg-get g :cards))))
(should (= 23 (length (cg-get g :stock))))
(should (equal (number-sequence 18 27) (cg-pat--exposed g))) ; base row
(should-not (cg-pat--exposed-p g 0)))) ; apex covered
(ert-deftest cgt-pat-pyramid-deal ()
(let ((g (cg-pat--deal (cg-pyramid-game))))
(should (= 28 (length (cg-get g :cards))))
(should (= 24 (length (cg-get g :stock))))
(should (null (cg-get g :waste)))
(should (equal (number-sequence 21 27) (cg-pat--exposed g))) ; base row r=6
(should-not (cg-pat--exposed-p g 0)))) ; apex covered by 1,2
(ert-deftest cgt-pat-exposed-reveal ()
(let ((g (cg-pat--deal (cg-golf-game))))
;; clear column 0's lower cards; slot 0 (top) becomes exposed
(dolist (i '(4 3 2 1)) (cg-pat--remove-slot g i))
(should (cg-pat--exposed-p g 0))))
(ert-deftest cgt-pat-build-and-win ()
(let ((g (cg-pat--deal (cg-golf-game))))
;; reduce to one exposed card adjacent to the waste top
(cg-put g :cards (let ((v (make-vector 35 nil))) (aset v 34 '(0 . 5)) v))
(cg-put g :waste (list '(1 . 4))) ; 5 of clubs, rank 4; 6s is adjacent
(cg-put g :stock nil) (cg-put g :cursor 0)
(with-temp-buffer
(setq cg-pat--game g)
(cg-pat-act)) ; plays slot 34 onto the waste
(should (null (aref (cg-get g :cards) 34)))
(should (cg-won-p g))))
(ert-deftest cgt-pat-sum13 ()
(let ((g (cg-pat--deal (cg-pyramid-game))))
;; King value is 13
(should (= 13 (cg-pat--value '(0 . 12))))
;; mark two base cards summing to 13 -> both removed
(cg-put g :cards (let ((v (make-vector 28 nil)))
(aset v 21 '(0 . 4)) (aset v 22 '(1 . 7)) v)) ; 5 (val5) + 8 (val8) = 13
(cg-put g :marks nil)
(cg-pat--toggle-mark g '(slot . 21))
(cg-pat--toggle-mark g '(slot . 22))
(should (null (aref (cg-get g :cards) 21)))
(should (null (aref (cg-get g :cards) 22)))))
(ert-deftest cgt-pat-render ()
(dolist (cls '(cg-golf-game cg-tripeaks-game cg-pyramid-game))
(let ((g (cg-pat--deal (make-instance cls))))
(should (stringp (cg-render g))))))
(defun cgt--drive (g limit)
"Play a whole match with AI for every seat, including the human seat 0."
(let ((n 0))
(while (and (not (cg-trick--game-over-p g)) (< n limit))
(when (eq (cg-get g :phase) 'play)
(cg-trick--play g (cg-get g :turn) (cg-trick--ai-play g (cg-get g :turn)))
(cg-trick--run g))
(cl-incf n))))
(ert-deftest cgt-whist-deal-trump ()
(let ((noninteractive t) (g (make-instance 'cg-whist-game)))
(cg-trick--new g)
(should (memq (oref g trump) '(0 1 2 3)))
(let ((tot (length (cg-get g :trick))))
(dotimes (s 4) (cl-incf tot (length (cg-trick--hand g s))))
(should (= 52 tot)))))
(ert-deftest cgt-whist-full-game ()
(let ((noninteractive t) (g (make-instance 'cg-whist-game)))
(cg-trick--new g)
(cgt--drive g 400)
(should (cg-trick--game-over-p g))
(should (integerp (cg-trick--winner-seat g)))))
(ert-deftest cgt-ohhell-rounds ()
(let ((noninteractive t) (g (make-instance 'cg-ohhell-game)))
(cg-trick--new g)
;; first round deals 7 cards each
(should (= 7 (length (cg-trick--hand g 0))))
(cgt--drive g 400)
(should (cg-trick--game-over-p g))
(should (= 7 (cg-get g :round))) ; seven rounds played
(should (integerp (cg-trick--winner-seat g)))))
(ert-deftest cgt-ohhell-exact-scoring ()
(let ((g (make-instance 'cg-ohhell-game)))
(cg-put g :scores (make-vector 4 0))
(cg-put g :round 0)
(cg-put g :bids (vector 2 0 1 3))
(cg-put g :tricks (vector 2 1 1 0)) ; seats 0 and 2 made exact bids
(cg-trick--score-hand g)
(should (= 12 (aref (cg-get g :scores) 0))) ; 10 + 2
(should (= 0 (aref (cg-get g :scores) 1))) ; bid 0 took 1 -> miss
(should (= 11 (aref (cg-get g :scores) 2))) ; 10 + 1
(should (= 0 (aref (cg-get g :scores) 3)))))
(ert-deftest cgt-whist-render ()
(let ((noninteractive t) (g (make-instance 'cg-whist-game)))
(cg-trick--new g) (should (stringp (cg-render g)))))
(ert-deftest cgt-pres-power ()
(should (> (cg-pres--power 0) (cg-pres--power 12))) ; the Two beats the Ace
(should (< (cg-pres--power 1) (cg-pres--power 11)))) ; 3 below King
(ert-deftest cgt-pres-deal ()
(let* ((cg-president-players 4) (g (cg-pres--deal (cg-president-game))) (tot 0))
(should (= 4 (cg-get g :nplayers)))
(dotimes (s 4) (cl-incf tot (length (cg-pres--hand g s))))
(should (= 52 tot))
(should (= 0 (cg-get g :count)))))
(ert-deftest cgt-pres-legal ()
(let ((g (cg-president-game)))
(cg-put g :hands (vector (list '(0 . 5) '(1 . 5) '(0 . 8)) nil nil nil))
(cg-put g :nplayers 4)
;; leading: any rank ok
(cg-put g :count 0) (cg-put g :top -1)
(should (= 2 (length (cg-pres--legal-ranks g 0)))) ; ranks 5 and 8
;; following a single of power 5: need power>5 -> only rank 8
(cg-put g :count 1) (cg-put g :top 5)
(should (equal '(8) (cg-pres--legal-ranks g 0)))
;; following a PAIR: need 2 of a higher rank -> rank 5 has two but power 5 not >5; none
(cg-put g :count 2) (cg-put g :top 5)
(should (null (cg-pres--legal-ranks g 0)))))
(ert-deftest cgt-pres-full-game ()
(let* ((cg-president-players 4) (g (cg-pres--deal (cg-president-game))) (n 0))
(while (and (eq (cg-get g :phase) 'play) (< n 5000))
(cg-pres--ai-move g (cg-get g :turn))
(cl-incf n))
(should (eq (cg-get g :phase) 'game-over))
(should (= 4 (length (cg-get g :order)))) ; everyone placed
(should (= 4 (length (delete-dups (copy-sequence (cg-get g :order)))))))) ; all distinct
(ert-deftest cgt-pres-exchange ()
(let* ((cg-president-players 4) (g (cg-president-game)))
;; simulate a prior finishing order, then deal and check the swap happened
(cg-put g :order '(2 3 1 0)) ; prez=2, scum=0
(cg-pres--deal g)
;; conservation: still 52 cards across 4 hands after the exchange
(let ((tot 0)) (dotimes (s 4) (cl-incf tot (length (cg-pres--hand g s))))
(should (= 52 tot)))))
(ert-deftest cgt-pres-render ()
(let ((g (cg-pres--deal (cg-president-game)))) (should (stringp (cg-render g)))))