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

Add the rummy family: meld engine + Gin, Rummy, Rummy 500, Hand & Foot

Browse source 
Introduce a shared meld engine and four games built on it, all on
cg-core/EIEIO with console UNICODE rendering.

* cg-rummy.el: the meld engine and Gin Rummy.  Set/run validation,
  candidate-meld enumeration, a bitmask-DP minimum-deadwood partition,
  and a layoff finder, plus the abstract cg-rummy-game base and shared
  render helpers.  Gin is two-handed with draw/take/discard/knock, gin
  and undercut bonuses, opponent layoffs, and play to 100.

* cg-rum500.el: the abstract cg-tablemeld-game (one mode and command
  set, dispatching on the subclass) driving Basic Rummy (meld out;
  score the cards left in other hands; to 100) and Rummy 500 (score the
  cards you lay down, lose those left in hand; ace high and worth 15;
  to 500).

* cg-handfoot.el: Hand & Foot, a partnership Canasta cousin.  Hand and
  foot packets, Twos and Jokers wild, rank books with clean/dirty piles,
  go-out bonus, and partnership scoring to 5000.  Deliberately
This commit is contained in:
Corwin Brust 2026-06-25 05:53:02 -05:00
parent b5410e1830
commit 86c44a362a
8 changed files with 1782 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -3,7 +3,7 @@ EMACS ?= emacs
PKG = card-games
VERSION = 1.0.60
# Source files in dependency order (cg-core first).
EL = cg-core.el cg-svg.el cg-render.el cg-net.el cg-bid.el cg-gaps.el cg-bid-ui.el cg-bid-net.el cg-solitaire.el cg-trick.el cg-eights.el cg-patience.el cg-president.el card-games.el
EL = cg-core.el cg-svg.el cg-render.el cg-net.el cg-bid.el cg-gaps.el cg-bid-ui.el cg-bid-net.el cg-solitaire.el cg-trick.el cg-eights.el cg-patience.el cg-president.el cg-rummy.el cg-rum500.el cg-handfoot.el card-games.el
ELC = $(EL:.el=.elc)
PKGDESC = $(PKG)-pkg.el
TARDIR = $(PKG)-$(VERSION)

14
README.org
View file

@ -60,6 +60,20 @@ with its command.
beat it or pass; first out rules, last out scrubs, and the roles trade
cards on the next deal.
** Rummy
- ~cg-gin~ -- Gin Rummy. A two-handed duel: draw or take the discard,
build sets and runs, and knock once your deadwood is ten or less, or go
gin with none; your opponent then lays off and may undercut you. First
to 100 wins.
- ~cg-rummy-basic~ -- Rummy. Meld sets and runs onto the table and lay
cards off onto them; empty your hand to go out and score the cards left
in the other hands.
- ~cg-rum500~ -- Rummy 500. As above, but you score the cards you lay
down and lose the cards left in your hand; first past 500 wins.
- ~cg-handfoot~ -- Hand & Foot. A partnership Canasta cousin: play a hand
and then a foot, build books of a rank with Twos and Jokers wild, and go
out once your side has completed two of them.
* TODO
- [X] make the suit symbols customizable (~cg-symbols~) and obey them
- [ ] a Texinfo manual

13
card-games.el
View file

