Card backs: new patterns, Emacs-logo backs, and a random default

* cg-svg.el (cg-svg-card-back): default to random; add lattice/waves/diamond
and the emacs/emacs-classic/gnu/splash logo backs.  (cg-svg--back-*,
cg-svg--draw-back): draw them.  (cg-svg--card-backs, cg-svg--random-back,
cg-svg--roll-back, cg-svg-shuffle-card-back, cg-svg--effective-back): random
machinery.
* card-games.el (card-game): re-roll the random back on each menu visit.
* test/card-games-tests.el: add cgt-svg-logo-smoke, cgt-svg-card-back-smoke.
* NEWS: note the card backs and random default.

NEWS

@@ -43,6 +43,12 @@ the mouse as well as the keyboard.
     ~cg-svg-emacs-logo~: it embeds a real logo that ships with Emacs --
     the modern icon (default), the classic icon, a GNU head, or the
     splash image -- or the small built-in drawn emblem, or none.
+  - More card backs, and a random default.  ~cg-svg-card-back~ now offers
+    ~dots~, ~rings~, ~solid~, ~lattice~, ~waves~, ~diamond~, and four
+    backs stamped with an Emacs logo (~emacs~, ~emacs-classic~, ~gnu~,
+    ~splash~).  It defaults to ~random~, which picks a back for the
+    session; ~M-x cg-svg-shuffle-card-back~ (or reopening the game menu)
+    rolls a new one.
   - Full SVG board for the rummy games (Gin Rummy, Rummy, Rummy 500):
     the stock and discard, the melds already down on the table, and your
     fanned hand with cursor, marks, and lay-off hints; click a card to

card-games.el

@@ -159,6 +159,9 @@ Each entry is (NAME COMMAND DESCRIPTION); `card-game' lists them.")
   "Open a chooser listing the available card games.
 Press RET (or click) on a game to start it."
   (interactive)
+  (when (and (boundp 'cg-svg-card-back) (eq cg-svg-card-back 'random)
+             (fboundp 'cg-svg--roll-back))
+    (cg-svg--roll-back))                 ; a fresh random back per menu visit
   (let ((buf (get-buffer-create "*Card Games*")))
     (with-current-buffer buf
       (card-game-mode)

cg-svg.el

@@ -86,9 +86,47 @@ not themed this way -- see `cg-svg--highlight' -- so it never picks up a
 theme's `region' colour."
   :type 'boolean :group 'cg-svg)
 
