From 585c4449a0544143c84c0a0a01786a4f5cb5d196 Mon Sep 17 00:00:00 2001 From: Corwin Brust Date: Wed, 1 Jul 2026 04:31:02 -0500 Subject: [PATCH] Rummy games: full SVG board (stock, discard, melds, fanned hand) * cg-rummy.el (cg-rummy--board-svg): shared board helper -- stock/discard, a melds table, and the hand with cursor/marks/lay-off hints and (hand . INDEX) click regions. (cg-gin--svg, cg-gin--render-text): Gin dispatch. * cg-rum500.el (cg-tm--svg, cg-tm--render-text): table-meld dispatch (Rummy and Rummy 500). (cg-render): SVG if graphical, else text. * test/card-games-tests.el: add cgt-gin-svg-smoke, cgt-tm-svg-smoke. * NEWS: note the rummy SVG board. --- NEWS | 4 ++ cg-rum500.el | 32 +++++++++- cg-rummy.el | 122 ++++++++++++++++++++++++++++++++++++++- test/card-games-tests.el | 21 +++++++ 4 files changed, 177 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index a7d6325..778ae5d 100644 --- a/NEWS +++ b/NEWS @@ -39,6 +39,10 @@ the mouse as well as the keyboard. the middle, and your fanned hand, with the legal cards you may play ringed. Click a card to play it. Set ~cg-trick-svg-cards~ to nil for the plain-text board. + - Full SVG board for the rummy games (Gin Rummy, Rummy, Rummy 500): + the stock and discard, the melds already down on the table, and your + fanned hand with cursor, marks, and lay-off hints; click a card to + select it. Honours ~cg-rummy-svg-cards~. ** Rummy-family rules completed - Rummy 500: take a card from anywhere in the discard pile (key ~T~) -- diff --git a/cg-rum500.el b/cg-rum500.el index 118956a..d5b9ada 100644 --- a/cg-rum500.el +++ b/cg-rum500.el @@ -351,8 +351,38 @@ Deep-pickup games show the whole pile with depth indices (0 = top)." :ace-high (cg-tm--ace-high game))) (cg-get game :table)))) +(defun cg-tm--svg (game) + "Return an SVG board for the table-meld GAME." + (let* ((scores (cg-get game :scores)) (laid (cg-get game :laid)) + (meldp (oref game score-style))) + (cg-rummy--board-svg + :title (format "%s (target %d)" (oref game vname) (oref game target)) + :infos (let (out) + (dotimes (s (cg-get game :nplayers)) + (unless (= s 0) + (push (format "Player %d: %d cards score %d%s" + s (length (cg-rummy--hand game s)) (aref scores s) + (if (eq meldp 'meld-points) + (format " laid %d" (aref laid s)) "")) + out))) + (nreverse out)) + :melds (mapcar (lambda (rec) + (cons (if (= (car rec) 0) "you" (format "P%d" (car rec))) + (cdr rec))) + (cg-get game :table)) + :discard (cg-rummy--top game) :stock (length (cg-get game :stock)) + :hand (cg-rummy--hand game 0) :cursor (cg-get game :cursor) + :marks (cg-get game :marks) :hint-fn (cg-tm--layoff-hint game) + :message (cg-get game :message)))) + (cl-defmethod cg-render ((game cg-tablemeld-game)) - "Return a propertized depiction of the table-meld GAME." + "Return a depiction of the table-meld GAME: SVG board if graphical, else text." + (if (and cg-rummy-svg-cards (display-graphic-p)) + (cg-tm--svg game) + (cg-tm--render-text game))) + +(defun cg-tm--render-text (game) + "Return a plain-text 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))) diff --git a/cg-rummy.el b/cg-rummy.el index b8d6867..20f042e 100644 --- a/cg-rummy.el +++ b/cg-rummy.el @@ -325,6 +325,98 @@ and carries a card-size slider. Draws SVG cards on a graphical display (setq i (1+ i))) (apply #'concat (nreverse out))))) +(defun cg-rummy--board-svg (&rest args) + "Draw a rummy-style board; return a propertized display string. +Keyword ARGS: :title :infos :melds :discard :stock :hand :cursor :marks +:hint-fn :message. :melds is a list of (LABEL . CARDS), or the symbol +`none' to hide the table area. The hand carries (hand . INDEX) regions." + (let* ((title (or (plist-get args :title) "")) + (infos (plist-get args :infos)) + (raw-melds (plist-get args :melds)) + (show-table (not (eq raw-melds 'none))) + (melds (and show-table raw-melds)) + (discard (plist-get args :discard)) + (stock (or (plist-get args :stock) 0)) + (hand (plist-get args :hand)) + (cursor (or (plist-get args :cursor) 0)) + (marks (plist-get args :marks)) + (hint-fn (plist-get args :hint-fn)) + (msg (or (plist-get args :message) "")) + (w cg-svg-card-width) (h cg-svg-card-height) (gap cg-svg-card-gap) + (pad 16) (label-w 46) + (n (length hand)) + (overlap (cond ((> n 11) (- w 24)) ((> n 8) 20) (t 0))) + (step (max 14 (- (+ w gap) overlap))) + (fanw (if (> n 0) (+ (* (1- n) step) w) w)) + (mstep (max 16 (round (* w 0.5)))) + (n-info (length infos)) + (y-title 6) (y-info 26) + (y-sd (+ y-info (* n-info 16) 8)) + (meld-rowh (+ h 8)) + (y-melds (+ y-sd h 26)) + (melds-area (if show-table (+ (* (max 1 (length melds)) meld-rowh) 16) 6)) + (y-hand (+ y-melds melds-area)) + (height (+ y-hand h 30)) + (meld-maxw (if melds + (apply #'max 0 + (mapcar (lambda (m) + (+ label-w + (let ((k (length (cdr m)))) + (if (> k 0) (+ (* (1- k) mstep) w) w)))) + melds)) + 0)) + (width (max (+ fanw (* 2 pad)) (+ meld-maxw (* 2 pad)) 640)) + (svg (svg-create width height)) + (lc (cg-color 'shadow :foreground "gray50")) + (regions '())) + (cl-labels ((txt (str x y &optional sz bold) + (apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc + :font-family cg-svg-font-family + (and bold '(:font-weight "bold")))) + (drow (specs x y stp) + (let ((xx x)) + (dolist (sp specs) + (if sp (cg-svg-card svg xx y :rank (car sp) :suit (cdr sp)) + (cg-svg-card svg xx y :gap t)) + (setq xx (+ xx stp)))))) + (txt title pad (+ y-title 12) 13 t) + (let ((yy (+ y-info 4))) + (dolist (line infos) (txt line pad yy 12) (setq yy (+ yy 16)))) + (cg-svg-card svg pad y-sd :down (> stock 0) :gap (= stock 0)) + (txt (format "Stock %d" stock) pad (+ y-sd h 13) 11) + (let ((dx (+ pad w gap 24))) + (if discard + (let ((sp (cg-rummy--card-spec discard))) + (cg-svg-card svg dx y-sd :rank (car sp) :suit (cdr sp))) + (cg-svg-card svg dx y-sd :gap t)) + (txt "Discard" dx (+ y-sd h 13) 11)) + (when show-table + (txt "Table" pad (- y-melds 4) 11) + (if (null melds) + (txt "(no melds yet)" (+ pad label-w) (+ y-melds (round (* h 0.5))) 11) + (let ((yy y-melds)) + (dolist (m melds) + (txt (car m) pad (+ yy (round (* h 0.55))) 11) + (drow (mapcar #'cg-rummy--card-spec (cdr m)) (+ pad label-w) yy mstep) + (setq yy (+ yy meld-rowh)))))) + (txt "Your hand" pad (- y-hand 6) 11) + (let ((x (max pad (- (/ width 2) (/ fanw 2)))) (i 0)) + (dolist (c hand) + (let ((sp (cg-rummy--card-spec c)) + (curp (= i cursor)) + (markp (and marks (memq i marks))) + (hintp (and hint-fn (funcall hint-fn c)))) + (cg-svg-card svg x y-hand :rank (car sp) :suit (cdr sp) + :highlight curp :hint hintp) + (when markp + (svg-rectangle svg (- x 3) (- y-hand 3) (+ w 6) (+ h 6) + :rx 8 :fill "none" :stroke "#4a90d9" :stroke-width 3)) + (push (cons (list x y-hand (if (= i (1- n)) w step) h) (cons 'hand i)) regions)) + (setq x (+ x step) i (1+ i)))) + (txt msg pad (- height 8) 12)) + (propertize "*" 'display (cg-svg-image svg (cg-scale)) + 'cg-regions (nreverse regions)))) + (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 " ")) @@ -465,8 +557,36 @@ and carries a card-size slider. Draws SVG cards on a graphical display (defvar-local cg-gin--game nil "The Gin Rummy game in the current buffer.") +(defun cg-gin--svg (game) + "Return an SVG board for the Gin GAME." + (let* ((scores (cg-get game :scores)) (reveal (cg-get game :reveal)) + (hand (cg-rummy--hand game 0)) (infos '())) + (push (format "Opponent: %d cards score %d" + (length (cg-rummy--hand game 1)) (aref scores 1)) infos) + (when reveal + (let ((pp (cg-rummy-best-partition (cg-rummy--hand game 1)))) + (push (format " melds %s deadwood %s (%d)" + (cg-rummy--melds-string (plist-get pp :melds)) + (mapconcat #'cg-rummy-card-string (plist-get pp :deadwood) " ") + (plist-get pp :count)) + infos))) + (push (format "You: deadwood %d score %d" + (cg-gin--deadwood hand) (aref scores 0)) infos) + (cg-rummy--board-svg + :title (format "Gin Rummy (first to %d)" cg-gin-target) + :infos (nreverse infos) :melds 'none + :discard (cg-rummy--top game) :stock (length (cg-get game :stock)) + :hand hand :cursor (cg-get game :cursor) + :message (cg-get game :message)))) + (cl-defmethod cg-render ((game cg-gin-game)) - "Return a propertized depiction of the Gin GAME for a text display." + "Return a depiction of the Gin GAME: SVG board if graphical, else text." + (if (and cg-rummy-svg-cards (display-graphic-p)) + (cg-gin--svg game) + (cg-gin--render-text game))) + +(defun cg-gin--render-text (game) + "Return a plain-text depiction of the Gin GAME." (let* ((out '()) (scores (cg-get game :scores)) (reveal (cg-get game :reveal)) (hand (cg-rummy--hand game 0)) (cursor (cg-get game :cursor))) diff --git a/test/card-games-tests.el b/test/card-games-tests.el index 9de16bf..1492e3c 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -855,6 +855,27 @@ (cg-put g :bids (vector 3 nil 4 nil)) (cg-put g :scores (vector 100 50 100 50)) (should (stringp (cg-trick--svg g))))) +(ert-deftest cgt-gin-svg-smoke () + (let ((g (cg-gin-game))) + (cg-gin--deal g) + (cg-put g :cursor 0) (cg-put g :message "x") (cg-put g :scores (vector 0 0)) + (should (stringp (cg-gin--render-text g))) + (let ((sres (cg-gin--svg g))) + (should (get-text-property 0 'display sres)) + (should (rassoc '(hand . 0) (get-text-property 0 'cg-regions sres)))))) + +(ert-deftest cgt-tm-svg-smoke () + (let ((g (cg-rum500-game))) + (cg-tm--deal g) + (cg-put g :cursor 1) (cg-put g :message "x") + (cg-put g :table (list (cons 0 (list '(0 . 0) '(0 . 1) '(0 . 2))) + (cons 2 (list '(1 . 5) '(2 . 5) '(3 . 5))))) + (cg-put g :marks (list 0 2)) + (should (stringp (cg-tm--render-text g))) + (let ((regs (get-text-property 0 'cg-regions (cg-tm--svg g)))) + (should (rassoc '(hand . 0) regs)) + (should (cl-every (lambda (r) (= 4 (length (car r)))) regs))))) + (ert-deftest cgt-pat-golf-deal () (let ((g (cg-pat--deal (cg-golf-game)))) (should (= 35 (length (cg-get g :cards))))