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

Hand-cluster mouse + card-size slider

Browse source 
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.
This commit is contained in:
Corwin Brust 2026-06-25 09:53:56 -05:00
parent 287700ddca
commit 2c700b7739
10 changed files with 235 additions and 23 deletions
Download patch file Download diff file Expand all files Collapse all files

66
cg-core.el
View file

@ -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

14
cg-cribbage.el
View file

@ -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 "<left>") #'cg-crib-left)
(define-key map (kbd "<right>") #'cg-crib-right)
(define-key map (kbd "SPC") #'cg-crib-mark)

14
cg-handfoot.el
View file

@ -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 "<left>") #'cg-hf-left)
(define-key map (kbd "<right>") #'cg-hf-right)
(define-key map (kbd "SPC") #'cg-hf-mark)

14
cg-match.el
View file

@ -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 "<left>") #'cg-gf-left)
(define-key map (kbd "<right>") #'cg-gf-right)
(dolist (k '("1" "2" "3" "4")) (define-key map k #'cg-gf-ask))

14
cg-rum500.el
View file

@ -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 "<left>") #'cg-tm-left)
(define-key map (kbd "<right>") #'cg-tm-right)
(define-key map (kbd "SPC") #'cg-tm-mark)

59
cg-rummy.el
View file

@ -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 "<left>") #'cg-gin-left)
(define-key map (kbd "<right>") #'cg-gin-right)
(define-key map "s" #'cg-gin-draw-stock)

15
cg-scopa.el
View file

@ -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 "<left>") #'cg-fish-left)
(define-key map (kbd "<right>") #'cg-fish-right)
(define-key map (kbd "RET") #'cg-fish-play)

15
cg-spite.el
View file

@ -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 "<left>") #'cg-spite-left)
(define-key map (kbd "<right>") #'cg-spite-right)
(define-key map (kbd "RET") #'cg-spite-play)

31
cg-svg.el
View file

@ -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

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

@ -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))))