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

Rummy games: full SVG board (stock, discard, melds, fanned hand)

Browse source 
* 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.
This commit is contained in:
Corwin Brust 2026-07-01 04:31:02 -05:00
parent 98b297d149
commit 585c4449a0
4 changed files with 177 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

4
NEWS
View file

@ -39,6 +39,10 @@ the mouse as well as the keyboard.
the middle, and your fanned hand, with the legal cards you may play 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 ringed. Click a card to play it. Set ~cg-trick-svg-cards~ to nil
for the plain-text board. 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-family rules completed
- Rummy 500: take a card from anywhere in the discard pile (key ~T~) -- - Rummy 500: take a card from anywhere in the discard pile (key ~T~) --

32
cg-rum500.el
View file

@ -351,8 +351,38 @@ Deep-pickup games show the whole pile with depth indices (0 = top)."
:ace-high (cg-tm--ace-high game))) :ace-high (cg-tm--ace-high game)))
(cg-get game :table)))) (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)) (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)) (let* ((out '()) (scores (cg-get game :scores))
(laid (cg-get game :laid)) (meldp (oref game score-style)) (laid (cg-get game :laid)) (meldp (oref game score-style))
(hand (cg-rummy--hand game 0)) (cursor (cg-get game :cursor))) (hand (cg-rummy--hand game 0)) (cursor (cg-get game :cursor)))

122
cg-rummy.el
View file

@ -325,6 +325,98 @@ and carries a card-size slider. Draws SVG cards on a graphical display
(setq i (1+ i))) (setq i (1+ i)))
(apply #'concat (nreverse out))))) (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) (defun cg-rummy--melds-string (melds)
"Return a one-line depiction of MELDS (a list of card-lists)." "Return a one-line depiction of MELDS (a list of card-lists)."
(mapconcat (lambda (m) (mapconcat #'cg-rummy-card-string m " ")) (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.") (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)) (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)) (let* ((out '()) (scores (cg-get game :scores))
(reveal (cg-get game :reveal)) (reveal (cg-get game :reveal))
(hand (cg-rummy--hand game 0)) (cursor (cg-get game :cursor))) (hand (cg-rummy--hand game 0)) (cursor (cg-get game :cursor)))

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

@ -855,6 +855,27 @@
(cg-put g :bids (vector 3 nil 4 nil)) (cg-put g :scores (vector 100 50 100 50)) (cg-put g :bids (vector 3 nil 4 nil)) (cg-put g :scores (vector 100 50 100 50))
(should (stringp (cg-trick--svg g))))) (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 () (ert-deftest cgt-pat-golf-deal ()
(let ((g (cg-pat--deal (cg-golf-game)))) (let ((g (cg-pat--deal (cg-golf-game))))
(should (= 35 (length (cg-get g :cards)))) (should (= 35 (length (cg-get g :cards))))