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

Complete the rummy-family rules for 1.0: deep pickup, Hand & Foot

Browse source 
Rummy 500 gains the signature below-the-top discard pickup (T): take the
chosen card plus every card above it, melding or laying off the chosen
card at once.  New `deep-pickup' class slot keeps Basic Rummy top-only;
the AI takes a buried card when it completes a new meld; the pile renders
with 0=top depth indices.

Hand & Foot gains its three missing rules: pick up the discard pile (p)
by melding the top card with two matching naturals; red threes as bonus
cards (auto-collected with a replacement draw, +100 each / +200 all four);
and the round-by-round go-down minimum (50/90/120/150) enforced as one
atomic initial meld.

Add four ERT tests (suite 111->115); refresh the README and in-file
commentary; fix cg-rum500.el's truncated file footer.
This commit is contained in:
Corwin Brust 2026-06-26 16:34:02 -05:00
parent 519021f17d
commit 730b7e284b
4 changed files with 433 additions and 51 deletions
Download patch file Download diff file Expand all files Collapse all files

9
README.org
View file

@ -69,10 +69,15 @@ with its command.
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.
down and lose the cards left in your hand; first past 500 wins. Take a
buried discard card with ~T~: you take it and every card above it, and
meld the chosen card at once.
- ~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.
out once your side has completed two of them. Each round opens with a
rising go-down minimum (50, 90, 120, 150); red threes are bonus cards;
and you can pick up the discard pile (~p~) by melding its top card with
two matching naturals.
** Matching
- ~cg-go-fish~ -- Go Fish. Ask another player for a rank you hold;

258
cg-handfoot.el
View file

@ -36,10 +36,11 @@
;; 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
;; This Hand & Foot includes the round-by-round go-down minimum (50, 90,
;; 120, then 150), the red-three bonus (100 each, or 200 each for all four),
;; and picking up the discard pile -- meld its top card with two matching
;; naturals (`p') to take the top card plus several cards beneath it.
;; Cards use the package cons
;; (SUIT . RANK), RANK 0 (Ace) .. 12 (King), with jokers as (joker . 0).
;;; Code:
@ -53,6 +54,13 @@
"Points a partnership needs to win Hand & Foot."
:type 'integer :group 'card-games)
(defcustom cg-handfoot-pickup-count 7
"Cards taken (top included) when picking up the discard pile."
:type 'integer :group 'card-games)
(defconst cg-handfoot--minimums [50 90 120 150]
"Initial go-down minimum by round, the last value repeating thereafter.")
(defconst cg-handfoot--names ["You" "West" "North" "East"]
"Seat labels; North is your partner.")
@ -70,6 +78,10 @@
"Return non-nil when CARD is a three (never meldable)."
(and (not (cg-rummy-joker-p card)) (= (cdr card) 2)))
(defun cg-hf--red-three-p (card)
"Return non-nil when CARD is a red three (a bonus card)."
(and (not (cg-rummy-joker-p card)) (= (cdr card) 2) (cg-red-suit-p (car card))))
(defun cg-hf-value (card)
"Return the Hand & Foot point value of CARD."
(cond ((cg-rummy-joker-p card) 50)
@ -120,8 +132,12 @@
(cg-put game :feet feet)
(cg-put game :stage stage)
(cg-put game :books (make-vector (cg-get game :nteams) nil))
(cg-put game :round (1+ (or (cg-get game :round) -1)))
(cg-put game :down (make-vector (cg-get game :nteams) nil))
(cg-put game :redthrees (make-vector (cg-get game :nteams) nil))
(cg-put game :discard (list (pop deck)))
(cg-put game :stock deck)
(dotimes (s n) (cg-hf--collect-red-threes game s))
(cg-put game :turn 0)
(cg-put game :step 'draw)
(cg-put game :phase 'play)
@ -133,6 +149,156 @@
(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))
(defun cg-hf--down-p (game team)
"Return non-nil when TEAM has met this round's go-down minimum."
(aref (cg-get game :down) team))
(defun cg-hf--min-for-round (game)
"Return the go-down minimum for GAME's current round."
(let ((r (or (cg-get game :round) 0)))
(aref cg-handfoot--minimums
(min r (1- (length cg-handfoot--minimums))))))
(defun cg-hf--collect-red-threes (game s)
"Move seat S's red threes to its team pile, drawing replacements.
Return the number collected."
(let ((team (cg-hf--team game s)) (moved 0) (again t))
(while again
(setq again nil)
(let ((rt (cl-find-if #'cg-hf--red-three-p (cg-rummy--hand game s))))
(when rt
(cg-rummy--set-hand game s (cg-rummy--remove1 rt (cg-rummy--hand game s)))
(aset (cg-get game :redthrees) team
(cons rt (aref (cg-get game :redthrees) team)))
(setq moved (1+ moved))
(let ((stock (cg-get game :stock)))
(when stock
(cg-rummy--set-hand game s (cg-rummy-sort-hand
(cons (car stock) (cg-rummy--hand game s))))
(cg-put game :stock (cdr stock))))
(setq again t))))
moved))
(defun cg-hf--take-foot (game s)
"Move seat S onto its foot, collecting any red threes it holds."
(aset (cg-get game :stage) s 1)
(cg-rummy--set-hand game s (aref (cg-get game :feet) s))
(cg-hf--collect-red-threes game s))
(defun cg-hf--pickup-eligible (game s)
"Return non-nil when seat S may pick up the discard pile.
That needs two natural cards in hand matching a meldable top discard."
(let ((top (cg-rummy--top game)))
(and top (not (cg-hf--wild-p top)) (not (cg-hf--three-p top))
(>= (cl-count-if (lambda (c) (and (not (cg-hf--wild-p c))
(= (cdr c) (cdr top))))
(cg-rummy--hand game s))
2))))
(defun cg-hf--pickup (game s)
"Seat S picks up the discard pile, melding its top card.
Take the top card plus up to `cg-handfoot-pickup-count' - 1 cards beneath
it into hand, melding the top with two matching naturals. Return the top
card, or nil if ineligible."
(when (cg-hf--pickup-eligible game s)
(let* ((pile (cg-get game :discard)) (top (car pile)) (rank (cdr top))
(team (cg-hf--team game s)) (books (cg-hf--books game team))
(nats (cl-remove-if-not
(lambda (c) (and (not (cg-hf--wild-p c)) (= (cdr c) rank)))
(cg-rummy--hand game s)))
(two (list (nth 0 nats) (nth 1 nats)))
(existing (cl-find-if
(lambda (bk) (and (not (cg-hf--book-complete-p bk))
(equal (cg-hf--book-rank bk) rank)))
books))
(rest (cdr pile))
(ntake (min (1- cg-handfoot-pickup-count) (length rest)))
(take (cl-subseq rest 0 ntake))
(remain (nthcdr ntake rest)))
(dolist (c two)
(cg-rummy--set-hand game s (cg-rummy--remove1 c (cg-rummy--hand game s))))
(if existing
(setcar (memq existing books)
(cg-rummy-sort-hand (append (list top) two existing)))
(cg-hf--set-books game team
(append books (list (cg-rummy-sort-hand (cons top two))))))
(cg-put game :discard remain)
(dolist (c take)
(cg-rummy--set-hand game s (cg-rummy-sort-hand
(cons c (cg-rummy--hand game s)))))
(cg-hf--collect-red-threes game s)
top)))
(defun cg-hf--partition-books (cards)
"Partition CARDS into valid books, or nil if they can't all be used.
Naturals group by rank (each rank needs two), and wilds fill the groups."
(if (or (null cards) (cl-some #'cg-hf--three-p cards)) nil
(let ((wilds (cl-remove-if-not #'cg-hf--wild-p cards))
(byrank (make-hash-table :test 'eql)) (groups '()) (ok t))
(dolist (c cards)
(unless (cg-hf--wild-p c) (push c (gethash (cdr c) byrank))))
(maphash (lambda (_r cs) (push cs groups)) byrank)
(when (or (null groups) (cl-some (lambda (g) (< (length g) 2)) groups))
(setq ok nil))
(when ok
(let ((w (copy-sequence wilds)) (books '()))
(dolist (g (sort groups (lambda (a b) (< (length a) (length b)))))
(let ((bk (copy-sequence g)))
(while (and (< (length bk) 3) w) (push (pop w) bk))
(push bk books)))
(dolist (wcard w)
(let ((tgt (cl-find-if
(lambda (bk)
(and (< (length bk) 7)
(< (cl-count-if #'cg-hf--wild-p bk) 3)
(< (cl-count-if #'cg-hf--wild-p bk)
(cl-count-if-not #'cg-hf--wild-p bk))))
books)))
(if tgt (setcar (memq tgt books) (cons wcard tgt)) (setq ok nil))))
(if (and ok (cl-every #'cg-hf--book-valid-p books)) books nil))))))
(defun cg-hf--initial-meld (game s cards)
"Lay CARDS as seat S's initial meld, meeting the round minimum.
Return non-nil when the team goes down."
(let* ((books (cg-hf--partition-books cards))
(team (cg-hf--team game s)))
(when (and books
(cl-subsetp cards (cg-rummy--hand game s) :test #'equal)
(>= (apply #'+ (mapcar #'cg-hf-value cards))
(cg-hf--min-for-round game)))
(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)
(mapcar #'cg-rummy-sort-hand books)))
(aset (cg-get game :down) team t)
t)))
(defun cg-hf--ai-go-down (game s)
"Try to lay seat S's initial meld meeting the round minimum.
Return non-nil when the team goes down."
(let* ((hand (cg-rummy--hand game s))
(byrank (make-hash-table :test 'eql))
(wilds (cl-remove-if-not #'cg-hf--wild-p hand)) (cards '()))
(dolist (c hand)
(unless (or (cg-hf--wild-p c) (cg-hf--three-p c))
(push c (gethash (cdr c) byrank))))
(let ((w (copy-sequence wilds)))
(maphash (lambda (_r cs)
(cond ((>= (length cs) 3) (setq cards (append cs cards)))
((and (= (length cs) 2) w)
(setq cards (append cs (list (pop w)) cards)))))
byrank))
(when (and cards (>= (apply #'+ (mapcar #'cg-hf-value cards))
(cg-hf--min-for-round game)))
(cg-hf--initial-meld game s cards))))
(defun cg-hf--ai-meld (game s)
"Meld for seat S, going down only when the round minimum is met."
(let ((team (cg-hf--team game s)))
(unless (cg-hf--down-p game team) (cg-hf--ai-go-down game s))
(when (cg-hf--down-p game team) (cg-hf--ai-extend game s))))
;;;; Engine
(defun cg-hf--draw2 (game s)
@ -182,8 +348,7 @@
(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)))
(cg-hf--take-foot game 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)
@ -211,6 +376,8 @@
(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
(let ((k (length (aref (cg-get game :redthrees) team))))
(setq pts (+ pts (* k (if (>= k 4) 200 100))))) ; red threes
;; subtract cards left in members' hands and feet
(dotimes (s (cg-get game :nplayers))
(when (= (cg-hf--team game s) team)
@ -244,8 +411,8 @@
;;;; AI
(defun cg-hf--ai-meld (game s)
"Lay down and extend books for seat S as far as is easy."
(defun cg-hf--ai-extend (game s)
"Extend and add books for seat S once the team is down."
;; lay off naturals onto existing incomplete team books
(let ((again t))
(while again
@ -312,19 +479,22 @@
(cl-defmethod cg-hf--ai-turn ((game cg-handfoot-game) s)
"Play seat S's whole turn."
(if (not (cg-hf--draw2 game s))
(let ((got (or (and (> (length (cg-get game :stock)) 30)
(cg-hf--pickup-eligible game s)
(cg-hf--pickup game s))
(cg-hf--draw2 game s))))
(if (not got)
(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--take-foot game 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))))))
(cg-hf--advance game s)))))))
(defun cg-hf--run (game)
"Advance AI seats until it is your turn or the round ends."
@ -339,9 +509,15 @@
"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)
(push (format " Hand & Foot target %d round %d (go-down minimum %d)\n\n"
cg-handfoot-target (1+ (or (cg-get game :round) 0))
(cg-hf--min-for-round game)) out)
(dotimes (team (cg-get game :nteams))
(push (format " Team %d (score %d):\n" team (aref scores team)) out)
(push (format " Team %d (score %d)%s%s:\n" team (aref scores team)
(if (cg-hf--down-p game team) " down"
(format " needs %d to go down" (cg-hf--min-for-round game)))
(let ((k (length (aref (cg-get game :redthrees) team))))
(if (> k 0) (format " red3:%d" k) ""))) out)
(let ((bks (cg-hf--books game team)))
(if bks
(dolist (bk bks)
@ -359,10 +535,11 @@
(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"
(push (format "\n Discard: %s (pile %d) 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 :discard))
(length (cg-get game :stock)))
out)
(push (format " Your %s:\n " (if (= (aref (cg-get game :stage) 0) 1) "foot" "hand")) out)
@ -420,23 +597,36 @@
(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."
"Meld the marked cards.
Until your team is down you must mark a complete initial meld -- one or
more valid books totalling at least the round minimum -- and lay it in one
action. After that, mark single books as usual."
(interactive)
(let* ((g cg-hf--game) (cards (cg-hf--marked g)))
(let* ((g cg-hf--game) (cards (cg-hf--marked g)) (team (cg-hf--team 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)."))
((not (cg-hf--down-p g team))
(if (cg-hf--initial-meld g 0 cards)
(progn
(cg-put g :marks nil) (cg-hf--clamp g)
(when (and (= (aref (cg-get g :stage) 0) 0) (null (cg-rummy--hand g 0)))
(cg-hf--take-foot g 0) (cg-hf--clamp g))
(cg-put g :message
(format "You're down! (met the %d minimum.) Meld more, lay off, or discard."
(cg-hf--min-for-round g))))
(cg-put g :message
(format "Initial meld must be valid books totalling >= %d; mark them all, then m."
(cg-hf--min-for-round g)))))
((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)
(if (and (= (aref (cg-get g :stage) 0) 0) (null (cg-rummy--hand g 0)))
(progn (cg-hf--take-foot g 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).")))
(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)))
@ -462,11 +652,29 @@
((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-hf--collect-red-threes 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-pickup ()
"Pick up the discard pile by melding its top card (Hand & Foot)."
(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."))
((not (cg-hf--pickup-eligible g 0))
(cg-put g :message
"Can't pick up: you need two natural cards matching the top discard."))
(t (let ((top (cg-hf--pickup g 0)))
(cg-put g :step 'play) (cg-hf--clamp g)
(cg-put g :message
(format "Picked up the pile, melding %s. Meld more, lay off, or discard."
(cg-rummy-card-string top))))))
(cg-hf--redisplay)))
(defun cg-hf-discard ()
"Discard the cursor card and end your turn."
(interactive)
@ -487,7 +695,8 @@
(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 :scores (make-vector (cg-get g :nteams) 0))
(cg-put g :round -1))
(cg-put g :reveal nil)
(cg-hf--deal g)
(cg-hf--run g)
@ -498,7 +707,7 @@
(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"))
(message "Arrows: choose SPC: mark m: meld l: lay off s: draw 2 p: pick up pile RET: discard n: new"))
(defvar cg-handfoot-mode-map
(let ((map (make-sparse-keymap)))
@ -513,6 +722,7 @@
(define-key map "m" #'cg-hf-meld)
(define-key map "l" #'cg-hf-layoff)
(define-key map "s" #'cg-hf-draw)
(define-key map "p" #'cg-hf-pickup)
(define-key map (kbd "RET") #'cg-hf-discard)
(define-key map "n" #'cg-hf-new)
(define-key map "g" #'cg-hf-redraw)

127
cg-rum500.el
View file

@ -34,7 +34,9 @@
;; `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.
;; the cards left in your hand; first past 500 wins. In Rummy 500 you
;; may take a card from anywhere in the discard pile (T): you take that
;; card and everything above it, and the chosen card is melded at once.
;;
;; 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
@ -53,7 +55,8 @@
(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))
(score-style :initarg :score-style :initform 'go-out)
(deep-pickup :initarg :deep-pickup :initform nil))
"Abstract base for table-meld rummy games (Basic Rummy, Rummy 500)."
:abstract t)
@ -84,6 +87,7 @@
(defun cg-tm--ace-high (game) (oref game ace-high))
(defun cg-tm--ace-15 (game) (oref game ace-15))
(defun cg-tm--deep-pickup (game) (oref game deep-pickup))
(defun cg-tm--draw (game s)
"Move one stock card to seat S's hand; return it or nil if stock empty."
@ -240,16 +244,72 @@ Return non-nil if any meld was laid."
(let ((v (cg-rummy-value c (cg-tm--ace-15 game))))
(when (> v bestv) (setq best c bestv v))))))
(defun cg-tm--meld-for-target (game cards target)
"Return a minimal valid meld (card list) containing TARGET drawn from CARDS.
Return nil when TARGET cannot join a set or run with the other CARDS."
(let* ((ace-high (cg-tm--ace-high game))
(pool (cons target cards))
(cands (cg-rummy--candidate-melds pool :ace-high ace-high))
(vec (vconcat pool))
(withtgt (cl-remove-if-not (lambda (m) (memq 0 m)) cands)))
(when withtgt
(setq withtgt (sort withtgt (lambda (a b) (< (length a) (length b)))))
(mapcar (lambda (i) (aref vec i)) (car withtgt)))))
(defun cg-tm--take-deep (game s depth)
"Seat S takes the card DEPTH-deep in the discard pile, plus all above it.
The chosen card is melded or laid off at once, as Rummy 500 requires; the
rest enter the hand. Return a status string, or nil when the move is not
legal (the chosen card cannot be used immediately)."
(let* ((pile (cg-get game :discard)) (n (length pile)))
(when (and (cg-tm--deep-pickup game) (>= depth 0) (< depth n))
(let* ((target (nth depth pile))
(above (cl-subseq pile 0 depth))
(avail (append (cg-rummy--hand game s) above))
(lay (cl-find-if
(lambda (r)
(cg-rummy-meld-p (cons target (cdr r)) :min 3
:ace-high (cg-tm--ace-high game)))
(cg-get game :table)))
(meld (unless lay (cg-tm--meld-for-target game avail target))))
(when (or lay meld)
(let ((taken (cl-subseq pile 0 (1+ depth))))
(cg-put game :discard (nthcdr (1+ depth) pile))
(dolist (c taken)
(cg-rummy--set-hand game s (cg-rummy-sort-hand
(cons c (cg-rummy--hand game s))))))
(if lay (cg-tm--layoff game s target) (cg-tm--meld game s meld))
(format "Took %d card%s and used %s."
(1+ depth) (if (= depth 0) "" "s")
(cg-rummy-card-string target)))))))
(defun cg-tm--ai-deep-pickup (game s)
"Try a worthwhile below-the-top discard pickup for seat S.
Return non-nil when one was taken."
(when (cg-tm--deep-pickup game)
(let* ((pile (cg-get game :discard)) (n (length pile))
(limit (min n 7)) (hand (cg-rummy--hand game s)) (chosen nil))
(cl-loop for d from 1 below limit
for target = (nth d pile)
for above = (cl-subseq pile 0 d)
when (cg-tm--meld-for-target game (append hand above) target)
do (setq chosen d) (cl-return))
(when chosen (cg-tm--take-deep game s chosen)))))
(cl-defmethod cg-tm--ai-turn ((game cg-tablemeld-game) s)
"Play seat S's whole turn."
(let* ((deep (cg-tm--ai-deep-pickup game s))
(drew (if deep t
(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))
(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)))))
(if (and up with (< with cur))
(cg-tm--take-top game s)
(cg-tm--draw game s))))
(cg-tm--draw game s))))))
(if (not drew)
(cg-tm--score-hand game nil)
(cg-tm--ai-melds game s)
@ -268,6 +328,22 @@ Return non-nil if any meld was laid."
(defvar-local cg-tm--game nil "The table-meld game in the current buffer.")
(defun cg-tm--discard-string (game)
"Return the discard-pile display line for GAME.
Deep-pickup games show the whole pile with depth indices (0 = top)."
(cl-flet ((paint (c)
(let ((cs (cg-rummy-card-string c)))
(if (and c (not (cg-rummy-joker-p c)) (cg-red-suit-p (car c)))
(propertize cs 'face 'cg-red-suit) cs))))
(let ((pile (cg-get game :discard)))
(if (and (cg-tm--deep-pickup game) (cdr pile))
(concat "Discard (0=top): "
(let ((i -1))
(mapconcat
(lambda (c) (setq i (1+ i)) (format "%d:%s" i (paint c)))
(cl-subseq pile 0 (min (length pile) 12)) " ")))
(concat "Discard: " (paint (cg-rummy--top game)))))))
(defun cg-tm--layoff-hint (game)
"Return a predicate marking cards that can be laid off in GAME now."
(lambda (c)
@ -295,9 +371,8 @@ Return non-nil if any meld was laid."
(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))
(push (format "\n %s Stock: %d\n\n"
(cg-tm--discard-string game)
(length (cg-get game :stock)))
out)
(push (format " Your hand%s:\n "
@ -415,6 +490,32 @@ Return non-nil if any meld was laid."
(cg-rummy-card-string c))))))
(cg-tm--redisplay)))
(defun cg-tm-take-deep ()
"Take a card from below the top of the discard pile (Rummy 500).
You take that card and every card lying on top of it; the chosen card is
melded or laid off at once, the rest go into your hand."
(interactive)
(let* ((g cg-tm--game) (pile (cg-get g :discard)) (n (length pile)))
(cond
((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn."))
((not (cg-tm--deep-pickup g))
(cg-put g :message "This game lets you take only the top discard (t)."))
((not (eq (cg-get g :step) 'draw)) (cg-put g :message "You already drew."))
((< n 1) (cg-put g :message "The discard pile is empty."))
(t (let ((depth (read-number
(format "Take how deep? 0=top .. %d (you must meld that card): "
(1- n)) 0)))
(if (and (integerp depth) (>= depth 0) (< depth n))
(let ((desc (cg-tm--take-deep g 0 depth)))
(if desc
(progn (cg-put g :step 'play) (cg-tm--clamp-cursor g)
(cg-put g :message
(concat desc " Meld, lay off, or discard (RET).")))
(cg-put g :message
"You can't use that card right now -- choose another.")))
(cg-put g :message "No card at that depth.")))))
(cg-tm--redisplay)))
(defun cg-tm-discard ()
"Discard the cursor card and end your turn."
(interactive)
@ -446,7 +547,7 @@ Return non-nil if any meld was laid."
(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"))
(message "Arrows: choose SPC: mark m: meld l: lay off s: draw t: take T: deep take RET: discard n: new"))
(defvar cg-tm-mode-map
(let ((map (make-sparse-keymap)))
@ -462,6 +563,7 @@ Return non-nil if any meld was laid."
(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 "T" #'cg-tm-take-deep)
(define-key map (kbd "RET") #'cg-tm-discard)
(define-key map "n" #'cg-tm-new)
(define-key map "g" #'cg-tm-redraw)
@ -513,6 +615,7 @@ Return non-nil if any meld was laid."
(score-style :initform 'meld-points)
(ace-15 :initform t)
(ace-high :initform t)
(deep-pickup :initform t)
(target :initform 500))
"A game of Rummy 500.")
@ -528,4 +631,4 @@ Return non-nil if any meld was laid."
(defalias 'cg-rummy-500 #'cg-rum500)
(provide 'cg-rum500)
;;;
;;; cg-rum500.el ends here

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

@ -1101,3 +1101,67 @@
(should (= 1.5 cg-card-scale))
(cg-render-apply g 'zoom-reset)
(should (= 1.0 cg-card-scale))))
;;;; Rummy 500 deep pickup and Hand & Foot rule completions
(ert-deftest cgt-rum500-deep-pickup ()
"Taking a buried discard card melds it at once, keeping the cards above."
(let ((g (cg-rum500-game :nplayers 2 :hand-size 10)))
(cg-put g :nplayers 2) (cg-put g :scores (make-vector 2 0))
(cg-put g :hands (vector (list (cons 0 5) (cons 0 6)) nil)) ; 6S 7S
(cg-put g :discard (list (cons 1 9) (cons 0 4) (cons 2 3))) ; top 10C, buried 5S
(cg-put g :table nil) (cg-put g :laid (make-vector 2 0))
(cg-put g :turn 0) (cg-put g :step 'draw) (cg-put g :phase 'play)
(should (cg-tm--take-deep g 0 1))
(should (equal (cg-get g :table) '((0 (0 . 4) (0 . 5) (0 . 6)))))
(should (equal (cg-rummy--hand g 0) '((1 . 9))))
(should (= 1 (length (cg-get g :discard))))
;; a card you cannot use immediately may not be taken
(cg-put g :hands (vector (list (cons 3 11)) nil))
(cg-put g :discard (list (cons 1 9) (cons 2 2)))
(should-not (cg-tm--take-deep g 0 1))))
(ert-deftest cgt-handfoot-redthree ()
"Red threes leave the hand on deal and collect to the team pile."
(let ((g (cg-handfoot-game)))
(cg-put g :nplayers 4) (cg-put g :nteams 2) (cg-put g :scores (make-vector 2 0))
(cg-hf--deal g)
(dotimes (s 4)
(should (= 0 (cl-count-if #'cg-hf--red-three-p (cg-rummy--hand g s)))))
(cg-put g :redthrees (make-vector 2 nil))
(cg-rummy--set-hand g 0 (list (cons 2 2) (cons 0 5))) ; 3 of diamonds + 6S
(cg-put g :stock (list (cons 0 9)))
(should (= 1 (cg-hf--collect-red-threes g 0)))
(should (= 1 (length (aref (cg-get g :redthrees) (cg-hf--team g 0)))))
(should-not (cl-find-if #'cg-hf--red-three-p (cg-rummy--hand g 0)))))
(ert-deftest cgt-handfoot-min-meld ()
"Initial meld must reach the round minimum; below it is refused."
(let ((g (cg-handfoot-game)))
(cg-put g :nplayers 4) (cg-put g :nteams 2) (cg-put g :scores (make-vector 2 0))
(cg-hf--deal g) (cg-put g :round 0)
(cg-put g :down (make-vector 2 nil)) (cg-put g :books (make-vector 2 nil))
(cg-put g :hands (vector (list (cons 0 3)(cons 1 3)(cons 2 3)) nil nil nil)) ; three 4s = 15
(should-not (cg-hf--initial-meld g 0 (cg-rummy--hand g 0)))
(should-not (cg-hf--down-p g 0))
(cg-put g :hands (vector (list (cons 0 0)(cons 1 0)(cons 2 0)) nil nil nil)) ; three aces = 60
(should (cg-hf--initial-meld g 0 (cg-rummy--hand g 0)))
(should (cg-hf--down-p g 0))
(should (= 1 (length (cg-hf--books g 0))))))
(ert-deftest cgt-handfoot-pickup ()
"Picking up melds the top discard and rakes in the cards beneath it."
(let ((g (cg-handfoot-game)))
(cg-put g :nplayers 4) (cg-put g :nteams 2) (cg-put g :scores (make-vector 2 0))
(cg-hf--deal g)
(cg-put g :redthrees (make-vector 2 nil)) (cg-put g :books (make-vector 2 nil))
(cg-put g :hands (vector (list (cons 0 8)(cons 1 8)(cons 0 4)) nil nil nil)) ; two 9s + 5S
(cg-put g :discard (list (cons 2 8)(cons 3 5)(cons 0 6)(cons 1 7))) ; top 9D + 3 beneath
(cg-put g :stock nil)
(should (cg-hf--pickup-eligible g 0))
(let ((top (cg-hf--pickup g 0)))
(should (equal top (cons 2 8)))
(should (= 1 (length (cg-hf--books g 0))))
(should (cg-hf--book-valid-p (car (cg-hf--books g 0))))
(should (= 4 (length (cg-rummy--hand g 0))))
(should-not (cg-get g :discard)))))