card-game.el/cg-rum500.el

636 lines
26 KiB
EmacsLisp
Raw Permalink Normal View History

;;; 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.90
;; 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. 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
;; 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)
(deep-pickup :initarg :deep-pickup :initform nil))
"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--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."
(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))))))
(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)))))
(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--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)
(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 %s Stock: %d\n\n"
(cg-tm--discard-string game)
(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) 'hand)
out)
(push (format "\n\n %s\n" (cg-get game :message)) out)
(apply #'concat (nreverse out))))
(cl-defmethod cg-render-apply ((g cg-tablemeld-game) action)
"Apply a click ACTION on the hand to GAME G."
(pcase action
(`(hand . ,i) (cg-put g :cursor i))
(_ (cl-call-next-method))))
(defun cg-tm--redisplay ()
"Redraw the table-meld buffer."
(let ((game cg-tm--game) (inhibit-read-only t))
(setq cg-current-game game cg-redisplay-function #'cg-tm--redisplay)
(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-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)
(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 T: deep take RET: discard n: new"))
(defvar cg-tm-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [mouse-1] #'cg-card-click)
(define-key map "+" #'cg-card-zoom-in)
(define-key map "=" #'cg-card-zoom-in)
(define-key map "-" #'cg-card-zoom-out)
(define-key map "0" #'cg-card-zoom-reset)
(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 "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)
(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)
(setq-local cursor-type cg-cursor-type))
(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)
(deep-pickup :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)
;;; cg-rum500.el ends here