From 287700ddca994c82adf04926334aaf436e484679 Mon Sep 17 00:00:00 2001 From: Corwin Brust Date: Thu, 25 Jun 2026 09:10:42 -0500 Subject: [PATCH 1/4] Wire the renderer registry: SVG treatment returns a region click-map cg-renderer gains a regions slot; the text/svg treatments get real draw/hit methods; cg-regions-hit + cg-render-apply complete the loop. Prototype on solitaire: cg-sol--svg returns (image . regions), redisplay goes through cg-render-game, and [mouse-1] selects-and-acts by reusing the keyboard pick-up/drop. Adds cgt-keystone-regions; suite 110/110. --- cg-core.el | 19 ++++++++++++++- cg-render.el | 28 ++++++++++++++++++++++ cg-solitaire.el | 52 ++++++++++++++++++++++++++++++---------- test/card-games-tests.el | 22 +++++++++++++++++ 4 files changed, 108 insertions(+), 13 deletions(-) diff --git a/cg-core.el b/cg-core.el index 58fb2ea..0e5ed53 100644 --- a/cg-core.el +++ b/cg-core.el @@ -94,7 +94,10 @@ and SPC as an action key. Takes effect the next time a game starts." (defclass cg-renderer () ((name :initarg :name :initform 'text :type symbol - :documentation "Symbol naming this treatment.")) + :documentation "Symbol naming this treatment.") + (regions :initarg :regions :initform nil + :documentation "Click map from the last draw: list of (RECT . ACTION), +RECT being (X Y W H) in unscaled image pixels.")) "Abstract base class for a display treatment (a \"skin\")." :abstract t) @@ -114,6 +117,20 @@ Return non-nil when the click was handled.") "Default method: treat the click as unhandled." nil) +(defun cg-regions-hit (regions px py) + "Return the ACTION of the first region in REGIONS containing PX, PY. +Each region is (RECT . ACTION) with RECT (X Y W H) in image pixels." + (cl-loop for (rect . action) in regions + for (x y w h) = rect + when (and (>= px x) (< px (+ x w)) (>= py y) (< py (+ y h))) + return action)) + +(cl-defgeneric cg-render-apply (game action) + "Perform ACTION (returned by a renderer hit) on GAME. +The default does nothing; games specialise this to make clicks act." + (ignore game action) + nil) + (defvar cg-renderers nil "Alist mapping a treatment name (a symbol) to a `cg-renderer' subclass. Populate it with `cg-register-renderer' and look entries up with diff --git a/cg-render.el b/cg-render.el index 4e6a5f8..f6e3c32 100644 --- a/cg-render.el +++ b/cg-render.el @@ -94,5 +94,33 @@ The default treatment comes from `cg-render-resolve-treatment'." "Switch GAME to the treatment NAME and return its new renderer." (oset game renderer (cg-make-renderer name))) +(cl-defgeneric cg-render-text (game) + "Return the plain-text display string for GAME. +The default falls back to the game's `cg-render' method." + (cg-render game)) + +(cl-defgeneric cg-render-svg (game) + "Return (DISPLAY-STRING . REGIONS) for GAME's SVG treatment. +The default falls back to the `cg-render' string with no click regions." + (cons (cg-render game) nil)) + +(cl-defmethod cg-renderer-draw ((r cg-text-renderer) (game cg-game)) + "Draw GAME as plain text, clearing any click regions." + (oset r regions nil) + (insert (cg-render-text game))) + +(cl-defmethod cg-renderer-draw ((r cg-svg-renderer) (game cg-game)) + "Draw GAME as SVG and record its click regions on R." + (let ((res (cg-render-svg game))) + (oset r regions (cdr res)) + (insert (car res)))) + +(cl-defmethod cg-renderer-hit ((r cg-svg-renderer) (game cg-game) position) + "Map POSITION to a game action via the regions recorded at the last draw." + (ignore game) + (let ((xy (posn-object-x-y position)) (sc (cg-scale))) + (and xy (cg-regions-hit (oref r regions) + (round (/ (car xy) sc)) (round (/ (cdr xy) sc)))))) + (provide 'cg-render) ;;; cg-render.el ends here diff --git a/cg-solitaire.el b/cg-solitaire.el index 8393a78..57500e1 100644 --- a/cg-solitaire.el +++ b/cg-solitaire.el @@ -50,6 +50,7 @@ (require 'eieio) (require 'cg-core) (require 'cg-svg) +(require 'cg-render) ;;;; Cards @@ -610,31 +611,34 @@ With prefix COUNT, pick up exactly COUNT cards from a column." (and card (cons (aref cg-sol-ranks (cdr card)) (car card)))) (defun cg-sol--svg (game) - "Return a propertized one-image SVG board for solitaire GAME." + "Return (DISPLAY . REGIONS) for an SVG board of solitaire GAME. +DISPLAY is a propertized one-image string; REGIONS is a click map of +\(RECT . SPOT) entries, RECT being (X Y W H) in unscaled image pixels." (let* ((w cg-svg-card-width) (h cg-svg-card-height) (pad 12) (gap cg-svg-card-gap) (colgap 8) (vdown 12) (vup 26) (ncols (oref game ncols)) (cur-spot (cg-sol--cur-spot game)) (sel (cg-get game :sel)) (sel-n (or (cg-get game :sel-n) 0)) (lc (cg-color 'shadow :foreground "gray40")) - (slots '())) + (regions '()) (slots '())) (when (oref game has-stock) (push (list (format "Stock(%d)" (length (cg-get game :stock))) - nil (and (cg-get game :stock) t) (equal cur-spot '(stock . 0))) slots)) + nil (and (cg-get game :stock) t) (equal cur-spot '(stock . 0)) + '(stock . 0)) slots)) (when (oref game has-waste) (push (list "Waste" (cg-sol--spec (car (last (cg-get game :waste)))) nil - (equal cur-spot '(waste . 0))) slots)) + (equal cur-spot '(waste . 0)) '(waste . 0)) slots)) (when (oref game has-reserve) (push (list (format "Resv(%d)" (length (cg-get game :reserve))) (cg-sol--spec (car (last (cg-get game :reserve)))) nil - (equal cur-spot '(reserve . 0))) slots)) + (equal cur-spot '(reserve . 0)) '(reserve . 0)) slots)) (dotimes (i (oref game nfree)) (push (list (format "F%d" (1+ i)) (cg-sol--spec (aref (cg-get game :free) i)) nil - (equal cur-spot (cons 'free i))) slots)) + (equal cur-spot (cons 'free i)) (cons 'free i)) slots)) (dotimes (i (oref game nfound)) (push (list (format "%d" (1+ i)) (cg-sol--spec (car (last (aref (cg-get game :found) i)))) nil - (equal cur-spot (cons 'found i))) slots)) + (equal cur-spot (cons 'found i)) (cons 'found i)) slots)) (setq slots (nreverse slots)) (let* ((ntop (length slots)) (topw (+ (* 2 pad) (* ntop (+ w gap)))) @@ -653,13 +657,14 @@ With prefix COUNT, pick up exactly COUNT cards from a column." (svg (svg-create width height))) (let ((x pad)) (dolist (sl slots) - (cl-destructuring-bind (label spec downp cursorp) sl + (cl-destructuring-bind (label spec downp cursorp spot) sl (svg-text svg label :x (+ x 1) :y (- top-y 3) :font-size 11 :fill lc :font-family cg-svg-font-family) (cond (downp (cg-svg-card svg x top-y :down t :highlight cursorp)) (spec (cg-svg-card svg x top-y :rank (car spec) :suit (cdr spec) :highlight cursorp)) - (t (cg-svg-card svg x top-y :gap t :highlight cursorp)))) + (t (cg-svg-card svg x top-y :gap t :highlight cursorp))) + (push (cons (list x top-y w h) spot) regions)) (setq x (+ x w gap)))) (dotimes (c ncols) (let* ((x (+ pad (* c (+ w colgap)))) (col (aref tab c)) (len (length col)) @@ -667,6 +672,7 @@ With prefix COUNT, pick up exactly COUNT cards from a column." (cursorp (equal cur-spot (cons 'col c)))) (svg-text svg (format "%d" (1+ c)) :x (+ x 1) :y col-label-y :font-size 11 :fill lc :font-family cg-svg-font-family) + (push (cons (list x col-y w maxext) (cons 'col c)) regions) (if (= len 0) (cg-svg-card svg x y :gap t :highlight cursorp) (dolist (card col) @@ -677,14 +683,27 @@ With prefix COUNT, pick up exactly COUNT cards from a column." :suit (cdr (cg-sol--spec card)) :highlight (and top-card cursorp) :hint selp)) (setq y (+ y (if downp vdown vup)) r (1+ r))))))) - (propertize "*" 'display (cg-svg-image svg (cg-scale)))))) + (cons (propertize "*" 'display (cg-svg-image svg (cg-scale))) + (nreverse regions))))) (cl-defmethod cg-render ((game cg-solitaire-game)) "Return a propertized depiction of GAME (SVG on a graphical display)." (if (and cg-sol-svg-cards (display-graphic-p)) - (cg-sol--svg game) + (car (cg-sol--svg game)) (cg-sol--render-text game))) +(cl-defmethod cg-render-text ((game cg-solitaire-game)) + (cg-sol--render-text game)) + +(cl-defmethod cg-render-svg ((game cg-solitaire-game)) + (if cg-sol-svg-cards (cg-sol--svg game) + (cons (cg-sol--render-text game) nil))) + +(cl-defmethod cg-render-apply ((game cg-solitaire-game) action) + "Apply a click ACTION (a cursor spot) by selecting it and acting." + (let ((idx (cl-position action (cg-sol--spots game) :test #'equal))) + (when idx (cg-put game :cursor idx) (cg-sol-act)))) + (defun cg-sol--render-text (game) "Return a plain-text depiction of solitaire GAME." (let* ((spots (cg-sol--spots game)) @@ -763,13 +782,22 @@ With prefix COUNT, pick up exactly COUNT cards from a column." (let ((s (cg-get game :sel))) (if s "carrying" "playing"))))) (erase-buffer) - (insert (cg-render game)) + (cg-render-game game) (goto-char (point-min)))) ;;;; Mode and commands +(defun cg-sol-mouse (event) + "Handle a mouse click on the solitaire board: select that pile and act." + (interactive "e") + (let* ((game cg-sol--game) + (r (and game (oref game renderer))) + (action (and r (cg-renderer-hit r game (event-start event))))) + (when action (cg-render-apply game action)))) + (defvar cg-sol-mode-map (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] #'cg-sol-mouse) (define-key map (kbd "") #'cg-sol-left) (define-key map (kbd "") #'cg-sol-right) (define-key map (kbd "") #'cg-sol-up) diff --git a/test/card-games-tests.el b/test/card-games-tests.el index 62d530f..4845bf5 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -1063,3 +1063,25 @@ (should (memq (cg-get g :phase) '(scored passed-out))) (should (stringp (cg-render g))))) (should (> scored 0)))) +;;;; Renderer registry / region keystone + +(ert-deftest cgt-keystone-regions () + (let* ((g (cg-sol--deal (make-instance 'cg-klondike-game))) + (res (cg-render-svg g))) + (should (stringp (car res))) + (should (>= (length (cdr res)) 13)) ; 6 top slots + 7 columns + (let* ((reg (cl-find '(col . 3) (cdr res) :key #'cdr :test #'equal)) + (rect (car reg))) + (should reg) + (should (equal '(col . 3) + (cg-regions-hit (cdr res) + (+ (nth 0 rect) (/ (nth 2 rect) 2)) + (+ (nth 1 rect) 10))))) + (should (null (cg-regions-hit (cdr res) -5 -5)))) + (with-temp-buffer + (setq cg-sol--game (cg-sol--deal (make-instance 'cg-klondike-game))) + (cg-render-game cg-sol--game) + (should (oref cg-sol--game renderer)) + (should (> (buffer-size) 0)) + (cg-render-apply cg-sol--game '(col . 5)) + (should (= 11 (cg-get cg-sol--game :cursor))))) ; spot index of (col . 5) From 2c700b77391c53b598a6de25fb24ef6b7fa27d38 Mon Sep 17 00:00:00 2001 From: Corwin Brust Date: Thu, 25 Jun 2026 09:53:56 -0500 Subject: [PATCH 2/4] Hand-cluster mouse + card-size slider Shared hand row gains a region-tag: tagged hands carry a cg-regions click map (cards -> (hand . i)) and a card-size slider in the same image. cg-core adds cg-mouse-action, cg-card-click, zoom commands, cg-card-scale (folded into cg-scale), and a cg-render-apply base for scale/zoom. Seven hand games are now click-to-position (Scopa/Casino/Spite click-to-play), with [mouse-1] and +/-/0 bound. Adds cgt-hand-regions; suite 111/111. --- cg-core.el | 66 ++++++++++++++++++++++++++++++++++++---- cg-cribbage.el | 14 ++++++++- cg-handfoot.el | 14 ++++++++- cg-match.el | 14 ++++++++- cg-rum500.el | 14 ++++++++- cg-rummy.el | 59 ++++++++++++++++++++++++++++------- cg-scopa.el | 15 ++++++++- cg-spite.el | 15 ++++++++- cg-svg.el | 31 +++++++++++++++++++ test/card-games-tests.el | 16 ++++++++++ 10 files changed, 235 insertions(+), 23 deletions(-) diff --git a/cg-core.el b/cg-core.el index 0e5ed53..e01bd8c 100644 --- a/cg-core.el +++ b/cg-core.el @@ -44,6 +44,11 @@ :group 'games :prefix "cg-") +(defcustom cg-card-scale 1.0 + "Card-size multiplier applied on top of any text scaling. +Adjust with the card-size slider or the zoom keys (+/-/0)." + :type 'number :group 'card-games) + ;;;; Engine base @@ -127,9 +132,15 @@ Each region is (RECT . ACTION) with RECT (X Y W H) in image pixels." (cl-defgeneric cg-render-apply (game action) "Perform ACTION (returned by a renderer hit) on GAME. -The default does nothing; games specialise this to make clicks act." - (ignore game action) - nil) +Card-size actions (scale/zoom) are handled here; games specialise this +for their own actions and delegate the rest with `cl-call-next-method'." + (ignore game) + (pcase action + (`(scale . ,v) (setq cg-card-scale v) t) + ('zoom-in (setq cg-card-scale (min 3.0 (+ cg-card-scale 0.15))) t) + ('zoom-out (setq cg-card-scale (max 0.4 (- cg-card-scale 0.15))) t) + ('zoom-reset (setq cg-card-scale 1.0) t) + (_ nil))) (defvar cg-renderers nil "Alist mapping a treatment name (a symbol) to a `cg-renderer' subclass. @@ -217,10 +228,53 @@ or batch), so callers always get a drawable colour string." (defun cg-scale () "Return the SVG card scale factor for the current buffer. -Tracks `text-scale-increase'/`text-scale-decrease' via the buffer-local -`text-scale-mode-amount', so enlarging the text enlarges the cards." +Combines `cg-card-scale' with `text-scale-mode-amount', so both the +size slider and `text-scale-increase' enlarge the cards." (let ((amt (if (boundp 'text-scale-mode-amount) text-scale-mode-amount 0))) - (max 0.4 (min 4.0 (expt 1.15 amt))))) + (max 0.3 (min 4.0 (* cg-card-scale (expt 1.15 amt)))))) + +(defvar-local cg-current-game nil + "The `cg-game' shown in the current buffer (for shared mouse/zoom).") + +(defvar-local cg-redisplay-function #'ignore + "Buffer-local function that redraws the current game's buffer.") + +(defun cg-card-refresh () + "Redraw the current game buffer via `cg-redisplay-function'." + (funcall cg-redisplay-function)) + +(defun cg-mouse-action (event) + "Return the action under mouse EVENT from the clicked image's region map. +The clicked display string must carry a `cg-regions' text property." + (let* ((posn (event-start event)) (pt (posn-point posn)) + (regions (and pt (get-text-property pt 'cg-regions)))) + (when regions + (let ((xy (posn-object-x-y posn)) (sc (cg-scale))) + (and xy (cg-regions-hit regions + (round (/ (car xy) sc)) (round (/ (cdr xy) sc)))))))) + +(defun cg-card-click (event) + "Dispatch a mouse click on a card or control to the current game." + (interactive "e") + (let ((action (cg-mouse-action event))) + (when (and action cg-current-game) + (cg-render-apply cg-current-game action) + (cg-card-refresh)))) + +(defun cg-card-zoom-in () + "Make the cards larger." + (interactive) + (setq cg-card-scale (min 3.0 (+ cg-card-scale 0.15))) (cg-card-refresh)) + +(defun cg-card-zoom-out () + "Make the cards smaller." + (interactive) + (setq cg-card-scale (max 0.4 (- cg-card-scale 0.15))) (cg-card-refresh)) + +(defun cg-card-zoom-reset () + "Reset the card size." + (interactive) + (setq cg-card-scale 1.0) (cg-card-refresh)) (provide 'cg-core) ;;; cg-core.el ends here diff --git a/cg-cribbage.el b/cg-cribbage.el index 921b3a9..60b5b8b 100644 --- a/cg-cribbage.el +++ b/cg-cribbage.el @@ -319,12 +319,19 @@ TOTAL is the running count after the play." (mapconcat #'cg-rummy-card-string (cg-get game :crib) " ")) out)))) (let* ((hand (if (eq phase 'play) (cg-crib--play game 0) (cg-crib--hand game 0)))) (push (format "\n Your %s:\n " (if (eq phase 'play) "cards" "hand")) out) - (push (cg-rummy--render-cards hand cursor (cg-get game :marks)) out)) + (push (cg-rummy--render-cards hand cursor (cg-get game :marks) nil 'hand) out)) (push (format "\n\n %s\n" (cg-get game :message)) out) (apply #'concat (nreverse out)))) +(cl-defmethod cg-render-apply ((g cg-cribbage-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-crib--redisplay () (let ((game cg-crib--game) (inhibit-read-only t)) + (setq cg-current-game game cg-redisplay-function #'cg-crib--redisplay) (setq-local mode-line-process (format " [%s]" (cg-get game :phase))) (erase-buffer) (insert (cg-render game)) (goto-char (point-min)))) @@ -406,6 +413,11 @@ TOTAL is the running count after the play." (defvar cg-cribbage-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 "") #'cg-crib-left) (define-key map (kbd "") #'cg-crib-right) (define-key map (kbd "SPC") #'cg-crib-mark) diff --git a/cg-handfoot.el b/cg-handfoot.el index 33e3a97..659e4f2 100644 --- a/cg-handfoot.el +++ b/cg-handfoot.el @@ -366,13 +366,20 @@ (length (cg-get game :stock))) out) (push (format " Your %s:\n " (if (= (aref (cg-get game :stage) 0) 1) "foot" "hand")) out) - (push (cg-rummy--render-cards hand cursor (cg-get game :marks)) out) + (push (cg-rummy--render-cards hand cursor (cg-get game :marks) nil 'hand) out) (push (format "\n\n %s\n" (cg-get game :message)) out) (apply #'concat (nreverse out)))) +(cl-defmethod cg-render-apply ((g cg-handfoot-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-hf--redisplay () "Redraw the Hand & Foot buffer." (let ((game cg-hf--game) (inhibit-read-only t)) + (setq cg-current-game game cg-redisplay-function #'cg-hf--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)))) @@ -495,6 +502,11 @@ (defvar cg-handfoot-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 "") #'cg-hf-left) (define-key map (kbd "") #'cg-hf-right) (define-key map (kbd "SPC") #'cg-hf-mark) diff --git a/cg-match.el b/cg-match.el index 02bf7b2..a41bfee 100644 --- a/cg-match.el +++ b/cg-match.el @@ -208,12 +208,19 @@ Return non-nil when S can ask." (push (format "\n Stock: %d Your books: %d\n\n" (length (cg-get game :stock)) (cg-gf--books game 0)) out) (push " Your hand:\n " out) - (push (cg-rummy--render-cards hand cursor nil) out) + (push (cg-rummy--render-cards hand cursor nil nil 'hand) out) (push (format "\n\n %s\n" (cg-get game :message)) out) (apply #'concat (nreverse out)))) +(cl-defmethod cg-render-apply ((g cg-go-fish-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-gf--redisplay () (let ((game cg-gf--game) (inhibit-read-only t)) + (setq cg-current-game game cg-redisplay-function #'cg-gf--redisplay) (setq-local mode-line-process (format " [%s]" (cg-get game :phase))) (erase-buffer) (insert (cg-render game)) (goto-char (point-min)))) @@ -257,6 +264,11 @@ Return non-nil when S can ask." (defvar cg-go-fish-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 "") #'cg-gf-left) (define-key map (kbd "") #'cg-gf-right) (dolist (k '("1" "2" "3" "4")) (define-key map k #'cg-gf-ask)) diff --git a/cg-rum500.el b/cg-rum500.el index b96baf6..7ef8adf 100644 --- a/cg-rum500.el +++ b/cg-rum500.el @@ -306,14 +306,21 @@ Return non-nil if any meld was laid." (format " (score %d)" (aref scores 0)))) out) (push (cg-rummy--render-cards hand cursor (cg-get game :marks) - (cg-tm--layoff-hint game)) + (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)))) @@ -443,6 +450,11 @@ Return non-nil if any meld was laid." (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 "") #'cg-tm-left) (define-key map (kbd "") #'cg-tm-right) (define-key map (kbd "SPC") #'cg-tm-mark) diff --git a/cg-rummy.el b/cg-rummy.el index 2e68dfc..cac8351 100644 --- a/cg-rummy.el +++ b/cg-rummy.el @@ -289,8 +289,10 @@ Set to nil to force the plain-text card row everywhere." (if (cg-rummy-joker-p card) (cons "" 'joker) (cons (aref cg-rummy-ranks (cdr card)) (car card)))) -(defun cg-rummy--svg-row (cards cursor marks hint-fn) - "Return a one-image SVG row for CARDS with CURSOR, MARKS and HINT-FN." +(defun cg-rummy--svg-row (cards cursor marks hint-fn &optional region-tag) + "Return a one-image SVG row for CARDS. +When REGION-TAG is non-nil, attach a `cg-regions' click map (each card as +\(REGION-TAG . INDEX)) and draw a card-size slider beneath the row." (let* ((specs (mapcar #'cg-rummy--card-spec cards)) (hints (when hint-fn (let ((hs '()) (i 0)) @@ -298,18 +300,41 @@ Set to nil to force the plain-text card row everywhere." (setq i (1+ i))) hs))) (cur (and (integerp cursor) (>= cursor 0) cursor)) - (overlap (if (> (length cards) 11) (max 0 (- cg-svg-card-width 24)) 0)) - (svg (cg-svg-hand-svg specs :cursor cur :hints hints - :marks marks :overlap overlap))) - (propertize "*" 'display (cg-svg-image svg (cg-scale))))) + (overlap (if (> (length cards) 11) (max 0 (- cg-svg-card-width 24)) 0))) + (if (not region-tag) + (propertize "*" 'display + (cg-svg-image (cg-svg-hand-svg specs :cursor cur :hints hints + :marks marks :overlap overlap) + (cg-scale))) + (let* ((w cg-svg-card-width) (h cg-svg-card-height) (pad 8) + (step (max 1 (- (+ w cg-svg-card-gap) overlap))) + (n (length cards)) + (cardw (if (> n 0) (+ (* (1- n) step) w) w)) + (sh (cg-svg-slider-height)) + (width (+ (* 2 pad) (max cardw (cg-svg-slider-width)))) + (height (+ (* 2 pad) h 8 sh)) + (svg (svg-create width height)) (regions '()) (x pad) (i 0)) + (dolist (spec specs) + (cg-svg--draw-spec svg x pad spec (eql i cur) (and (memq i hints) t)) + (when (memq i marks) + (svg-rectangle svg (- x 3) (- pad 3) (+ w 6) (+ h 6) + :rx 7 :fill "none" :stroke "#4a90d9" :stroke-width 3)) + (push (cons (list x pad w h) (cons region-tag i)) regions) + (setq x (+ x step) i (1+ i))) + (setq regions (append (nreverse regions) + (cg-svg-slider-draw svg pad (+ pad h 8) cg-card-scale))) + (propertize "*" 'display (cg-svg-image svg (cg-scale)) + 'cg-regions regions))))) -(defun cg-rummy--render-cards (cards cursor marks &optional hint-fn) +(defun cg-rummy--render-cards (cards cursor marks &optional hint-fn region-tag) "Return a propertized row of CARDS. CURSOR is the highlighted index, MARKS a list of marked indices, and -HINT-FN an optional predicate marking playable cards. Draws SVG cards on -a graphical display (see `cg-rummy-svg-cards'), else a plain-text row." +HINT-FN an optional predicate marking playable cards. When REGION-TAG is +non-nil the SVG row is clickable (each card mapped to (REGION-TAG . INDEX)) +and carries a card-size slider. Draws SVG cards on a graphical display +\(see `cg-rummy-svg-cards'), else a plain-text row." (if (and cg-rummy-svg-cards (display-graphic-p)) - (cg-rummy--svg-row cards cursor marks hint-fn) + (cg-rummy--svg-row cards cursor marks hint-fn region-tag) (let ((i 0) (out '())) (dolist (c cards) (let ((cs (cg-rummy-card-string c)) (faces nil)) @@ -485,7 +510,7 @@ a graphical display (see `cg-rummy-svg-cards'), else a plain-text row." out) (push (format " Your hand (deadwood %d, score %d):\n " (cg-gin--deadwood hand) (aref scores 0)) out) - (push (cg-rummy--render-cards hand cursor nil) out) + (push (cg-rummy--render-cards hand cursor nil nil 'hand) out) (when reveal (let ((p (cg-rummy-best-partition hand))) (push (format "\n melds: %s\n deadwood: %s" @@ -495,9 +520,16 @@ a graphical display (see `cg-rummy-svg-cards'), else a plain-text row." (push (format "\n\n %s\n" (cg-get game :message)) out) (apply #'concat (nreverse out)))) +(cl-defmethod cg-render-apply ((g cg-gin-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-gin--redisplay () "Redraw the Gin Rummy buffer." (let ((game cg-gin--game) (inhibit-read-only t)) + (setq cg-current-game game cg-redisplay-function #'cg-gin--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)))) @@ -610,6 +642,11 @@ a graphical display (see `cg-rummy-svg-cards'), else a plain-text row." (defvar cg-gin-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 "") #'cg-gin-left) (define-key map (kbd "") #'cg-gin-right) (define-key map "s" #'cg-gin-draw-stock) diff --git a/cg-scopa.el b/cg-scopa.el index 5b884ef..d28757d 100644 --- a/cg-scopa.el +++ b/cg-scopa.el @@ -235,12 +235,20 @@ Only subsets of two or more cards are considered. Return nil if none." "(empty)") out) (push "\n\n Your hand:\n " out) - (push (cg-rummy--render-cards (cg-fish--hand game 0) cursor nil) out) + (push (cg-rummy--render-cards (cg-fish--hand game 0) cursor nil nil 'hand) out) (push (format "\n\n %s\n" (cg-get game :message)) out) (apply #'concat (nreverse out)))) +(cl-defmethod cg-render-apply ((g cg-fish-game) action) + "Apply a click ACTION on the hand to GAME G." + (pcase action + (`(hand . ,i) (cg-put g :cursor i) + (cg-fish-play)) + (_ (cl-call-next-method)))) + (defun cg-fish--redisplay () (let ((game cg-fish--game) (inhibit-read-only t)) + (setq cg-current-game game cg-redisplay-function #'cg-fish--redisplay) (setq-local mode-line-process (format " [%s]" (cg-get game :phase))) (erase-buffer) (insert (cg-render game)) (goto-char (point-min)))) @@ -287,6 +295,11 @@ Only subsets of two or more cards are considered. Return nil if none." (defvar cg-fish-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 "") #'cg-fish-left) (define-key map (kbd "") #'cg-fish-right) (define-key map (kbd "RET") #'cg-fish-play) diff --git a/cg-spite.el b/cg-spite.el index 56d8a46..c5677de 100644 --- a/cg-spite.el +++ b/cg-spite.el @@ -291,12 +291,20 @@ out) (push (format " Your discards: %s\n\n" (cg-spite--disc-string game 0)) out) (push " Your hand:\n " out) - (push (cg-rummy--render-cards (cg-spite--hand game 0) cursor nil) out) + (push (cg-rummy--render-cards (cg-spite--hand game 0) cursor nil nil 'hand) out) (push (format "\n\n %s\n" (cg-get game :message)) out) (apply #'concat (nreverse out)))) +(cl-defmethod cg-render-apply ((g cg-spite-game) action) + "Apply a click ACTION on the hand to GAME G." + (pcase action + (`(hand . ,i) (cg-put g :cursor i) + (cg-spite-play)) + (_ (cl-call-next-method)))) + (defun cg-spite--redisplay () (let ((game cg-spite--game) (inhibit-read-only t)) + (setq cg-current-game game cg-redisplay-function #'cg-spite--redisplay) (setq-local mode-line-process (format " [%s]" (cg-get game :phase))) (erase-buffer) (insert (cg-render game)) (goto-char (point-min)))) @@ -391,6 +399,11 @@ (defvar cg-spite-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 "") #'cg-spite-left) (define-key map (kbd "") #'cg-spite-right) (define-key map (kbd "RET") #'cg-spite-play) diff --git a/cg-svg.el b/cg-svg.el index 93bb90f..993ac41 100644 --- a/cg-svg.el +++ b/cg-svg.el @@ -404,5 +404,36 @@ indices to ring as playable and as marked; OVERLAP fans the cards." (setq x (+ x step) i (1+ i))) svg)) +(defcustom cg-svg-slider-stops '(0.6 0.8 1.0 1.25 1.5 1.8 2.2) + "Card-size slider stops, as scale multipliers." + :type '(repeat number) :group 'card-games) + +(defun cg-svg-slider-width () + "Return the pixel width of the card-size slider." + (+ 36 (* (length cg-svg-slider-stops) 24) 8)) + +(defun cg-svg-slider-height () + "Return the pixel height of the card-size slider." + 24) + +(defun cg-svg-slider-draw (svg x y current) + "Draw a card-size slider into SVG at X, Y knobbed at CURRENT. +Return its click regions as a list of (RECT . (scale . VALUE))." + (let* ((stops cg-svg-slider-stops) (segw 24) (regions '()) (i 0) + (cy (+ y 10)) (tx (+ x 36))) + (svg-text svg "size" :x x :y (+ y 14) :font-size 9 :fill "gray55" + :font-family cg-svg-font-family) + (svg-line svg tx cy (+ tx (* (length stops) segw)) cy + :stroke "gray60" :stroke-width 2) + (dolist (v stops) + (let* ((px (+ tx (* i segw) (/ segw 2))) + (near (< (abs (- v current)) 0.08))) + (svg-circle svg px cy (if near 7 4) + :fill (if near (cg-svg--highlight) "white") + :stroke "gray50" :stroke-width 1) + (push (cons (list (+ tx (* i segw)) y segw 22) (cons 'scale v)) regions)) + (setq i (1+ i))) + (nreverse regions))) + (provide 'cg-svg) ;;; cg-svg.el ends here diff --git a/test/card-games-tests.el b/test/card-games-tests.el index 4845bf5..9678ca1 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -1085,3 +1085,19 @@ (should (> (buffer-size) 0)) (cg-render-apply cg-sol--game '(col . 5)) (should (= 11 (cg-get cg-sol--game :cursor))))) ; spot index of (col . 5) +;;;; Hand-cluster click regions + card-size slider + +(ert-deftest cgt-hand-regions () + (let* ((cards '((0 . 0) (0 . 1) (1 . 5))) + (str (cg-rummy--svg-row cards 0 nil nil 'hand)) + (regs (get-text-property 0 'cg-regions str))) + (should (= (+ 3 (length cg-svg-slider-stops)) (length regs))) ; 3 cards + stops + (should (equal '(hand . 0) (cdr (car regs)))) + (should (cl-find-if (lambda (r) (eq (car-safe (cdr r)) 'scale)) regs))) + (let ((g (cg-gin--deal (cg-gin-game))) (cg-card-scale 1.0)) + (cg-render-apply g '(hand . 2)) + (should (= 2 (cg-get g :cursor))) + (cg-render-apply g '(scale . 1.5)) ; base method handles scale + (should (= 1.5 cg-card-scale)) + (cg-render-apply g 'zoom-reset) + (should (= 1.0 cg-card-scale)))) From 519021f17d2185e8f68888ad4674b170f3431d14 Mon Sep 17 00:00:00 2001 From: Corwin Brust Date: Fri, 26 Jun 2026 15:30:46 -0500 Subject: [PATCH 3/4] Click-to-play for the trick family and Bridge; factor cg-svg-hand-image Extract the clickable hand+slider builder into cg-svg-hand-image and have the rummy, trick, and bridge svg rows delegate to it. Tag the South hand in cg-trick (covers all seven trick games) and the acting hand in cg-bridge with click regions, mapping (hand . i) to select-and-play via cg-render-apply; bind [mouse-1] and +/-/0. Suite 111/111. --- cg-bridge.el | 30 ++++++++++++++++++++---------- cg-rummy.el | 48 +++++++++++++----------------------------------- cg-svg.el | 29 +++++++++++++++++++++++++++++ cg-trick.el | 31 +++++++++++++++++++++---------- 4 files changed, 83 insertions(+), 55 deletions(-) diff --git a/cg-bridge.el b/cg-bridge.el index d03dbf5..fe24ce8 100644 --- a/cg-bridge.el +++ b/cg-bridge.el @@ -490,15 +490,13 @@ vulnerability, and TRICKS the declarer side's trick count. Keys: "Return the cg-svg display spec (RANK-STRING . SUIT) for CARD." (cons (aref cg-bridge-ranks (cdr card)) (car card))) -(cl-defun cg-bridge--svg-row (cards &key cursor hints) - "Return a one-image SVG row for CARDS with CURSOR and HINTS indices." - (propertize "*" 'display - (cg-svg-image - (cg-svg-hand-svg (mapcar #'cg-bridge--spec cards) - :cursor cursor :hints hints - :overlap (if (> (length cards) 11) - (max 0 (- cg-svg-card-width 26)) 0)) - (cg-scale)))) +(cl-defun cg-bridge--svg-row (cards &key cursor hints region-tag) + "Return a one-image SVG row for CARDS (clickable + sliderful when REGION-TAG)." + (cg-svg-hand-image (mapcar #'cg-bridge--spec cards) + :cursor cursor :hints hints + :overlap (if (> (length cards) 11) + (max 0 (- cg-svg-card-width 26)) 0) + :region-tag region-tag)) (cl-defmethod cg-render ((game cg-bridge-game)) "Return a propertized depiction of the Bridge GAME." @@ -565,7 +563,7 @@ vulnerability, and TRICKS the declarer side's trick count. Keys: (when (and (= (cg-get game :turn) act) (cg-bridge--legal-play-p game act c)) (push i hi)) (setq i (1+ i))) - (push (cg-bridge--svg-row hand :cursor cursor :hints hi) out))) + (push (cg-bridge--svg-row hand :cursor cursor :hints hi :region-tag 'hand) out))) ((eq phase 'play) (let ((i 0)) (dolist (c hand) @@ -580,8 +578,15 @@ vulnerability, and TRICKS the declarer side's trick count. Keys: (push (format "\n\n %s\n" (cg-get game :message)) out) (apply #'concat (nreverse out)))) +(cl-defmethod cg-render-apply ((g cg-bridge-game) action) + "Apply a click ACTION on the hand: select that card and play it." + (pcase action + (`(hand . ,i) (cg-put g :cursor i) (cg-bridge-play)) + (_ (cl-call-next-method)))) + (defun cg-bridge--redisplay () (let ((game cg-bridge--game) (inhibit-read-only t)) + (setq cg-current-game game cg-redisplay-function #'cg-bridge--redisplay) (setq-local mode-line-process (format " [%s]" (cg-get game :phase))) (erase-buffer) (insert (cg-render game)) (goto-char (point-min)))) @@ -728,6 +733,11 @@ vulnerability, and TRICKS the declarer side's trick count. Keys: (defvar cg-bridge-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 "") #'cg-bridge-left) (define-key map (kbd "") #'cg-bridge-right) (define-key map (kbd "") #'cg-bridge-up) diff --git a/cg-rummy.el b/cg-rummy.el index cac8351..8fcf13b 100644 --- a/cg-rummy.el +++ b/cg-rummy.el @@ -290,41 +290,19 @@ Set to nil to force the plain-text card row everywhere." (cons (aref cg-rummy-ranks (cdr card)) (car card)))) (defun cg-rummy--svg-row (cards cursor marks hint-fn &optional region-tag) - "Return a one-image SVG row for CARDS. -When REGION-TAG is non-nil, attach a `cg-regions' click map (each card as -\(REGION-TAG . INDEX)) and draw a card-size slider beneath the row." - (let* ((specs (mapcar #'cg-rummy--card-spec cards)) - (hints (when hint-fn - (let ((hs '()) (i 0)) - (dolist (c cards) (when (funcall hint-fn c) (push i hs)) - (setq i (1+ i))) - hs))) - (cur (and (integerp cursor) (>= cursor 0) cursor)) - (overlap (if (> (length cards) 11) (max 0 (- cg-svg-card-width 24)) 0))) - (if (not region-tag) - (propertize "*" 'display - (cg-svg-image (cg-svg-hand-svg specs :cursor cur :hints hints - :marks marks :overlap overlap) - (cg-scale))) - (let* ((w cg-svg-card-width) (h cg-svg-card-height) (pad 8) - (step (max 1 (- (+ w cg-svg-card-gap) overlap))) - (n (length cards)) - (cardw (if (> n 0) (+ (* (1- n) step) w) w)) - (sh (cg-svg-slider-height)) - (width (+ (* 2 pad) (max cardw (cg-svg-slider-width)))) - (height (+ (* 2 pad) h 8 sh)) - (svg (svg-create width height)) (regions '()) (x pad) (i 0)) - (dolist (spec specs) - (cg-svg--draw-spec svg x pad spec (eql i cur) (and (memq i hints) t)) - (when (memq i marks) - (svg-rectangle svg (- x 3) (- pad 3) (+ w 6) (+ h 6) - :rx 7 :fill "none" :stroke "#4a90d9" :stroke-width 3)) - (push (cons (list x pad w h) (cons region-tag i)) regions) - (setq x (+ x step) i (1+ i))) - (setq regions (append (nreverse regions) - (cg-svg-slider-draw svg pad (+ pad h 8) cg-card-scale))) - (propertize "*" 'display (cg-svg-image svg (cg-scale)) - 'cg-regions regions))))) + "Return a one-image SVG row for CARDS (clickable + sliderful when REGION-TAG). +HINT-FN is an optional predicate marking playable cards." + (let ((hints (when hint-fn + (let ((hs '()) (i 0)) + (dolist (c cards) (when (funcall hint-fn c) (push i hs)) + (setq i (1+ i))) + hs)))) + (cg-svg-hand-image (mapcar #'cg-rummy--card-spec cards) + :cursor (and (integerp cursor) (>= cursor 0) cursor) + :marks marks :hints hints + :overlap (if (> (length cards) 11) + (max 0 (- cg-svg-card-width 24)) 0) + :region-tag region-tag))) (defun cg-rummy--render-cards (cards cursor marks &optional hint-fn region-tag) "Return a propertized row of CARDS. diff --git a/cg-svg.el b/cg-svg.el index 993ac41..b5be549 100644 --- a/cg-svg.el +++ b/cg-svg.el @@ -435,5 +435,34 @@ Return its click regions as a list of (RECT . (scale . VALUE))." (setq i (1+ i))) (nreverse regions))) +(cl-defun cg-svg-hand-image (specs &key cursor marks hints (overlap 0) region-tag) + "Return a propertized one-image string for a hand of card SPECS. +CURSOR is the highlighted index; MARKS and HINTS are index lists. With +REGION-TAG non-nil, the image carries a `cg-regions' click map (each card +as (REGION-TAG . INDEX)) and a card-size slider beneath the row." + (if (not region-tag) + (propertize "*" 'display + (cg-svg-image (cg-svg-hand-svg specs :cursor cursor :hints hints + :marks marks :overlap overlap) + (cg-scale))) + (let* ((w cg-svg-card-width) (h cg-svg-card-height) (pad 8) + (step (max 1 (- (+ w cg-svg-card-gap) overlap))) + (n (length specs)) + (cardw (if (> n 0) (+ (* (1- n) step) w) w)) + (sh (cg-svg-slider-height)) + (width (+ (* 2 pad) (max cardw (cg-svg-slider-width)))) + (height (+ (* 2 pad) h 8 sh)) + (svg (svg-create width height)) (regions '()) (x pad) (i 0)) + (dolist (spec specs) + (cg-svg--draw-spec svg x pad spec (eql i cursor) (and (memq i hints) t)) + (when (memq i marks) + (svg-rectangle svg (- x 3) (- pad 3) (+ w 6) (+ h 6) + :rx 7 :fill "none" :stroke "#4a90d9" :stroke-width 3)) + (push (cons (list x pad w h) (cons region-tag i)) regions) + (setq x (+ x step) i (1+ i))) + (setq regions (append (nreverse regions) + (cg-svg-slider-draw svg pad (+ pad h 8) cg-card-scale))) + (propertize "*" 'display (cg-svg-image svg (cg-scale)) 'cg-regions regions)))) + (provide 'cg-svg) ;;; cg-svg.el ends here diff --git a/cg-trick.el b/cg-trick.el index ec1cae2..45d2783 100644 --- a/cg-trick.el +++ b/cg-trick.el @@ -537,15 +537,13 @@ "Return the cg-svg display spec (RANK-STRING . SUIT) for CARD." (cons (aref cg-trick-ranks (cdr card)) (car card))) -(cl-defun cg-trick--svg-row (cards &key cursor marks hints) - "Return a one-image SVG row for CARDS with CURSOR, MARKS, HINTS indices." - (propertize "*" 'display - (cg-svg-image - (cg-svg-hand-svg (mapcar #'cg-trick--spec cards) - :cursor cursor :marks marks :hints hints - :overlap (if (> (length cards) 11) - (max 0 (- cg-svg-card-width 24)) 0)) - (cg-scale)))) +(cl-defun cg-trick--svg-row (cards &key cursor marks hints region-tag) + "Return a one-image SVG row for CARDS (clickable + sliderful when REGION-TAG)." + (cg-svg-hand-image (mapcar #'cg-trick--spec cards) + :cursor cursor :marks marks :hints hints + :overlap (if (> (length cards) 11) + (max 0 (- cg-svg-card-width 24)) 0) + :region-tag region-tag)) (cl-defmethod cg-render ((game cg-trick-game)) "Return a propertized string depicting GAME for a text display." @@ -584,7 +582,8 @@ (when (member c marks) (push i mi)) (when (and legalp (cg-trick--legal-p game 0 c)) (push i hi)) (setq i (1+ i))) - (push (cg-trick--svg-row hand :cursor cursor :marks mi :hints hi) out)) + (push (cg-trick--svg-row hand :cursor cursor :marks mi :hints hi + :region-tag 'hand) out)) (let ((i 0)) (dolist (c hand) (let* ((cs (cg-trick-card-string c)) @@ -597,9 +596,16 @@ (push (format "\n\n %s\n" (cg-get game :message)) out) (apply #'concat (nreverse out)))) +(cl-defmethod cg-render-apply ((g cg-trick-game) action) + "Apply a click ACTION on the hand: select that card and play it." + (pcase action + (`(hand . ,i) (cg-put g :cursor i) (cg-trick-act)) + (_ (cl-call-next-method)))) + (defun cg-trick--redisplay () "Redraw the current trick-game buffer." (let ((game cg-trick--game) (inhibit-read-only t)) + (setq cg-current-game game cg-redisplay-function #'cg-trick--redisplay) (setq-local mode-line-process (format " [%s]" (or (cg-get game :phase) "play"))) (erase-buffer) @@ -675,6 +681,11 @@ (defvar cg-trick-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 "") #'cg-trick-left) (define-key map (kbd "") #'cg-trick-right) (define-key map (kbd "RET") #'cg-trick-act) From 730b7e284b9fd6dc23e9bb4667680d1a08bc2c94 Mon Sep 17 00:00:00 2001 From: Corwin Brust Date: Fri, 26 Jun 2026 16:34:02 -0500 Subject: [PATCH 4/4] 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)))))