Trick games: full SVG table (opponents, trick, fanned hand)

* cg-trick.el (cg-trick--svg, cg-trick--draw-backs): draw the whole table
as one SVG -- three opponents, the trick in a diamond, the South hand
fanned with cursor, legal-play hints, and pass marks; hand cards carry
(hand . INDEX) click regions.  (cg-trick--render-text): the text fallback.
(cg-render): dispatch SVG on a graphical display, else text.  Add a footer
legend; refresh the help.  Covers Hearts, Spades, Whist, Oh Hell, and the
Euchre/Pitch/Briscola subclasses.
* test/card-games-tests.el: add cgt-trick-svg-smoke, cgt-trick-svg-bidding.
* NEWS: note the trick-taking SVG table.

NEWS

@@ -21,7 +21,10 @@ the mouse as well as the keyboard.
     "stop" rule that ends your turn if you skip a foundation play
     (toggle with ~cg-crapette-stops~), and sequenced house-to-house
     moves limited by the number of empty houses -- with ~[~ and ~]~ to
-    choose how many cards of a run to drop onto an empty house.
+    choose how many cards of a run to drop onto an empty house.  On a
+    graphical display it draws an SVG board (houses shown as stacks) that
+    you can click to pick up and drop, with ~+~ / ~-~ / ~0~ to zoom;
+    set ~cg-crapette-svg-cards~ to nil for the plain-text board.
   - Pegging: Cribbage.   Capturing: Scopa, Casino.   Spite & Malice.
   (These join Gaps/Montana, Hell's Half-Acre, and 500 from 1.0.60.)
 
@@ -31,6 +34,11 @@ the mouse as well as the keyboard.
   - Mouse support everywhere: click cards to select or play, click board
     slots and buttons, and use an on-screen card-size slider plus the
     ~+~ / ~-~ / ~0~ zoom keys.
+  - Full SVG table for the trick-taking games (Hearts, Spades, Whist,
+    Oh Hell, Euchre, Pitch, Briscola): the three opponents, the trick in
+    the middle, and your fanned hand, with the legal cards you may play
+    ringed.  Click a card to play it.  Set ~cg-trick-svg-cards~ to nil
+    for the plain-text board.
 
 ** Rummy-family rules completed
   - Rummy 500: take a card from anywhere in the discard pile (key ~T~) --

cg-trick.el

@@ -545,8 +545,100 @@
                                   (max 0 (- cg-svg-card-width 24)) 0)
                      :region-tag region-tag))
 
