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