@ -49,6 +49,9 @@
(require 'cg-eights)
(require 'cg-patience)
(require 'cg-president)
(require 'cg-rummy)
(require 'cg-rum500)
(require 'cg-handfoot)
(defvar card-games-list
'(("500 (Bid)" cg-bid
@ -88,7 +91,15 @@
("Oh Hell" cg-ohhell
"Trick-taking: shrinking hands; bid the exact tricks you will take.")
("President" cg-president
"Climbing: shed your hand; first out rules, last out scrubs."))
"Climbing: shed your hand; first out rules, last out scrubs.")
("Gin Rummy" cg-gin
"Rummy: form melds, knock with little deadwood; head to head to 100.")
("Rummy" cg-rummy-basic
"Rummy: meld your whole hand to the table to go out.")
("Rummy 500" cg-rum500
"Rummy: score the cards you lay down; race past 500.")
("Hand & Foot" cg-handfoot
"Rummy: partnership Canasta cousin; build books from hand and foot."))
"Registry of playable games.
Each entry is (NAME COMMAND DESCRIPTION); `card-game' lists them.")

535
cg-handfoot.el Normal file
View file

@ -0,0 +1,535 @@
;;; cg-handfoot.el --- Hand and Foot, a partnership rummy -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Corwin Brust
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Hand & Foot, a Canasta cousin played in partnerships. Each player is
;; dealt two packets: a "hand" played first and a "foot" taken up once the
;; hand is gone. Partners build *books* -- three or more cards of one
;; rank, suits ignored -- on the table; a book of seven is complete (a
;; "pile"), clean if it holds no wild card and dirty if it does. Twos and
;; Jokers are wild. You go out, ending the round, once your side owns at
;; least two complete books and you can empty your foot.
;;
;; You partner the North player against East and West, all three of them
;; computer opponents. Mark cards with SPC, meld them with m, lay off onto
;; a book with l, and discard with RET.
;;
;; This is a deliberately streamlined Hand & Foot: it omits picking up the
;; discard pile, the red-three bonus, and round-by-round minimum-meld
;; requirements, keeping the books, wilds, hand/foot, and partnership
;; scoring that give the game its character. Cards use the package cons
;; (SUIT . RANK), RANK 0 (Ace) .. 12 (King), with jokers as (joker . 0).
;;; Code:
(require 'cl-lib)
(require 'eieio)
(require 'cg-core)
(require 'cg-rummy)
(defcustom cg-handfoot-target 5000
"Points a partnership needs to win Hand & Foot."
:type 'integer :group 'card-games)
(defconst cg-handfoot--names ["You" "West" "North" "East"]
"Seat labels; North is your partner.")
(defclass cg-handfoot-game (cg-rummy-game)
((vname :initform "Hand & Foot"))
"A game of Hand & Foot.")
;;;; Cards
(defun cg-hf--wild-p (card)
"Return non-nil when CARD is wild (a Joker or a Two)."
(or (cg-rummy-joker-p card) (= (cdr card) 1)))
(defun cg-hf--three-p (card)
"Return non-nil when CARD is a three (never meldable)."
(and (not (cg-rummy-joker-p card)) (= (cdr card) 2)))
(defun cg-hf-value (card)
"Return the Hand & Foot point value of CARD."
(cond ((cg-rummy-joker-p card) 50)
(t (let ((r (cdr card)))
(cond ((= r 1) 20) ; Two (wild)
((= r 0) 20) ; Ace
((= r 2) 5) ; Three
((<= r 6) 5) ; 4 5 6 7
(t 10)))))) ; 8 9 10 J Q K
(defun cg-hf--book-rank (cards)
"Return the natural rank shared by CARDS, or nil if invalid."
(let ((nats (cl-remove-if #'cg-hf--wild-p cards)))
(and nats
(let ((r (cdr (car nats))))
(and (cl-every (lambda (c) (= (cdr c) r)) nats)
(/= r 2)
r)))))
(defun cg-hf--book-valid-p (cards)
"Return non-nil when CARDS form a legal book."
(let* ((nats (cl-remove-if #'cg-hf--wild-p cards))
(wilds (cl-remove-if-not #'cg-hf--wild-p cards)))
(and (>= (length cards) 3)
(cg-hf--book-rank cards)
(>= (length nats) 2)
(<= (length wilds) 3)
(<= (length wilds) (length nats)))))
(defun cg-hf--book-complete-p (cards) (>= (length cards) 7))
(defun cg-hf--book-clean-p (cards) (not (cl-some #'cg-hf--wild-p cards)))
;;;; Setup
(defun cg-hf--team (game s) (mod s (cg-get game :nteams)))
(cl-defmethod cg-hf--deal ((game cg-handfoot-game))
"Deal a fresh round into GAME."
(let* ((n (cg-get game :nplayers))
(decks (1+ n))
(deck (cg-rummy-deck decks 2))
(hands (make-vector n nil)) (feet (make-vector n nil))
(stage (make-vector n 0)))
(dotimes (s n)
(aset hands s (cg-rummy-sort-hand (cl-loop repeat 11 collect (pop deck))))
(aset feet s (cg-rummy-sort-hand (cl-loop repeat 11 collect (pop deck)))))
(cg-put game :hands hands)
(cg-put game :feet feet)
(cg-put game :stage stage)
(cg-put game :books (make-vector (cg-get game :nteams) nil))
(cg-put game :discard (list (pop deck)))
(cg-put game :stock deck)
(cg-put game :turn 0)
(cg-put game :step 'draw)
(cg-put game :phase 'play)
(cg-put game :cursor 0)
(cg-put game :marks nil)
(cg-put game :message "Your turn: s draws two cards.")
game))
(defun cg-hf--books (game team) (aref (cg-get game :books) team))
(defun cg-hf--set-books (game team v) (aset (cg-get game :books) team v))
;;;; Engine
(defun cg-hf--draw2 (game s)
"Draw two stock cards into seat S's hand. Return nil if stock runs out."
(let ((ok t))
(dotimes (_ 2)
(let ((stock (cg-get game :stock)))
(if (null stock) (setq ok nil)
(cg-rummy--set-hand game s (cg-rummy-sort-hand
(cons (car stock) (cg-rummy--hand game s))))
(cg-put game :stock (cdr stock)))))
ok))
(defun cg-hf--meld (game s cards)
"Have seat S lay CARDS as a new book for their team. Return non-nil on win."
(when (and (cg-hf--book-valid-p cards)
(cl-subsetp cards (cg-rummy--hand game s) :test #'equal))
(let ((team (cg-hf--team game s)))
(dolist (c cards)
(cg-rummy--set-hand game s (cg-rummy--remove1 c (cg-rummy--hand game s))))
(cg-hf--set-books game team
(append (cg-hf--books game team)
(list (cg-rummy-sort-hand (copy-sequence cards)))))
t)))
(defun cg-rummy--remove1 (card list)
"Return LIST with one copy of CARD (an `equal' match) removed."
(let ((seen nil))
(cl-remove-if (lambda (c) (and (not seen) (equal c card) (setq seen t))) list)))
(defun cg-hf--layoff (game s card)
"Lay CARD off onto a team book it fits. Return non-nil on success."
(let* ((team (cg-hf--team game s)) (books (cg-hf--books game team)) (done nil))
(catch 'hit
(dolist (bk books)
(unless (cg-hf--book-complete-p bk)
(let ((cand (cons card bk)))
(when (cg-hf--book-valid-p cand)
(cg-rummy--set-hand game s (cg-rummy--remove1 card (cg-rummy--hand game s)))
(setcar (memq bk books) (cg-rummy-sort-hand cand))
(setq done t)
(throw 'hit t))))))
done))
(defun cg-hf--advance (game s)
"After a play, take up the foot or finish, then pass the turn."
(let ((stage (cg-get game :stage)))
(when (and (= (aref stage s) 0) (null (cg-rummy--hand game s)))
;; hand exhausted: pick up the foot
(aset stage s 1)
(cg-rummy--set-hand game s (aref (cg-get game :feet) s)))
(if (and (= (aref stage s) 1) (null (cg-rummy--hand game s))
(cg-hf--can-go-out-p game (cg-hf--team game s)))
(cg-hf--score-round game s)
(cg-put game :turn (mod (1+ s) (cg-get game :nplayers)))
(cg-put game :step 'draw))))
(defun cg-hf--can-go-out-p (game team)
"Return non-nil when TEAM owns at least two complete books."
(>= (cl-count-if #'cg-hf--book-complete-p (cg-hf--books game team)) 2))
(defun cg-hf--discard (game s card)
"Discard CARD from seat S and end the play portion of the turn."
(cg-rummy--set-hand game s (cg-rummy--remove1 card (cg-rummy--hand game s)))
(cg-put game :discard (cons card (cg-get game :discard)))
(cg-hf--advance game s))
(cl-defmethod cg-hf--score-round ((game cg-handfoot-game) outseat)
"Score the round (OUTSEAT went out, or nil if the stock ran dry)."
(let* ((nt (cg-get game :nteams)) (scores (cg-get game :scores)))
(dotimes (team nt)
(let ((pts 0))
(dolist (bk (cg-hf--books game team))
(dolist (c bk) (setq pts (+ pts (cg-hf-value c))))
(when (cg-hf--book-complete-p bk)
(setq pts (+ pts (if (cg-hf--book-clean-p bk) 500 300)))))
(when (and outseat (= (cg-hf--team game outseat) team))
(setq pts (+ pts 100))) ; going-out bonus
;; subtract cards left in members' hands and feet
(dotimes (s (cg-get game :nplayers))
(when (= (cg-hf--team game s) team)
(dolist (c (cg-rummy--hand game s)) (setq pts (- pts (cg-hf-value c))))
(when (= (aref (cg-get game :stage) s) 0)
(dolist (c (aref (cg-get game :feet) s))
(setq pts (- pts (cg-hf-value c)))))))
(aset scores team (+ (aref scores team) pts))))
(let ((win nil) (best most-negative-fixnum))
(dotimes (team nt)
(when (and (>= (aref scores team) cg-handfoot-target)
(> (aref scores team) best))
(setq win team best (aref scores team))))
(cg-put game :phase (if win 'game-over 'round-over))
(cg-put game :winner (or win (and outseat (cg-hf--team game outseat))))
(cg-put game :reveal t)
(cg-put game :message
(concat
(if outseat (format "%s goes out! " (aref cg-handfoot--names outseat))
"Stock exhausted. ")
(if win (format "Team %d wins the game! (n: new game)" win)
(format "Round over. Scores: %s. (n: next round)"
(cg-hf--scores-string game))))))))
(defun cg-hf--scores-string (game)
"Return a compact per-team score line for GAME."
(let ((scores (cg-get game :scores)) (parts '()))
(dotimes (team (cg-get game :nteams))
(push (format "Team %d %d" team (aref scores team)) parts))
(mapconcat #'identity (nreverse parts) " · ")))
;;;; AI
(defun cg-hf--ai-meld (game s)
"Lay down and extend books for seat S as far as is easy."
;; lay off naturals onto existing incomplete team books
(let ((again t))
(while again
(setq again nil)
(let ((card (cl-find-if
(lambda (c)
(and (not (cg-hf--wild-p c)) (not (cg-hf--three-p c))
(cl-find-if
(lambda (bk) (and (not (cg-hf--book-complete-p bk))
(equal (cg-hf--book-rank bk) (cdr c))))
(cg-hf--books game (cg-hf--team game s)))))
(cg-rummy--hand game s))))
(when card (cg-hf--layoff game s card) (setq again t)))))
;; start new books from ranks with >=3 naturals in hand
(let ((again t))
(while again
(setq again nil)
(let* ((hand (cg-rummy--hand game s))
(byrank (make-hash-table :test 'eql)) (target nil))
(dolist (c hand)
(unless (or (cg-hf--wild-p c) (cg-hf--three-p c))
(push c (gethash (cdr c) byrank))))
(maphash (lambda (_r cs) (when (and (not target) (>= (length cs) 3))
(setq target cs)))
byrank)
(when target
(cg-hf--meld game s (cl-subseq target 0 (min 7 (length target))))
(setq again t)))))
;; push a nearly-complete book to seven with a spare wild
(let ((again t))
(while again
(setq again nil)
(let ((wild (cl-find-if #'cg-hf--wild-p (cg-rummy--hand game s)))
(team (cg-hf--team game s)))
(when wild
(let ((bk (cl-find-if
(lambda (b)
(and (not (cg-hf--book-complete-p b))
(>= (length b) 5)
(> (cl-count-if-not #'cg-hf--wild-p b)
(cl-count-if #'cg-hf--wild-p b))
(< (cl-count-if #'cg-hf--wild-p b) 3)))
(cg-hf--books game team))))
(when bk
(cg-rummy--set-hand game s (cg-rummy--remove1 wild (cg-rummy--hand game s)))
(setcar (memq bk (cg-hf--books game team))
(cg-rummy-sort-hand (cons wild bk)))
(setq again t))))))))
(defun cg-hf--ai-discard-card (game s)
"Return the card seat S should discard."
(let ((hand (cg-rummy--hand game s)))
(or (cl-find-if #'cg-hf--three-p hand)
;; a high singleton, else the first card
(let ((byrank (make-hash-table :test 'eql)) (best (car hand)) (bestv -1))
(dolist (c hand) (unless (cg-hf--wild-p c)
(push c (gethash (cdr c) byrank))))
(maphash (lambda (_r cs)
(when (= (length cs) 1)
(let ((v (cg-hf-value (car cs))))
(when (> v bestv) (setq best (car cs) bestv v)))))
byrank)
best))))
(cl-defmethod cg-hf--ai-turn ((game cg-handfoot-game) s)
"Play seat S's whole turn."
(if (not (cg-hf--draw2 game s))
(cg-hf--score-round game nil)
(cg-hf--ai-meld game s)
(when (eq (cg-get game :phase) 'play)
;; if the hand emptied through melding, pick up the foot and meld again
(when (and (= (aref (cg-get game :stage) s) 0) (null (cg-rummy--hand game s)))
(aset (cg-get game :stage) s 1)
(cg-rummy--set-hand game s (aref (cg-get game :feet) s))
(cg-hf--ai-meld game s))
(when (eq (cg-get game :phase) 'play)
(if (cg-rummy--hand game s)
(cg-hf--discard game s (cg-hf--ai-discard-card game s))
(cg-hf--advance game s))))))
(defun cg-hf--run (game)
"Advance AI seats until it is your turn or the round ends."
(while (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0))
(cg-hf--ai-turn game (cg-get game :turn))))
;;;; UI
(defvar-local cg-hf--game nil "The Hand & Foot game in the current buffer.")
(cl-defmethod cg-render ((game cg-handfoot-game))
"Return a propertized depiction of the Hand & Foot GAME."
(let* ((out '()) (scores (cg-get game :scores))
(hand (cg-rummy--hand game 0)) (cursor (cg-get game :cursor)))
(push (format " Hand & Foot target %d\n\n" cg-handfoot-target) out)
(dotimes (team (cg-get game :nteams))
(push (format " Team %d (score %d):\n" team (aref scores team)) out)
(let ((bks (cg-hf--books game team)))
(if bks
(dolist (bk bks)
(push (format " %s%s\n"
(mapconcat #'cg-rummy-card-string bk " ")
(cond ((cg-hf--book-complete-p bk)
(if (cg-hf--book-clean-p bk) " [clean pile]" " [dirty pile]"))
(t "")))
out))
(push " (no books yet)\n" out))))
(push "\n" out)
(dotimes (s (cg-get game :nplayers))
(unless (= s 0)
(push (format " %-6s %d in hand%s\n" (aref cg-handfoot--names s)
(length (cg-rummy--hand game s))
(if (= (aref (cg-get game :stage) s) 1) " (on foot)" ""))
out)))
(push (format "\n Discard: %s Stock: %d\n\n"
(let ((cs (cg-rummy-card-string (cg-rummy--top game))) (tp (cg-rummy--top game)))
(if (and tp (not (cg-rummy-joker-p tp)) (cg-red-suit-p (car tp)))
(propertize cs 'face 'cg-red-suit) cs))
(length (cg-get game :stock)))
out)
(push (format " Your %s:\n " (if (= (aref (cg-get game :stage) 0) 1) "foot" "hand")) out)
(push (cg-rummy--render-cards hand cursor (cg-get game :marks)) out)
(push (format "\n\n %s\n" (cg-get game :message)) out)
(apply #'concat (nreverse out))))
(defun cg-hf--redisplay ()
"Redraw the Hand & Foot buffer."
(let ((game cg-hf--game) (inhibit-read-only t))
(setq-local mode-line-process
(format " [%s]" (or (cg-get game :step) (cg-get game :phase))))
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
(defun cg-hf--clamp (g)
"Keep G's cursor in range and drop stale marks."
(let ((n (length (cg-rummy--hand g 0))))
(cg-put g :cursor (if (> n 0) (min (cg-get g :cursor) (1- n)) 0))
(cg-put g :marks (cl-remove-if (lambda (i) (>= i n)) (cg-get g :marks)))))
(defun cg-hf--my-turn-p (g)
(and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0)))
(defun cg-hf-left ()
"Move the hand cursor left."
(interactive)
(let* ((g cg-hf--game) (n (length (cg-rummy--hand g 0))))
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n)))
(cg-hf--redisplay)))
(defun cg-hf-right ()
"Move the hand cursor right."
(interactive)
(let* ((g cg-hf--game) (n (length (cg-rummy--hand g 0))))
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n)))
(cg-hf--redisplay)))
(defun cg-hf-mark ()
"Toggle a mark on the card under the cursor."
(interactive)
(let* ((g cg-hf--game) (i (cg-get g :cursor)) (marks (cg-get g :marks)))
(cg-put g :marks (if (memq i marks) (delq i marks) (cons i marks)))
(cg-hf--redisplay)))
(defun cg-hf--marked (g)
"Return the marked cards in G's hand."
(let ((hand (cg-rummy--hand g 0)))
(mapcar (lambda (i) (nth i hand)) (sort (copy-sequence (cg-get g :marks)) #'<))))
(defun cg-hf-meld ()
"Meld the marked cards as a new book."
(interactive)
(let* ((g cg-hf--game) (cards (cg-hf--marked g)))
(cond
((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn."))
((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s)."))
((not (cg-hf--book-valid-p cards))
(cg-put g :message "Not a legal book: 3+ of a rank, 2+ natural, wilds <= naturals."))
((cg-hf--meld g 0 cards)
(cg-put g :marks nil) (cg-hf--clamp g)
(when (and (= (aref (cg-get g :stage) 0) 0) (null (cg-rummy--hand g 0)))
(aset (cg-get g :stage) 0 1)
(cg-rummy--set-hand g 0 (aref (cg-get g :feet) 0))
(cg-hf--clamp g)
(cg-put g :message "Hand cleared -- foot picked up! Keep melding or discard (RET)."))
(unless (and (= (aref (cg-get g :stage) 0) 1) (null (cg-rummy--hand g 0)))
(cg-put g :message "Booked. Meld more, lay off (l), or discard (RET).")))
(t (cg-put g :message "Could not meld those cards.")))
(cg-hf--redisplay)))
(defun cg-hf-layoff ()
"Lay the cursor card (or marked cards) off onto a team book."
(interactive)
(let* ((g cg-hf--game) (marks (cg-hf--marked g)))
(cond
((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn."))
((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s)."))
(t (let ((cards (or marks (list (nth (cg-get g :cursor) (cg-rummy--hand g 0)))))
(any nil))
(dolist (c cards) (when (and c (cg-hf--layoff g 0 c)) (setq any t)))
(cg-put g :marks nil) (cg-hf--clamp g)
(cg-put g :message (if any "Laid off." "That card fits none of your books.")))))
(cg-hf--redisplay)))
(defun cg-hf-draw ()
"Draw two cards from the stock."
(interactive)
(let ((g cg-hf--game))
(cond
((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn."))
((not (eq (cg-get g :step) 'draw)) (cg-put g :message "You already drew."))
((cg-hf--draw2 g 0)
(cg-put g :step 'play) (cg-hf--clamp g)
(cg-put g :message "Meld (m), lay off (l), then discard (RET)."))
(t (cg-hf--score-round g nil)))
(cg-hf--redisplay)))
(defun cg-hf-discard ()
"Discard the cursor card and end your turn."
(interactive)
(let* ((g cg-hf--game) (card (nth (cg-get g :cursor) (cg-rummy--hand g 0))))
(cond
((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn."))
((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s)."))
((null card) (cg-put g :message "No card selected."))
(t (cg-hf--discard g 0 card)
(cg-put g :marks nil)
(when (memq (cg-get g :phase) '(play))
(cg-put g :message "You discarded.")
(cg-hf--run g))))
(cg-hf--redisplay)))
(defun cg-hf-new ()
"Deal a fresh round, or a new game when one is over."
(interactive)
(let ((g cg-hf--game))
(when (eq (cg-get g :phase) 'game-over)
(cg-put g :scores (make-vector (cg-get g :nteams) 0)))
(cg-put g :reveal nil)
(cg-hf--deal g)
(cg-hf--run g)
(cg-hf--redisplay)))
(defun cg-hf-redraw () "Redraw the board." (interactive) (cg-hf--redisplay))
(defun cg-hf-help ()
"Describe the Hand & Foot controls."
(interactive)
(message "Arrows: choose SPC: mark m: meld l: lay off s: draw 2 RET: discard n: new"))
(defvar cg-handfoot-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "<left>") #'cg-hf-left)
(define-key map (kbd "<right>") #'cg-hf-right)
(define-key map (kbd "SPC") #'cg-hf-mark)
(define-key map "m" #'cg-hf-meld)
(define-key map "l" #'cg-hf-layoff)
(define-key map "s" #'cg-hf-draw)
(define-key map (kbd "RET") #'cg-hf-discard)
(define-key map "n" #'cg-hf-new)
(define-key map "g" #'cg-hf-redraw)
(define-key map "?" #'cg-hf-help)
map)
"Keymap for `cg-handfoot-mode'.")
(define-derived-mode cg-handfoot-mode special-mode "Hand&Foot"
"Major mode for Hand & Foot."
(setq-local truncate-lines t))
;;;###autoload
(defun cg-handfoot ()
"Play Hand & Foot, partnering North against two AI opponents."
(interactive)
(let ((buf (get-buffer-create "*Hand & Foot*")))
(with-current-buffer buf
(cg-handfoot-mode)
(setq cg-hf--game (cg-handfoot-game))
(cg-put cg-hf--game :nplayers 4)
(cg-put cg-hf--game :nteams 2)
(cg-put cg-hf--game :scores (make-vector 2 0))
(cg-hf--deal cg-hf--game)
(cg-hf--run cg-hf--game)
(cg-hf--redisplay))
(switch-to-buffer buf)))
;;;###autoload
(defalias 'cg-hand-and-foot #'cg-handfoot)
(provide 'cg-handfoot)
;;; cg-handfoot.el ends here

519
cg-rum500.el Normal file
View file

@ -0,0 +1,519 @@
;;; cg-rum500.el --- Basic Rummy and Rummy 500 -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Corwin Brust
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Two table-meld rummy games sharing one engine, built on the meld
;; finder in cg-rummy.el.
;;
;; In a table-meld game you draw a card, lay melds face-up on the table,
;; lay single cards off onto melds already there, and end your turn by
;; discarding. Empty your hand to go out.
;;
;; `cg-rummy-basic' -- plain Rummy: the first player to meld their whole
;; hand wins the deal and scores the cards left in the others' hands.
;; `cg-rum500' -- Rummy 500: you score the cards you lay down and lose
;; the cards left in your hand; first past 500 wins.
;;
;; You are the South player (seat 0); the rest are simple AI. To meld,
;; mark cards with SPC and press m; to lay a card off, put the cursor on
;; it and press l.
;;; Code:
(require 'cl-lib)
(require 'eieio)
(require 'cg-core)
(require 'cg-rummy)
(defclass cg-tablemeld-game (cg-rummy-game)
((nplayers :initarg :nplayers :initform 2)
(hand-size :initarg :hand-size :initform 10)
(ace-15 :initarg :ace-15 :initform nil)
(ace-high :initarg :ace-high :initform nil)
(target :initarg :target :initform 100)
(score-style :initarg :score-style :initform 'go-out))
"Abstract base for table-meld rummy games (Basic Rummy, Rummy 500)."
:abstract t)
;;;; Engine
(cl-defmethod cg-tm--deal ((game cg-tablemeld-game))
"Deal a fresh hand into GAME."
(let* ((n (oref game nplayers))
(deck (cg-rummy-deck))
(per (oref game hand-size))
(hands (make-vector n nil)))
(dotimes (s n)
(aset hands s (cg-rummy-sort-hand (cl-loop repeat per collect (pop deck)))))
(cg-put game :hands hands)
(cg-put game :nplayers n)
(cg-put game :discard (list (pop deck)))
(cg-put game :stock deck)
(cg-put game :table nil)
(cg-put game :laid (make-vector n 0))
(cg-put game :turn 0)
(cg-put game :step 'draw)
(cg-put game :phase 'play)
(cg-put game :cursor 0)
(cg-put game :marks nil)
(unless (cg-get game :scores) (cg-put game :scores (make-vector n 0)))
(cg-put game :message "Your turn: s draws from stock, t takes the discard.")
game))
(defun cg-tm--ace-high (game) (oref game ace-high))
(defun cg-tm--ace-15 (game) (oref game ace-15))
(defun cg-tm--draw (game s)
"Move one stock card to seat S's hand; return it or nil if stock empty."
(let ((stock (cg-get game :stock)))
(when stock
(let ((c (pop stock)))
(cg-put game :stock stock)
(cg-rummy--set-hand game s (cg-rummy-sort-hand
(cons c (cg-rummy--hand game s))))
c))))
(defun cg-tm--take-top (game s)
"Move the discard top to seat S's hand and return it."
(let ((c (cg-rummy--top game)))
(when c
(cg-put game :discard (cdr (cg-get game :discard)))
(cg-rummy--set-hand game s (cg-rummy-sort-hand
(cons c (cg-rummy--hand game s))))
c)))
(defun cg-tm--meld-value (game cards)
"Return the total point value of CARDS for GAME's scoring."
(apply #'+ (mapcar (lambda (c) (cg-rummy-value c (cg-tm--ace-15 game))) cards)))
(cl-defmethod cg-tm--meld ((game cg-tablemeld-game) s cards)
"Have seat S meld CARDS onto the table. Return non-nil on success."
(when (cg-rummy-meld-p cards :min 3 :ace-high (cg-tm--ace-high game)
:distinct-suits t)
(dolist (c cards) (cg-rummy--set-hand game s (remove c (cg-rummy--hand game s))))
(cg-put game :table (append (cg-get game :table)
(list (cons s (copy-sequence cards)))))
(let ((laid (cg-get game :laid)))
(aset laid s (+ (aref laid s) (cg-tm--meld-value game cards))))
t))
(cl-defmethod cg-tm--layoff ((game cg-tablemeld-game) s card)
"Have seat S lay CARD off onto a matching table meld. Return non-nil on success."
(let ((rec (cl-find-if
(lambda (r) (cg-rummy-meld-p (cons card (cdr r)) :min 3
:ace-high (cg-tm--ace-high game)))
(cg-get game :table))))
(when rec
(cg-rummy--set-hand game s (remove card (cg-rummy--hand game s)))
(setcdr rec (cg-rummy-sort-hand (cons card (cdr rec))))
(let ((laid (cg-get game :laid)))
(aset laid s (+ (aref laid s) (cg-rummy-value card (cg-tm--ace-15 game)))))
t)))
(cl-defmethod cg-tm--score-hand ((game cg-tablemeld-game) outseat)
"Score the hand ended by OUTSEAT (or nil for a washed-out hand)."
(let* ((n (cg-get game :nplayers)) (scores (cg-get game :scores))
(style (oref game score-style)))
(cond
((eq style 'go-out)
(when outseat
(let ((sum 0))
(dotimes (s n)
(unless (= s outseat)
(dolist (c (cg-rummy--hand game s))
(setq sum (+ sum (cg-rummy-value c))))))
(aset scores outseat (+ (aref scores outseat) sum)))))
((eq style 'meld-points)
(let ((laid (cg-get game :laid)))
(dotimes (s n)
(let ((rem (apply #'+ (mapcar (lambda (c)
(cg-rummy-value c (cg-tm--ace-15 game)))
(cg-rummy--hand game s)))))
(aset scores s (+ (aref scores s) (- (aref laid s) rem))))))))
;; decide if the game is over
(let ((win nil) (best most-negative-fixnum))
(dotimes (s n)
(when (and (>= (aref scores s) (oref game target))
(> (aref scores s) best))
(setq win s best (aref scores s))))
(cg-put game :phase (if win 'game-over 'hand-over))
(cg-put game :winner (or win outseat))
(cg-put game :reveal t)
(cg-put game :message
(if win
(format "%s wins the game with %d! (n: new game)"
(cg-tm--who win) (aref scores win))
(concat (if outseat (format "%s goes out. " (cg-tm--who outseat))
"Stock exhausted. ")
(format "Scores: %s. (n: next hand)"
(cg-tm--scores-string game))))))))
(defun cg-tm--who (s) (if (= s 0) "You" (format "Player %d" s)))
(defun cg-tm--scores-string (game)
"Return a compact \"You N · P1 N ...\" score line for GAME."
(let ((scores (cg-get game :scores)) (parts '()))
(dotimes (s (cg-get game :nplayers))
(push (format "%s %d" (if (= s 0) "You" (format "P%d" s)) (aref scores s))
parts))
(mapconcat #'identity (nreverse parts) " · ")))
(cl-defmethod cg-tm--end-turn ((game cg-tablemeld-game) s)
"Finish seat S's turn: go out if the hand is empty, else advance."
(if (null (cg-rummy--hand game s))
(cg-tm--score-hand game s)
(cg-put game :turn (mod (1+ s) (cg-get game :nplayers)))
(cg-put game :step 'draw)))
(cl-defmethod cg-tm--discard ((game cg-tablemeld-game) s card)
"Discard CARD from seat S and finish the turn."
(cg-rummy--set-hand game s (remove card (cg-rummy--hand game s)))
(cg-put game :discard (cons card (cg-get game :discard)))
(cg-tm--end-turn game s))
;;;; AI
(defun cg-tm--ai-melds (game s)
"Lay down every meld seat S can, keeping a card back to discard.
Return non-nil if any meld was laid."
(let ((did nil) (again t))
(while again
(setq again nil)
(let* ((hand (cg-rummy--hand game s))
(p (cg-rummy-best-partition hand :ace-high (cg-tm--ace-high game)
:ace-15 (cg-tm--ace-15 game)))
(melds (plist-get p :melds))
;; keep one card to discard: skip a meld if it would empty the hand
(melded (apply #'+ (mapcar #'length melds))))
(when (and melds (= melded (length hand)))
(setq melds (cdr (sort melds (lambda (a b) (< (length a) (length b)))))))
(when melds
(cg-tm--meld game s (car melds))
(setq did t again t))))
did))
(defun cg-tm--ai-layoffs (game s)
"Lay off every fitting card from seat S, keeping a card back to discard."
(let ((again t))
(while again
(setq again nil)
(when (> (length (cg-rummy--hand game s)) 1)
(let ((card (cl-find-if
(lambda (c)
(cl-find-if
(lambda (r) (cg-rummy-meld-p (cons c (cdr r)) :min 3
:ace-high (cg-tm--ace-high game)))
(cg-get game :table)))
(cg-rummy--hand game s))))
(when card (cg-tm--layoff game s card) (setq again t)))))))
(defun cg-tm--ai-discard-card (game s)
"Return the best card for seat S to discard (highest deadwood)."
(let* ((hand (cg-rummy--hand game s))
(p (cg-rummy-best-partition hand :ace-high (cg-tm--ace-high game)
:ace-15 (cg-tm--ace-15 game)))
(dead (or (plist-get p :deadwood) hand))
(best (car dead)) (bestv -1))
(dolist (c dead best)
(let ((v (cg-rummy-value c (cg-tm--ace-15 game))))
(when (> v bestv) (setq best c bestv v))))))
(cl-defmethod cg-tm--ai-turn ((game cg-tablemeld-game) s)
"Play seat S's whole turn."
(let* ((hand (cg-rummy--hand game s))
(up (cg-rummy--top game))
(cur (cg-rummy-deadwood hand (cg-tm--ace-high game) (cg-tm--ace-15 game)))
(with (and up (cg-rummy-deadwood (cons up hand)
(cg-tm--ace-high game) (cg-tm--ace-15 game))))
(drew (if (and up with (< with cur))
(cg-tm--take-top game s)
(cg-tm--draw game s))))
(if (not drew)
(cg-tm--score-hand game nil)
(cg-tm--ai-melds game s)
(cg-tm--ai-layoffs game s)
(when (eq (cg-get game :phase) 'play)
(if (null (cg-rummy--hand game s))
(cg-tm--end-turn game s) ; melded out, no discard needed
(cg-tm--discard game s (cg-tm--ai-discard-card game s)))))))
(defun cg-tm--run (game)
"Advance AI seats until it is the human's turn or the hand ends."
(while (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0))
(cg-tm--ai-turn game (cg-get game :turn))))
;;;; UI
(defvar-local cg-tm--game nil "The table-meld game in the current buffer.")
(defun cg-tm--layoff-hint (game)
"Return a predicate marking cards that can be laid off in GAME now."
(lambda (c)
(cl-find-if (lambda (r) (cg-rummy-meld-p (cons c (cdr r)) :min 3
:ace-high (cg-tm--ace-high game)))
(cg-get game :table))))
(cl-defmethod cg-render ((game cg-tablemeld-game))
"Return a propertized depiction of the table-meld GAME."
(let* ((out '()) (scores (cg-get game :scores))
(laid (cg-get game :laid)) (meldp (oref game score-style))
(hand (cg-rummy--hand game 0)) (cursor (cg-get game :cursor)))
(push (format " %s target %d\n\n" (oref game vname) (oref game target)) out)
(dotimes (s (cg-get game :nplayers))
(unless (= s 0)
(push (format " Player %d: %d cards score %d%s\n"
s (length (cg-rummy--hand game s)) (aref scores s)
(if (eq meldp 'meld-points)
(format " (laid %d)" (aref laid s)) ""))
out)))
(push "\n Table:\n" out)
(if (cg-get game :table)
(dolist (rec (cg-get game :table))
(push (format " [%s] %s\n" (if (= (car rec) 0) "you" (format "P%d" (car rec)))
(mapconcat #'cg-rummy-card-string (cdr rec) " "))
out))
(push " (empty)\n" out))
(push (format "\n Discard: %s Stock: %d\n\n"
(let ((cs (cg-rummy-card-string (cg-rummy--top game))) (tp (cg-rummy--top game)))
(if (and tp (cg-red-suit-p (car tp))) (propertize cs 'face 'cg-red-suit) cs))
(length (cg-get game :stock)))
out)
(push (format " Your hand%s:\n "
(if (eq meldp 'meld-points) (format " (laid %d, score %d)"
(aref laid 0) (aref scores 0))
(format " (score %d)" (aref scores 0))))
out)
(push (cg-rummy--render-cards hand cursor (cg-get game :marks)
(cg-tm--layoff-hint game))
out)
(push (format "\n\n %s\n" (cg-get game :message)) out)
(apply #'concat (nreverse out))))
(defun cg-tm--redisplay ()
"Redraw the table-meld buffer."
(let ((game cg-tm--game) (inhibit-read-only t))
(setq-local mode-line-process
(format " [%s]" (or (cg-get game :step) (cg-get game :phase))))
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
(defun cg-tm--clamp-cursor (g)
"Keep G's cursor within the hand and drop stale marks."
(let ((n (length (cg-rummy--hand g 0))))
(cg-put g :cursor (if (> n 0) (min (cg-get g :cursor) (1- n)) 0))
(cg-put g :marks (cl-remove-if (lambda (i) (>= i n)) (cg-get g :marks)))))
(defun cg-tm--my-turn-p (g)
(and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0)))
(defun cg-tm-left ()
"Move the hand cursor left."
(interactive)
(let* ((g cg-tm--game) (n (length (cg-rummy--hand g 0))))
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n)))
(cg-tm--redisplay)))
(defun cg-tm-right ()
"Move the hand cursor right."
(interactive)
(let* ((g cg-tm--game) (n (length (cg-rummy--hand g 0))))
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n)))
(cg-tm--redisplay)))
(defun cg-tm-mark ()
"Toggle a mark on the card under the cursor (for melding)."
(interactive)
(let* ((g cg-tm--game) (i (cg-get g :cursor)) (marks (cg-get g :marks)))
(cg-put g :marks (if (memq i marks) (delq i marks) (cons i marks)))
(cg-tm--redisplay)))
(defun cg-tm--marked-cards (g)
"Return the cards currently marked in G's hand."
(let ((hand (cg-rummy--hand g 0)))
(mapcar (lambda (i) (nth i hand)) (sort (copy-sequence (cg-get g :marks)) #'<))))
(defun cg-tm-meld ()
"Meld the marked cards onto the table."
(interactive)
(let* ((g cg-tm--game) (cards (cg-tm--marked-cards g)))
(cond
((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn."))
((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s or t)."))
((< (length cards) 3) (cg-put g :message "Mark at least three cards (SPC), then m."))
((cg-tm--meld g 0 cards)
(cg-put g :marks nil) (cg-tm--clamp-cursor g)
(cg-put g :message "Melded. Lay off with l, meld more, or discard (RET)."))
(t (cg-put g :message "Those cards are not a valid set or run.")))
(cg-tm--redisplay)))
(defun cg-tm-layoff ()
"Lay the cursor card (or marked cards) off onto a table meld."
(interactive)
(let* ((g cg-tm--game) (marks (cg-tm--marked-cards g)))
(cond
((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn."))
((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s or t)."))
(t (let ((cards (or marks (list (nth (cg-get g :cursor) (cg-rummy--hand g 0)))))
(any nil))
(dolist (c cards) (when (and c (cg-tm--layoff g 0 c)) (setq any t)))
(cg-put g :marks nil) (cg-tm--clamp-cursor g)
(cg-put g :message (if any "Laid off." "That card fits no meld on the table.")))))
(cg-tm--redisplay)))
(defun cg-tm-draw-stock ()
"Draw the top stock card."
(interactive)
(let ((g cg-tm--game))
(cond
((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn."))
((not (eq (cg-get g :step) 'draw)) (cg-put g :message "You already drew."))
((cg-tm--draw g 0)
(cg-put g :step 'play) (cg-tm--clamp-cursor g)
(cg-put g :message "Meld (m), lay off (l), then discard (RET)."))
(t (cg-tm--score-hand g nil)))
(cg-tm--redisplay)))
(defun cg-tm-take ()
"Take the discard top into your hand."
(interactive)
(let ((g cg-tm--game))
(cond
((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn."))
((not (eq (cg-get g :step) 'draw)) (cg-put g :message "You already drew."))
((null (cg-rummy--top g)) (cg-put g :message "The discard pile is empty."))
(t (let ((c (cg-tm--take-top g 0)))
(cg-put g :step 'play) (cg-tm--clamp-cursor g)
(cg-put g :message (format "Took %s. Meld (m), lay off (l), discard (RET)."
(cg-rummy-card-string c))))))
(cg-tm--redisplay)))
(defun cg-tm-discard ()
"Discard the cursor card and end your turn."
(interactive)
(let* ((g cg-tm--game) (card (nth (cg-get g :cursor) (cg-rummy--hand g 0))))
(cond
((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn."))
((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s or t)."))
((null card) (cg-put g :message "No card selected."))
(t (cg-tm--discard g 0 card)
(cg-put g :marks nil)
(when (eq (cg-get g :phase) 'play)
(cg-put g :message "You discarded.")
(cg-tm--run g))))
(cg-tm--redisplay)))
(defun cg-tm-new ()
"Deal a fresh hand, or a new game when one is over."
(interactive)
(let ((g cg-tm--game))
(when (eq (cg-get g :phase) 'game-over)
(cg-put g :scores (make-vector (oref g nplayers) 0)))
(cg-put g :reveal nil)
(cg-tm--deal g)
(cg-tm--run g)
(cg-tm--redisplay)))
(defun cg-tm-redraw () "Redraw the board." (interactive) (cg-tm--redisplay))
(defun cg-tm-help ()
"Describe the table-meld controls."
(interactive)
(message "Arrows: choose SPC: mark m: meld l: lay off s: draw t: take RET: discard n: new"))
(defvar cg-tm-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "<left>") #'cg-tm-left)
(define-key map (kbd "<right>") #'cg-tm-right)
(define-key map (kbd "SPC") #'cg-tm-mark)
(define-key map "m" #'cg-tm-meld)
(define-key map "l" #'cg-tm-layoff)
(define-key map "s" #'cg-tm-draw-stock)
(define-key map "t" #'cg-tm-take)
(define-key map (kbd "RET") #'cg-tm-discard)
(define-key map "n" #'cg-tm-new)
(define-key map "g" #'cg-tm-redraw)
(define-key map "?" #'cg-tm-help)
map)
"Keymap for `cg-tm-mode'.")
(define-derived-mode cg-tm-mode special-mode "Rummy"
"Major mode for the table-meld rummy games."
(setq-local truncate-lines t))
(defun cg-tm--start (game buffer-name)
"Start GAME in a buffer named BUFFER-NAME."
(let ((buf (get-buffer-create buffer-name)))
(with-current-buffer buf
(cg-tm-mode)
(setq cg-tm--game game)
(cg-tm--deal game)
(cg-tm--run game)
(cg-tm--redisplay))
(switch-to-buffer buf)))
;;;; The two games
(defcustom cg-rummy-basic-players 2
"Number of players in Basic Rummy, including you (2-4)."
:type '(choice (const 2) (const 3) (const 4)) :group 'card-games)
(defclass cg-rummy-basic-game (cg-tablemeld-game)
((vname :initform "Rummy")
(score-style :initform 'go-out)
(target :initform 100))
"A game of plain Rummy.")
;;;###autoload
(defun cg-rummy-basic ()
"Play Basic Rummy against the computer."
(interactive)
(let ((n (max 2 (min 4 cg-rummy-basic-players))))
(cg-tm--start (cg-rummy-basic-game :nplayers n :hand-size (if (= n 2) 10 7))
"*Rummy*")))
(defcustom cg-rum500-players 3
"Number of players in Rummy 500, including you (2-4)."
:type '(choice (const 2) (const 3) (const 4)) :group 'card-games)
(defclass cg-rum500-game (cg-tablemeld-game)
((vname :initform "Rummy 500")
(score-style :initform 'meld-points)
(ace-15 :initform t)
(ace-high :initform t)
(target :initform 500))
"A game of Rummy 500.")
;;;###autoload
(defun cg-rum500 ()
"Play Rummy 500 against the computer."
(interactive)
(let ((n (max 2 (min 4 cg-rum500-players))))
(cg-tm--start (cg-rum500-game :nplayers n :hand-size (if (= n 2) 13 7))
"*Rummy 500*")))
;;;###autoload
(defalias 'cg-rummy-500 #'cg-rum500)
(provide 'cg-rum500)
;;;

617
cg-rummy.el Normal file
View file

@ -0,0 +1,617 @@
;;; cg-rummy.el --- Rummy meld engine and Gin Rummy -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Corwin Brust
;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Version: 1.0.60
;; Package-Requires: ((emacs "26.1"))
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; The shared meld engine for the rummy family, plus Gin Rummy.
;;
;; A "meld" is a list of cards that is either a *set* (three or four cards
;; of the same rank) or a *run* (three or more cards of the same suit in
;; consecutive rank). The engine validates melds, enumerates the melds
;; latent in a hand, and -- the hard part -- finds the layout that leaves
;; the least deadwood, which drives both knock detection and the AI.
;;
;; Cards use the package-standard cons (SUIT . RANK) with SUIT 0 spades,
;; 1 clubs, 2 diamonds, 3 hearts, and RANK 0 (Ace) .. 12 (King). A joker,
;; used only by Hand & Foot, is the cons (joker . 0).
;;
;; Gin Rummy: a two-handed game of ten-card hands. Draw from the stock or
;; take the discard, then discard one card. Knock when your deadwood is
;; ten or less, or go gin with none; your opponent then lays off onto your
;; melds. First to 100 points wins. This file also provides the abstract
;; `cg-rummy-game' base and the rendering helpers reused by the other
;; rummy games (cg-rum500.el, cg-handfoot.el).
;;; Code:
(require 'cl-lib)
(require 'eieio)
(require 'cg-core)
(defconst cg-rummy-ranks
["A" "2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K"]
"Rank labels indexed 0 (Ace) .. 12 (King).")
(defface cg-rummy-mark '((t :background "steelblue" :foreground "white"))
"Face for a card the player has marked toward a meld."
:group 'card-games)
(defun cg-rummy-card-string (card)
"Return a short label for CARD, or a dot for nil."
(cond ((null card) "·")
((eq (car card) 'joker) (cg-suit-glyph 'joker))
(t (concat (aref cg-rummy-ranks (cdr card)) (cg-suit-glyph (car card))))))
(defun cg-rummy-joker-p (card)
"Return non-nil when CARD is a joker."
(and card (eq (car card) 'joker)))
(defun cg-rummy-value (card &optional ace-15)
"Return the point value of CARD.
Faces and tens are 10, an Ace is 1 (or 15 when ACE-15 is non-nil), and
other cards their pip value. A joker is worth 0 here; games that use
jokers value them separately."
(cond ((or (null card) (cg-rummy-joker-p card)) 0)
(t (let ((r (cdr card)))
(cond ((= r 0) (if ace-15 15 1))
((<= r 8) (1+ r))
(t 10))))))
;;;; Meld predicates
(defun cg-rummy--consec-p (ranks)
"Return non-nil when sorted RANKS rise by exactly one with no repeats."
(let ((ok t) (prev nil))
(dolist (r ranks ok)
(when (and prev (/= r (1+ prev))) (setq ok nil))
(setq prev r))))
(cl-defun cg-rummy-set-p (cards &key (min 3) distinct-suits)
"Return non-nil when CARDS form a set (>= MIN cards of one rank).
With DISTINCT-SUITS, every suit must differ (a single-deck rule)."
(and (>= (length cards) min)
(not (cl-some #'cg-rummy-joker-p cards))
(let ((r (cdr (car cards))))
(cl-every (lambda (c) (= (cdr c) r)) cards))
(or (not distinct-suits)
(let ((suits (mapcar #'car cards)))
(= (length suits)
(length (delete-dups (copy-sequence suits))))))))
(cl-defun cg-rummy-run-p (cards &key (min 3) ace-high)
"Return non-nil when CARDS form a run (>= MIN cards, one suit, in sequence).
With ACE-HIGH, an Ace may sit above the King (Q-K-A)."
(and (>= (length cards) min)
(not (cl-some #'cg-rummy-joker-p cards))
(let ((suit (car (car cards)))
(ranks (sort (mapcar #'cdr cards) #'<)))
(and (cl-every (lambda (c) (= (car c) suit)) cards)
(= (length ranks) (length (delete-dups (copy-sequence ranks))))
(or (cg-rummy--consec-p ranks)
(and ace-high (eql (car ranks) 0)
(cg-rummy--consec-p (sort (cons 13 (cdr ranks)) #'<))))))))
(cl-defun cg-rummy-meld-p (cards &key (min 3) ace-high distinct-suits)
"Return non-nil when CARDS form a valid set or run.
MIN, ACE-HIGH and DISTINCT-SUITS are passed through to the predicates."
(or (cg-rummy-set-p cards :min min :distinct-suits distinct-suits)
(cg-rummy-run-p cards :min min :ace-high ace-high)))
;;;; Candidate melds and best partition
(defun cg-rummy--combinations (lst k)
"Return all K-element combinations of LST, each as a list."
(cond ((= k 0) (list nil))
((null lst) nil)
(t (append
(mapcar (lambda (c) (cons (car lst) c))
(cg-rummy--combinations (cdr lst) (1- k)))
(cg-rummy--combinations (cdr lst) k)))))
(defun cg-rummy--runs-in (pairs)
"Return index-lists of runs (length >= 3) within PAIRS.
PAIRS is a list of (RANK . INDEX) sorted ascending by RANK."
(let ((res '()) (vec (vconcat pairs)))
(let ((n (length vec)))
(dotimes (i n)
(let ((idxs (list (cdr (aref vec i))))
(last (car (aref vec i)))
(j (1+ i)))
(while (and (< j n) (= (car (aref vec j)) (1+ last)))
(setq last (car (aref vec j)))
(setq idxs (cons (cdr (aref vec j)) idxs))
(when (>= (length idxs) 3)
(push (reverse idxs) res))
(setq j (1+ j))))))
res))
(cl-defun cg-rummy--candidate-melds (cards &key ace-high)
"Return candidate melds for CARDS as a list of index-lists.
Each index-list refers to positions in CARDS. With ACE-HIGH, high runs
ending in an Ace are also generated."
(let* ((vec (vconcat cards)) (n (length vec)) (melds '()))
;; sets, grouped by rank
(let ((byrank (make-hash-table :test 'eql)))
(dotimes (i n)
(let ((c (aref vec i)))
(unless (cg-rummy-joker-p c)
(push i (gethash (cdr c) byrank)))))
(maphash
(lambda (_r idxs)
(when (>= (length idxs) 3)
(dolist (k '(3 4))
(dolist (combo (cg-rummy--combinations idxs k))
(when (cg-rummy-set-p (mapcar (lambda (i) (aref vec i)) combo)
:distinct-suits t)
(push (sort (copy-sequence combo) #'<) melds))))))
byrank))
;; runs, grouped by suit
(let ((bysuit (make-hash-table :test 'eql)))
(dotimes (i n)
(let ((c (aref vec i)))
(unless (cg-rummy-joker-p c)
(push (cons (cdr c) i) (gethash (car c) bysuit)))))
(maphash
(lambda (_s pairs)
(let ((sorted (sort (copy-sequence pairs)
(lambda (a b) (< (car a) (car b))))))
(dolist (m (cg-rummy--runs-in sorted)) (push (sort m #'<) melds)))
(when (and ace-high (assq 0 pairs))
(let* ((hi (mapcar (lambda (p) (if (= (car p) 0) (cons 13 (cdr p)) p))
pairs))
(sh (sort hi (lambda (a b) (< (car a) (car b))))))
(dolist (m (cg-rummy--runs-in sh)) (push (sort m #'<) melds)))))
bysuit))
(delete-dups melds)))
(cl-defun cg-rummy-best-partition (cards &key ace-high ace-15)
"Return the lowest-deadwood layout of CARDS.
The result is a plist (:melds MELDS :deadwood CARDS :count N) where MELDS
is a list of card-lists, DEADWOOD the unmelded cards and N their value
sum. ACE-HIGH allows Q-K-A runs; ACE-15 scores Aces at 15."
(let* ((vec (vconcat cards)) (n (length vec))
(cand (cg-rummy--candidate-melds cards :ace-high ace-high))
(mmasks (mapcar (lambda (m)
(let ((b 0)) (dolist (i m) (setq b (logior b (ash 1 i))))
b))
cand))
(memo (make-hash-table :test 'eql))
(full (1- (ash 1 n))))
(cl-labels
((cval (i) (cg-rummy-value (aref vec i) ace-15))
(lowbit (avail)
(let ((i 0)) (while (zerop (logand avail (ash 1 i))) (setq i (1+ i))) i))
(solve (avail)
(if (zerop avail) (cons 0 '())
(or (gethash avail memo)
(let* ((i (lowbit avail))
(ibit (ash 1 i))
(sub0 (solve (logxor avail ibit)))
(best (cons (+ (cval i) (car sub0)) (cdr sub0))))
(dolist (mask mmasks)
(when (and (/= 0 (logand mask ibit))
(= mask (logand mask avail)))
(let ((sub (solve (logand avail (lognot mask)))))
(when (< (car sub) (car best))
(setq best (cons (car sub) (cons mask (cdr sub))))))))
(puthash avail best memo)
best)))))
(let* ((res (solve full)) (maskmelds (cdr res)) (used 0))
(dolist (m maskmelds) (setq used (logior used m)))
(list :melds
(mapcar (lambda (mask)
(let ((cl '()))
(dotimes (i n)
(when (/= 0 (logand mask (ash 1 i)))
(push (aref vec i) cl)))
(nreverse cl)))
maskmelds)
:deadwood
(let ((dl '()))
(dotimes (i n)
(when (= 0 (logand used (ash 1 i))) (push (aref vec i) dl)))
(nreverse dl))
:count (car res))))))
(defun cg-rummy-deadwood (cards &optional ace-high ace-15)
"Return the minimum deadwood value of CARDS.
ACE-HIGH and ACE-15 are passed to `cg-rummy-best-partition'."
(plist-get (cg-rummy-best-partition cards :ace-high ace-high :ace-15 ace-15)
:count))
(defun cg-rummy-layoff-p (card melds &optional ace-high)
"Return the first meld in MELDS that CARD extends, or nil.
ACE-HIGH allows extending a run with a high Ace."
(cl-find-if (lambda (m)
(cg-rummy-meld-p (cons card m) :min 3 :ace-high ace-high))
melds))
;;;; Shared deck and base game
(defun cg-rummy-deck (&optional ndecks jokers)
"Return a shuffled deck of NDECKS standard packs plus JOKERS jokers each.
NDECKS defaults to 1 and JOKERS to 0."
(random t)
(let ((cards '()))
(dotimes (_ (or ndecks 1))
(dotimes (s 4) (dotimes (r 13) (push (cons s r) cards)))
(dotimes (_ (or jokers 0)) (push (cons 'joker 0) cards)))
(cg-shuffle cards)))
(defclass cg-rummy-game (cg-game) ()
"Abstract base for rummy-style draw-and-discard games."
:abstract t)
(defsubst cg-rummy--hand (game s) (aref (cg-get game :hands) s))
(defsubst cg-rummy--set-hand (game s v) (aset (cg-get game :hands) s v))
(defsubst cg-rummy--top (game) (car (cg-get game :discard)))
(defun cg-rummy-sort-hand (cards)
"Return CARDS sorted by suit then rank for display, jokers last."
(sort (copy-sequence cards)
(lambda (a b)
(let ((sa (if (cg-rummy-joker-p a) 99 (car a)))
(sb (if (cg-rummy-joker-p b) 99 (car b))))
(if (= sa sb) (< (cdr a) (cdr b)) (< sa sb))))))
(defun cg-rummy--render-cards (cards cursor marks &optional hint-fn)
"Return a propertized row of CARDS.
CURSOR is the highlighted index, MARKS a list of marked indices, and
HINT-FN an optional predicate marking playable cards."
(let ((i 0) (out '()))
(dolist (c cards)
(let ((cs (cg-rummy-card-string c)) (faces nil))
(when (and (not (cg-rummy-joker-p c)) (cg-red-suit-p (car c)))
(push 'cg-red-suit faces))
(when (and hint-fn (funcall hint-fn c)) (push 'cg-hint faces))
(when (memq i marks) (push 'cg-rummy-mark faces))
(when (eql i cursor) (push 'cg-cursor faces))
(push (propertize (format "%4s" cs) 'face (or faces 'default)) out))
(setq i (1+ i)))
(apply #'concat (nreverse out))))
(defun cg-rummy--melds-string (melds)
"Return a one-line depiction of MELDS (a list of card-lists)."
(mapconcat (lambda (m) (mapconcat #'cg-rummy-card-string m " "))
melds " | "))
;;;; Gin Rummy
(defcustom cg-gin-target 100
"Points needed to win a game of Gin Rummy."
:type 'integer :group 'card-games)
(defclass cg-gin-game (cg-rummy-game)
((vname :initform "Gin Rummy"))
"A two-handed game of Gin Rummy.")
(cl-defmethod cg-gin--deal ((game cg-gin-game))
"Deal a fresh Gin hand into GAME."
(let ((deck (cg-rummy-deck)) (hands (make-vector 2 nil)))
(dotimes (s 2)
(aset hands s (cg-rummy-sort-hand (cl-loop repeat 10 collect (pop deck)))))
(cg-put game :hands hands)
(cg-put game :discard (list (pop deck)))
(cg-put game :stock deck)
(cg-put game :turn 0)
(cg-put game :step 'draw)
(cg-put game :phase 'play)
(cg-put game :cursor 0)
(unless (cg-get game :scores) (cg-put game :scores (make-vector 2 0)))
(cg-put game :message
"Your turn: s draws from stock, t takes the discard.")
game))
(defun cg-gin--deadwood (cards) (cg-rummy-deadwood cards))
(defun cg-gin--draw (game s)
"Move one stock card to seat S's hand; return it or nil if stock empty."
(let ((stock (cg-get game :stock)))
(when stock
(let ((c (pop stock)))
(cg-put game :stock stock)
(cg-rummy--set-hand game s (cons c (cg-rummy--hand game s)))
c))))
(defun cg-gin--take (game s)
"Move the discard top to seat S's hand and return it."
(let ((c (cg-rummy--top game)))
(cg-put game :discard (cdr (cg-get game :discard)))
(cg-rummy--set-hand game s (cons c (cg-rummy--hand game s)))
c))
(defun cg-gin--discard (game s card)
"Discard CARD from seat S's hand onto the pile."
(cg-rummy--set-hand game s (cg-rummy-sort-hand
(remove card (cg-rummy--hand game s))))
(cg-put game :discard (cons card (cg-get game :discard))))
(defun cg-gin--ai-best-discard (game s)
"Return the card seat S should discard to minimise its deadwood."
(let ((hand (cg-rummy--hand game s)) (best nil) (bestv most-positive-fixnum))
(dolist (c hand best)
(let ((d (cg-gin--deadwood (remove c hand))))
(when (or (< d bestv)
(and (= d bestv) best
(> (cg-rummy-value c) (cg-rummy-value best))))
(setq best c bestv d))))))
(cl-defmethod cg-gin--ai-turn ((game cg-gin-game) s)
"Play seat S's whole turn, then hand control back."
(let* ((hand (cg-rummy--hand game s))
(cur (cg-gin--deadwood hand))
(up (cg-rummy--top game))
(with (and up (cg-gin--deadwood (cons up hand))))
;; take the discard only when it strictly helps
(drew (if (and up with (< with cur))
(cg-gin--take game s)
(cg-gin--draw game s))))
(if (not drew)
(cg-gin--exhaust game) ; stock exhausted: wash the hand
(let ((card (cg-gin--ai-best-discard game s)))
(cg-gin--discard game s card)
(let ((dw (cg-gin--deadwood (cg-rummy--hand game s))))
(if (<= dw 10)
(cg-gin--knock game s)
(cg-put game :turn 0)
(cg-put game :step 'draw)
(cg-put game :message
(format "Opponent discarded %s. s draws, t takes."
(cg-rummy-card-string card)))))))))
(cl-defmethod cg-gin--knock ((game cg-gin-game) knocker)
"Resolve the hand when KNOCKER knocks; score and end the hand."
(let* ((kpart (cg-rummy-best-partition (cg-rummy--hand game knocker)))
(kmelds (plist-get kpart :melds))
(kdw (plist-get kpart :count))
(opp (- 1 knocker))
(opart (cg-rummy-best-partition (cg-rummy--hand game opp)))
(odead (plist-get opart :deadwood))
(gin (= kdw 0)))
;; opponent lays off onto the knocker's melds (not allowed on gin)
(unless gin
(let (remaining)
(dolist (c odead)
(let ((m (cg-rummy-layoff-p c kmelds)))
(if m (setcdr (last m) (list c)) ; extend that meld in place
(push c remaining))))
(setq odead (nreverse remaining))))
(let* ((odw (apply #'+ (mapcar #'cg-rummy-value odead)))
(scores (cg-get game :scores))
(winner knocker) (pts 0) (note ""))
(cond
(gin (setq pts (+ 25 odw) note "Gin!"))
((< kdw odw) (setq pts (- odw kdw) note "Knock."))
(t ;; undercut: defender wins
(setq winner opp pts (+ 25 (- kdw odw)) note "Undercut!")))
(aset scores winner (+ (aref scores winner) pts))
(cg-put game :phase 'hand-over)
(cg-put game :reveal t)
(cg-put game :winner winner)
(cg-put game :message
(format "%s %s scores %d. %s (n: next hand)"
note
(if (= winner 0) "You" "Opponent") pts
(if (>= (aref scores winner) cg-gin-target)
(progn (cg-put game :phase 'game-over)
(format "%s wins the game!"
(if (= winner 0) "You" "Opponent")))
(format "Score %d-%d."
(aref scores 0) (aref scores 1))))))))
(cl-defmethod cg-gin--exhaust ((game cg-gin-game))
"End a hand washed out because the stock ran dry."
(cg-put game :phase 'hand-over)
(cg-put game :reveal t)
(cg-put game :message "Stock exhausted -- the hand is a wash. n: next hand."))
;;;; Gin UI
(defvar-local cg-gin--game nil "The Gin Rummy game in the current buffer.")
(cl-defmethod cg-render ((game cg-gin-game))
"Return a propertized depiction of the Gin GAME for a text display."
(let* ((out '()) (scores (cg-get game :scores))
(reveal (cg-get game :reveal))
(hand (cg-rummy--hand game 0)) (cursor (cg-get game :cursor)))
(push (format " Gin Rummy first to %d\n\n" cg-gin-target) out)
(push (format " Opponent: %d cards score %d\n"
(length (cg-rummy--hand game 1)) (aref scores 1)) out)
(when reveal
(let ((p (cg-rummy-best-partition (cg-rummy--hand game 1))))
(push (format " melds: %s\n deadwood: %s (%d)\n"
(cg-rummy--melds-string (plist-get p :melds))
(mapconcat #'cg-rummy-card-string (plist-get p :deadwood) " ")
(plist-get p :count))
out)))
(push (format "\n Discard: %s Stock: %d\n\n"
(let ((cs (cg-rummy-card-string (cg-rummy--top game))))
(if (and (cg-rummy--top game) (cg-red-suit-p (car (cg-rummy--top game))))
(propertize cs 'face 'cg-red-suit) cs))
(length (cg-get game :stock)))
out)
(push (format " Your hand (deadwood %d, score %d):\n "
(cg-gin--deadwood hand) (aref scores 0)) out)
(push (cg-rummy--render-cards hand cursor nil) out)
(when reveal
(let ((p (cg-rummy-best-partition hand)))
(push (format "\n melds: %s\n deadwood: %s"
(cg-rummy--melds-string (plist-get p :melds))
(mapconcat #'cg-rummy-card-string (plist-get p :deadwood) " "))
out)))
(push (format "\n\n %s\n" (cg-get game :message)) out)
(apply #'concat (nreverse out))))
(defun cg-gin--redisplay ()
"Redraw the Gin Rummy buffer."
(let ((game cg-gin--game) (inhibit-read-only t))
(setq-local mode-line-process
(format " [%s]" (or (cg-get game :step) (cg-get game :phase))))
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
(defun cg-gin--cursor-card ()
"Return the card under the cursor in your hand."
(nth (cg-get cg-gin--game :cursor) (cg-rummy--hand cg-gin--game 0)))
(defun cg-gin-left ()
"Move the hand cursor left."
(interactive)
(let* ((g cg-gin--game) (n (length (cg-rummy--hand g 0))))
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n)))
(cg-gin--redisplay)))
(defun cg-gin-right ()
"Move the hand cursor right."
(interactive)
(let* ((g cg-gin--game) (n (length (cg-rummy--hand g 0))))
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n)))
(cg-gin--redisplay)))
(defun cg-gin--my-turn-p (g)
"Return non-nil when it is your turn to act in G."
(and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0)))
(defun cg-gin-draw-stock ()
"Draw the top stock card into your hand."
(interactive)
(let ((g cg-gin--game))
(cond
((not (cg-gin--my-turn-p g)) (cg-put g :message "Not your turn."))
((not (eq (cg-get g :step) 'draw)) (cg-put g :message "Discard first (RET)."))
((cg-gin--draw g 0)
(cg-put g :step 'discard)
(cg-put g :cursor 0)
(cg-put g :message "Choose a card and discard with RET, or knock with k."))
(t (cg-gin--exhaust g)))
(cg-gin--redisplay)))
(defun cg-gin-take-discard ()
"Take the discard top into your hand."
(interactive)
(let ((g cg-gin--game))
(cond
((not (cg-gin--my-turn-p g)) (cg-put g :message "Not your turn."))
((not (eq (cg-get g :step) 'draw)) (cg-put g :message "Discard first (RET)."))
((null (cg-rummy--top g)) (cg-put g :message "The discard pile is empty."))
(t (let ((c (cg-gin--take g 0)))
(cg-put g :step 'discard)
(cg-put g :cursor 0)
(cg-put g :message
(format "Took %s. Discard with RET, or knock with k."
(cg-rummy-card-string c))))))
(cg-gin--redisplay)))
(defun cg-gin--after-discard (g)
"Hand control to the opponent after you discard in G."
(cg-put g :turn 1)
(cg-put g :step 'draw)
(cg-gin--ai-turn g 1)
(cg-gin--redisplay))
(defun cg-gin-discard ()
"Discard the selected card and end your turn."
(interactive)
(let* ((g cg-gin--game) (card (cg-gin--cursor-card)))
(cond
((not (cg-gin--my-turn-p g)) (cg-put g :message "Not your turn.")
(cg-gin--redisplay))
((not (eq (cg-get g :step) 'discard))
(cg-put g :message "Draw first (s or t).") (cg-gin--redisplay))
((null card) (cg-put g :message "No card selected.") (cg-gin--redisplay))
(t (cg-gin--discard g 0 card)
(cg-put g :message (format "You discarded %s." (cg-rummy-card-string card)))
(cg-gin--after-discard g)))))
(defun cg-gin-knock ()
"Knock, discarding the selected card, if your deadwood allows."
(interactive)
(let* ((g cg-gin--game) (card (cg-gin--cursor-card)))
(cond
((not (cg-gin--my-turn-p g)) (cg-put g :message "Not your turn."))
((not (eq (cg-get g :step) 'discard))
(cg-put g :message "Draw first (s or t)."))
((null card) (cg-put g :message "No card selected."))
(t (let ((dw (cg-gin--deadwood (remove card (cg-rummy--hand g 0)))))
(if (> dw 10)
(cg-put g :message
(format "Can't knock: that leaves %d deadwood (need <= 10)." dw))
(cg-gin--discard g 0 card)
(cg-gin--knock g 0)))))
(cg-gin--redisplay)))
(defun cg-gin-new ()
"Deal a fresh hand (or a new game when one is over)."
(interactive)
(let ((g cg-gin--game))
(when (eq (cg-get g :phase) 'game-over) (cg-put g :scores (make-vector 2 0)))
(cg-put g :reveal nil)
(cg-gin--deal g)
(cg-gin--redisplay)))
(defun cg-gin-redraw () "Redraw the board." (interactive) (cg-gin--redisplay))
(defun cg-gin-help ()
"Describe the Gin Rummy controls."
(interactive)
(message "Arrows: choose s: draw stock t: take discard RET: discard k: knock n: new g: redraw"))
(defvar cg-gin-mode-map
(let ((map (make-sparse-keymap)))
(define-key map (kbd "<left>") #'cg-gin-left)
(define-key map (kbd "<right>") #'cg-gin-right)
(define-key map "s" #'cg-gin-draw-stock)
(define-key map "t" #'cg-gin-take-discard)
(define-key map (kbd "RET") #'cg-gin-discard)
(define-key map "k" #'cg-gin-knock)
(define-key map "n" #'cg-gin-new)
(define-key map "g" #'cg-gin-redraw)
(define-key map "?" #'cg-gin-help)
map)
"Keymap for `cg-gin-mode'.")
(define-derived-mode cg-gin-mode special-mode "Gin"
"Major mode for Gin Rummy."
(setq-local truncate-lines t))
;;;###autoload
(defun cg-gin ()
"Play Gin Rummy against the computer."
(interactive)
(let ((buf (get-buffer-create "*Gin Rummy*")))
(with-current-buffer buf
(cg-gin-mode)
(setq cg-gin--game (cg-gin-game))
(cg-gin--deal cg-gin--game)
(cg-gin--redisplay))
(switch-to-buffer buf)))
;;;###autoload
(defalias 'cg-gin-rummy #'cg-gin)
(provide 'cg-rummy)
;;; cg-rummy.el ends here

4
runemacs.sh Normal file
View file

@ -0,0 +1,4 @@
#!/usr/bin/env bash
# Load the card-games package from this directory and open the launcher.
dir="$(cd "$(dirname "$0")" && pwd)"
exec emacs -L "$dir" -l card-games -f card-game "$@"

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

@ -828,3 +828,83 @@
(ert-deftest cgt-pres-render ()
(let ((g (cg-pres--deal (cg-president-game)))) (should (stringp (cg-render g)))))
;;;; Rummy family
(ert-deftest cgt-rummy-set-run ()
(should (cg-rummy-set-p '((0 . 5) (1 . 5) (2 . 5)) :distinct-suits t))
(should-not (cg-rummy-set-p '((0 . 5) (0 . 5) (2 . 5)) :distinct-suits t))
(should (cg-rummy-run-p '((0 . 3) (0 . 4) (0 . 5))))
(should-not (cg-rummy-run-p '((0 . 3) (1 . 4) (0 . 5))))
(should (cg-rummy-run-p '((0 . 10) (0 . 11) (0 . 12) (0 . 0)) :ace-high t))
(should-not (cg-rummy-run-p '((0 . 11) (0 . 12) (0 . 0))))
(should (cg-rummy-run-p '((0 . 0) (0 . 1) (0 . 2)))))
(ert-deftest cgt-rummy-best-partition ()
(let* ((hand '((0 . 2)(0 . 3)(0 . 4) (0 . 6)(1 . 6)(2 . 6)
(3 . 8)(3 . 9)(3 . 10) (3 . 12)))
(p (cg-rummy-best-partition hand)))
(should (= 3 (length (plist-get p :melds))))
(should (= 10 (plist-get p :count))))
(should (= 0 (cg-rummy-deadwood
'((0 . 0)(0 . 1)(0 . 2) (1 . 4)(1 . 5)(1 . 6)
(2 . 8)(2 . 9)(2 . 10)(2 . 11))))))
(ert-deftest cgt-rummy-layoff ()
(should (cg-rummy-layoff-p '(3 . 11) '(((3 . 8)(3 . 9)(3 . 10)))))
(should-not (cg-rummy-layoff-p '(0 . 4) '(((3 . 8)(3 . 9)(3 . 10))))))
(ert-deftest cgt-gin-full-game ()
(let ((g (cg-gin-game)) (turns 0))
(cg-gin--deal g)
(while (and (not (eq (cg-get g :phase) 'game-over)) (< turns 100000))
(if (eq (cg-get g :phase) 'hand-over)
(progn (cg-put g :reveal nil) (cg-gin--deal g))
(cg-gin--ai-turn g (cg-get g :turn)) (cl-incf turns)))
(should (eq (cg-get g :phase) 'game-over))
(should (>= (apply #'max (append (cg-get g :scores) nil)) cg-gin-target))))
(ert-deftest cgt-gin-render () (let ((g (cg-gin--deal (cg-gin-game))))
(should (stringp (cg-render g)))))
(ert-deftest cgt-tablemeld-games ()
(dolist (mk (list (lambda () (cg-rummy-basic-game :nplayers 3 :hand-size 7))
(lambda () (cg-rum500-game :nplayers 3 :hand-size 7))))
(let ((g (funcall mk)) (turns 0))
(cg-tm--deal g)
(while (and (not (eq (cg-get g :phase) 'game-over)) (< turns 200000))
(if (eq (cg-get g :phase) 'hand-over)
(progn (cg-put g :reveal nil) (cg-tm--deal g))
(cg-tm--ai-turn g (cg-get g :turn)) (cl-incf turns)))
(should (eq (cg-get g :phase) 'game-over))
(should (stringp (cg-render g))))))
(ert-deftest cgt-tablemeld-conservation ()
(let ((g (cg-rum500-game :nplayers 3 :hand-size 7)))
(cg-tm--deal g)
(dotimes (_ 30) (when (eq (cg-get g :phase) 'play)
(cg-tm--ai-turn g (cg-get g :turn))))
(let ((tot (+ (length (cg-get g :stock)) (length (cg-get g :discard))
(apply #'+ (mapcar (lambda (r) (length (cdr r))) (cg-get g :table))))))
(dotimes (s 3) (setq tot (+ tot (length (cg-rummy--hand g s)))))
(should (= tot 52)))))
(ert-deftest cgt-handfoot-book ()
(should (cg-hf--book-valid-p '((0 . 7)(1 . 7)(2 . 7))))
(should (cg-hf--book-valid-p '((0 . 7)(1 . 7)(joker . 0)))) ; dirty
(should-not (cg-hf--book-valid-p '((0 . 7)(joker . 0)(joker . 0)))) ; wilds > nats
(should-not (cg-hf--book-valid-p '((0 . 2)(1 . 2)(2 . 2)))) ; threes
(should (cg-hf--book-complete-p '(a b c d e f g)))
(should (cg-hf--book-clean-p '((0 . 7)(1 . 7)(2 . 7))))
(should-not (cg-hf--book-clean-p '((0 . 7)(1 . 7)(joker . 0)))))
(ert-deftest cgt-handfoot-full-game ()
(let ((g (cg-handfoot-game)) (rounds 0) (turns 0) (expect (* 5 54)))
(cg-put g :nplayers 4) (cg-put g :nteams 2) (cg-put g :scores (make-vector 2 0))
(cg-hf--deal g)
(while (and (not (eq (cg-get g :phase) 'game-over)) (< rounds 60))
(cond ((eq (cg-get g :phase) 'round-over)
(cg-put g :reveal nil) (cg-hf--deal g) (cl-incf rounds))
(t (cg-hf--ai-turn g (cg-get g :turn)) (cl-incf turns)
(when (> turns 500000) (error "runaway")))))
(should (eq (cg-get g :phase) 'game-over))
(should (stringp (cg-render g)))))