From 5ff6d8afedee07d2ed1c4b214531839f20f92868 Mon Sep 17 00:00:00 2001 From: Corwin Brust Date: Fri, 26 Jun 2026 16:43:33 -0500 Subject: [PATCH] Finish mouse support: Crazy Eights, President, the patience boards The last three keyboard-only games are now click-to-play, so every game in the package responds to the mouse. Crazy Eights and President route their hands through the shared cg-regions click map (President maps each rank group to a click); the patience boards (Golf, TriPeaks, Pyramid) follow the solitaire keystone, mapping exposed slots plus the waste and stock to their spots. Each adds a card-size slider, [mouse-1], and +/-/0 zoom. Add cgt-mouse-regions asserting the SVG click maps build (suite -> 116). --- cg-eights.el | 29 +++++++++++++++++++++-------- cg-patience.el | 37 +++++++++++++++++++++++++++++++------ cg-president.el | 33 +++++++++++++++++++++++++++------ test/card-games-tests.el | 25 +++++++++++++++++++++++++ 4 files changed, 104 insertions(+), 20 deletions(-) diff --git a/cg-eights.el b/cg-eights.el index ac0f4f9..8391407 100644 --- a/cg-eights.el +++ b/cg-eights.el @@ -233,13 +233,11 @@ Return the drawn card, or nil when none is available." (if (and cg-eights-svg-cards (display-graphic-p)) (let ((hi '()) (i 0)) (dolist (c hand) (when (cg-eights--legal-p game c) (push i hi)) (setq i (1+ i))) - (push (propertize "*" 'display - (cg-svg-image - (cg-svg-hand-svg (mapcar #'cg-eights--spec hand) - :cursor cursor :hints hi - :overlap (if (> (length hand) 11) - (max 0 (- cg-svg-card-width 24)) 0)) - (cg-scale))) + (push (cg-svg-hand-image (mapcar #'cg-eights--spec hand) + :cursor cursor :hints hi + :overlap (if (> (length hand) 11) + (max 0 (- cg-svg-card-width 24)) 0) + :region-tag 'hand) out)) (let ((i 0)) (dolist (c hand) @@ -252,9 +250,19 @@ Return the drawn card, or nil when none is available." (push (format "\n\n %s\n" (cg-get game :message)) out) (apply #'concat (nreverse out)))) +(cl-defmethod cg-render-apply ((g cg-eights-game) action) + "Apply a click ACTION on the hand to GAME G (a click also plays)." + (pcase action + (`(hand . ,i) + (cg-put g :cursor i) + (when (and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0)) + (cg-eights-act))) + (_ (cl-call-next-method)))) + (defun cg-eights--redisplay () "Redraw the Crazy Eights buffer." (let ((game cg-eights--game) (inhibit-read-only t)) + (setq cg-current-game game cg-redisplay-function #'cg-eights--redisplay) (setq-local mode-line-process (format " [%s]" (cg-get game :phase))) (erase-buffer) (insert (cg-render game)) (goto-char (point-min)))) @@ -335,10 +343,15 @@ Return the drawn card, or nil when none is available." (defun cg-eights-help () "Describe the controls." (interactive) - (message "Arrows: choose RET: play d: draw x: pass n: new deal g: redraw")) + (message "Arrows or click: choose/play RET: play d: draw x: pass +/-: size n: new g: redraw")) (defvar cg-eights-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-eights-left) (define-key map (kbd "") #'cg-eights-right) (define-key map (kbd "RET") #'cg-eights-act) diff --git a/cg-patience.el b/cg-patience.el index 21a55e4..ff37bcc 100644 --- a/cg-patience.el +++ b/cg-patience.el @@ -291,7 +291,7 @@ (cg-pat--deal cg-pat--game) (cg-pat--redisplay)) (defun cg-pat-redraw () "Redraw." (interactive) (cg-pat--redisplay)) (defun cg-pat-help () "Controls." (interactive) - (message "Arrows: move RET: play/mark/deal u: undo n: new g: redraw")) + (message "Arrows or click: move/play RET: play/mark/deal u: undo +/-: size n: new")) ;;;; Rendering @@ -312,14 +312,19 @@ (and card (cons (aref cg-pat-ranks (cdr card)) (car card)))) (defun cg-pat--svg (game) - "Return a propertized one-image SVG board for patience GAME." + "Return a propertized, clickable one-image SVG board for patience GAME. +Exposed slots, the waste, and the stock each carry a click region (the +matching spot); a card-size slider sits below." (let* ((w cg-svg-card-width) (h cg-svg-card-height) (pad 12) (gap cg-svg-card-gap) (rowstep 30) (rows (cg-get game :rows)) (cur (cg-pat--cur-spot game)) (marks (cg-get game :marks)) (lc (cg-color 'shadow :foreground "gray40")) (maxlen (apply #'max 1 (mapcar #'length rows))) (nrows (length rows)) - (width (+ (* 2 pad) (* maxlen (+ w gap)))) + (sh (cg-svg-slider-height)) + (width (+ (* 2 pad) (max (* maxlen (+ w gap)) (cg-svg-slider-width)))) (boardh (+ (* (1- nrows) rowstep) h)) (bottom-y (+ pad boardh 26)) - (height (+ bottom-y h pad)) (svg (svg-create width height)) (r 0)) + (slider-y (+ bottom-y h 10)) + (height (+ slider-y sh pad)) (svg (svg-create width height)) + (r 0) (regions '())) (dolist (row rows) (let* ((len (length row)) (x0 (/ (- width (* len (+ w gap))) 2)) (y (+ pad (* r rowstep))) (c 0)) @@ -329,7 +334,9 @@ (cg-svg-card svg x y :rank (car (cg-pat--spec card)) :suit (cdr (cg-pat--spec card)) :highlight (equal cur (cons 'slot i)) - :hint (and (member (cons 'slot i) marks) t)))) + :hint (and (member (cons 'slot i) marks) t)) + (when (cg-pat--exposed-p game i) + (push (cons (list x y w h) (cons 'slot i)) regions)))) (setq c (1+ c)))) (setq r (1+ r))) (svg-text svg "Waste" :x pad :y (- bottom-y 3) :font-size 11 :fill lc @@ -340,13 +347,25 @@ :highlight (equal cur '(waste . 0)) :hint (and (member '(waste . 0) marks) t)) (cg-svg-card svg pad bottom-y :gap t :highlight (equal cur '(waste . 0))))) + (push (cons (list pad bottom-y w h) (cons 'waste 0)) regions) (svg-text svg (format "Stock(%d)" (length (cg-get game :stock))) :x (+ pad w gap) :y (- bottom-y 3) :font-size 11 :fill lc :font-family cg-svg-font-family) (if (cg-get game :stock) (cg-svg-card svg (+ pad w gap) bottom-y :down t :highlight (equal cur '(stock . 0))) (cg-svg-card svg (+ pad w gap) bottom-y :gap t :highlight (equal cur '(stock . 0)))) - (propertize "*" 'display (cg-svg-image svg (cg-scale))))) + (push (cons (list (+ pad w gap) bottom-y w h) (cons 'stock 0)) regions) + (setq regions (append (nreverse regions) + (cg-svg-slider-draw svg pad slider-y cg-card-scale))) + (propertize "*" 'display (cg-svg-image svg (cg-scale)) 'cg-regions regions))) + +(cl-defmethod cg-render-apply ((g cg-patience-game) action) + "Apply a click ACTION (a board spot) to GAME G: select that spot and play." + (pcase action + ((or `(slot . ,_) `(waste . ,_) `(stock . ,_)) + (let ((idx (cl-position action (cg-pat--spots g) :test #'equal))) + (when idx (cg-put g :cursor idx) (cg-pat-act)))) + (_ (cl-call-next-method)))) (cl-defmethod cg-render ((game cg-patience-game)) "Return a propertized depiction of GAME (SVG on a graphical display)." @@ -380,6 +399,7 @@ (defun cg-pat--redisplay () (let ((game cg-pat--game) (inhibit-read-only t)) + (setq cg-current-game game cg-redisplay-function #'cg-pat--redisplay) (setq-local mode-line-process (format " [%s]" (if (cg-won-p game) "solved" "playing"))) (erase-buffer) (insert (cg-render game)) (goto-char (point-min)))) @@ -387,6 +407,11 @@ (defvar cg-pat-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-pat-left) (define-key map (kbd "") #'cg-pat-right) (define-key map (kbd "") #'cg-pat-left) diff --git a/cg-president.el b/cg-president.el index 3035dd7..32f9c8c 100644 --- a/cg-president.el +++ b/cg-president.el @@ -310,29 +310,35 @@ (cg-pres--deal cg-pres--game) (cg-pres--run cg-pres--game) (cg-pres--redisplay)) (defun cg-pres-redraw () "Redraw." (interactive) (cg-pres--redisplay)) (defun cg-pres-help () "Controls." (interactive) - (message "Arrows: choose rank RET: play (C-u N to lead N) p: pass n: new g: redraw")) + (message "Arrows or click: choose/play RET: play (C-u N to lead N) p: pass +/-: size n: new")) (defcustom cg-pres-svg-cards t "When non-nil, draw the hand as SVG on a graphical display." :type 'boolean :group 'card-games) (defun cg-pres--svg (game) - "Return a propertized SVG row of the hand, one card per rank with a count." + "Return a propertized, clickable SVG row of the hand: one card per rank. +Each rank maps to a (hand . INDEX) region and a card-size slider sits below." (let* ((w cg-svg-card-width) (h cg-svg-card-height) (pad 10) (gap (+ cg-svg-card-gap 8)) (ranks (cg-pres--hand-ranks game)) (cur (cg-get game :cursor)) (hand (cg-pres--hand game 0)) (n (length ranks)) (lc (cg-color 'shadow :foreground "gray40")) - (width (+ (* 2 pad) (max (+ w gap) (* n (+ w gap))))) - (height (+ pad h 20 pad)) (svg (svg-create width height)) (x pad) (i 0)) + (sh (cg-svg-slider-height)) (slider-y (+ pad h 22)) + (width (+ (* 2 pad) (max (+ w gap) (* n (+ w gap)) (cg-svg-slider-width)))) + (height (+ slider-y sh pad)) (svg (svg-create width height)) + (x pad) (i 0) (regions '())) (dolist (r ranks) (let* ((cnt (cl-count r (mapcar #'cdr hand))) (suit (car (cl-find r hand :key #'cdr)))) (cg-svg-card svg x pad :rank (aref cg-pres-ranks r) :suit suit :highlight (= i cur)) (svg-text svg (format "x%d" cnt) :x (+ x 3) :y (+ pad h 15) - :font-size 13 :fill lc :font-family cg-svg-font-family)) + :font-size 13 :fill lc :font-family cg-svg-font-family) + (push (cons (list x pad w h) (cons 'hand i)) regions)) (setq x (+ x w gap) i (1+ i))) - (propertize "*" 'display (cg-svg-image svg (cg-scale))))) + (setq regions (append (nreverse regions) + (cg-svg-slider-draw svg pad slider-y cg-card-scale))) + (propertize "*" 'display (cg-svg-image svg (cg-scale)) 'cg-regions regions))) (cl-defmethod cg-render ((game cg-president-game)) "Return a propertized string depicting GAME for a text display." @@ -364,13 +370,28 @@ (push (format "\n\n %s\n" (cg-get game :message)) out) (apply #'concat (nreverse out)))) +(cl-defmethod cg-render-apply ((g cg-president-game) action) + "Apply a click ACTION on the rank row to GAME G (a click also plays)." + (pcase action + (`(hand . ,i) + (cg-put g :cursor i) + (when (and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0)) + (cg-pres-act))) + (_ (cl-call-next-method)))) + (defun cg-pres--redisplay () (let ((game cg-pres--game) (inhibit-read-only t)) + (setq cg-current-game game cg-redisplay-function #'cg-pres--redisplay) (setq-local mode-line-process (format " [%s]" (cg-get game :phase))) (erase-buffer) (insert (cg-render game)) (goto-char (point-min)))) (defvar cg-pres-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-pres-left) (define-key map (kbd "") #'cg-pres-right) (define-key map (kbd "RET") #'cg-pres-act) diff --git a/test/card-games-tests.el b/test/card-games-tests.el index 2a5c3be..5cddfa2 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -1165,3 +1165,28 @@ (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))))) + +;;;; Mouse click-region wiring for eights, president, and the patience boards + +(ert-deftest cgt-mouse-regions () + "The newly clickable games attach a `cg-regions' map to their SVG." + (let* ((g (cg-pat--deal (cg-golf-game))) + (regs (get-text-property 0 'cg-regions (cg-pat--svg g)))) + (should regs) + (should (cl-find '(waste . 0) (mapcar #'cdr regs) :test #'equal)) + (should (cl-find '(stock . 0) (mapcar #'cdr regs) :test #'equal)) + (should (cl-find-if (lambda (a) (eq (car a) 'slot)) (mapcar #'cdr regs)))) + (let ((g (cg-president-game))) + (cg-put g :games 0) (cg-pres--deal g) + (let ((regs (get-text-property 0 'cg-regions (cg-pres--svg g)))) + (should regs) + (should (cl-find-if (lambda (a) (and (consp a) (eq (car a) 'hand))) + (mapcar #'cdr regs))))) + (let ((g (cg-eights-game))) + (cg-put g :scores (make-vector 3 0)) (cg-eights--deal g) + (let* ((img (cg-svg-hand-image (mapcar #'cg-eights--spec (cg-eights--hand g 0)) + :region-tag 'hand)) + (regs (get-text-property 0 'cg-regions img))) + (should regs) + (should (cl-find-if (lambda (a) (and (consp a) (eq (car a) 'hand))) + (mapcar #'cdr regs))))))