-(cl-defmethod cg-render ((game cg-trick-game))
+(defun cg-trick--draw-backs (svg x y n)
-  "Return a propertized string depicting GAME for a text display."
+  "Draw up to three overlapped face-down backs at X, Y for a hand of N cards."
+  (let ((k (min (max n 0) 3)) (xx x))
+    (dotimes (_ k)
+      (cg-svg-card svg xx y :down t)
+      (setq xx (+ xx 16)))))
+
+(defun cg-trick--svg (game)
+  "Return a propertized full-table SVG depiction of trick GAME.
+The South hand carries clickable (hand . INDEX) regions."
+  (let* ((w cg-svg-card-width) (h cg-svg-card-height) (gap cg-svg-card-gap)
+         (pad 16)
+         (hand (cg-trick--sort (cg-trick--hand game 0)))
+         (n (length hand))
+         (overlap (cond ((> n 11) (- w 24)) ((> n 8) 20) (t 0)))
+         (step (max 14 (- (+ w gap) overlap)))
+         (fanw (if (> n 0) (+ (* (1- n) step) w) w))
+         (width (max (+ fanw (* 2 pad)) 720))
+         (cx (/ width 2))
+         (scores (cg-get game :scores))
+         (trick (cg-get game :trick))
+         (turn (cg-get game :turn))
+         (phase (cg-get game :phase))
+         (marks (cg-get game :marks))
+         (cursor (cg-get game :cursor))
+         (bids (cg-get game :bids))
+         (tks (cg-get game :tricks))
+         (y-title 6) (y-north 26)
+         (y-tn (+ y-north h 22))
+         (cy (+ y-tn (round (* h 0.55))))
+         (y-ts (+ cy (round (* h 0.15))))
+         (y-south (+ y-ts h 34))
+         (height (+ y-south h 30))
+         (svg (svg-create width height))
+         (lc (cg-color 'shadow :foreground "gray50"))
+         (regions '()))
+    (cl-labels
+        ((txt (str x y &optional sz bold anchor)
+              (apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
+                     :font-family cg-svg-font-family
+                     (append (and bold '(:font-weight "bold"))
+                             (and anchor (list :text-anchor anchor)))))
+         (seat (s x y)
+               (cg-trick--draw-backs svg x (+ y 6) (length (cg-trick--hand game s)))
+               (txt (format "%s%s%s%s" (aref cg-trick-seat-names s)
+                            (if (and bids (aref bids s)) (format "  bid %d" (aref bids s)) "")
+                            (if (and tks (> (aref tks s) 0)) (format "  won %d" (aref tks s)) "")
+                            (if (= turn s) "  <-" ""))
+                    x y 11))
+         (trick-card (s x y)
+                     (let ((play (assq s trick)))
+                       (when play
+                         (let ((sp (cg-trick--spec (cdr play))))
+                           (cg-svg-card svg x y :rank (car sp) :suit (cdr sp)))))))
+      (txt (format "%s -- %s" (oref game vname)
+                   (pcase phase
+                     ('pass "pass three cards") ('bid "bidding")
+                     ('play (if (= turn 0) "your turn" "opponents playing"))
+                     (_ "play")))
+           pad (+ y-title 12) 13 t)
+      (when scores
+        (txt (format "S %d  W %d  N %d  E %d"
+                     (aref scores 0) (aref scores 1) (aref scores 2) (aref scores 3))
+             (- width pad) (+ y-title 12) 12 nil "end"))
+      (seat 2 (- cx 40) y-north)
+      (seat 1 pad cy)
+      (seat 3 (- width pad 100) cy)
+      (trick-card 2 (- cx (/ w 2)) y-tn)
+      (trick-card 0 (- cx (/ w 2)) y-ts)
+      (trick-card 1 (- cx w (round (* w 0.4))) (round (- cy (* h 0.25))))
+      (trick-card 3 (+ cx (round (* w 0.4))) (round (- cy (* h 0.25))))
+      (txt (format "Your hand (South)%s"
+                   (if (eq phase 'pass) (format " -- marked %d/3" (length marks)) ""))
+           pad (- y-south 6) 11)
+      (let ((x (- cx (/ fanw 2))) (i 0)
+            (legalp (and (eq phase 'play) (= turn 0))))
+        (dolist (c hand)
+          (let ((sp (cg-trick--spec c))
+                (curp (= i cursor))
+                (markp (member c marks))
+                (hintp (and legalp (cg-trick--legal-p game 0 c))))
+            (cg-svg-card svg x y-south :rank (car sp) :suit (cdr sp)
+                         :highlight curp :hint hintp)
+            (when markp
+              (svg-rectangle svg (- x 3) (- y-south 3) (+ w 6) (+ h 6)
+                             :rx 8 :fill "none" :stroke "#4a90d9" :stroke-width 3))
+            (push (cons (list x y-south (if (= i (1- n)) w step) h) (cons 'hand i)) regions))
+          (setq x (+ x step) i (1+ i))))
+      (txt (or (cg-get game :message) "") pad (- height 8) 12))
+    (propertize "*" 'display (cg-svg-image svg (cg-scale))
+                'cg-regions (nreverse regions))))
+
+(defun cg-trick--render-text (game)
+  "Return a plain-text depiction of trick GAME."
   (let* ((out (list))
          (scores (cg-get game :scores))
          (marks (cg-get game :marks))
@@ -557,45 +649,36 @@
       (push (format "  Scores:  South %d  West %d  North %d  East %d\n\n"
                     (aref scores 0) (aref scores 1) (aref scores 2) (aref scores 3))
             out))
-    (dolist (s '(2 1 3))                 ; North, West, East
+    (dolist (s '(2 1 3))
       (push (cg-trick--seat-line game s) out))
-    ;; current trick
     (push "\n  Trick: " out)
-    (cond
+    (if (null (cg-get game :trick))
-     ((null (cg-get game :trick)) (push "(empty)" out))
+        (push "(empty)" out)
-     ((and cg-trick-svg-cards (display-graphic-p))
+      (dolist (play (reverse (cg-get game :trick)))
-      (push (concat (mapconcat (lambda (p) (aref cg-trick-seat-names (car p)))
-                               (reverse (cg-get game :trick)) "  ") "   ")
-            out)
-      (push (cg-trick--svg-row (mapcar #'cdr (reverse (cg-get game :trick)))) out))
-     (t (dolist (play (reverse (cg-get game :trick)))
         (push (format "%s:%s  " (aref cg-trick-seat-names (car play))
                       (let ((cs (cg-trick-card-string (cdr play))))
                         (if (cg-trick-red-p (cdr play))
                             (propertize cs 'face 'cg-red-suit) cs)))
-                out))))
+              out)))
     (push "\n\n  Your hand (South):\n   " out)
-    (if (and cg-trick-svg-cards (display-graphic-p))
-        (let ((mi '()) (hi '()) (i 0)
-              (legalp (and (eq (cg-get game :phase) 'play) (= (cg-get game :turn) 0))))
-          (dolist (c hand)
-            (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
-                                  :region-tag 'hand) out))
     (let ((i 0))
       (dolist (c hand)
-          (let* ((cs (cg-trick-card-string c))
+        (let ((cs (cg-trick-card-string c)) (faces nil))
-                 (faces nil))
           (when (cg-trick-red-p c) (push 'cg-red-suit faces))
           (when (member c marks) (push 'cg-hint faces))
           (when (= i cursor) (push 'cg-cursor faces))
           (push (propertize (format "%4s" cs) 'face (or faces 'default)) out))
-          (setq i (1+ i)))))
+        (setq i (1+ i))))
     (push (format "\n\n  %s\n" (cg-get game :message)) out)
     (apply #'concat (nreverse out))))
 
+(cl-defmethod cg-render ((game cg-trick-game))
+  "Return a depiction of GAME: a full SVG table on a graphical display,
+else a plain-text board."
+  (if (and cg-trick-svg-cards (display-graphic-p))
+      (cg-trick--svg game)
+    (cg-trick--render-text game)))
+
 (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

test/card-games-tests.el

@@ -821,6 +821,40 @@
     (should (= 2 (length (cg-crap--house g 0))))
     (should (= 1 (length (cg-crap--house g 1))))))
 
+(ert-deftest cgt-crap-svg-smoke ()
+  (let ((g (cg-crap--deal (cg-crapette-game))))
+    (aset (cg-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6)))  ; a run to draw
+    (aset (cg-get g :reserve) 0 (list '(3 . 0)))                   ; a forced foundation
+    (cg-put g :sel '(house . 0)) (cg-put g :sel-n 2) (cg-put g :cursor 3)
+    (let ((res (cg-crap--svg g)))
+      (should (stringp (car res)))
+      (should (get-text-property 0 'display (car res)))
+      (should (get-text-property 0 'cg-regions (car res)))
+      ;; every clickable region is a (RECT . SPOT) with a 4-number RECT
+      (should (cl-every (lambda (r) (= 4 (length (car r)))) (cdr res)))
+      (should (rassoc '(house . 0) (cdr res))))))
+
+(ert-deftest cgt-trick-svg-smoke ()
+  (let ((g (cg-hearts-game)))
+    (cg-trick--deal g)
+    (cg-put g :cursor 0) (cg-put g :phase 'play) (cg-put g :turn 0) (cg-put g :message "x")
+    (cg-put g :trick (list (cons 1 (car (cg-trick--hand g 1)))))   ; West has led
+    (should (stringp (cg-trick--render-text g)))
+    (let ((s (cg-trick--svg g)))
+      (should (stringp s))
+      (should (get-text-property 0 'display s))
+      (let ((regs (get-text-property 0 'cg-regions s)))
+        (should regs)
+        (should (rassoc '(hand . 0) regs))
+        (should (cl-every (lambda (r) (= 4 (length (car r)))) regs))))))
+
+(ert-deftest cgt-trick-svg-bidding ()
+  (let ((g (cg-spades-game)))
+    (cg-trick--deal g)
+    (cg-put g :cursor 2) (cg-put g :phase 'bid) (cg-put g :turn 0) (cg-put g :message "bid")
+    (cg-put g :bids (vector 3 nil 4 nil)) (cg-put g :scores (vector 100 50 100 50))
+    (should (stringp (cg-trick--svg g)))))
+
 (ert-deftest cgt-pat-golf-deal ()
   (let ((g (cg-pat--deal (cg-golf-game))))
     (should (= 35 (length (cg-get g :cards))))