diff --git a/Makefile b/Makefile index f085770..ecc7d0c 100644 --- a/Makefile +++ b/Makefile @@ -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) diff --git a/README.org b/README.org index 395a507..1fadacb 100644 --- a/README.org +++ b/README.org @@ -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. diff --git a/card-games-pkg.el b/card-games-pkg.el index b4aca71..9bf10e7 100644 --- a/card-games-pkg.el +++ b/card-games-pkg.el @@ -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") diff --git a/card-games.el b/card-games.el index 4f17cb3..de17e2b 100644 --- a/card-games.el +++ b/card-games.el @@ -4,7 +4,7 @@ ;; Author: Corwin Brust ;; Maintainer: Corwin Brust -;; 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.") diff --git a/cg-bid-net.el b/cg-bid-net.el index bf3e145..29ae018 100644 --- a/cg-bid-net.el +++ b/cg-bid-net.el @@ -4,7 +4,7 @@ ;; Author: Corwin Brust ;; Maintainer: Corwin Brust -;; Version: 1.0.50 +;; Version: 1.0.60 ;; Package-Requires: ((emacs "26.1")) ;; Keywords: games ;; URL: https://code.bru.st/corwin/card-game.el diff --git a/cg-bid-ui.el b/cg-bid-ui.el index 472524e..e4d23a5 100644 --- a/cg-bid-ui.el +++ b/cg-bid-ui.el @@ -4,7 +4,7 @@ ;; Author: Corwin Brust ;; Maintainer: Corwin Brust -;; Version: 1.0.50 +;; Version: 1.0.60 ;; Package-Requires: ((emacs "26.1")) ;; Keywords: games ;; URL: https://code.bru.st/corwin/card-game.el diff --git a/cg-bid.el b/cg-bid.el index c6ab108..265dc33 100644 --- a/cg-bid.el +++ b/cg-bid.el @@ -4,7 +4,7 @@ ;; Author: Corwin Brust ;; Maintainer: Corwin Brust -;; Version: 1.0.50 +;; Version: 1.0.60 ;; Package-Requires: ((emacs "26.1")) ;; Keywords: games ;; URL: https://code.bru.st/corwin/card-game.el diff --git a/cg-core.el b/cg-core.el index a22898f..58fb2ea 100644 --- a/cg-core.el +++ b/cg-core.el @@ -4,7 +4,7 @@ ;; Author: Corwin Brust ;; Maintainer: Corwin Brust -;; Version: 1.0.50 +;; Version: 1.0.60 ;; Package-Requires: ((emacs "26.1")) ;; Keywords: games ;; URL: https://code.bru.st/corwin/card-game.el diff --git a/cg-eights.el b/cg-eights.el new file mode 100644 index 0000000..ff2b19c --- /dev/null +++ b/cg-eights.el @@ -0,0 +1,352 @@ +;;; cg-eights.el --- Crazy Eights, a shedding card game -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; Version: 1.0.60 +;; Package-Requires: ((emacs "26.1")) +;; Keywords: games +;; URL: https://code.bru.st/corwin/card-game.el + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; 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 "") #'cg-eights-left) + (define-key map (kbd "") #'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 diff --git a/cg-gaps.el b/cg-gaps.el index d05aa02..f13bfae 100644 --- a/cg-gaps.el +++ b/cg-gaps.el @@ -4,7 +4,7 @@ ;; Author: Corwin Brust ;; Maintainer: Corwin Brust -;; Version: 1.0.50 +;; Version: 1.0.60 ;; Package-Requires: ((emacs "26.1")) ;; Keywords: games ;; URL: https://code.bru.st/corwin/card-game.el diff --git a/cg-net.el b/cg-net.el index 5e8f1c1..7a5d237 100644 --- a/cg-net.el +++ b/cg-net.el @@ -4,7 +4,7 @@ ;; Author: Corwin Brust ;; Maintainer: Corwin Brust -;; Version: 1.0.50 +;; Version: 1.0.60 ;; Package-Requires: ((emacs "26.1")) ;; Keywords: games ;; URL: https://code.bru.st/corwin/card-game.el diff --git a/cg-patience.el b/cg-patience.el new file mode 100644 index 0000000..c08d464 --- /dev/null +++ b/cg-patience.el @@ -0,0 +1,370 @@ +;;; cg-patience.el --- Pile solitaires (Golf, TriPeaks, Pyramid) -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; Version: 1.0.60 +;; Package-Requires: ((emacs "26.1")) +;; Keywords: games +;; URL: https://code.bru.st/corwin/card-game.el + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Three "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 "") #'cg-pat-left) + (define-key map (kbd "") #'cg-pat-right) + (define-key map (kbd "") #'cg-pat-left) + (define-key map (kbd "") #'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 diff --git a/cg-president.el b/cg-president.el new file mode 100644 index 0000000..f060125 --- /dev/null +++ b/cg-president.el @@ -0,0 +1,378 @@ +;;; cg-president.el --- President (Scum), a climbing card game -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; Version: 1.0.60 +;; Package-Requires: ((emacs "26.1")) +;; Keywords: games +;; URL: https://code.bru.st/corwin/card-game.el + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; 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 "") #'cg-pres-left) + (define-key map (kbd "") #'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 diff --git a/cg-render.el b/cg-render.el index eb67f78..4e6a5f8 100644 --- a/cg-render.el +++ b/cg-render.el @@ -4,7 +4,7 @@ ;; Author: Corwin Brust ;; Maintainer: Corwin Brust -;; Version: 1.0.50 +;; Version: 1.0.60 ;; Package-Requires: ((emacs "26.1")) ;; Keywords: games ;; URL: https://code.bru.st/corwin/card-game.el diff --git a/cg-solitaire.el b/cg-solitaire.el new file mode 100644 index 0000000..a2d37f8 --- /dev/null +++ b/cg-solitaire.el @@ -0,0 +1,844 @@ +;;; cg-solitaire.el --- Tableau solitaires (Klondike, FreeCell, Spider, Yukon) -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; Version: 1.0.60 +;; Package-Requires: ((emacs "26.1")) +;; Keywords: games +;; URL: https://code.bru.st/corwin/card-game.el + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; 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 "") #'cg-sol-left) + (define-key map (kbd "") #'cg-sol-right) + (define-key map (kbd "") #'cg-sol-up) + (define-key map (kbd "") #'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 diff --git a/cg-svg.el b/cg-svg.el index 668372c..3a74be5 100644 --- a/cg-svg.el +++ b/cg-svg.el @@ -4,7 +4,7 @@ ;; Author: Corwin Brust ;; Maintainer: Corwin Brust -;; Version: 1.0.50 +;; Version: 1.0.60 ;; Package-Requires: ((emacs "26.1")) ;; Keywords: games ;; URL: https://code.bru.st/corwin/card-game.el diff --git a/cg-trick.el b/cg-trick.el new file mode 100644 index 0000000..f5f438c --- /dev/null +++ b/cg-trick.el @@ -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 +;; Maintainer: Corwin Brust +;; Version: 1.0.60 +;; Package-Requires: ((emacs "26.1")) +;; Keywords: games +;; URL: https://code.bru.st/corwin/card-game.el + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; 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 "") #'cg-trick-left) + (define-key map (kbd "") #'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 diff --git a/known-games.org b/known-games.org new file mode 100644 index 0000000..9240d1e --- /dev/null +++ b/known-games.org @@ -0,0 +1,1113 @@ +#+TITLE: Known Games — research collation for card-games.el +#+AUTHOR: Corwin Brust (research compiled with Mentat) +#+OPTIONS: toc:2 num:nil +#+STARTUP: showall + +* About this file + +This is a *research collation*, not an order list. It records card games +we have looked into, what we learned about their rules, a rough level-of- +effort (LoE) guess as a T-shirt size, and links to authoritative rules. + +We only consider *building* a game once its Rules section is filled in well +enough that we believe we could implement it. People will suggest games +over time; before researching a new one, search this file for its ~name~ to +see whether we have already looked at it and what we found. + +** Meta-table fields + +Each game is a top-level section containing a left-header table with: + +- *name* :: common name (section heading matches). +- *package* :: ~NA~ if unbuilt, otherwise the launch command in + =card-games= (e.g. ~M-x cg-klondike~). +- *players* :: supported player counts. +- *LoE* :: T-shirt size — *S* easier · *M* normal · *H* clearly more work. +- *engine* :: which shared engine/cluster it belongs to (see end). +- *links* :: authoritative rules. +- *added* / *updated* :: ISO dates. + +** T-shirt sizing key + +- *S* :: small — little new logic; mostly reuses an existing engine. +- *M* :: medium — a normal game's worth of new rules/UI. +- *H* :: hard — multi-deck, melding, or heavy scoring; clearly more work. + +* Beggar-My-Neighbour + +| name | Beggar-My-Neighbour | +| package | NA | +| players | 2 (3-4 variants) | +| LoE | S | +| engine | shedding/auto | +| links | https://en.wikipedia.org/wiki/Beggar-my-neighbour | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Deal the whole 52-card deck out evenly, face down, one stack per player. +Players do not look at their cards. In turn, each player plays the top +card of their stack face up to a central pile. Play passes until someone +plays a "penalty card" (an honour): Ace, King, Queen, or Jack. The *next* +player must then pay a forfeit by playing cards to the pile: 4 for an Ace, +3 for a King, 2 for a Queen, 1 for a Jack. If during a forfeit another +honour appears, the forfeit cancels and the obligation flips to the +following player. If a forfeit is paid out with only number cards, the +player who laid the last honour takes the whole central pile and places it +face down under their stack, then leads again. A player who runs out of +cards is out; last player holding cards wins. + +** Notes + +Fully deterministic once dealt — *zero decisions*. Ideal first "auto-play" +demo: the engine just animates. Famous for sometimes never terminating. + +* Briscola + +| name | Briscola | +| package | NA | +| players | 2, 4 (partnership) | +| LoE | M | +| engine | trick (no follow-suit) | +| links | https://en.wikipedia.org/wiki/Briscola · https://www.pagat.com/aceten/briscola.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +40-card Italian deck (or strip 8/9/10... — actually strip the 8s,9s,10s +from a French deck to get 40, ranks A,3,K,Q,J,7,6,5,4,2). Card-point +values: Ace 11, Three 10, King 4, Queen/Horse 3, Jack/Knave 2, others 0 +(total 120). Deal 3 cards each; turn the next card face up — its suit is +the *briscola* (trump) for the hand — and place it half-under the stock. +No requirement to follow suit. Highest briscola wins; else highest card +of the led suit. Winner of each trick draws first from stock, then others, +restoring hands to 3. The last face-up trump is the final card drawn. +Continue until the deck and hands are exhausted (20 tricks total in 2p). +Score the card points captured; 61+ wins. + +** Notes + +No-follow-suit makes the trick resolver simpler than 500/Spades. Shares +the deck/trick/AI scaffolding of the trick cluster; good companion to Scopa +for an "Italian games" set. + +* Canasta + +| name | Canasta | +| package | NA | +| players | 4 (partnership); 2-3 variants | +| LoE | H | +| engine | rummy/meld (multi-deck) | +| links | https://en.wikipedia.org/wiki/Canasta · https://www.pagat.com/rummy/canasta.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Two 52-card decks + 4 jokers (108). Deal 11 each. Jokers and 2s are +wild. Players draw and discard, melding sets of 3+ equal ranks (no runs). +A *canasta* is a meld of 7: *natural/clean* (no wilds, 500 bonus) or +*mixed/dirty* (1-3 wilds, 300 bonus). Red 3s are bonus cards laid aside +(100 each; all four = 800). Black 3s block the discard pile and can only +be melded when going out. Minimum first-meld point count rises with your +team's cumulative score (e.g. 50/90/120). The discard pile can be "frozen" +and taken wholesale if you can meld its top card. Going out requires at +least one canasta; +100 bonus (+200 concealed). Card values: jokers 50, +2s & aces 20, K-8 10, 7-4 & black 3 5. + +** Notes + +The heavyweight of the meld family: wilds, frozen pile, escalating minimums, +multi-deck. Build *Hand and Foot* first (simpler cousin) to prove the meld +engine, then extend. + +* Canfield + +| name | Canfield | +| package | ~M-x cg-canfield~ | +| players | 1 (solitaire) | +| LoE | M | +| engine | tableau-solitaire | +| links | https://en.wikipedia.org/wiki/Canfield_(solitaire) | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52. Deal 13 cards to a face-down *reserve* (demon) with the top +turned up. Deal one card to the first *foundation*; its rank sets the base +rank for all four foundations (they build up in suit, wrapping K→A). Deal +4 cards face up as the *tableau*. Remaining cards form the stock, dealt to +waste 3 at a time with unlimited redeals. Tableau builds down in alter- +nating colour, wrapping A→K; groups move as units. Empty tableau columns +are filled from the reserve (when the reserve empties, from the waste). +Win by building all four foundations up 13 cards. + +** Notes + +Same engine as Klondike/FreeCell plus a *reserve* pile and a *variable +foundation base rank*. Build Klondike first; Canfield is then mostly the +reserve + base-rank wrinkle. Famously hard (~8% win). + +* Casino + +| name | Casino | +| package | NA | +| players | 2-4 | +| LoE | M | +| engine | fishing | +| links | https://en.wikipedia.org/wiki/Cassino_(card_game) · https://www.pagat.com/fishing/casino.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52. Deal 2 to each player and 4 face up to the table (then 2 more +to players, repeating until the deck is gone, 2 at a time). On your turn +play one card to: *capture* table cards of equal rank (face cards by rank +only) or sets of number cards summing to your card's value (A=1); *build* a +combination you can later capture; or *trail* (place a card on the table). +A capture that clears the table is a *sweep* (+1). Number cards count +their pips for building. Scoring at deck's end: most cards 3, most spades +1, the 10♦ ("big casino") 2, the 2♠ ("little casino") 1, each Ace 1, each +sweep 1. Play to 21 over hands. + +** Notes + +Fishing engine, shared with Scopa. Builds are the tricky part (track build +value + owner). Pair with Scopa for the capture-engine cluster. + +* Clock (solitaire) + +| name | Clock | +| package | NA | +| players | 1 (solitaire) | +| LoE | S | +| engine | pile-solitaire | +| links | https://en.wikipedia.org/wiki/Clock_(card_game) | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Deal all 52 into 13 piles of 4 (12 in a clock-face ring + 1 in the centre += Kings). Turn up the centre's top card, slide it face up under the pile +of its rank (Ace=1 … J=11, Q=12, K=centre), and turn up that pile's top +card; continue. You win if all 13 piles are turned face up before the 4th +King surfaces (which ends the game). Pure chance — no decisions. + +** Notes + +Another zero-decision auto-demo, like Beggar-My-Neighbour. Trivial state +machine; nice for testing the renderer's "ring" layout. + +* Concentration (Memory) + +| name | Concentration (Memory / Pairs) | +| package | NA | +| players | 1+ | +| LoE | S | +| engine | grid-flip | +| links | https://en.wikipedia.org/wiki/Concentration_(card_game) | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Shuffle 52 face down in a grid. On a turn, flip two cards; if they match +in rank, keep them and go again; otherwise flip them back. Most pairs +wins. Solo: minimise turns. + +** Notes + +Reuses the Gaps grid + cursor directly; only "face-down + reveal memory" +is new. Good cheap win that exercises the existing board renderer. + +* Crazy Eights + +| name | Crazy Eights | +| package | ~M-x cg-eights~ | +| players | 2-5 | +| LoE | M | +| engine | shedding | +| links | https://en.wikipedia.org/wiki/Crazy_Eights · https://www.pagat.com/eights/crazy8s.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52. Deal 5-7 each; flip one to start the discard pile; rest is +stock. On your turn play a card matching the top card's *rank or suit*. +*Eights are wild* — play any time and name the next suit. If you can't +play, draw from stock (until playable or stock empty, per variant). First +to shed all cards wins; score opponents' remaining cards (8=50, faces 10, +ace 1, else pip). The ancestor of UNO. + +** Notes + +The canonical shedding game; AI is easy (play matching, save eights). +Engine generalises to President-style climbing later. Very popular. + +* Cribbage + +| name | Cribbage | +| package | NA | +| players | 2 (3-4 variants) | +| LoE | M | +| engine | cribbage (own scorer) | +| links | https://en.wikipedia.org/wiki/Rules_of_cribbage · https://www.pagat.com/adders/crib6.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52 + a cribbage board (121 holes). Deal 6 each (2p); each player +discards 2 to the dealer's *crib*. Cut a *starter*; if it's a Jack, dealer +pegs 2 ("his heels"). *The Play (pegging):* alternate laying cards, calling +the running total (face=10, ace=1); never exceed 31. Score during play: +total 15 = 2; 31 = 2; pair = 2, pair-royal = 6, double-pair-royal = 12; +runs of 3+ = length; last card ("go"/last) = 1. Reset to 0 after 31 or a +go. *The Show:* count each hand then the crib (dealer last), with the +starter, for: every combo summing to 15 = 2; pairs = 2; runs = length; +flush = 4 (5 with starter; crib flush needs all 5); Jack of starter's suit +in hand ("his nobs") = 1. First to 121 wins. + +** Notes + +Unique scoring engine (the 15s/pairs/runs/flush counter is the whole game). +No trump, no melds — its own cluster. The combinatorial hand-scorer is the +fun, testable core. High wishlist value. + +* Euchre + +| name | Euchre | +| package | NA | +| players | 4 (partnership); 2-3 variants | +| LoE | M | +| engine | trick (trump + bowers) | +| links | https://en.wikipedia.org/wiki/Euchre · https://www.pagat.com/euchre/euchre.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +24-card deck (9-A in four suits). Deal 5 each; turn the next card up. +Bidding: in turn, *order up* (accept the turned suit as trump, dealer takes +the card) or pass; if all pass, a second round lets players *name* a +different trump. *Bowers:* Jack of trump = highest (right bower); Jack of +same colour = second highest (left bower, counts as trump). The maker's +team must take 3+ of 5 tricks: 3-4 = 1 point, all 5 (march) = 2; *going +alone* and taking all 5 = 4. If the makers fail (*euchred*), defenders get +2. First to 10 points wins. + +** Notes + +Best second trick game after 500: small hand, the bower mechanic is the +only real novelty over the 500/Spades trick resolver. Hugely popular in +the US Midwest. + +* Forty Thieves + +| name | Forty Thieves | +| package | ~M-x cg-forty-thieves~ | +| players | 1 (solitaire) | +| LoE | M | +| engine | tableau-solitaire (2 decks) | +| links | https://en.wikipedia.org/wiki/Forty_Thieves_(solitaire) | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Two decks (104). Deal 10 columns of 4 cards, all face up. Eight +foundations build up by suit A→K. Tableau builds *down by suit*; move one +card at a time (no group moves in the strict rules). Stock dealt one at a +time to a single waste, no redeal. Empty columns take any card. Win by +filling all eight foundations. + +** Notes + +Two-deck tableau game — proves the engine scales to 104 cards and 8 +foundations. Strict (down-by-suit, single-card) so move logic is simpler +than Klondike, but very hard to win. + +* FreeCell + +| name | FreeCell | +| package | ~M-x cg-freecell~ | +| players | 1 (solitaire) | +| LoE | M | +| engine | tableau-solitaire | +| links | https://en.wikipedia.org/wiki/FreeCell · https://www.pagat.com/patience/freecell.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52, *all dealt face up*: 8 columns (first four of 7, last four of +6). Four *free cells* hold one card each. Four foundations build up by +suit A→K. Tableau builds down in alternating colour. Move one card at a +time, but a "supermove" of N cards is allowed when (free cells + 1) × +2^(empty columns) ≥ N. Nearly every deal is winnable. + +** Notes + +Same tableau/foundation engine as Klondike, minus the stock/waste, plus +free cells and the supermove count. No hidden cards → pure skill; great +for a deterministic, fully testable solver-friendly game. Very popular. + +* Gin Rummy + +| name | Gin Rummy | +| package | NA | +| players | 2 | +| LoE | M | +| engine | rummy/meld | +| links | https://en.wikipedia.org/wiki/Gin_rummy · https://www.pagat.com/rummy/gin.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52. Deal 10 each; flip one to start the discard. Draw (stock or +discard top) then discard. Form melds: runs (3+ same suit in sequence) and +sets (3-4 same rank). *Knock* when unmatched ("deadwood") ≤ 10; *gin* when +deadwood = 0 (+25 bonus). After a knock, the opponent lays off cards onto +the knocker's melds; difference in deadwood scores; if the opponent has ≤ +the knocker (*undercut*), they score the difference + 25. Game to 100. + +** Notes + +The two-hand meld game. The deadwood/meld-optimiser (find the best meld +partition to minimise deadwood) is the reusable core for the whole rummy +family. Strong wishlist item. + +* Go Fish + +| name | Go Fish | +| package | NA | +| players | 2-6 | +| LoE | S | +| engine | ask/match | +| links | https://en.wikipedia.org/wiki/Go_Fish · https://www.pagat.com/quartet/gofish.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52. Deal 5-7 each; rest is the "pool". On your turn ask a named +player for a rank you hold; if they have any, they give all of them and you +ask again; else "Go Fish" — draw from the pool (extra turn if you drew the +rank asked). Complete *books* (all 4 of a rank), lay them down; most books +when cards run out wins. + +** Notes + +Simple AI (track who asked for what = basic memory). Hidden-hand info game; +the "ask a player" interaction is new but small. Good kid-friendly title. + +* Golf (solitaire) + +| name | Golf | +| package | ~M-x cg-golf~ | +| players | 1 (solitaire) | +| LoE | S | +| engine | pile-solitaire (waste-build) | +| links | https://en.wikipedia.org/wiki/Golf_(patience) | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52. Deal 7 columns of 5 face up (35). One card to the waste; the +rest is stock. Move an *exposed* tableau card to the waste if it is one +rank higher or lower than the waste top (no wrap unless variant; suit +ignored). When stuck, deal the next stock card to the waste. Clear all +tableau cards to win; score = cards left when stock is exhausted. + +** Notes + +Tiny rule set, one legal-move test (±1 rank). Shares its waste-build core +with TriPeaks. Fast, satisfying, very testable. + +* Hand and Foot + +| name | Hand and Foot | +| package | NA | +| players | 4 (partnership); 2-6 variants | +| LoE | H | +| engine | rummy/meld (multi-deck) | +| links | https://en.wikipedia.org/wiki/Hand_and_Foot_(card_game) · https://www.pagat.com/rummy/handfoot.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Typically 5-6 decks incl. jokers; deal each player a *hand* (11) and a +*foot* (11) — you play the hand first, then pick up the foot. Draw 2, +discard 1. Meld sets of same rank (no runs). *Clean/red* canasta = 7 with +no wilds (500); *dirty/black* = 7 with wilds (300). 2s and jokers wild; +red 3s are bonus. Going out needs a minimum number of clean + dirty +canastas and you must finish the foot. Per-round minimum first-meld counts +rise each round. + +** Notes + +Simpler than full Canasta (sets only, no frozen-pile finesse) so it is the +right *first* multi-deck meld build; Canasta then extends it. On the +original wishlist (3-player Hand and Foot). + +* Hearts + +| name | Hearts | +| package | ~M-x cg-hearts~ | +| players | 3-4 (4 classic) | +| LoE | M | +| engine | trick (avoidance) | +| links | https://en.wikipedia.org/wiki/Hearts_(card_game) · https://www.pagat.com/reverse/hearts.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52, 4 players, deal 13 each. Pass 3 cards (left/right/across/none +rotating). Holder of 2♣ leads it. Follow suit if able; cannot lead hearts +until "broken" (a heart or Q♠ discarded off-suit). No trump. Each heart = +1 penalty, Q♠ = 13. *Shooting the moon:* take all hearts + Q♠ → 0 to self, +26 to everyone else. Play until someone hits 100; lowest score wins. + +** Notes + +Same trick resolver as Spades/500 but *no trump* and *penalty* scoring +(avoidance) + the passing phase + "hearts broken" lead rule. Very popular; +3-handed too (drop 2♦, deal 17). Strong build target this wave. + +* Hell's Half-Acre + +| name | Hell's Half-Acre (Gaps variant) | +| package | card-games (~M-x cg-hells-half-acre~) | +| players | 1 (solitaire) | +| LoE | S (done) | +| engine | gaps-grid | +| links | https://en.wikipedia.org/wiki/Gaps | +| added | 2026-06-23 | +| updated | 2026-06-24 | + +** Rules + +A Gaps/Montana variant built *downward* from Kings (anchor rank K, step +-1). Lay out 52 in a 4×13 grid, remove the four 2s leaving gaps; fill a +gap with the card one rank lower than its left neighbour in the same suit. +Limited redeals. See Montana for the shared machinery. + +** Notes + +*Already implemented* as a subclass of ~cg-gaps-game~ (proves deriving a +game from a shared base). Differs from Montana only by head/step. + +* Klondike + +| name | Klondike | +| package | ~M-x cg-klondike~ | +| players | 1 (solitaire) | +| LoE | M | +| engine | tableau-solitaire | +| links | https://en.wikipedia.org/wiki/Klondike_(solitaire) · https://www.pagat.com/patience/klondike.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52. Seven columns of 1..7 cards, only the last of each face up. +Four foundations build up by suit A→K. Tableau builds down in alternating +colour; only a King (or group headed by one) moves to an empty column. +Turn a hidden card when it becomes the column's last. Stock dealt to waste +1 (or 3) at a time; redeals per variant. Win by sending all 52 to +foundations. This is "Solitaire" as most people know it. + +** Notes + +*The* keystone solitaire — build first; FreeCell, Canfield, Yukon, Forty +Thieves all reuse its tableau/foundation/stock-waste engine. Top priority. + +* Knock Rummy + +| name | Knock Rummy (Poker Rum) | +| package | NA | +| players | 2-5 | +| LoE | M | +| engine | rummy/meld | +| links | https://en.wikipedia.org/wiki/Knock_rummy · https://www.pagat.com/rummy/knockrummy.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Like basic Rummy (draw/discard, melds of sets and runs) but a player may +*knock* on any turn instead of melding as they go: lay down all cards +grouped into melds + deadwood; lowest deadwood wins the difference from +each opponent; knocking with 0 deadwood = rummy bonus. + +** Notes + +Essentially Gin generalised to 2-5 players; if Gin's meld-optimiser exists, +this is an S add-on. Listed M standalone. + +* Montana (Gaps) + +| name | Montana (Gaps) | +| package | card-games (~M-x cg-montana~, ~cg-gaps~) | +| players | 1 (solitaire) | +| LoE | S (done) | +| engine | gaps-grid | +| links | https://en.wikipedia.org/wiki/Gaps | +| added | 2026-06-23 | +| updated | 2026-06-24 | + +** Rules + +Lay out 52 in a 4×13 grid; remove the four Aces leaving gaps. Build each +row upward in a single suit starting at 2 (anchor rank 2, step +1): a gap is +filled by the card one rank higher than its left neighbour, same suit; a gap +to the right of a King (or at row start) is dead. Reshuffle stuck cards a +limited number of times. Win when each row is a single suit 2→K. + +** Notes + +*Already implemented* (~cg-gaps.el~) as the base ~cg-gaps-game~ with the +Hell's-Half-Acre subclass. The project's first solitaire. + +* Napoleon (Nap) + +| name | Napoleon (Nap) | +| package | NA | +| players | 2-6 (best 4-5) | +| LoE | M | +| engine | trick (trump, bidding) | +| links | https://en.wikipedia.org/wiki/Napoleon_(card_game) · https://www.pagat.com/napoleon/nap.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52, deal 5 each. One round of bidding: declare how many of 5 +tricks you will take (2, 3, 4, or "nap" = all 5); highest bid plays alone +vs the rest, the bid suit's first led card... actually trump = the suit the +declarer leads to the first trick. Make your bid to score; fail and you +are set. Simple, fast gambling-style trick game. + +** Notes + +A compact solo-vs-field trick game; reuses the trick resolver with a tiny +bidding layer. Good "lightweight Euchre". + +* Oh Hell + +| name | Oh Hell (Oh Pshaw / Blackout) | +| package | ~M-x cg-ohhell~ | +| players | 3-7 | +| LoE | M | +| engine | trick (exact-bid) | +| links | https://en.wikipedia.org/wiki/Oh_Hell · https://www.pagat.com/exact/ohhell.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52. Hand size changes each round (1,2,3,… up and/or back down). +Deal that many; turn the next card for trump (none in the max round). Each +player bids exactly how many tricks they will take; the *hook* rule forbids +the dealer from making total bids equal the number of tricks. Follow suit; +trump wins. Score: making your bid exactly = 10 + bid (common variant); +missing = 0 (or minus the miss). Most points after all rounds wins. + +** Notes + +Exact-bid scoring is the twist on the trick engine; variable hand size needs +a round driver. Excellent with AI; scales 3-7 players. + +* Old Maid + +| name | Old Maid | +| package | NA | +| players | 2-8 | +| LoE | S | +| engine | pair-discard | +| links | https://en.wikipedia.org/wiki/Old_Maid · https://www.pagat.com/quartet/oldmaid.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Remove one Queen (leaving 51; three Queens form the "old maid"). Deal all +out (uneven OK). Everyone discards pairs from hand. In turn, draw one +(unseen) from the player on your left and discard any new pair. Play until +all pairs are down; whoever holds the odd Queen loses. + +** Notes + +On the original wishlist. Pure mechanism, easy AI; the only state is hands ++ "draw from neighbour". Quick, kid-friendly. + +* Pinochle + +| name | Pinochle (single deck) | +| package | NA | +| players | 2 (4 partnership) | +| LoE | H | +| engine | trick + meld | +| links | https://en.wikipedia.org/wiki/Pinochle · https://www.pagat.com/marriage/pinmain.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +48-card pinochle deck (two each of 9,J,Q,K,10,A in four suits; ranking +A,10,K,Q,J,9). Phases: *bid*, *meld*, *trick*. Deal 12 each (2p). Bidding +sets trump and a target. *Meld* (declared, scored before play): run A-10-K- +Q-J of trump 150; royal marriage (K-Q trump) 40, common marriage 20; +pinochle (Q♠+J♦) 40, double 300; dix (9 of trump) 10; sets like four aces +100, etc. *Trick play:* must follow suit *and* head the trick if able +(win if you can); trump if void. Counters: each Ace/Ten/King = ... (A 11, +10 10, K 4, Q 3, J 2 in common scoring; or the 4/3/2 simplified) plus 1 for +last trick. Add meld + trick points; reaching the target scores, else set. + +** Notes + +The hard trick game: requires both a meld scorer *and* the strict +"must-win-if-able" trick rule + the special 48-card deck. Defer until the +trick engine and a meld scorer (from rummy) both exist. + +* Pitch (Setback) + +| name | Pitch (Auction Pitch / Setback) | +| package | NA | +| players | 2-7 (best 4 partnership) | +| LoE | M | +| engine | trick (point-trump) | +| links | https://en.wikipedia.org/wiki/Pitch_(card_game) · https://www.pagat.com/allfours/pitch.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52, deal 6 each (in 3+3). Bid 1-4 (or pass); high bidder is the +*pitcher* and leads — the suit led to the first trick becomes trump. +Follow suit or trump (you may always trump; off-trump you must follow). +Four points available: *High* (highest trump in play), *Low* (lowest trump +in play, to whoever takes it), *Jack* (of trump, if in play, to its taker), +*Game* (most card-points by value A=4,K=3,Q=2,J=1,10=10). Pitcher must +make the bid or be *set back* (subtract the bid). First to 7 (or 11) wins. + +** Notes + +"Led suit becomes trump" + the High/Low/Jack/Game point tally are the new +bits over the trick engine. Classic Americana; partnership variant fits the +4-seat scaffold. + +* President + +| name | President (Scum) | +| package | ~M-x cg-president~ | +| players | 3-8 (best 4-6) | +| LoE | M | +| engine | climbing/shedding | +| links | https://en.wikipedia.org/wiki/President_(card_game) · https://www.pagat.com/climbing/president.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52. Deal all out. Rank high→low: 2,A,K,Q,J,10,…,3. Leader plays +1-4 of a kind; each player in turn must play the *same count* of a strictly +higher rank or pass; once all but one pass (or someone matches a "complete" +set per variant), the pile clears and the last player leads. First out = +President, last = Scum. Next deal, Scum gives the President their two best +cards and gets two free choices back (Vice ranks trade one). + +** Notes + +The climbing-game archetype (extends the Crazy-Eights shedding core with a +"must beat the last play" comparator + role/exchange meta). Lively with +AI; build Crazy Eights first. + +* Pyramid + +| name | Pyramid | +| package | ~M-x cg-pyramid~ | +| players | 1 (solitaire) | +| LoE | M | +| engine | pile-solitaire (sum-13) | +| links | https://en.wikipedia.org/wiki/Pyramid_(solitaire) | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52. Deal 28 in a 7-row triangle (each card half-covered by two +below). Remove pairs of *exposed* cards summing to 13 (A=1, J=11, Q=12, K= +13 removed alone). Deal stock to waste; pair waste/exposed cards. Redeals +per variant. Clear the pyramid to win. + +** Notes + +The "sum to N" matcher (cf. Gaps' rank logic) over a triangular exposure +graph. Distinct exposure model from Klondike; share the "sum-13" rule with +nothing else, but the renderer's triangle is reusable for TriPeaks. + +* Rummy (Basic / 500 Rum) + +| name | Rummy (Basic / 500 Rum) | +| package | NA | +| players | 2-6 | +| LoE | M | +| engine | rummy/meld | +| links | https://en.wikipedia.org/wiki/Rummy · https://www.pagat.com/rummy/500rum.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52. Deal 7 (2p) / 10 etc. Draw (stock or discard) then discard. +Meld runs (3+ same-suit sequence) and sets (3-4 same rank) to the table; +*lay off* onto existing melds. Basic: first to shed all wins, score +opponents' cards. *500 Rum:* melds score their card values (A=15 or 1, face +10, pip face value); you may take *any* card from the discard pile if you +immediately meld it (and everything above it joins your hand); play to 500. + +** Notes + +On the original wishlist (rummy 500). Shares the meld model with Gin; 500 +Rum adds melds-score-points + deep-discard-take. Core rummy build. + +* Scopa + +| name | Scopa | +| package | NA | +| players | 2, 4 (partnership) | +| LoE | M | +| engine | fishing | +| links | https://en.wikipedia.org/wiki/Scopa · https://www.pagat.com/fishing/scopa.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +40-card deck (strip 8/9/10 from French deck; ranks A=1..7,J=8,Horse/Q=9, +K=10 for capture). Deal 3 each, 4 to the table. Play a card to *capture* +a table card of equal value, or a set summing to it; if both a single and a +combo are possible, the single is forced. Capturing all table cards = a +*scopa* (+1). Refill hands 3 at a time from stock. End scoring: most cards +1, most coins/diamonds 1, the *settebello* (7♦) 1, best *primiera* 1 +(per-suit best card: 7=21,6=18,A=16,5=15,4=14,3=13,2=12,face=10), plus each +scopa. Play to 11. + +** Notes + +Fishing engine shared with Casino; primiera scoring is the fiddly part. +Pairs with Briscola for an Italian set. Uses a 40-card deck — the engine +already abstracts the deck. + +* Scorpion + +| name | Scorpion | +| package | ~M-x cg-scorpion~ | +| players | 1 (solitaire) | +| LoE | M | +| engine | tableau-solitaire | +| links | https://en.wikipedia.org/wiki/Scorpion_(solitaire) | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52. Seven columns of 7 (top three rows of the first four columns +face down). Build *down by suit*; unlike Spider you may move a card *with +everything on top of it* regardless of order. Stock of 3 cards dealt to +the column bottoms when stuck. Goal: four K→A suit sequences. + +** Notes + +A "move the buried pile" twist on the tableau engine, kin to Spider but +single-deck. Good once Spider exists. + +* Snap + +| name | Snap | +| package | NA | +| players | 2-4 | +| LoE | S | +| engine | reflex/match | +| links | https://en.wikipedia.org/wiki/Snap_(card_game) | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Deal all out face down. Players in turn flip their top card to a personal +face-up pile. When two face-up tops show the same rank, the first to call +"Snap!" takes both piles. Collect all cards to win. + +** Notes + +Reflex game — needs a *timed* input (press key fastest). AI "reaction +time" is a tunable delay. Tests the engine's real-time input path; small. + +* Spades + +| name | Spades | +| package | ~M-x cg-spades~ | +| players | 4 (partnership) | +| LoE | M | +| engine | trick (trump, bid, partnership) | +| links | https://en.wikipedia.org/wiki/Spades · https://www.pagat.com/auctionwhist/spades.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52, 4 players in 2 partnerships, deal 13 each. Spades are *always +trump*. Each player bids the tricks they expect (0 = *nil*, with bonus/ +penalty). Follow suit; cannot lead spades until "broken" (a spade played +off-suit) unless only spades remain. Score: making the team's combined bid += 10 × bid + 1 per overtrick ("bag"); 10 bags = -100; missing the bid = -10 +× bid; nil made = +100 (failed -100). First to 500 wins. + +** Notes + +*Closest game to the already-built 500*: bidding + partnership + tricks + +spades-always-trump (simpler than 500's complex trump/joker). The cg-bid +trick/partnership machinery is the most directly reusable here. Top +trick-game target this wave. On the original wishlist (four-player spades). + +* Spider + +| name | Spider | +| package | ~M-x cg-spider~ | +| players | 1 (solitaire) | +| LoE | M | +| engine | tableau-solitaire (2 decks) | +| links | https://en.wikipedia.org/wiki/Spider_(solitaire) · https://www.pagat.com/patience/spider.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Two decks (104). Ten columns (four of 6, six of 5; only the bottom card +of each face up). Build *down regardless of suit*, but you may only move a +*run of the same suit* as a unit. Complete a K→A same-suit run and it is +removed. Stock deals one card to every column at once (no empty columns +allowed when dealing). 1/2/4-suit difficulty variants. Win by removing +all eight suit-runs. + +** Notes + +On the wishlist. Two-deck tableau; the "same-suit run moves/clears" rule is +the novelty. Difficulty knob (suits) is a nice defcustom. Build after +Klondike; shares the column/foundation-removal engine. + +* Spit (Speed) + +| name | Spit (Speed) | +| package | NA | +| players | 2 | +| LoE | M | +| engine | real-time tableau | +| links | https://en.wikipedia.org/wiki/Spit_(card_game) | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Split the deck between two players. Each lays a personal tableau (5 +stockpiles) and keeps a "spit" pile. On "spit", both flip a centre card +simultaneously; players *race* (no turns) to play tableau cards onto either +centre pile, building up or down by one (wrapping). When both stuck, spit +again. First to empty their cards wins the round; loser takes the smaller +centre pile. + +** Notes + +Real-time, two-pile build ±1 with wrap. Needs the timed-input loop (like +Snap) plus a reactive AI. Hardest of the "fast" games to make feel fair vs +AI; M. + +* Spite and Malice + +| name | Spite and Malice (Cat and Mouse) | +| package | NA | +| players | 2 (3+ variants) | +| LoE | M | +| engine | stock-race / shedding | +| links | https://en.wikipedia.org/wiki/Spite_and_Malice · https://www.pagat.com/eights/spite.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Two decks + jokers. Each player has a face-down *pay-off* (goal) pile; +race to empty it. Shared centre *build* piles go up A→Q (Kings wild); +complete a pile (Q) and it is recycled. On your turn play from hand, +pay-off top, or four personal discard piles onto the centre; you must start +each centre pile with an Ace. End your turn by discarding to one of your +four discard piles. First to exhaust the pay-off pile wins. + +** Notes + +Solitaire-flavoured competitive build game; reuses foundation "build up" +logic with wild Kings. Good 2-player title that isn't a trick or rummy +game. + +* TriPeaks + +| name | TriPeaks | +| package | ~M-x cg-tripeaks~ | +| players | 1 (solitaire) | +| LoE | S | +| engine | pile-solitaire (waste-build) | +| links | https://en.wikipedia.org/wiki/Tri_Peaks_(card_game) | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52. Deal 18 cards as three overlapping peaks over a row of 10 +(28 on the board), rest is stock. Move an *exposed* board card to the waste +if it is ±1 rank from the waste top (wrap A-K-A); chain as far as you can. +Deal from stock when stuck. Clear the board to win; longer chains score +more. + +** Notes + +Same ±1 waste-build as Golf, on a peaks layout (renderer shares Pyramid's +triangle). Combine Golf + TriPeaks behind one engine. + +* War + +| name | War | +| package | NA | +| players | 2 | +| LoE | S | +| engine | auto/compare | +| links | https://en.wikipedia.org/wiki/War_(card_game) | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Split the deck in two face-down stacks. Both flip the top card; higher +rank takes both. Tie = "war": each lays 3 face down + 1 up; higher up-card +takes all (recurse on further ties). Collect all 52 to win. + +** Notes + +Zero-decision auto-demo (like Beggar/Clock). Trivial; nice for animation +and as the very first "two-player" engine smoke test. + +* Whist + +| name | Whist | +| package | ~M-x cg-whist~ | +| players | 4 (partnership) | +| LoE | M | +| engine | trick (trump, no bid) | +| links | https://en.wikipedia.org/wiki/Whist · https://www.pagat.com/whist/whist.html | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52, 4 players in 2 partnerships, deal 13 each; turn the dealer's +last card up for trump (it joins their hand). No bidding. Follow suit; +trump wins; highest of led suit otherwise. Score 1 point per trick over 6 +("the book"); honours variants optional. Game to 5 (short) or 9 (long). + +** Notes + +The purest trick game — the trick engine with *no bidding* and a fixed +trump. Easiest trick-game build; a good first proof of the shared trick +resolver before Spades/Hearts add their twists. + +* Yukon + +| name | Yukon | +| package | ~M-x cg-yukon~ | +| players | 1 (solitaire) | +| LoE | S | +| engine | tableau-solitaire | +| links | https://en.wikipedia.org/wiki/Yukon_(solitaire) | +| added | 2026-06-24 | +| updated | 2026-06-24 | + +** Rules + +Standard 52. Like Klondike's seven columns, but *all* remaining cards are +dealt face up onto the columns (no stock/waste). Build foundations up by +suit A→K. Tableau builds down in alternating colour, but you may move *any* +face-up card together with every card on top of it (the group need not be +ordered). Empty columns take Kings (+ their pile). + +** Notes + +Klondike layout with "grab-any-buried-group" moves and no stock — an *S* +add-on once the Klondike tableau engine exists. + +* 500 (Bid) + +| name | 500 (Bid) | +| package | card-games (~M-x cg-bid~) | +| players | 4 (partnership); + live multiplayer | +| LoE | H (done) | +| engine | trick (trump+joker, bid, kitty) | +| links | https://en.wikipedia.org/wiki/500_(card_game) · https://www.pagat.com/euchre/500.html | +| added | 2026-06-23 | +| updated | 2026-06-24 | + +** Rules + +Implemented: 43/45-card variant, 5-card kitty, Avondale bidding (suits + +NT + misère/open misère), joker > right/left bower trump order, 10 tricks, +front-door win at 500 on a made contract, back-door loss at -500. Networked +host-authoritative live play (~M-x cg-bid-host~ / ~cg-bid-join~). + +** Notes + +*Already implemented* (~cg-bid.el~, ~cg-bid-ui.el~, ~cg-bid-net.el~) with +smart AI and SVG table UI. The reference trick implementation that Spades/ +Hearts/Euchre/Whist will factor a shared engine out of. + +* Shared engines / clusters (build-planning view) + +Games group by the engine they want, which drives the build order: + +- *gaps-grid* (DONE) :: Montana, Hell's Half-Acre. Reusable for + Concentration (face-down grid). +- *tableau-solitaire* :: Klondike → FreeCell, Canfield, Yukon, Forty + Thieves, Scorpion, Spider (2-deck). One stock/waste/foundation/column + engine; biggest single payoff (≥7 games, all solo, no user input). +- *pile-solitaire* :: Golf, TriPeaks (shared ±1 waste-build), Pyramid + (sum-13), Clock (auto). +- *trick* :: 500 (DONE, reference) → Whist (no bid) → Spades, Hearts (bid/ + penalty + partnership) → Euchre, Oh Hell, Pitch, Napoleon, Briscola → + Pinochle (adds meld). Factor a ~cg-trick~ base from cg-bid. +- *shedding/climbing* :: Crazy Eights → President. +- *rummy/meld* :: Gin → Rummy/500 Rum, Knock Rummy → Hand and Foot → + Canasta. One meld-finder/scorer reused throughout. +- *fishing* :: Scopa, Casino (shared capture-by-value engine). +- *auto (zero-decision)* :: War, Beggar-My-Neighbour, Clock, Snap (Snap + adds timed input). +- *own scorer* :: Cribbage (15s/pairs/runs/flush counter). +- *stock-race* :: Spite and Malice. + +** Build priorities (no user input needed · unlocks others · popular) + +1. *tableau-solitaire engine + Klondike, FreeCell, Spider* — solo, no + input, hugely popular, unlocks Canfield/Yukon/Forty Thieves/Scorpion. +2. *trick engine + Spades and Hearts* — most popular trick games, reuse the + 500 machinery, unlock Euchre/Whist/Oh Hell/Pitch. +3. *Crazy Eights* — popular, self-contained, unlocks President. +4. *pile-solitaire + Golf/TriPeaks*; *Cribbage*; then the rummy and fishing + clusters. + diff --git a/test/card-games-tests.el b/test/card-games-tests.el index 767d0c8..92cf653 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -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)))))