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

Click-to-play for the trick family and Bridge; factor cg-svg-hand-image

Browse source 
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.
This commit is contained in:
Corwin Brust 2026-06-26 15:30:46 -05:00
parent 2c700b7739
commit 519021f17d
4 changed files with 83 additions and 55 deletions
Download patch file Download diff file Expand all files Collapse all files

30
cg-bridge.el
View file

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

48
cg-rummy.el
View file

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

29
cg-svg.el
View file

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

31
cg-trick.el
View file

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