-(defcustom cg-svg-card-back 'dots
+(defcustom cg-svg-card-back 'random
-  "Pattern drawn on a face-down card back."
+  "Pattern drawn on a face-down card back.
-  :type '(choice (const dots) (const rings) (const solid)) :group 'cg-svg)
+The `emacs', `emacs-classic', `gnu' and `splash' backs stamp the card with
+a logo that ships with Emacs.  `random' picks one of the concrete backs
+for the session (reshuffle with `cg-svg-shuffle-card-back')."
+  :type '(choice (const dots) (const rings) (const solid)
+                 (const lattice) (const waves) (const diamond)
+                 (const emacs) (const emacs-classic) (const gnu) (const splash)
+                 (const random))
+  :group 'cg-svg)
+
+(defconst cg-svg--card-backs
+  '(dots rings solid lattice waves diamond emacs emacs-classic gnu splash)
+  "Concrete card backs that `random' chooses among.")
+
+(defvar cg-svg--random-back nil
+  "The concrete back currently chosen for the `random' setting.")
+
+(defun cg-svg--roll-back ()
+  "Choose a fresh concrete back for `random' and return it."
+  (setq cg-svg--random-back
+        (nth (random (length cg-svg--card-backs)) cg-svg--card-backs)))
+
+;;;###autoload
+(defun cg-svg-shuffle-card-back ()
+  "Pick a new random card back (used when `cg-svg-card-back' is `random')."
+  (interactive)
+  (cg-svg--roll-back)
+  (when (called-interactively-p 'interactive)
+    (message "Card back: %s" cg-svg--random-back)))
+
+(defun cg-svg--effective-back ()
+  "Return the concrete back to draw, resolving `random'."
+  (if (eq cg-svg-card-back 'random)
+      (or cg-svg--random-back (cg-svg--roll-back))
+    cg-svg-card-back))
+
+(defun cg-svg--back-logo-name (back)
+  "Map a logo card-back BACK to a `cg-svg--logo-files' key."
+  (pcase back ('emacs 'modern) ('emacs-classic 'classic)
+         ('gnu 'gnu) ('splash 'splash)))
 
 (defcustom cg-svg-four-color nil
   "Use a four-colour deck when non-nil.
@@ -255,6 +293,60 @@ X, Y and W, H give the card's top-left corner and size."
   (cg-svg--text svg "★" (+ x (/ w 2.0)) (+ y (* h 0.52)) (* h 0.40) color)
   (cg-svg--text svg "JOKER" (+ x (/ w 2.0)) (+ y (* h 0.74)) (* h 0.135) color t))
 
+(defun cg-svg--back-dots (svg x y w h)
+  "Draw the dotted-medallion back pattern."
+  (let ((gy (+ y 10)))
+    (while (< gy (- (+ y h) 8))
+      (let ((gx (+ x 10)))
+        (while (< gx (- (+ x w) 8))
+          (svg-circle svg gx gy 1.1 :fill cg-svg-back-trim)
+          (setq gx (+ gx 9))))
+      (setq gy (+ gy 9)))))
+
+(defun cg-svg--back-lattice (svg x y w h)
+  "Draw a small-cross lattice back pattern."
+  (let ((gy (+ y 13)))
+    (while (< gy (- (+ y h) 10))
+      (let ((gx (+ x 13)))
+        (while (< gx (- (+ x w) 10))
+          (svg-line svg (- gx 2) (- gy 2) (+ gx 2) (+ gy 2)
+                    :stroke cg-svg-back-trim :stroke-width 1)
+          (svg-line svg (- gx 2) (+ gy 2) (+ gx 2) (- gy 2)
+                    :stroke cg-svg-back-trim :stroke-width 1)
+          (setq gx (+ gx 11))))
+      (setq gy (+ gy 11)))))
+
+(defun cg-svg--back-waves (svg x y w h)
+  "Draw a staggered-dash (brickwork) back pattern."
+  (let ((gy (+ y 12)) (row 0))
+    (while (< gy (- (+ y h) 9))
+      (let ((gx (+ x (if (cl-evenp row) 9 15))))
+        (while (< gx (- (+ x w) 9))
+          (svg-line svg gx gy (+ gx 6) gy :stroke cg-svg-back-trim :stroke-width 1.4)
+          (setq gx (+ gx 12))))
+      (setq gy (+ gy 8) row (1+ row)))))
+
+(defun cg-svg--back-diamond (svg x y w h)
+  "Draw concentric diamonds as the back pattern."
+  (let ((cx (+ x (/ w 2.0))) (cy (+ y (/ h 2.0))))
+    (dolist (f '(0.40 0.28 0.16))
+      (let ((dw (* w f)) (dh (* h f)))
+        (svg-polygon svg (list (cons cx (- cy dh)) (cons (+ cx dw) cy)
+                               (cons cx (+ cy dh)) (cons (- cx dw) cy))
+                     :fill "none" :stroke cg-svg-back-trim :stroke-width 1)))))
+
+(defun cg-svg--back-logo (svg x y w h back)
+  "Stamp the Emacs logo for BACK centred on the card, or dots if unavailable."
+  (let ((file (and (fboundp 'svg-embed)
+                   (cg-svg--logo-file (cg-svg--back-logo-name back)))))
+    (if (null file)
+        (cg-svg--back-dots svg x y w h)
+      (let ((size (round (* h 0.52))))
+        (svg-embed svg file "image/png" nil
+                   :x (round (+ x (/ (- w size) 2.0)))
+                   :y (round (+ y (/ (- h size) 2.0)))
+                   :width size :height size)))))
+
 (defun cg-svg--draw-back (svg x y w h r)
   "Draw a face-down card back on SVG at X, Y (W by H, corner R).
 The pattern is controlled by `cg-svg-card-back'."
@@ -262,21 +354,20 @@ The pattern is controlled by `cg-svg-card-back'."
                  :stroke cg-svg-border-color :stroke-width 1)
   (svg-rectangle svg (+ x 4) (+ y 4) (- w 8) (- h 8) :rx 4 :fill "none"
                  :stroke cg-svg-back-trim :stroke-width 1)
-  (pcase cg-svg-card-back
+  (let ((back (cg-svg--effective-back)))
-    ('solid nil)
+    (pcase back
-    ('rings
+      ('solid nil)
-     (svg-rectangle svg (+ x 8) (+ y 8) (- w 16) (- h 16) :rx 5 :fill "none"
+      ('rings
-                    :stroke cg-svg-back-trim :stroke-width 1)
+       (svg-rectangle svg (+ x 8) (+ y 8) (- w 16) (- h 16) :rx 5 :fill "none"
-     (svg-rectangle svg (+ x 12) (+ y 12) (- w 24) (- h 24) :rx 4 :fill "none"
+                      :stroke cg-svg-back-trim :stroke-width 1)
-                    :stroke cg-svg-back-trim :stroke-width 1))
+       (svg-rectangle svg (+ x 12) (+ y 12) (- w 24) (- h 24) :rx 4 :fill "none"
-    (_
+                      :stroke cg-svg-back-trim :stroke-width 1))
-     (let ((gy (+ y 10)))
+      ('lattice (cg-svg--back-lattice svg x y w h))
-       (while (< gy (- (+ y h) 8))
+      ('waves (cg-svg--back-waves svg x y w h))
-         (let ((gx (+ x 10)))
+      ('diamond (cg-svg--back-diamond svg x y w h))
-           (while (< gx (- (+ x w) 8))
+      ((or 'emacs 'emacs-classic 'gnu 'splash)
-             (svg-circle svg gx gy 1.1 :fill cg-svg-back-trim)
+       (cg-svg--back-logo svg x y w h back))
-             (setq gx (+ gx 9))))
+      (_ (cg-svg--back-dots svg x y w h)))))
-         (setq gy (+ gy 9)))))))
 
 (defun cg-svg--draw-face (svg x y w h r rank suit)
   "Draw a face-up card (RANK of SUIT) on SVG at X, Y (W by H, corner R)."

test/card-games-tests.el

@@ -787,6 +787,21 @@
     (should (null (cg-crap--reserve g 1)))
     (should (member '(2 . 5) (cg-crap--reserve g 0)))))     ; loaded onto you
 
+(ert-deftest cgt-svg-logo-smoke ()
+  (dolist (choice '(modern classic gnu splash drawn none nonexistent))
+    (let ((cg-svg-emacs-logo choice) (svg (svg-create 200 120)))
+      (cg-svg-draw-logo svg 100 60 1.0)
+      (should (imagep (svg-image svg))))))
+
+(ert-deftest cgt-svg-card-back-smoke ()
+  (dolist (b '(dots rings solid lattice waves diamond
+               emacs emacs-classic gnu splash random))
+    (let ((cg-svg-card-back b) (svg (svg-create 80 100)))
+      (cg-svg-card svg 12 10 :down t)
+      (should (imagep (svg-image svg)))))
+  (cg-svg--roll-back)
+  (should (memq cg-svg--random-back cg-svg--card-backs)))
+
 (ert-deftest cgt-crap-house-run ()
   (let ((g (cg-crap--deal (cg-crapette-game))))
     (aset (cg-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6)))  ; 9D 8S 7H