Corwin Brust
ff7a9f6e49
Bring the SVG board and the text-mode faces up to WCAG 2.1 AA contrast. Two oppositions drove the changes: no single ring colour meets 3:1 on both a near-white card face and the dark-green felt, and no single fixed suit/marker colour meets 4.5:1 on both a light and a dark Emacs theme. The rings therefore become haloed (bright core plus dark edge, readable on either ground) and the theme-sensitive faces gain light/dark variants. Ratios are computed from the sRGB relative-luminance formula. * card-games-svg.el (card-games-svg-card): Draw the cursor highlight as a haloed ring (dark edge, bright core) so it clears 3:1 on both a card face and the felt; the old single gold ring was 1.63:1 on a card. Draw the hint as a haloed dashed ring for the same reason, keeping the dash pattern so it stays distinct by shape, not colour alone. (card-games-svg-club-color): #1a8a3c -> #166534; four-colour clubs were 4.35:1 on the card face, now 7.00:1. (card-games-svg-hint-color): #27ae60 -> #7cf59a; 2.36:1 -> 4.97:1 on felt. (card-games-svg-gap-color): #95a5a6 -> #cbd5e1; 2.65:1 -> 4.57:1 on felt (empty slots carry meaning in Gaps and Montana). * card-games-core.el (card-games-red-suit): Add a dark-theme variant (card-games-hint): Give light/dark variants (#207a3f on light, green3 bold on dark); green3 was 2.16:1 on white, now 5.36:1. (card-games-gap): Give light/dark variants (#595959 light, #a6a6a6 dark); gray50 failed both themes, now about 7:1 light and 6:1 dark. The card border and faint panel divider are left unchanged -- the card face already contrasts the felt at 6.67:1, so card edges read regardless -- and the SVG board's lack of an accessible name is covered by the text/UNICODE rendering, the intended accessible alternative. Assisted-by: Claude:claude-opus-4-8
636 lines
30 KiB
EmacsLisp
636 lines
30 KiB
EmacsLisp
;;; card-games-svg.el --- SVG card drawing for card games -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2026 Corwin Brust
|
|
|
|
;; Author: Corwin Brust <corwin@bru.st>
|
|
;; Maintainer: Corwin Brust <corwin@bru.st>
|
|
;; Version: 1.0.91
|
|
;; Keywords: games
|
|
;; URL: https://code.bru.st/corwin/card-game.el
|
|
|
|
;; This program is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; Reusable SVG drawing for the graphical (GUI) renderers, shared by the
|
|
;; games in this package. Console rendering remains the baseline; these
|
|
;; helpers add a prettier display when `display-graphic-p' is non-nil.
|
|
;;
|
|
;; Faces are drawn the way real cards are: a stacked rank/suit index in
|
|
;; the top-left corner (mirrored, upside-down, in the bottom-right),
|
|
;; canonical pip layouts for the number cards (with the lower pips
|
|
;; rotated 180 degrees), a large central pip for the ace, framed letters
|
|
;; for the court cards, and a distinct joker. Backs show a dotted
|
|
;; medallion; cards cast a soft shadow; the cursor card gets a glowing
|
|
;; ring.
|
|
;;
|
|
;; The primitives are game-agnostic. A card to draw is a "spec":
|
|
;;
|
|
;; (RANK-STRING . SUIT) face-up; SUIT is 0-3 or the symbol `joker';
|
|
;; RANK-STRING is the caller's label ("A" "10"
|
|
;; "K" ...).
|
|
;; `down' a face-down card.
|
|
;; nil an empty slot / gap.
|
|
;;
|
|
;; `card-games-svg-cards-svg' lays specs out in a row; `card-games-svg-grid-svg' lays
|
|
;; rows out as a grid. Both return an svg object; wrap with
|
|
;; `card-games-svg-image' to insert or `card-games-svg-to-string' to serialize.
|
|
|
|
;;; Code:
|
|
|
|
(require 'svg)
|
|
(require 'card-games-core)
|
|
|
|
(defgroup card-games-svg nil
|
|
"SVG rendering for card games."
|
|
:group 'card-games
|
|
:prefix "card-games-svg-")
|
|
|
|
(defcustom card-games-svg-card-width 56
|
|
"Card width in pixels."
|
|
:type 'integer :group 'card-games-svg)
|
|
|
|
(defcustom card-games-svg-card-height 80
|
|
"Card height in pixels."
|
|
:type 'integer :group 'card-games-svg)
|
|
|
|
(defcustom card-games-svg-card-gap 8
|
|
"Pixels between adjacent cards."
|
|
:type 'integer :group 'card-games-svg)
|
|
|
|
(defcustom card-games-svg-card-shadow t
|
|
"When non-nil, draw a soft drop shadow under each card."
|
|
:type 'boolean :group 'card-games-svg)
|
|
|
|
(defcustom card-games-svg-font-family "Helvetica, Arial, sans-serif"
|
|
"Font family used for ranks, pips and indices."
|
|
:type 'string :group 'card-games-svg)
|
|
|
|
(defcustom card-games-svg-theme-colors t
|
|
"Derive the card back and move-hint ring from the active theme.
|
|
When non-nil, those colours are taken from the active Emacs theme, with
|
|
the colour variables below as fallbacks. The cursor/selection ring is
|
|
not themed this way -- see `card-games-svg--highlight' -- so it never picks up a
|
|
theme's `region' colour."
|
|
:type 'boolean :group 'card-games-svg)
|
|
|
|
(defcustom card-games-svg-card-back 'random
|
|
"Pattern drawn on a face-down card back.
|
|
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 `card-games-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 'card-games-svg)
|
|
|
|
(defconst card-games-svg--card-backs
|
|
'(dots rings solid lattice waves diamond emacs emacs-classic gnu splash)
|
|
"Concrete card backs that `random' chooses among.")
|
|
|
|
(defvar card-games-svg--random-back nil
|
|
"The concrete back currently chosen for the `random' setting.")
|
|
|
|
(defun card-games-svg--roll-back ()
|
|
"Choose a fresh concrete back for `random' and return it."
|
|
(setq card-games-svg--random-back
|
|
(nth (random (length card-games-svg--card-backs)) card-games-svg--card-backs)))
|
|
|
|
;;;###autoload
|
|
(defun card-games-svg-shuffle-card-back ()
|
|
"Pick a new random card back (used when `card-games-svg-card-back' is `random')."
|
|
(interactive)
|
|
(card-games-svg--roll-back)
|
|
(when (called-interactively-p 'interactive)
|
|
(message "Card back: %s" card-games-svg--random-back)))
|
|
|
|
(defun card-games-svg--effective-back ()
|
|
"Return the concrete back to draw, resolving `random'."
|
|
(if (eq card-games-svg-card-back 'random)
|
|
(or card-games-svg--random-back (card-games-svg--roll-back))
|
|
card-games-svg-card-back))
|
|
|
|
(defun card-games-svg--back-logo-name (back)
|
|
"Map a logo card-back BACK to a `card-games-svg--logo-files' key."
|
|
(pcase back ('emacs 'modern) ('emacs-classic 'classic)
|
|
('gnu 'gnu) ('splash 'splash)))
|
|
|
|
(defcustom card-games-svg-four-color nil
|
|
"Use a four-colour deck when non-nil.
|
|
Clubs are drawn green and diamonds blue-purple; spades stay black and
|
|
hearts red."
|
|
:type 'boolean :group 'card-games-svg)
|
|
|
|
(defconst card-games-svg-corner-radius 6
|
|
"Corner radius of a drawn card.")
|
|
|
|
(defvar card-games-svg-red-color "#c0392b" "Colour for red suits.")
|
|
(defvar card-games-svg-black-color "#2c3e50" "Colour for black suits.")
|
|
(defvar card-games-svg-club-color "#166534" "Clubs colour in a four-colour deck.")
|
|
(defvar card-games-svg-diamond-color "#3b3fb0" "Diamonds colour in a four-colour deck.")
|
|
(defvar card-games-svg-joker-color "#8e44ad" "Colour for the Joker.")
|
|
(defvar card-games-svg-face-color "#fdfdfb" "Card face fill.")
|
|
(defvar card-games-svg-court-color "#f6f2e8" "Court-card inner panel fill.")
|
|
(defvar card-games-svg-border-color "#566573" "Card border colour.")
|
|
(defvar card-games-svg-back-color "#27496d" "Card back fill.")
|
|
(defvar card-games-svg-back-trim "#9fb3cf" "Card back inner trim/dots.")
|
|
(defvar card-games-svg-highlight-color "#f1c40f" "Cursor/selection highlight.")
|
|
(defvar card-games-svg-gap-color "#cbd5e1" "Empty-slot outline colour.")
|
|
|
|
(defun card-games-svg--highlight ()
|
|
"Resolve the cursor/selection ring colour.
|
|
Always the configured `card-games-svg-highlight-color' (a calm gold by
|
|
default). This is deliberately not taken from the theme's `region'
|
|
face: on many themes that face is a saturated colour, and a fat ring
|
|
in it reads as an alarming frame flashing around the whole board on
|
|
each redraw. Customize `card-games-svg-highlight-color' to change it."
|
|
card-games-svg-highlight-color)
|
|
|
|
(defun card-games-svg--back-fill ()
|
|
"Resolve the card-back fill colour (theme-aware)."
|
|
(if card-games-svg-theme-colors
|
|
(card-games-color 'mode-line :background card-games-svg-back-color)
|
|
card-games-svg-back-color))
|
|
|
|
(defun card-games-svg--court-fill (suit)
|
|
"Return a faint suit-tinted fill for a court card of SUIT."
|
|
(cond ((eq suit 'joker) "#f3eafa")
|
|
((card-games-red-suit-p suit) "#fbeceb")
|
|
(t "#eef2f6")))
|
|
|
|
(defvar card-games-svg-hint-color "#7cf59a" "Colour ringing a valid move target.")
|
|
|
|
(defun card-games-svg--hint ()
|
|
"Resolve the valid-move hint colour (theme-aware)."
|
|
(if card-games-svg-theme-colors
|
|
(card-games-color 'success :foreground card-games-svg-hint-color)
|
|
card-games-svg-hint-color))
|
|
|
|
(defconst card-games-svg--pip-layout
|
|
'((1 (0.5 . 0.50))
|
|
(2 (0.5 . 0.16) (0.5 . 0.84))
|
|
(3 (0.5 . 0.16) (0.5 . 0.50) (0.5 . 0.84))
|
|
(4 (0.30 . 0.16) (0.70 . 0.16) (0.30 . 0.84) (0.70 . 0.84))
|
|
(5 (0.30 . 0.16) (0.70 . 0.16) (0.5 . 0.50) (0.30 . 0.84) (0.70 . 0.84))
|
|
(6 (0.30 . 0.16) (0.70 . 0.16) (0.30 . 0.50) (0.70 . 0.50)
|
|
(0.30 . 0.84) (0.70 . 0.84))
|
|
(7 (0.30 . 0.16) (0.70 . 0.16) (0.5 . 0.33) (0.30 . 0.50) (0.70 . 0.50)
|
|
(0.30 . 0.84) (0.70 . 0.84))
|
|
(8 (0.30 . 0.16) (0.70 . 0.16) (0.5 . 0.33) (0.30 . 0.50) (0.70 . 0.50)
|
|
(0.5 . 0.67) (0.30 . 0.84) (0.70 . 0.84))
|
|
(9 (0.30 . 0.14) (0.70 . 0.14) (0.30 . 0.38) (0.70 . 0.38) (0.5 . 0.50)
|
|
(0.30 . 0.62) (0.70 . 0.62) (0.30 . 0.86) (0.70 . 0.86))
|
|
(10 (0.30 . 0.14) (0.70 . 0.14) (0.5 . 0.26) (0.30 . 0.38) (0.70 . 0.38)
|
|
(0.30 . 0.62) (0.70 . 0.62) (0.5 . 0.74) (0.30 . 0.86) (0.70 . 0.86)))
|
|
"Canonical pip positions per rank (fractions of the inner card area).
|
|
Pips with a Y fraction above 0.5 are drawn rotated 180 degrees.")
|
|
|
|
(defun card-games-svg--suit-color (suit)
|
|
"Return the ink colour for SUIT (0-3 or the symbol `joker')."
|
|
(cond ((eq suit 'joker) card-games-svg-joker-color)
|
|
(card-games-svg-four-color
|
|
(pcase suit (0 card-games-svg-black-color) (1 card-games-svg-club-color)
|
|
(2 card-games-svg-diamond-color) (3 card-games-svg-red-color)
|
|
(_ card-games-svg-black-color)))
|
|
((card-games-red-suit-p suit) card-games-svg-red-color)
|
|
(t card-games-svg-black-color)))
|
|
|
|
(defun card-games-svg--suit-glyph (suit)
|
|
"Return the glyph for SUIT (0-3 or the symbol `joker').
|
|
Defers to `card-games-suit-glyph', so it honours `card-games-symbols'."
|
|
(card-games-suit-glyph suit))
|
|
|
|
(defun card-games-svg--text (svg str x y size color &optional bold transform)
|
|
"Add centred text STR to SVG at X, Y with SIZE, COLOR, BOLD, TRANSFORM."
|
|
(let ((args (list :x (round x) :y (round y) :font-size (round size)
|
|
:fill color :text-anchor "middle"
|
|
:font-family card-games-svg-font-family)))
|
|
(when bold (setq args (append args (list :font-weight "bold"))))
|
|
(when transform (setq args (append args (list :transform transform))))
|
|
(apply #'svg-text svg str args)))
|
|
|
|
(defun card-games-svg--index (svg x y w h rank glyph color flip)
|
|
"Draw a stacked RANK/GLYPH index in COLOR on SVG.
|
|
X, Y and W, H give the card's top-left corner and size. The index sits
|
|
top-left normally, and bottom-right and upside-down when FLIP is non-nil."
|
|
(let* ((rs (max 8 (round (* h 0.18))))
|
|
(gs (max 7 (round (* h 0.15))))
|
|
(ix (+ x (round (* w 0.16))))
|
|
(ry (+ y (round (* h 0.18))))
|
|
(gy (+ ry (round (* gs 1.05))))
|
|
(tr (and flip (format "rotate(180 %d %d)"
|
|
(round (+ x (/ w 2.0)))
|
|
(round (+ y (/ h 2.0)))))))
|
|
(when (and rank (> (length rank) 0))
|
|
(card-games-svg--text svg rank ix ry rs color t tr))
|
|
(card-games-svg--text svg glyph ix gy gs color nil tr)))
|
|
|
|
(defun card-games-svg--pip (svg px py size glyph color flip)
|
|
"Draw a single pip GLYPH of SIZE in COLOR centred at PX, PY on SVG."
|
|
(card-games-svg--text svg glyph px (+ py (* size 0.36)) size color nil
|
|
(and flip (format "rotate(180 %d %d)" (round px) (round py)))))
|
|
|
|
(defun card-games-svg--draw-pips (svg x y w h n glyph color)
|
|
"Lay out N pips of GLYPH in COLOR within the card at X, Y (W by H) on SVG."
|
|
(let* ((mx (* w 0.24)) (my (* h 0.14))
|
|
(iw (- w (* 2 mx))) (ih (- h (* 2 my)))
|
|
(ps (max 9 (round (* h 0.155))))
|
|
(layout (cdr (assq n card-games-svg--pip-layout))))
|
|
(dolist (pos layout)
|
|
(card-games-svg--pip svg (+ x mx (* (car pos) iw)) (+ y my (* (cdr pos) ih))
|
|
ps glyph color (> (cdr pos) 0.5)))))
|
|
|
|
(defun card-games-svg--draw-ace (svg x y w h glyph color)
|
|
"Draw a single large central pip (an ace) of GLYPH in COLOR on SVG.
|
|
X, Y and W, H give the card's top-left corner and size."
|
|
(card-games-svg--pip svg (+ x (/ w 2.0)) (+ y (/ h 2.0)) (round (* h 0.42))
|
|
glyph color nil))
|
|
|
|
(defun card-games-svg--draw-court (svg x y w h rank glyph color suit)
|
|
"Draw a framed court card (RANK letter + GLYPH) of SUIT in COLOR on SVG.
|
|
X, Y and W, H give the card's top-left corner and size. The inner panel
|
|
has a quarter-circle scallop cut into each corner; the scallop radius is
|
|
8.5% of the panel height (17% diameter)."
|
|
(let* ((bw (round (* (- w (* 2 (round (* w 0.15)))) 0.67)))
|
|
(bh (round (* (- h (* 2 (round (* h 0.16)))) 0.67)))
|
|
(bx (round (+ x (/ (- w bw) 2.0))))
|
|
(by (round (+ y (/ (- h bh) 2.0))))
|
|
(rr (max 1 (round (* bh 0.085))))
|
|
(d (format (concat "M %d %d L %d %d "
|
|
"A %d %d 0 0 0 %d %d L %d %d "
|
|
"A %d %d 0 0 0 %d %d L %d %d "
|
|
"A %d %d 0 0 0 %d %d L %d %d "
|
|
"A %d %d 0 0 0 %d %d Z")
|
|
(+ bx rr) by (- (+ bx bw) rr) by
|
|
rr rr (+ bx bw) (+ by rr)
|
|
(+ bx bw) (- (+ by bh) rr)
|
|
rr rr (- (+ bx bw) rr) (+ by bh)
|
|
(+ bx rr) (+ by bh)
|
|
rr rr bx (- (+ by bh) rr)
|
|
bx (+ by rr)
|
|
rr rr (+ bx rr) by)))
|
|
(svg-node svg 'path :d d :fill (card-games-svg--court-fill suit)
|
|
:stroke color :stroke-width 1)
|
|
(card-games-svg--text svg rank (+ x (/ w 2.0)) (+ y (* h 0.65)) (* h 0.282) color t)
|
|
(card-games-svg--text svg glyph (+ x (/ w 2.0)) (+ y (* h 0.82)) (* h 0.17) color)))
|
|
|
|
(defun card-games-svg--draw-joker (svg x y w h color)
|
|
"Draw the joker face in COLOR on SVG.
|
|
X, Y and W, H give the card's top-left corner and size."
|
|
(card-games-svg--text svg "★" (+ x (/ w 2.0)) (+ y (* h 0.52)) (* h 0.40) color)
|
|
(card-games-svg--text svg "JOKER" (+ x (/ w 2.0)) (+ y (* h 0.74)) (* h 0.135) color t))
|
|
|
|
(defun card-games-svg--back-dots (svg x y w h)
|
|
"Draw the dotted-medallion back pattern on SVG within X, Y, W, H."
|
|
(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 card-games-svg-back-trim)
|
|
(setq gx (+ gx 9))))
|
|
(setq gy (+ gy 9)))))
|
|
|
|
(defun card-games-svg--back-lattice (svg x y w h)
|
|
"Draw a small-cross lattice back pattern on SVG within X, Y, W, H."
|
|
(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 card-games-svg-back-trim :stroke-width 1)
|
|
(svg-line svg (- gx 2) (+ gy 2) (+ gx 2) (- gy 2)
|
|
:stroke card-games-svg-back-trim :stroke-width 1)
|
|
(setq gx (+ gx 11))))
|
|
(setq gy (+ gy 11)))))
|
|
|
|
(defun card-games-svg--back-waves (svg x y w h)
|
|
"Draw a staggered-dash (brickwork) back pattern on SVG within X, Y, W, H."
|
|
(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 card-games-svg-back-trim :stroke-width 1.4)
|
|
(setq gx (+ gx 12))))
|
|
(setq gy (+ gy 8) row (1+ row)))))
|
|
|
|
(defun card-games-svg--back-diamond (svg x y w h)
|
|
"Draw concentric diamonds as the back pattern on SVG within X, Y, W, H."
|
|
(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 card-games-svg-back-trim :stroke-width 1)))))
|
|
|
|
(defun card-games-svg--back-logo (svg x y w h back)
|
|
"Stamp the Emacs logo named BACK on SVG within X, Y, W, H.
|
|
Fall back to dots when the logo image is unavailable."
|
|
(let ((file (and (fboundp 'svg-embed)
|
|
(card-games-svg--logo-file (card-games-svg--back-logo-name back)))))
|
|
(if (null file)
|
|
(card-games-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 card-games-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 `card-games-svg-card-back'."
|
|
(svg-rectangle svg x y w h :rx r :ry r :fill (card-games-svg--back-fill)
|
|
:stroke card-games-svg-border-color :stroke-width 1)
|
|
(svg-rectangle svg (+ x 4) (+ y 4) (- w 8) (- h 8) :rx 4 :fill "none"
|
|
:stroke card-games-svg-back-trim :stroke-width 1)
|
|
(let ((back (card-games-svg--effective-back)))
|
|
(pcase back
|
|
('solid nil)
|
|
('rings
|
|
(svg-rectangle svg (+ x 8) (+ y 8) (- w 16) (- h 16) :rx 5 :fill "none"
|
|
:stroke card-games-svg-back-trim :stroke-width 1)
|
|
(svg-rectangle svg (+ x 12) (+ y 12) (- w 24) (- h 24) :rx 4 :fill "none"
|
|
:stroke card-games-svg-back-trim :stroke-width 1))
|
|
('lattice (card-games-svg--back-lattice svg x y w h))
|
|
('waves (card-games-svg--back-waves svg x y w h))
|
|
('diamond (card-games-svg--back-diamond svg x y w h))
|
|
((or 'emacs 'emacs-classic 'gnu 'splash)
|
|
(card-games-svg--back-logo svg x y w h back))
|
|
(_ (card-games-svg--back-dots svg x y w h)))))
|
|
|
|
(defun card-games-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)."
|
|
(svg-rectangle svg x y w h :rx r :ry r :fill card-games-svg-face-color
|
|
:stroke card-games-svg-border-color :stroke-width 1)
|
|
(let ((color (card-games-svg--suit-color suit))
|
|
(glyph (card-games-svg--suit-glyph suit)))
|
|
(card-games-svg--index svg x y w h rank glyph color nil)
|
|
(card-games-svg--index svg x y w h rank glyph color t)
|
|
(cond
|
|
((eq suit 'joker) (card-games-svg--draw-joker svg x y w h color))
|
|
((member rank '("J" "Q" "K")) (card-games-svg--draw-court svg x y w h rank glyph color suit))
|
|
((equal rank "A") (card-games-svg--draw-ace svg x y w h glyph color))
|
|
(t (let ((n (truncate (string-to-number (or rank "0")))))
|
|
(if (and (>= n 1) (<= n 10))
|
|
(card-games-svg--draw-pips svg x y w h n glyph color)
|
|
(card-games-svg--text svg glyph (+ x (/ w 2.0)) (+ y (* h 0.6))
|
|
(* h 0.40) color)))))))
|
|
|
|
(cl-defun card-games-svg-card (svg x y &key rank suit down gap highlight hint)
|
|
"Draw one card onto SVG with its top-left corner at X, Y.
|
|
With GAP draw an empty slot; with DOWN draw a face-down card;
|
|
otherwise draw a face card labelled RANK of SUIT (0-3 or `joker').
|
|
HIGHLIGHT draws a glowing cursor ring around the card."
|
|
(let* ((w card-games-svg-card-width)
|
|
(h card-games-svg-card-height)
|
|
(r card-games-svg-corner-radius))
|
|
(when (and card-games-svg-card-shadow (not gap))
|
|
(svg-rectangle svg (+ x 2) (+ y 3) w h :rx r :ry r
|
|
:fill "black" :fill-opacity 0.16))
|
|
(cond
|
|
(gap
|
|
(svg-rectangle svg x y w h :rx r :ry r :fill "black" :fill-opacity 0.05
|
|
:stroke card-games-svg-gap-color :stroke-width 1.5
|
|
:stroke-dasharray "4,4"))
|
|
(down (card-games-svg--draw-back svg x y w h r))
|
|
(t (card-games-svg--draw-face svg x y w h r rank suit)))
|
|
(when hint
|
|
;; Haloed dashed ring: a dark backing reads on the light card faces and
|
|
;; the bright ring reads on the (green) felt -- one colour cannot do
|
|
;; both. Dashed (vs the solid cursor ring) keeps it distinct by shape,
|
|
;; not colour alone.
|
|
(svg-rectangle svg (- x 3) (- y 3) (+ w 6) (+ h 6) :rx (+ r 2)
|
|
:fill "none" :stroke "#101010" :stroke-opacity 0.55
|
|
:stroke-width 4 :stroke-dasharray "3,3")
|
|
(svg-rectangle svg (- x 2) (- y 2) (+ w 4) (+ h 4) :rx (+ r 1)
|
|
:fill "none" :stroke (card-games-svg--hint) :stroke-width 2
|
|
:stroke-dasharray "3,3"))
|
|
(when highlight
|
|
(let ((hl (card-games-svg--highlight)))
|
|
;; Haloed ring so the cursor reads on both the near-white card faces
|
|
;; (dark edges) and the dark felt (bright ring): no single colour
|
|
;; meets 3:1 on both, so pair a bright ring with dark edges.
|
|
(svg-rectangle svg (- x 5) (- y 5) (+ w 10) (+ h 10) :rx (+ r 4)
|
|
:fill "none" :stroke "#101010" :stroke-opacity 0.6
|
|
:stroke-width 6)
|
|
(svg-rectangle svg (- x 3) (- y 3) (+ w 6) (+ h 6) :rx (+ r 2)
|
|
:fill "none" :stroke hl :stroke-width 3.5)
|
|
(svg-rectangle svg (- x 1) (- y 1) (+ w 2) (+ h 2) :rx (+ r 1)
|
|
:fill "none" :stroke "#101010" :stroke-opacity 0.55
|
|
:stroke-width 1.5)))))
|
|
|
|
(defun card-games-svg--draw-spec (svg x y spec highlight &optional hint)
|
|
"Draw SPEC onto SVG at X, Y, with HIGHLIGHT and optional HINT ring.
|
|
SPEC is (RANK . SUIT), the symbol `down', or nil for a gap."
|
|
(cond
|
|
((null spec) (card-games-svg-card svg x y :gap t :highlight highlight :hint hint))
|
|
((eq spec 'down) (card-games-svg-card svg x y :down t :highlight highlight :hint hint))
|
|
(t (card-games-svg-card svg x y :rank (car spec) :suit (cdr spec)
|
|
:highlight highlight :hint hint))))
|
|
|
|
(cl-defun card-games-svg-cards-svg (specs &key highlight (pad 10) (overlap 0))
|
|
"Return an svg object drawing SPECS left to right.
|
|
SPECS is a list of card specs (see Commentary). HIGHLIGHT is the
|
|
index of a card to ring. OVERLAP fans cards by overlapping them by
|
|
that many pixels. PAD is the margin around the row."
|
|
(let* ((w card-games-svg-card-width)
|
|
(h card-games-svg-card-height)
|
|
(step (max 1 (- (+ w card-games-svg-card-gap) overlap)))
|
|
(n (length specs))
|
|
(width (+ (* 2 pad) (if (> n 0) (+ (* (1- n) step) w) w)))
|
|
(height (+ (* 2 pad) h))
|
|
(svg (svg-create width height)))
|
|
(let ((x pad) (i 0))
|
|
(dolist (spec specs)
|
|
(card-games-svg--draw-spec svg x pad spec (and highlight (= i highlight)))
|
|
(setq x (+ x step) i (1+ i))))
|
|
svg))
|
|
|
|
(cl-defun card-games-svg-grid-svg (rows &key cursor hints (pad 10))
|
|
"Return an svg object drawing ROWS as a grid of cards.
|
|
ROWS is a list of rows, each a list of card specs. CURSOR is (ROW . COL)
|
|
to highlight, or nil. HINTS is a list of (ROW . COL) to ring as valid
|
|
targets. PAD is the margin around the grid."
|
|
(let* ((w card-games-svg-card-width)
|
|
(h card-games-svg-card-height)
|
|
(gx card-games-svg-card-gap)
|
|
(gy card-games-svg-card-gap)
|
|
(ncols (apply #'max 1 (mapcar #'length rows)))
|
|
(nrows (max 1 (length rows)))
|
|
(width (+ (* 2 pad) (* ncols w) (* (1- ncols) gx)))
|
|
(height (+ (* 2 pad) (* nrows h) (* (1- nrows) gy)))
|
|
(svg (svg-create width height))
|
|
(r 0))
|
|
(dolist (row rows)
|
|
(let ((c 0)
|
|
(y (+ pad (* r (+ h gy)))))
|
|
(dolist (spec row)
|
|
(card-games-svg--draw-spec svg (+ pad (* c (+ w gx))) y spec
|
|
(and cursor (= r (car cursor)) (= c (cdr cursor)))
|
|
(and hints (member (cons r c) hints) t))
|
|
(setq c (1+ c))))
|
|
(setq r (1+ r)))
|
|
svg))
|
|
|
|
(defun card-games-svg-image (svg &optional scale)
|
|
"Return an Emacs image for SVG, optionally enlarged by SCALE."
|
|
(if (and scale (/= scale 1.0))
|
|
(svg-image svg :scale scale)
|
|
(svg-image svg)))
|
|
|
|
(defun card-games-svg-to-string (svg)
|
|
"Return the serialized XML string for SVG."
|
|
(with-temp-buffer
|
|
(svg-print svg)
|
|
(buffer-string)))
|
|
|
|
(cl-defun card-games-svg-hand-svg (specs &key cursor hints marks (overlap 0) (pad 8))
|
|
"Return an svg drawing SPECS as a left-to-right hand.
|
|
CURSOR is the index to ring as the cursor; HINTS and MARKS are lists of
|
|
indices to ring as playable and as marked; OVERLAP fans the cards and
|
|
PAD insets the row."
|
|
(let* ((w card-games-svg-card-width) (h card-games-svg-card-height)
|
|
(step (max 1 (- (+ w card-games-svg-card-gap) overlap)))
|
|
(n (length specs))
|
|
(width (+ (* 2 pad) (if (> n 0) (+ (* (1- n) step) w) w)))
|
|
(height (+ (* 2 pad) h))
|
|
(svg (svg-create width height))
|
|
(x pad) (i 0))
|
|
(dolist (spec specs)
|
|
(card-games-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))
|
|
(setq x (+ x step) i (1+ i)))
|
|
svg))
|
|
|
|
(defcustom card-games-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 card-games-svg-slider-width ()
|
|
"Return the pixel width of the card-size slider."
|
|
(+ 36 (* (length card-games-svg-slider-stops) 24) 8))
|
|
|
|
(defun card-games-svg-slider-height ()
|
|
"Return the pixel height of the card-size slider."
|
|
24)
|
|
|
|
(defun card-games-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 card-games-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 card-games-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 (card-games-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)))
|
|
|
|
(cl-defun card-games-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 and
|
|
OVERLAP fans the cards. With REGION-TAG non-nil, the image carries a
|
|
`card-games-regions' click map (each card as (REGION-TAG . INDEX)) and a
|
|
card-size slider beneath the row."
|
|
(if (not region-tag)
|
|
(propertize "*" 'display
|
|
(card-games-svg-image (card-games-svg-hand-svg specs :cursor cursor :hints hints
|
|
:marks marks :overlap overlap)
|
|
(card-games-scale)))
|
|
(let* ((w card-games-svg-card-width) (h card-games-svg-card-height) (pad 8)
|
|
(step (max 1 (- (+ w card-games-svg-card-gap) overlap)))
|
|
(n (length specs))
|
|
(cardw (if (> n 0) (+ (* (1- n) step) w) w))
|
|
(sh (card-games-svg-slider-height))
|
|
(width (+ (* 2 pad) (max cardw (card-games-svg-slider-width))))
|
|
(height (+ (* 2 pad) h 8 sh))
|
|
(svg (svg-create width height)) (regions '()) (x pad) (i 0))
|
|
(dolist (spec specs)
|
|
(card-games-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)
|
|
(card-games-svg-slider-draw svg pad (+ pad h 8) card-games-card-scale)))
|
|
(propertize "*" 'display (card-games-svg-image svg (card-games-scale)) 'card-games-regions regions))))
|
|
|
|
(defcustom card-games-svg-emacs-logo 'modern
|
|
"Which Emacs emblem to show in the full-window (svg-fill) games.
|
|
The image choices embed a logo that ships with Emacs, falling back to the
|
|
drawn emblem when the file is unavailable. `drawn' is a small built-in
|
|
emblem and `none' shows nothing."
|
|
:type '(choice (const :tag "Modern Emacs icon" modern)
|
|
(const :tag "Classic Emacs icon" classic)
|
|
(const :tag "GNU head (Gnus)" gnu)
|
|
(const :tag "GNU Emacs splash" splash)
|
|
(const :tag "Drawn emblem" drawn)
|
|
(const :tag "None" none))
|
|
:group 'card-games-svg)
|
|
|
|
(defconst card-games-svg--logo-files
|
|
'((modern . ("images/icons/hicolor/48x48/apps/emacs.png"
|
|
"images/icons/hicolor/128x128/apps/emacs.png"))
|
|
(classic . ("images/icons/hicolor/48x48/apps/emacs23.png"
|
|
"images/icons/hicolor/128x128/apps/emacs23.png"))
|
|
(gnu . ("images/gnus/gnus.png"))
|
|
(splash . ("images/splash.png")))
|
|
"Map a logo name to candidate image files relative to `data-directory'.")
|
|
|
|
(defun card-games-svg--logo-file (name)
|
|
"Return the first readable image file for logo NAME, or nil."
|
|
(cl-loop for rel in (cdr (assq name card-games-svg--logo-files))
|
|
for f = (expand-file-name rel data-directory)
|
|
when (file-readable-p f) return f))
|
|
|
|
(defun card-games-svg--draw-logo-emblem (svg cx cy fs)
|
|
"Draw the built-in purple GNU Emacs emblem on SVG.
|
|
Centre it at CX, CY, scaled by FS."
|
|
(svg-gradient svg "card-games-logo" 'linear '((0 . "#8056c8") (100 . "#3f1f9e")))
|
|
(svg-circle svg cx cy (round (* 26 fs)) :gradient "card-games-logo"
|
|
:stroke "#2a1370" :stroke-width 2)
|
|
(card-games-svg--text svg "e" cx (+ cy (round (* 10 fs))) (round (* 30 fs)) "#ffffff" t)
|
|
(card-games-svg--text svg "GNU Emacs" cx (+ cy (round (* 42 fs)))
|
|
(max 10 (round (* 11 fs))) "#c7bbe6"))
|
|
|
|
(defun card-games-svg-draw-logo (svg cx cy &optional fs)
|
|
"Draw the configured Emacs emblem on SVG, centred at CX, CY.
|
|
The emblem is chosen by `card-games-svg-emacs-logo'; FS scales it. Embeds a
|
|
real Emacs logo image when one is available, and otherwise draws the
|
|
built-in emblem."
|
|
(let ((fs (or fs 1.0)) (choice card-games-svg-emacs-logo))
|
|
(pcase choice
|
|
('none nil)
|
|
('drawn (card-games-svg--draw-logo-emblem svg cx cy fs))
|
|
(_ (let ((file (and (fboundp 'svg-embed) (card-games-svg--logo-file choice))))
|
|
(if (null file)
|
|
(card-games-svg--draw-logo-emblem svg cx cy fs)
|
|
(let ((size (round (* 56 fs))))
|
|
(svg-embed svg file "image/png" nil
|
|
:x (round (- cx (/ size 2)))
|
|
:y (round (- cy (/ size 2)))
|
|
:width size :height size))))))))
|
|
|
|
(provide 'card-games-svg)
|
|
;;; card-games-svg.el ends here
|