From 730b7e284b9fd6dc23e9bb4667680d1a08bc2c94 Mon Sep 17 00:00:00 2001 From: Corwin Brust Date: Fri, 26 Jun 2026 16:34:02 -0500 Subject: [PATCH] Complete the rummy-family rules for 1.0: deep pickup, Hand & Foot 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. --- README.org | 9 +- cg-handfoot.el | 278 ++++++++++++++++++++++++++++++++++----- cg-rum500.el | 133 ++++++++++++++++--- test/card-games-tests.el | 64 +++++++++ 4 files changed, 433 insertions(+), 51 deletions(-) diff --git a/README.org b/README.org index 1cdbfa1..ad42a09 100644 --- a/README.org +++ b/README.org @@ -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; diff --git a/cg-handfoot.el b/cg-handfoot.el index 659e4f2..592f2e8 100644 --- a/cg-handfoot.el +++ b/cg-handfoot.el @@ -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)) - (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)) + (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 (cg-rummy--hand game s) - (cg-hf--discard game s (cg-hf--ai-discard-card game s)) - (cg-hf--advance game s)))))) + ;; 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))) + (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))))))) (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) - (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)."))) + (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).")))) (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) diff --git a/cg-rum500.el b/cg-rum500.el index 7ef8adf..f604ce5 100644 --- a/cg-rum500.el +++ b/cg-rum500.el @@ -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* ((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)))) + (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))))) + (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) @@ -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) -;;; \ No newline at end of file +;;; cg-rum500.el ends here diff --git a/test/card-games-tests.el b/test/card-games-tests.el index 9678ca1..2a5c3be 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -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)))))