initial commit
This commit is contained in:
commit
a025434c2b
11 changed files with 3826 additions and 0 deletions
5
.gitignore
vendored
Normal file
5
.gitignore
vendored
Normal file
|
|
@ -0,0 +1,5 @@
|
||||||
|
*.elc
|
||||||
|
/dist/
|
||||||
|
/card-games-*.tar
|
||||||
|
/card-games-*-src.tar.gz
|
||||||
|
*.sketch
|
||||||
82
Makefile
Normal file
82
Makefile
Normal file
|
|
@ -0,0 +1,82 @@
|
||||||
|
# Makefile for card-games -- byte-compile, test, and package.
|
||||||
|
EMACS ?= emacs
|
||||||
|
PKG = card-games
|
||||||
|
VERSION = 1.0.50
|
||||||
|
# Source files in dependency order (cg-core first).
|
||||||
|
EL = cg-core.el cg-svg.el cg-bid.el cg-gaps.el cg-bid-ui.el card-games.el
|
||||||
|
ELC = $(EL:.el=.elc)
|
||||||
|
PKGDESC = $(PKG)-pkg.el
|
||||||
|
TARDIR = $(PKG)-$(VERSION)
|
||||||
|
TAR = $(TARDIR).tar
|
||||||
|
SRCTAR = $(PKG)-$(VERSION)-src.tar.gz
|
||||||
|
DIST = dist
|
||||||
|
BATCH = $(EMACS) -Q --batch -L .
|
||||||
|
EXTRA = README.org $(PKGDESC)
|
||||||
|
|
||||||
|
.PHONY: all compile test clean distclean checkdoc lint package tarball elpa release help
|
||||||
|
|
||||||
|
help:
|
||||||
|
@echo "card-games $(VERSION) -- make targets:"
|
||||||
|
@echo " compile byte-compile all sources"
|
||||||
|
@echo " test run the ERT test suite"
|
||||||
|
@echo " checkdoc run checkdoc on all sources"
|
||||||
|
@echo " lint run package-lint (if installed)"
|
||||||
|
@echo " package build the installable package tarball ($(TAR))"
|
||||||
|
@echo " elpa build a one-package ELPA archive in $(DIST)/"
|
||||||
|
@echo " release clean + test + package + source tarball"
|
||||||
|
@echo " clean remove .elc and build artifacts"
|
||||||
|
|
||||||
|
all: compile
|
||||||
|
|
||||||
|
# Compile in order so each file sees its compiled dependencies.
|
||||||
|
compile:
|
||||||
|
$(BATCH) -f batch-byte-compile $(EL)
|
||||||
|
|
||||||
|
test:
|
||||||
|
$(BATCH) -L test -l test/$(PKG)-tests.el -f ert-run-tests-batch-and-exit
|
||||||
|
|
||||||
|
checkdoc:
|
||||||
|
$(BATCH) --eval "(progn (dolist (f '($(EL))) (checkdoc-file f)))"
|
||||||
|
|
||||||
|
lint:
|
||||||
|
-$(BATCH) --eval "(progn (require 'package) (package-initialize) \
|
||||||
|
(unless (require 'package-lint nil t) (error \"package-lint not installed\")) \
|
||||||
|
(setq package-lint-main-file \"$(PKG).el\") \
|
||||||
|
(dolist (f '($(EL))) (with-temp-buffer (insert-file-contents f) \
|
||||||
|
(emacs-lisp-mode) (package-lint-buffer))))"
|
||||||
|
|
||||||
|
# Installable multi-file package: card-games-VERSION.tar with a top
|
||||||
|
# directory of the same name (package.el / package-install-file format).
|
||||||
|
package: tarball
|
||||||
|
# Uses GNU tar's --transform to add the top directory without a temp copy.
|
||||||
|
tarball: $(EL) $(EXTRA)
|
||||||
|
tar --transform 's,^,$(TARDIR)/,' -cf $(TAR) $(EL) $(EXTRA)
|
||||||
|
@echo "Built $(TAR)"
|
||||||
|
|
||||||
|
# A minimal ELPA archive (archive-contents + tar) under dist/.
|
||||||
|
# Testers can: (add-to-list 'package-archives '("cg" . "/path/to/dist/"))
|
||||||
|
elpa: tarball
|
||||||
|
rm -rf $(DIST)
|
||||||
|
mkdir -p $(DIST)
|
||||||
|
$(BATCH) --eval "(progn (require 'package-x) \
|
||||||
|
(let ((package-archive-upload-base (expand-file-name \"$(DIST)\"))) \
|
||||||
|
(package-upload-file \"$(TAR)\")))"
|
||||||
|
@echo "ELPA archive in $(DIST)/"
|
||||||
|
|
||||||
|
# Source snapshot for a GitHub release. Archive an explicit file list
|
||||||
|
# (not ".") so the growing output tarball and editor lock files are never
|
||||||
|
# read mid-write -- which is what caused "tar: .: file changed as we read it".
|
||||||
|
SRCFILES = $(EL) $(EXTRA) Makefile .gitignore test
|
||||||
|
release: distclean test tarball
|
||||||
|
rm -f $(SRCTAR)
|
||||||
|
tar --transform 's,^,$(TARDIR)/,' \
|
||||||
|
--exclude='*.elc' --exclude='*.tar' --exclude='*.tar.gz' \
|
||||||
|
--exclude='.#*' --exclude='$(DIST)' --exclude='.git' \
|
||||||
|
-czf $(SRCTAR) $(SRCFILES)
|
||||||
|
@echo "Built $(SRCTAR) and $(TAR) for release $(VERSION)"
|
||||||
|
|
||||||
|
clean:
|
||||||
|
rm -f $(ELC)
|
||||||
|
|
||||||
|
distclean: clean
|
||||||
|
rm -rf $(DIST) $(TARDIR) $(TAR) $(SRCTAR)
|
||||||
83
README.org
Normal file
83
README.org
Normal file
|
|
@ -0,0 +1,83 @@
|
||||||
|
#+TITLE: card-games -- Play card games in Emacs
|
||||||
|
#+AUTHOR: Corwin Brust
|
||||||
|
|
||||||
|
Card games for Emacs.
|
||||||
|
|
||||||
|
Renders SVG by default when ~display-graphic-p~ is t and rsvg is
|
||||||
|
available. The default (UNICODE) symbols maybe customized by
|
||||||
|
configuring ~card-game-symbols~.
|
||||||
|
|
||||||
|
* Games
|
||||||
|
- *500 (Bid)* -- the four-handed partnership trick-taking game, against
|
||||||
|
three computer opponents (=M-x cg-bid=).
|
||||||
|
- *Gaps / Hell's Half-Acre* -- solitaire; sort each row into one suit
|
||||||
|
running 2..K (=M-x cg-gaps=).
|
||||||
|
|
||||||
|
To launch the game-menu press =M-x card-game= or launch a game
|
||||||
|
directly by calling it's launcher command. Launcher commands take the
|
||||||
|
form ~cg-GAME~ where ~GAME~ is one of
|
||||||
|
- montana - Montana: <SHORT_RULES>
|
||||||
|
- gap - Gap: <SHORT_RULES>
|
||||||
|
- hha - Hells Half Acre: <SHORT_RULES>
|
||||||
|
- bid - Bid, (or 500 Bid): <SHORT_RULES>
|
||||||
|
|
||||||
|
* TODO
|
||||||
|
- [ ] documentation
|
||||||
|
- [ ] create ~card-game-symbols~ and obey it
|
||||||
|
- [ ] refactor to allow games to subclass components (svg)
|
||||||
|
- [ ] add manual-control silder for card size (svgfull)
|
||||||
|
- [ ] mor games
|
||||||
|
|
||||||
|
* Install
|
||||||
|
** From the package tarball
|
||||||
|
#+begin_src
|
||||||
|
make package # builds card-games-1.0.50.tar
|
||||||
|
#+end_src
|
||||||
|
Then in Emacs: ~M-x package-install-file RET card-games-1.0.50.tar~.
|
||||||
|
|
||||||
|
** From a local ELPA archive
|
||||||
|
#+begin_src
|
||||||
|
make elpa # builds dist/ (archive-contents + tar)
|
||||||
|
#+end_src
|
||||||
|
#+begin_src emacs-lisp
|
||||||
|
(add-to-list 'package-archives '("cg" . "/path/to/dist/"))
|
||||||
|
(package-refresh-contents)
|
||||||
|
(package-install 'card-games)
|
||||||
|
#+end_src
|
||||||
|
|
||||||
|
** Manually
|
||||||
|
Put the ~cg-*.el~ and ~card-games.el~ files on your ~load-path~ and
|
||||||
|
~(require 'card-games)~.
|
||||||
|
|
||||||
|
* Playing
|
||||||
|
Both games work with the keyboard everywhere and with the mouse on a
|
||||||
|
graphical display.
|
||||||
|
|
||||||
|
- 500: ~b~ bid, ~p~ pass, arrows + ~RET~ to play (or click a card),
|
||||||
|
~n~ next hand / new game, ~?~ help.
|
||||||
|
- Gaps: arrows or ~hjkl~ to move, ~RET~ to fill a gap (or click it),
|
||||||
|
~r~ redeal, ~u~ undo, ~n~ new, ~?~ help.
|
||||||
|
|
||||||
|
* Customization
|
||||||
|
~M-x customize-group RET cg-svg~ and ~RET card-games~:
|
||||||
|
- ~cg-svg-theme-colors~ -- derive the highlight ring and card backs
|
||||||
|
from your theme (on by default).
|
||||||
|
- ~cg-bid-felt-color~ -- the 500 table felt.
|
||||||
|
- ~cg-svg-card-width~, ~cg-svg-card-height~, ~cg-svg-card-shadow~,
|
||||||
|
~cg-svg-font-family~ -- card appearance.
|
||||||
|
- ~cg-svg-card-back~ -- card-back pattern: dots, rings, or solid.
|
||||||
|
- ~cg-bid-animate~, ~cg-bid-ai-delay~, ~cg-bid-trick-pause~ -- pace the
|
||||||
|
500 AI so play is watchable and completed tricks linger.
|
||||||
|
- ~M-x card-games-set-theme~ -- apply a preset (classic, dark, contrast).
|
||||||
|
|
||||||
|
* Development
|
||||||
|
#+begin_src
|
||||||
|
make compile # byte-compile (should be warning-free)
|
||||||
|
make test # run the ERT suite
|
||||||
|
make checkdoc # documentation lint
|
||||||
|
make release # clean + test + package + source tarball
|
||||||
|
#+end_src
|
||||||
|
|
||||||
|
* License
|
||||||
|
GPL-3.0-or-later. See the file headers; add a COPYING file with the
|
||||||
|
full GPLv3 text for distribution.
|
||||||
9
card-games-pkg.el
Normal file
9
card-games-pkg.el
Normal file
|
|
@ -0,0 +1,9 @@
|
||||||
|
;;; card-games-pkg.el --- Package metadata -*- no-byte-compile: t; -*-
|
||||||
|
(define-package "card-games" "1.0.50"
|
||||||
|
"Play card games in Emacs (console UNICODE and graphical SVG)."
|
||||||
|
'((emacs "26.1"))
|
||||||
|
:keywords '("games")
|
||||||
|
:url "https://github.com/corwin/card-games"
|
||||||
|
:authors '(("Corwin Brust" . "corwin@bru.st"))
|
||||||
|
:maintainer '("Corwin Brust" . "corwin@bru.st"))
|
||||||
|
;;; card-games-pkg.el ends here
|
||||||
132
card-games.el
Normal file
132
card-games.el
Normal file
|
|
@ -0,0 +1,132 @@
|
||||||
|
;;; card-games.el --- Play card games in Emacs (console + SVG) -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2026 Corwin Brust
|
||||||
|
|
||||||
|
;; Author: Corwin Brust <corwin@bru.st>
|
||||||
|
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||||
|
;; Version: 1.0.50
|
||||||
|
;; Package-Requires: ((emacs "26.1"))
|
||||||
|
;; Keywords: games
|
||||||
|
;; URL: https://github.com/corwin/card-games
|
||||||
|
|
||||||
|
;; 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:
|
||||||
|
|
||||||
|
;; Card games for Emacs, rendered as UNICODE text in a terminal and as
|
||||||
|
;; SVG cards on a graphical display. This file is the umbrella: it
|
||||||
|
;; pulls in the individual games and offers a chooser.
|
||||||
|
;;
|
||||||
|
;; Run `M-x card-game' for a menu, or start a game directly:
|
||||||
|
;;
|
||||||
|
;; `cg-bid' -- 500, the four-handed partnership trick-taking game,
|
||||||
|
;; played against three computer opponents.
|
||||||
|
;; `cg-gaps' -- Gaps / Montana / "Hell's Half-Acre" solitaire.
|
||||||
|
;;
|
||||||
|
;; New games register themselves by adding to `card-games-list'.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'cg-core)
|
||||||
|
(require 'cg-gaps)
|
||||||
|
(require 'cg-bid-ui)
|
||||||
|
|
||||||
|
(defvar card-games-list
|
||||||
|
'(("500 (Bid)" cg-bid
|
||||||
|
"Four-handed partnership trick-taking versus three AI opponents.")
|
||||||
|
("Gaps (Montana)" cg-montana
|
||||||
|
"Solitaire: a Two anchors each row; build up 2 through King.")
|
||||||
|
("Hell's Half-Acre" cg-hells-half-acre
|
||||||
|
"Solitaire: a King anchors each row; build down King through 2."))
|
||||||
|
"Registry of playable games.
|
||||||
|
Each entry is (NAME COMMAND DESCRIPTION); `card-game' lists them.")
|
||||||
|
|
||||||
|
(defun card-game--launch (button)
|
||||||
|
"Start the game whose command is stored on BUTTON."
|
||||||
|
(let ((cmd (button-get button 'card-game-command)))
|
||||||
|
(quit-window)
|
||||||
|
(call-interactively cmd)))
|
||||||
|
|
||||||
|
(defvar card-game-mode-map
|
||||||
|
(let ((map (make-sparse-keymap)))
|
||||||
|
(set-keymap-parent map special-mode-map)
|
||||||
|
(define-key map "n" #'forward-button)
|
||||||
|
(define-key map "p" #'backward-button)
|
||||||
|
(define-key map (kbd "TAB") #'forward-button)
|
||||||
|
(define-key map (kbd "<backtab>") #'backward-button)
|
||||||
|
map)
|
||||||
|
"Keymap for `card-game-mode'.")
|
||||||
|
|
||||||
|
(define-derived-mode card-game-mode special-mode "Card-Games"
|
||||||
|
"Major mode for the `card-game' chooser."
|
||||||
|
(setq-local cursor-type nil))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun card-game ()
|
||||||
|
"Open a chooser listing the available card games.
|
||||||
|
Press RET (or click) on a game to start it."
|
||||||
|
(interactive)
|
||||||
|
(let ((buf (get-buffer-create "*Card Games*")))
|
||||||
|
(with-current-buffer buf
|
||||||
|
(card-game-mode)
|
||||||
|
(let ((inhibit-read-only t))
|
||||||
|
(erase-buffer)
|
||||||
|
(insert (propertize " Card Games for Emacs\n" 'face 'bold))
|
||||||
|
(insert (propertize
|
||||||
|
" Choose a game with RET or the mouse. q to quit.\n\n"
|
||||||
|
'face 'shadow))
|
||||||
|
(dolist (g card-games-list)
|
||||||
|
(insert " ")
|
||||||
|
(insert-text-button
|
||||||
|
(format "%-26s" (nth 0 g))
|
||||||
|
'face 'link
|
||||||
|
'help-echo (nth 2 g)
|
||||||
|
'card-game-command (nth 1 g)
|
||||||
|
'action #'card-game--launch)
|
||||||
|
(insert (propertize (concat " " (nth 2 g) "\n") 'face 'shadow)))
|
||||||
|
(insert "\n")))
|
||||||
|
(switch-to-buffer buf)
|
||||||
|
(goto-char (point-min))
|
||||||
|
(forward-button 1)))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defalias 'card-games #'card-game
|
||||||
|
"Alias for `card-game'.")
|
||||||
|
|
||||||
|
(defconst card-games-themes
|
||||||
|
'((classic :felt "#15692f" :theme t)
|
||||||
|
(dark :felt "#23272e" :back "#3b4252" :highlight "#88c0d0" :theme nil)
|
||||||
|
(contrast :felt "#0a0a0a" :back "#000000" :highlight "#ffd400" :theme nil))
|
||||||
|
"Named table/card colour presets for `card-games-set-theme'.")
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun card-games-set-theme (name)
|
||||||
|
"Apply the card-games colour preset NAME (see `card-games-themes')."
|
||||||
|
(interactive
|
||||||
|
(list (intern (completing-read
|
||||||
|
"Card-games theme: "
|
||||||
|
(mapcar (lambda (e) (symbol-name (car e))) card-games-themes)
|
||||||
|
nil t))))
|
||||||
|
(let ((p (alist-get name card-games-themes)))
|
||||||
|
(unless p (user-error "No such card-games theme: %s" name))
|
||||||
|
(setq cg-bid-felt-color (plist-get p :felt))
|
||||||
|
(when (plist-member p :theme)
|
||||||
|
(setq cg-svg-theme-colors (plist-get p :theme)))
|
||||||
|
(when (plist-get p :back) (setq cg-svg-back-color (plist-get p :back)))
|
||||||
|
(when (plist-get p :highlight)
|
||||||
|
(setq cg-svg-highlight-color (plist-get p :highlight)))
|
||||||
|
(message "card-games theme: %s" name)))
|
||||||
|
|
||||||
|
(provide 'card-games)
|
||||||
|
;;; card-games.el ends here
|
||||||
1082
cg-bid-ui.el
Normal file
1082
cg-bid-ui.el
Normal file
File diff suppressed because it is too large
Load diff
844
cg-bid.el
Normal file
844
cg-bid.el
Normal file
|
|
@ -0,0 +1,844 @@
|
||||||
|
;;; cg-bid.el --- 500 (Bid) — game logic -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2026 Corwin Brust
|
||||||
|
|
||||||
|
;; Author: Corwin Brust <corwin@bru.st>
|
||||||
|
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||||
|
;; Version: 1.0.50
|
||||||
|
;; Package-Requires: ((emacs "26.1"))
|
||||||
|
;; Keywords: games
|
||||||
|
;; URL: https://github.com/corwin/card-games
|
||||||
|
|
||||||
|
;; 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:
|
||||||
|
|
||||||
|
;; 500 ("Bid"): the four-handed partnership trick-taking game. This
|
||||||
|
;; file holds the rules engine (deck, auction, kitty, trick play,
|
||||||
|
;; scoring, the full game to 500, and the basic AI). The console UI and
|
||||||
|
;; the `cg-bid' command live in cg-bid-ui.el.
|
||||||
|
;;
|
||||||
|
;; You sit South (seat 0); partner North (2); West (1) and East (3)
|
||||||
|
;; oppose. A side wins only by reaching 500 on a contract it made (the
|
||||||
|
;; "front door"); a side that sinks to -500 loses ("back door").
|
||||||
|
;;
|
||||||
|
;; Deck (Corwin's 45-card variant): Four..Ace in all four suits plus a
|
||||||
|
;; single Joker; ten cards each and a five-card kitty. With a trump
|
||||||
|
;; suit the order is Joker, right bower (jack of trumps), left bower
|
||||||
|
;; (other jack of the trump colour), then A K Q 10 9 8 7 6 5 4. In
|
||||||
|
;; no-trumps the Joker is the only trump and is highest. Misère/Nullo
|
||||||
|
;; is "own hand": the contractor's partner sits out and the contractor
|
||||||
|
;; tries to take no tricks; Open Nullo exposes the hand after trick one.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'cl-lib)
|
||||||
|
(require 'cg-core)
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Cards specific to 500
|
||||||
|
|
||||||
|
(defconst cg-bid-ranks
|
||||||
|
["4" "5" "6" "7" "8" "9" "10" "J" "Q" "K" "A"]
|
||||||
|
"Rank labels indexed 0..10 (Four through Ace). Index 7 is the Jack.")
|
||||||
|
|
||||||
|
(defconst cg-bid-jack 7 "Rank index of the Jack.")
|
||||||
|
(defconst cg-bid-joker '(4 . 0) "Canonical Joker card; suit index 4.")
|
||||||
|
|
||||||
|
(defsubst cg-bid-joker-p (card)
|
||||||
|
"Return non-nil when CARD is the Joker."
|
||||||
|
(and (consp card) (= (car card) 4)))
|
||||||
|
|
||||||
|
(defun cg-bid-card-string (card)
|
||||||
|
"Return a short label for CARD."
|
||||||
|
(cond
|
||||||
|
((null card) "--")
|
||||||
|
((cg-bid-joker-p card) "Jk")
|
||||||
|
(t (concat (aref cg-bid-ranks (cdr card)) (aref cg-suits (car card))))))
|
||||||
|
|
||||||
|
(defun cg-bid--full-deck ()
|
||||||
|
"Return the 45-card deck as a list of cards."
|
||||||
|
(cons (cons 4 0)
|
||||||
|
(cl-loop for s below 4
|
||||||
|
append (cl-loop for r below 11 collect (cons s r)))))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; The Avondale-style bid schedule
|
||||||
|
|
||||||
|
(defconst cg-bid-schedule
|
||||||
|
;; (LABEL NAME VALUE TRICKS TRUMP OPEN)
|
||||||
|
;; TRUMP: 0-3 suit, nt, or nullo.
|
||||||
|
'(("6♠" "Six Spades" 40 6 0)
|
||||||
|
("6♣" "Six Clubs" 60 6 1)
|
||||||
|
("6♦" "Six Diamonds" 80 6 2)
|
||||||
|
("6♥" "Six Hearts" 100 6 3)
|
||||||
|
("6NT" "Six No Trump" 120 6 nt)
|
||||||
|
("7♠" "Seven Spades" 140 7 0)
|
||||||
|
("7♣" "Seven Clubs" 160 7 1)
|
||||||
|
("7♦" "Seven Diamonds" 180 7 2)
|
||||||
|
("7♥" "Seven Hearts" 200 7 3)
|
||||||
|
("7NT" "Seven No Trump" 220 7 nt)
|
||||||
|
("8♠" "Eight Spades" 240 8 0)
|
||||||
|
("NL" "Nullo" 250 0 nullo)
|
||||||
|
("8♣" "Eight Clubs" 260 8 1)
|
||||||
|
("8♦" "Eight Diamonds" 280 8 2)
|
||||||
|
("8♥" "Eight Hearts" 300 8 3)
|
||||||
|
("8NT" "Eight No Trump" 320 8 nt)
|
||||||
|
("9♠" "Nine Spades" 340 9 0)
|
||||||
|
("ON" "Open Nullo" 350 0 nullo t)
|
||||||
|
("9♣" "Nine Clubs" 360 9 1)
|
||||||
|
("9♦" "Nine Diamonds" 380 9 2)
|
||||||
|
("9♥" "Nine Hearts" 400 9 3)
|
||||||
|
("9NT" "Nine No Trump" 420 9 nt)
|
||||||
|
("10♠" "Ten Spades" 440 10 0)
|
||||||
|
("GN" "Grand Nullo" 450 0 nullo t)
|
||||||
|
("10♣" "Ten Clubs" 460 10 1)
|
||||||
|
("10♦" "Ten Diamonds" 480 10 2)
|
||||||
|
("10♥" "Ten Hearts" 500 10 3)
|
||||||
|
("10NT" "Ten No Trump" 520 10 nt))
|
||||||
|
"Bidding schedule, ascending by value.
|
||||||
|
Each entry is (LABEL NAME VALUE TRICKS TRUMP [OPEN]).")
|
||||||
|
|
||||||
|
(defsubst cg-bid-label (bid) (nth 0 bid))
|
||||||
|
(defsubst cg-bid-name (bid) (nth 1 bid))
|
||||||
|
(defsubst cg-bid-value (bid) (nth 2 bid))
|
||||||
|
(defsubst cg-bid-tricks (bid) (nth 3 bid))
|
||||||
|
(defsubst cg-bid-trump (bid) (nth 4 bid))
|
||||||
|
(defsubst cg-bid-open-p (bid) (nth 5 bid))
|
||||||
|
(defsubst cg-bid-nullo-p (bid) (eq (cg-bid-trump bid) 'nullo))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Card power and trick logic
|
||||||
|
|
||||||
|
(defun cg-bid-effective-suit (card trump)
|
||||||
|
"Return the suit CARD belongs to for following, given TRUMP.
|
||||||
|
TRUMP is a suit index 0-3, or the symbol `nt' or `nullo'.
|
||||||
|
The left bower counts as the trump suit; the Joker counts as
|
||||||
|
trump (or as its own suit `joker' when there is no trump suit)."
|
||||||
|
(cond
|
||||||
|
((cg-bid-joker-p card) (if (memq trump '(nt nullo)) 'joker trump))
|
||||||
|
((and (numberp trump)
|
||||||
|
(= (cdr card) cg-bid-jack)
|
||||||
|
(= (car card) (cg-sister-suit trump)))
|
||||||
|
trump)
|
||||||
|
(t (car card))))
|
||||||
|
|
||||||
|
(defun cg-bid-power (card trump led)
|
||||||
|
"Return an integer strength for CARD given TRUMP and the LED suit.
|
||||||
|
Higher wins. Cards that are neither trump nor of the led suit score
|
||||||
|
below 100 and so can never win a trick."
|
||||||
|
(let ((es (cg-bid-effective-suit card trump)))
|
||||||
|
(cond
|
||||||
|
((cg-bid-joker-p card) 1000)
|
||||||
|
((and (numberp trump) (eq es trump))
|
||||||
|
(cond
|
||||||
|
((and (= (cdr card) cg-bid-jack) (= (car card) trump)) 900) ; right bower
|
||||||
|
((= (cdr card) cg-bid-jack) 899) ; left bower
|
||||||
|
(t (+ 800 (cdr card)))))
|
||||||
|
((eq es led) (+ 100 (cdr card)))
|
||||||
|
(t (cdr card)))))
|
||||||
|
|
||||||
|
(defun cg-bid-trick-winner (plays trump led)
|
||||||
|
"Return the seat that wins a trick.
|
||||||
|
PLAYS is a list of (SEAT . CARD); TRUMP and LED as in `cg-bid-power'."
|
||||||
|
(car (cl-reduce
|
||||||
|
(lambda (best p)
|
||||||
|
(if (> (cg-bid-power (cdr p) trump led)
|
||||||
|
(cg-bid-power (cdr best) trump led))
|
||||||
|
p best))
|
||||||
|
plays)))
|
||||||
|
|
||||||
|
(defun cg-bid-legal-cards (hand led trump)
|
||||||
|
"Return the legal subset of HAND given the LED suit and TRUMP.
|
||||||
|
When LED is nil (leading) every card is legal. Otherwise a player
|
||||||
|
must follow the led suit if able."
|
||||||
|
(if (null led)
|
||||||
|
hand
|
||||||
|
(let ((follow (cl-remove-if-not
|
||||||
|
(lambda (c) (eq (cg-bid-effective-suit c trump) led))
|
||||||
|
hand)))
|
||||||
|
(or follow hand))))
|
||||||
|
|
||||||
|
(defun cg-bid-sort-hand (hand trump)
|
||||||
|
"Return HAND sorted for display: trumps first (by power), then by suit."
|
||||||
|
(sort (copy-sequence hand)
|
||||||
|
(lambda (a b)
|
||||||
|
(let* (( at (and (numberp trump)
|
||||||
|
(eq (cg-bid-effective-suit a trump) trump)))
|
||||||
|
(bt (and (numberp trump)
|
||||||
|
(eq (cg-bid-effective-suit b trump) trump)))
|
||||||
|
(aj (cg-bid-joker-p a))
|
||||||
|
(bj (cg-bid-joker-p b)))
|
||||||
|
(cond
|
||||||
|
((or aj bt) (and (not bj) (or aj bt) t))
|
||||||
|
(t
|
||||||
|
(let ((ak (if (or aj at) -1 (car a)))
|
||||||
|
(bk (if (or bj bt) -1 (car b))))
|
||||||
|
(if (/= ak bk) (< ak bk)
|
||||||
|
(> (cg-bid-power a (or trump 'nt) nil)
|
||||||
|
(cg-bid-power b (or trump 'nt) nil))))))))))
|
||||||
|
|
||||||
|
|
||||||
|
(defun cg-bid--display-key (card trump)
|
||||||
|
"Return an ascending sort key for CARD to group a hand for display.
|
||||||
|
Trumps (and the Joker) sort first, strongest first; the remaining
|
||||||
|
suits are grouped spades, hearts, clubs, diamonds, high rank first."
|
||||||
|
(cond
|
||||||
|
((cg-bid-joker-p card) 0)
|
||||||
|
((and (numberp trump) (eq (cg-bid-effective-suit card trump) trump))
|
||||||
|
(- 1000 (cg-bid-power card trump trump)))
|
||||||
|
(t (let ((si (cl-position (car card) [0 3 1 2])))
|
||||||
|
(+ 2000 (* (or si 0) 100) (- 12 (cdr card)))))))
|
||||||
|
|
||||||
|
(defun cg-bid-sort-display (hand trump)
|
||||||
|
"Return HAND sorted for display under TRUMP.
|
||||||
|
Trumps lead (strongest first), then each side suit runs high to low."
|
||||||
|
(sort (copy-sequence hand)
|
||||||
|
(lambda (a b) (< (cg-bid--display-key a trump)
|
||||||
|
(cg-bid--display-key b trump)))))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Game object and dealing
|
||||||
|
|
||||||
|
(defclass cg-bid-game (cg-game)
|
||||||
|
((name :initform "500 Bid"))
|
||||||
|
"The partnership trick-taking game 500.")
|
||||||
|
|
||||||
|
(defvar cg-bid--human-seats '(0)
|
||||||
|
"List of seats controlled by a human player. South is seat 0.")
|
||||||
|
|
||||||
|
(defconst cg-bid-seat-names ["South" "West" "North" "East"]
|
||||||
|
"Seat labels; partners sit opposite (0/2 and 1/3).")
|
||||||
|
|
||||||
|
(defsubst cg-bid--human-p (seat)
|
||||||
|
"Return non-nil when SEAT is played by a human."
|
||||||
|
(memq seat cg-bid--human-seats))
|
||||||
|
|
||||||
|
(defsubst cg-bid--partner (seat) (mod (+ seat 2) 4))
|
||||||
|
(defsubst cg-bid--team (seat) (mod seat 2)) ; 0 -> team 0 (S/N), 1 -> team 1 (W/E)
|
||||||
|
|
||||||
|
(cl-defmethod cg-bid--deal ((game cg-bid-game) &optional dealer)
|
||||||
|
"Deal a fresh hand into GAME. DEALER defaults to East so South bids first."
|
||||||
|
(random t)
|
||||||
|
(let ((deck (cg-shuffle (cg-bid--full-deck)))
|
||||||
|
(hands (make-vector 4 nil))
|
||||||
|
(dealer (or dealer 3)))
|
||||||
|
(dotimes (s 4)
|
||||||
|
(aset hands s (cl-loop repeat 10 collect (pop deck))))
|
||||||
|
(cg-put game :hands hands)
|
||||||
|
(cg-put game :kitty deck) ; remaining 5 cards
|
||||||
|
(cg-put game :dealer dealer)
|
||||||
|
(cg-put game :phase 'auction)
|
||||||
|
(cg-put game :passed (make-vector 4 nil))
|
||||||
|
(cg-put game :high-bid nil)
|
||||||
|
(cg-put game :high-bidder nil)
|
||||||
|
(cg-put game :bidder (mod (1+ dealer) 4)) ; left of dealer bids first
|
||||||
|
(cg-put game :contract nil)
|
||||||
|
(cg-put game :contractor nil)
|
||||||
|
(cg-put game :trick nil)
|
||||||
|
(cg-put game :last-trick nil)
|
||||||
|
(cg-put game :led nil)
|
||||||
|
(cg-put game :leader nil)
|
||||||
|
(cg-put game :tricks (make-vector 4 0))
|
||||||
|
(cg-put game :ntricks 0)
|
||||||
|
(cg-put game :exposed nil)
|
||||||
|
(cg-put game :cursor 0)
|
||||||
|
(cg-put game :marks nil)
|
||||||
|
(cg-put game :hand-result nil)
|
||||||
|
(unless (cg-get game :scores) (cg-put game :scores (cons 0 0)))
|
||||||
|
(unless (plist-member (oref game env) :game-over)
|
||||||
|
(cg-put game :game-over nil))
|
||||||
|
(unless (cg-get game :hand-no) (cg-put game :hand-no 0))
|
||||||
|
(cg-put game :hand-no (1+ (cg-get game :hand-no)))
|
||||||
|
(cg-bid--note game "— Hand %d —" (cg-get game :hand-no))
|
||||||
|
(cg-put game :message
|
||||||
|
(format "Auction: %s to bid." (aref cg-bid-seat-names
|
||||||
|
(cg-get game :bidder))))
|
||||||
|
game))
|
||||||
|
|
||||||
|
(defun cg-bid--hand (game seat) (aref (cg-get game :hands) seat))
|
||||||
|
(defun cg-bid--set-hand (game seat cards) (aset (cg-get game :hands) seat cards))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Auction
|
||||||
|
|
||||||
|
(defun cg-bid--legal-bids (game)
|
||||||
|
"Return the schedule entries that outbid the current high bid."
|
||||||
|
(let ((hv (if (cg-get game :high-bid)
|
||||||
|
(cg-bid-value (cg-get game :high-bid)) 0)))
|
||||||
|
(cl-remove-if-not (lambda (b) (> (cg-bid-value b) hv)) cg-bid-schedule)))
|
||||||
|
|
||||||
|
(defun cg-bid--active-seats (game)
|
||||||
|
"Return the seats that have not passed."
|
||||||
|
(cl-loop for s below 4
|
||||||
|
unless (aref (cg-get game :passed) s) collect s))
|
||||||
|
|
||||||
|
(defun cg-bid--next-bidder (game from)
|
||||||
|
"Return the next non-passed seat after FROM, or nil if none."
|
||||||
|
(cl-loop for i from 1 to 4
|
||||||
|
for s = (mod (+ from i) 4)
|
||||||
|
unless (aref (cg-get game :passed) s) return s))
|
||||||
|
|
||||||
|
(defun cg-bid--note (game fmt &rest args)
|
||||||
|
"Append a narrative line (FMT with ARGS) to GAME's message log."
|
||||||
|
(cg-put game :log (cons (apply #'format fmt args) (cg-get game :log)))
|
||||||
|
(cg-put game :log-scroll 0))
|
||||||
|
|
||||||
|
(cl-defmethod cg-bid--auction-act ((game cg-bid-game) seat bid)
|
||||||
|
"Record SEAT's action: BID is a schedule entry, or nil to pass."
|
||||||
|
(if bid
|
||||||
|
(progn (cg-put game :high-bid bid)
|
||||||
|
(cg-put game :high-bidder seat)
|
||||||
|
(cg-put game :message
|
||||||
|
(format "%s bids %s."
|
||||||
|
(aref cg-bid-seat-names seat) (cg-bid-label bid)))
|
||||||
|
(cg-bid--note game "%s bids %s."
|
||||||
|
(aref cg-bid-seat-names seat) (cg-bid-label bid)))
|
||||||
|
(aset (cg-get game :passed) seat t)
|
||||||
|
(cg-put game :message (format "%s passes." (aref cg-bid-seat-names seat)))
|
||||||
|
(cg-bid--note game "%s passes." (aref cg-bid-seat-names seat)))
|
||||||
|
(let ((active (cg-bid--active-seats game)))
|
||||||
|
(cond
|
||||||
|
;; everyone passed with no bid -> throw in
|
||||||
|
((and (null (cg-get game :high-bid)) (null active))
|
||||||
|
(cg-bid--deal game (mod (1+ (cg-get game :dealer)) 4))
|
||||||
|
(cg-put game :message "All passed — redeal."))
|
||||||
|
;; one bidder left standing -> contract is set
|
||||||
|
((and (cg-get game :high-bid) (= (length active) 1))
|
||||||
|
(cg-bid--begin-contract game))
|
||||||
|
(t
|
||||||
|
(cg-put game :bidder (cg-bid--next-bidder game seat))))))
|
||||||
|
|
||||||
|
(cl-defmethod cg-bid--begin-contract ((game cg-bid-game))
|
||||||
|
"Set the winning contract and move to the kitty phase."
|
||||||
|
(let* ((contractor (cg-get game :high-bidder))
|
||||||
|
(bid (cg-get game :high-bid)))
|
||||||
|
(cg-put game :contractor contractor)
|
||||||
|
(cg-put game :contract bid)
|
||||||
|
(cg-put game :phase 'kitty)
|
||||||
|
;; contractor takes the kitty into hand
|
||||||
|
(cg-bid--set-hand game contractor
|
||||||
|
(append (cg-bid--hand game contractor)
|
||||||
|
(cg-get game :kitty)))
|
||||||
|
(cg-put game :kitty nil)
|
||||||
|
(cg-put game :leader contractor)
|
||||||
|
(cg-put game :turn contractor)
|
||||||
|
(cg-put game :message
|
||||||
|
(format "%s won the auction with %s (%s). Kitty taken."
|
||||||
|
(aref cg-bid-seat-names contractor)
|
||||||
|
(cg-bid-label bid) (cg-bid-name bid)))
|
||||||
|
(cg-bid--note game "%s won the bid: %s."
|
||||||
|
(aref cg-bid-seat-names contractor) (cg-bid-label bid))))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Kitty discard
|
||||||
|
|
||||||
|
(cl-defmethod cg-bid--discard ((game cg-bid-game) seat cards)
|
||||||
|
"Have SEAT discard CARDS (a list of 5) and start play."
|
||||||
|
(cg-bid--set-hand game seat
|
||||||
|
(cl-set-difference (cg-bid--hand game seat) cards
|
||||||
|
:test #'equal))
|
||||||
|
(cg-put game :phase 'play)
|
||||||
|
(cg-put game :turn (cg-get game :contractor))
|
||||||
|
(cg-put game :leader (cg-get game :contractor))
|
||||||
|
(cg-put game :led nil)
|
||||||
|
(cg-put game :trick nil)
|
||||||
|
(cg-put game :cursor 0)
|
||||||
|
(cg-put game :message
|
||||||
|
(format "Play! %s leads."
|
||||||
|
(aref cg-bid-seat-names (cg-get game :contractor)))))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Seat order (a partner sits out during a misère)
|
||||||
|
|
||||||
|
(defun cg-bid--misere-p (game)
|
||||||
|
"Return non-nil when the current contract is a nullo/misère."
|
||||||
|
(let ((c (cg-get game :contract))) (and c (cg-bid-nullo-p c))))
|
||||||
|
|
||||||
|
(defun cg-bid--sitter (game)
|
||||||
|
"Return the seat sitting out (contractor's partner) in a misère, else nil."
|
||||||
|
(and (cg-bid--misere-p game)
|
||||||
|
(cg-bid--partner (cg-get game :contractor))))
|
||||||
|
|
||||||
|
(defun cg-bid--in-play-p (game seat)
|
||||||
|
"Return non-nil when SEAT takes part in the current hand's play."
|
||||||
|
(not (eql seat (cg-bid--sitter game))))
|
||||||
|
|
||||||
|
(defun cg-bid--num-players (game)
|
||||||
|
"Return the number of seats playing to each trick (3 in misère, else 4)."
|
||||||
|
(if (cg-bid--misere-p game) 3 4))
|
||||||
|
|
||||||
|
(defun cg-bid--next-seat (game seat)
|
||||||
|
"Return the next in-play seat clockwise from SEAT."
|
||||||
|
(let ((n (mod (1+ seat) 4)))
|
||||||
|
(if (cg-bid--in-play-p game n) n (mod (1+ n) 4))))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Trick play
|
||||||
|
|
||||||
|
(cl-defmethod cg-bid--play ((game cg-bid-game) seat card)
|
||||||
|
"Have SEAT play CARD into the current trick and advance."
|
||||||
|
(let* ((trump (cg-bid-trump (cg-get game :contract)))
|
||||||
|
(led (cg-get game :led))
|
||||||
|
(lead-p (null (cg-get game :trick))))
|
||||||
|
;; remove card from hand
|
||||||
|
(cg-bid--set-hand game seat
|
||||||
|
(cl-remove card (cg-bid--hand game seat)
|
||||||
|
:test #'equal :count 1))
|
||||||
|
(cg-put game :trick (append (cg-get game :trick) (list (cons seat card))))
|
||||||
|
(cg-bid--note game "%s %s the %s."
|
||||||
|
(aref cg-bid-seat-names seat)
|
||||||
|
(if lead-p "leads" "plays")
|
||||||
|
(cg-bid-card-string card))
|
||||||
|
;; establish led suit
|
||||||
|
(unless led
|
||||||
|
(setq led (cg-bid-effective-suit card trump))
|
||||||
|
;; joker led in no-trump nominates a suit
|
||||||
|
(when (and (eq led 'joker))
|
||||||
|
(setq led (cg-bid--nominate-suit game seat)))
|
||||||
|
(cg-put game :led led))
|
||||||
|
(if (= (length (cg-get game :trick)) (cg-bid--num-players game))
|
||||||
|
(cg-bid--finish-trick game)
|
||||||
|
(cg-put game :turn (cg-bid--next-seat game seat)))))
|
||||||
|
|
||||||
|
(defun cg-bid--nominate-suit (game seat)
|
||||||
|
"Choose the suit nominated when the Joker leads under no-trump."
|
||||||
|
(let ((hand (cg-bid--hand game seat)))
|
||||||
|
(if (cg-bid--human-p seat)
|
||||||
|
(let ((ch (read-char-choice
|
||||||
|
"Joker leads — nominate a suit [s]pades [c]lubs [d]iamonds [h]earts: "
|
||||||
|
'(?s ?c ?d ?h))))
|
||||||
|
(cdr (assq ch '((?s . 0) (?c . 1) (?d . 2) (?h . 3)))))
|
||||||
|
;; AI: nominate its longest non-joker suit
|
||||||
|
(let ((counts (make-vector 4 0)))
|
||||||
|
(dolist (c hand)
|
||||||
|
(unless (cg-bid-joker-p c) (cl-incf (aref counts (car c)))))
|
||||||
|
(let ((best 0))
|
||||||
|
(dotimes (s 4) (when (> (aref counts s) (aref counts best))
|
||||||
|
(setq best s)))
|
||||||
|
best)))))
|
||||||
|
|
||||||
|
(cl-defmethod cg-bid--finish-trick ((game cg-bid-game))
|
||||||
|
"Resolve the completed trick, award it, and set up the next."
|
||||||
|
(let* ((trump (cg-bid-trump (cg-get game :contract)))
|
||||||
|
(led (cg-get game :led))
|
||||||
|
(plays (cg-get game :trick))
|
||||||
|
(winner (cg-bid-trick-winner plays trump led)))
|
||||||
|
(cl-incf (aref (cg-get game :tricks) winner))
|
||||||
|
(cg-put game :ntricks (1+ (cg-get game :ntricks)))
|
||||||
|
(cg-put game :last-trick plays)
|
||||||
|
(cg-put game :trick nil)
|
||||||
|
(cg-put game :led nil)
|
||||||
|
(cg-put game :leader winner)
|
||||||
|
(cg-put game :turn winner)
|
||||||
|
(cg-put game :message
|
||||||
|
(format "%s wins the trick (%s)."
|
||||||
|
(aref cg-bid-seat-names winner)
|
||||||
|
(mapconcat (lambda (p) (cg-bid-card-string (cdr p))) plays " ")))
|
||||||
|
(cg-bid--note game "%s wins the trick." (aref cg-bid-seat-names winner))
|
||||||
|
;; open misère: expose the contractor's hand after the first trick
|
||||||
|
(when (and (cg-bid-open-p (cg-get game :contract))
|
||||||
|
(= (cg-get game :ntricks) 1))
|
||||||
|
(cg-put game :exposed (cg-get game :contractor)))
|
||||||
|
;; hand over after ten tricks
|
||||||
|
(when (= (cg-get game :ntricks) 10)
|
||||||
|
(cg-bid--score-hand game))))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Scoring
|
||||||
|
|
||||||
|
(cl-defmethod cg-bid--score-hand ((game cg-bid-game))
|
||||||
|
"Score the completed hand per the Avondale schedule."
|
||||||
|
(let* ((bid (cg-get game :contract))
|
||||||
|
(contractor (cg-get game :contractor))
|
||||||
|
(cteam (cg-bid--team contractor))
|
||||||
|
(tricks (cg-get game :tricks))
|
||||||
|
(side (+ (aref tricks contractor)
|
||||||
|
(aref tricks (cg-bid--partner contractor))))
|
||||||
|
(opp (- 10 side))
|
||||||
|
(scores (cg-get game :scores))
|
||||||
|
(delta-c 0) (delta-o 0) (made nil) result)
|
||||||
|
(cond
|
||||||
|
((cg-bid-nullo-p bid)
|
||||||
|
;; contractor alone must take no tricks (own-hand misère)
|
||||||
|
(setq made (zerop (aref tricks contractor)))
|
||||||
|
(setq delta-c (if made (cg-bid-value bid) (- (cg-bid-value bid)))))
|
||||||
|
(t
|
||||||
|
(setq made (>= side (cg-bid-tricks bid)))
|
||||||
|
(if made
|
||||||
|
(setq delta-c (if (and (= side 10) (< (cg-bid-value bid) 250))
|
||||||
|
250 (cg-bid-value bid)))
|
||||||
|
(setq delta-c (- (cg-bid-value bid))))
|
||||||
|
(setq delta-o (* 10 opp))))
|
||||||
|
;; apply to teams
|
||||||
|
(let ((c (if (= cteam 0) (cons delta-c delta-o) (cons delta-o delta-c))))
|
||||||
|
(cg-put game :scores (cons (+ (car scores) (car c))
|
||||||
|
(+ (cdr scores) (cdr c)))))
|
||||||
|
(setq result
|
||||||
|
(format "%s %s %s: %s/%s took %d trick%s. %s %+d%s"
|
||||||
|
(aref cg-bid-seat-names contractor)
|
||||||
|
(if made "MADE" "was SET on")
|
||||||
|
(cg-bid-label bid)
|
||||||
|
(aref cg-bid-seat-names contractor)
|
||||||
|
(aref cg-bid-seat-names (cg-bid--partner contractor))
|
||||||
|
side (if (= side 1) "" "s")
|
||||||
|
(if (= cteam 0) "You/North" "West/East")
|
||||||
|
delta-c
|
||||||
|
(if (and (not (cg-bid-nullo-p bid)) (> delta-o 0))
|
||||||
|
(format ", opponents +%d" delta-o) "")))
|
||||||
|
(cg-put game :phase 'done)
|
||||||
|
(cg-put game :hand-result result)
|
||||||
|
(cg-bid--note game "%s" result)
|
||||||
|
(let ((winner (cg-bid--check-gameover game made cteam)))
|
||||||
|
(cg-put game :message
|
||||||
|
(if winner
|
||||||
|
(format "%s — GAME OVER: %s WIN! Final — You/North %d, West/East %d. Press n for a new game."
|
||||||
|
result
|
||||||
|
(if (= winner 0) "You/North" "West/East")
|
||||||
|
(car (cg-get game :scores)) (cdr (cg-get game :scores)))
|
||||||
|
(concat result " — press n for the next hand."))))))
|
||||||
|
|
||||||
|
(cl-defmethod cg-bid--check-gameover ((game cg-bid-game) made cteam)
|
||||||
|
"End the game if a side has won (front door) or lost (back door).
|
||||||
|
Return the winning team, or nil. MADE and CTEAM describe the hand
|
||||||
|
just scored: a side wins only by reaching 500 on a made contract;
|
||||||
|
a side that sinks to -500 loses."
|
||||||
|
(let* ((sc (cg-get game :scores))
|
||||||
|
(t0 (car sc)) (t1 (cdr sc))
|
||||||
|
(winner
|
||||||
|
(cond
|
||||||
|
((and made (>= (if (= cteam 0) t0 t1) 500)) cteam)
|
||||||
|
((<= t0 -500) 1)
|
||||||
|
((<= t1 -500) 0)
|
||||||
|
(t nil))))
|
||||||
|
(when winner
|
||||||
|
(cg-put game :game-over winner)
|
||||||
|
(cg-put game :phase 'gameover))
|
||||||
|
winner))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Basic AI
|
||||||
|
|
||||||
|
(defvar cg-bid-ai-policies (vector 'smart 'smart 'smart 'smart)
|
||||||
|
"Per-seat AI policy vector; each element is `smart' or `basic'.")
|
||||||
|
|
||||||
|
(defvar cg-bid-ai-partner-help 1.0
|
||||||
|
"Tricks the smart bidder assumes its partner will contribute.")
|
||||||
|
|
||||||
|
(defun cg-bid--policy (seat)
|
||||||
|
"Return the AI policy symbol for SEAT."
|
||||||
|
(aref cg-bid-ai-policies seat))
|
||||||
|
|
||||||
|
;;; shared helpers
|
||||||
|
|
||||||
|
(defun cg-bid--lowest (cards trump led)
|
||||||
|
"Return the weakest of CARDS given TRUMP and LED."
|
||||||
|
(car (sort (copy-sequence cards)
|
||||||
|
(lambda (a b) (< (cg-bid-power a trump led)
|
||||||
|
(cg-bid-power b trump led))))))
|
||||||
|
|
||||||
|
(defun cg-bid--highest (cards trump led)
|
||||||
|
"Return the strongest of CARDS given TRUMP and LED."
|
||||||
|
(car (sort (copy-sequence cards)
|
||||||
|
(lambda (a b) (> (cg-bid-power a trump led)
|
||||||
|
(cg-bid-power b trump led))))))
|
||||||
|
|
||||||
|
(defun cg-bid--trump-cards (hand trump)
|
||||||
|
"Return the cards of HAND that are trumps under TRUMP (incl. Joker, bowers)."
|
||||||
|
(cl-remove-if-not
|
||||||
|
(lambda (c) (or (cg-bid-joker-p c)
|
||||||
|
(and (numberp trump) (eq (cg-bid-effective-suit c trump) trump))))
|
||||||
|
hand))
|
||||||
|
|
||||||
|
(defun cg-bid--suit-cards (hand suit trump)
|
||||||
|
"Return non-Joker cards of HAND whose effective suit is SUIT under TRUMP."
|
||||||
|
(cl-remove-if-not
|
||||||
|
(lambda (c) (and (not (cg-bid-joker-p c))
|
||||||
|
(eq (cg-bid-effective-suit c trump) suit)))
|
||||||
|
hand))
|
||||||
|
|
||||||
|
;;; basic policy (original heuristics)
|
||||||
|
|
||||||
|
(defun cg-bid--ai-estimate (hand trump)
|
||||||
|
"Rough trick estimate for HAND if TRUMP (0-3 or `nt') were the contract."
|
||||||
|
(let ((joker (cl-some #'cg-bid-joker-p hand))
|
||||||
|
(aces 0) (kings 0) (trumps 0))
|
||||||
|
(dolist (c hand)
|
||||||
|
(unless (cg-bid-joker-p c)
|
||||||
|
(cond
|
||||||
|
((and (numberp trump) (eq (cg-bid-effective-suit c trump) trump))
|
||||||
|
(cl-incf trumps))
|
||||||
|
((= (cdr c) 10) (cl-incf aces))
|
||||||
|
((= (cdr c) 9) (cl-incf kings)))))
|
||||||
|
(floor (+ trumps aces (* 0.5 kings) (if joker 1 0)))))
|
||||||
|
|
||||||
|
(defun cg-bid--ai-best-contract (hand)
|
||||||
|
"Return (TRUMP . EST) for the strongest contract HAND suggests (basic)."
|
||||||
|
(let ((best (cons 'nt (cg-bid--ai-estimate hand 'nt))))
|
||||||
|
(dotimes (s 4)
|
||||||
|
(let ((e (cg-bid--ai-estimate hand s)))
|
||||||
|
(when (> e (cdr best)) (setq best (cons s e)))))
|
||||||
|
best))
|
||||||
|
|
||||||
|
(defun cg-bid--ai-bid-basic (game seat)
|
||||||
|
"Pick and record a bid (or pass) for AI SEAT using the basic estimate."
|
||||||
|
(let* ((hand (cg-bid--hand game seat))
|
||||||
|
(best (cg-bid--ai-best-contract hand))
|
||||||
|
(trump (car best))
|
||||||
|
(est (min 10 (cdr best)))
|
||||||
|
(maxval (cl-loop for b in cg-bid-schedule
|
||||||
|
when (and (eq (cg-bid-trump b) trump)
|
||||||
|
(= (cg-bid-tricks b) est))
|
||||||
|
return (cg-bid-value b)))
|
||||||
|
(legal (cg-bid--legal-bids game))
|
||||||
|
(choice (and maxval (>= est 6)
|
||||||
|
(car (cl-remove-if-not
|
||||||
|
(lambda (b) (<= (cg-bid-value b) maxval))
|
||||||
|
legal)))))
|
||||||
|
(cg-bid--auction-act game seat choice)))
|
||||||
|
|
||||||
|
(defun cg-bid--ai-discard-basic (game seat)
|
||||||
|
"Discard SEAT's five weakest cards (basic)."
|
||||||
|
(let* ((trump (cg-bid-trump (cg-get game :contract)))
|
||||||
|
(sorted (cg-bid-sort-hand (cg-bid--hand game seat) trump))
|
||||||
|
(discard (last sorted 5)))
|
||||||
|
(cg-bid--discard game seat discard)))
|
||||||
|
|
||||||
|
(defun cg-bid--ai-play-positive (game seat)
|
||||||
|
"Trick-play for AI SEAT under a suit or no-trump contract (basic)."
|
||||||
|
(let* ((trump (cg-bid-trump (cg-get game :contract)))
|
||||||
|
(led (cg-get game :led))
|
||||||
|
(hand (cg-bid--hand game seat))
|
||||||
|
(legal (cg-bid-legal-cards hand led trump))
|
||||||
|
(plays (cg-get game :trick))
|
||||||
|
card)
|
||||||
|
(if (null plays)
|
||||||
|
(setq card (or (cl-find-if
|
||||||
|
(lambda (c) (and (not (cg-bid-joker-p c)) (= (cdr c) 10)
|
||||||
|
(or (not (numberp trump))
|
||||||
|
(/= (cg-bid-effective-suit c trump) trump))))
|
||||||
|
legal)
|
||||||
|
(cg-bid--lowest legal trump led)))
|
||||||
|
(let* ((winner (cg-bid-trick-winner plays trump led))
|
||||||
|
(partner-winning (= (cg-bid--partner seat) winner))
|
||||||
|
(best-power (cg-bid-power (cdr (assq winner plays)) trump led)))
|
||||||
|
(if partner-winning
|
||||||
|
(setq card (cg-bid--lowest legal trump led))
|
||||||
|
(let ((winners (cl-remove-if-not
|
||||||
|
(lambda (c) (> (cg-bid-power c trump led) best-power))
|
||||||
|
legal)))
|
||||||
|
(setq card (if winners
|
||||||
|
(cg-bid--lowest winners trump led)
|
||||||
|
(cg-bid--lowest legal trump led)))))))
|
||||||
|
(cg-bid--play game seat card)))
|
||||||
|
|
||||||
|
;;; smart policy
|
||||||
|
|
||||||
|
(defun cg-bid--eval-suit (hand trump)
|
||||||
|
"Estimate tricks (float) for a suit TRUMP contract from HAND."
|
||||||
|
(let* ((trumps (cg-bid--trump-cards hand trump))
|
||||||
|
(nt (length trumps))
|
||||||
|
(high (cl-count-if (lambda (c) (>= (cg-bid-power c trump trump) 809)) trumps))
|
||||||
|
(trump-tricks (+ high (max 0 (- nt 4))))
|
||||||
|
(side 0.0) (ruffs 0.0))
|
||||||
|
(dotimes (s 4)
|
||||||
|
(unless (= s trump)
|
||||||
|
(let* ((cs (cg-bid--suit-cards hand s trump))
|
||||||
|
(len (length cs))
|
||||||
|
(ranks (mapcar #'cdr cs)))
|
||||||
|
(when (memql 10 ranks) (cl-incf side 1.0))
|
||||||
|
(when (memql 9 ranks) (cl-incf side (if (>= len 2) 0.5 0.25)))
|
||||||
|
(cond ((= len 0) (cl-incf ruffs 1.0))
|
||||||
|
((and (= len 1) (not (memql 10 ranks))) (cl-incf ruffs 0.5))))))
|
||||||
|
(min 10.0 (+ trump-tricks side (min ruffs (float nt))))))
|
||||||
|
|
||||||
|
(defun cg-bid--eval-nt (hand)
|
||||||
|
"Estimate tricks (float) for a no-trump contract from HAND."
|
||||||
|
(let ((est (if (cl-some #'cg-bid-joker-p hand) 1.0 0.0)))
|
||||||
|
(dotimes (s 4)
|
||||||
|
(let* ((cs (cg-bid--suit-cards hand s 'nt))
|
||||||
|
(len (length cs))
|
||||||
|
(ranks (mapcar #'cdr cs)))
|
||||||
|
(when (memql 10 ranks) (cl-incf est 1.0))
|
||||||
|
(when (memql 9 ranks) (cl-incf est (if (>= len 2) 0.5 0.25)))
|
||||||
|
(when (>= len 5) (cl-incf est (* 0.5 (- len 4))))))
|
||||||
|
(min 10.0 est)))
|
||||||
|
|
||||||
|
(defun cg-bid--best-smart (hand)
|
||||||
|
"Return (TRUMP . EST-float) for the best contract HAND suggests (smart)."
|
||||||
|
(let ((best (cons 'nt (cg-bid--eval-nt hand))))
|
||||||
|
(dotimes (s 4)
|
||||||
|
(let ((e (cg-bid--eval-suit hand s)))
|
||||||
|
(when (> e (cdr best)) (setq best (cons s e)))))
|
||||||
|
best))
|
||||||
|
|
||||||
|
(defun cg-bid--ai-bid-smart (game seat)
|
||||||
|
"Pick and record a bid (or pass) for AI SEAT using the smart evaluation."
|
||||||
|
(let* ((hand (cg-bid--hand game seat))
|
||||||
|
(best (cg-bid--best-smart hand))
|
||||||
|
(trump (car best))
|
||||||
|
(est (min 10 (floor (+ (cdr best) cg-bid-ai-partner-help))))
|
||||||
|
(maxval (cl-loop for b in cg-bid-schedule
|
||||||
|
when (and (eq (cg-bid-trump b) trump)
|
||||||
|
(= (cg-bid-tricks b) est))
|
||||||
|
return (cg-bid-value b)))
|
||||||
|
(legal (cg-bid--legal-bids game))
|
||||||
|
(choice (and maxval (>= est 6)
|
||||||
|
(car (cl-remove-if-not
|
||||||
|
(lambda (b) (<= (cg-bid-value b) maxval))
|
||||||
|
legal)))))
|
||||||
|
(cg-bid--auction-act game seat choice)))
|
||||||
|
|
||||||
|
(defun cg-bid--ai-discard-smart (game seat)
|
||||||
|
"Discard to keep trumps and aces and to void short side suits for ruffs."
|
||||||
|
(let* ((trump (cg-bid-trump (cg-get game :contract)))
|
||||||
|
(hand (cg-bid--hand game seat))
|
||||||
|
(cand '()))
|
||||||
|
(dolist (c hand)
|
||||||
|
(unless (or (cg-bid-joker-p c) (= (cdr c) 10)
|
||||||
|
(and (numberp trump) (eq (cg-bid-effective-suit c trump) trump)))
|
||||||
|
(push c cand)))
|
||||||
|
(let ((bysuit (make-vector 4 0)))
|
||||||
|
(dolist (c cand) (cl-incf (aref bysuit (car c))))
|
||||||
|
(setq cand (sort cand
|
||||||
|
(lambda (a b)
|
||||||
|
(if (/= (aref bysuit (car a)) (aref bysuit (car b)))
|
||||||
|
(< (aref bysuit (car a)) (aref bysuit (car b)))
|
||||||
|
(< (cdr a) (cdr b))))))
|
||||||
|
(let ((discard (if (>= (length cand) 5)
|
||||||
|
(cl-subseq cand 0 5)
|
||||||
|
(last (cg-bid-sort-hand hand trump) 5))))
|
||||||
|
(cg-bid--discard game seat discard)))))
|
||||||
|
|
||||||
|
(defun cg-bid--lead-low-long (hand trump legal)
|
||||||
|
"Lead the lowest card of the player's longest side suit, from LEGAL."
|
||||||
|
(let ((best-suit nil) (best-len -1))
|
||||||
|
(dotimes (s 4)
|
||||||
|
(unless (and (numberp trump) (= s trump))
|
||||||
|
(let ((len (length (cg-bid--suit-cards hand s trump))))
|
||||||
|
(when (> len best-len) (setq best-len len best-suit s)))))
|
||||||
|
(let ((cs (and best-suit
|
||||||
|
(cl-remove-if-not
|
||||||
|
(lambda (c) (and (not (cg-bid-joker-p c))
|
||||||
|
(eq (cg-bid-effective-suit c trump) best-suit)))
|
||||||
|
legal))))
|
||||||
|
(cg-bid--lowest (or cs legal) trump nil))))
|
||||||
|
|
||||||
|
(defun cg-bid--ai-play-smart (game seat)
|
||||||
|
"Trick-play for AI SEAT under a suit/NT contract with simple tactics:
|
||||||
|
declarer draws trumps and cashes aces; everyone wins as cheaply as
|
||||||
|
possible and never overtakes a partner who is already winning."
|
||||||
|
(let* ((trump (cg-bid-trump (cg-get game :contract)))
|
||||||
|
(led (cg-get game :led))
|
||||||
|
(hand (cg-bid--hand game seat))
|
||||||
|
(legal (cg-bid-legal-cards hand led trump))
|
||||||
|
(plays (cg-get game :trick))
|
||||||
|
(contractor (cg-get game :contractor))
|
||||||
|
(declarer-side (= (cg-bid--team seat) (cg-bid--team contractor)))
|
||||||
|
card)
|
||||||
|
(cond
|
||||||
|
((null plays)
|
||||||
|
(let* ((trumps (and (numberp trump) (cg-bid--trump-cards hand trump)))
|
||||||
|
(hi (cl-count-if (lambda (c) (>= (cg-bid-power c trump trump) 809))
|
||||||
|
(or trumps '()))))
|
||||||
|
(setq card
|
||||||
|
(cond
|
||||||
|
((and declarer-side (numberp trump) trumps
|
||||||
|
(or (>= (length trumps) 4) (>= hi 2)))
|
||||||
|
(cg-bid--highest trumps trump trump))
|
||||||
|
((cl-find-if (lambda (c)
|
||||||
|
(and (not (cg-bid-joker-p c)) (= (cdr c) 10)
|
||||||
|
(or (not (numberp trump))
|
||||||
|
(/= (cg-bid-effective-suit c trump) trump))))
|
||||||
|
legal))
|
||||||
|
(t (cg-bid--lead-low-long hand trump legal))))))
|
||||||
|
(t
|
||||||
|
(let* ((winner (cg-bid-trick-winner plays trump led))
|
||||||
|
(partner-winning (= (cg-bid--partner seat) winner))
|
||||||
|
(best-power (cg-bid-power (cdr (assq winner plays)) trump led)))
|
||||||
|
(setq card
|
||||||
|
(if partner-winning
|
||||||
|
(cg-bid--lowest legal trump led)
|
||||||
|
(let ((winners (cl-remove-if-not
|
||||||
|
(lambda (c) (> (cg-bid-power c trump led) best-power))
|
||||||
|
legal)))
|
||||||
|
(if winners (cg-bid--lowest winners trump led)
|
||||||
|
(cg-bid--lowest legal trump led))))))))
|
||||||
|
(cg-bid--play game seat card)))
|
||||||
|
|
||||||
|
;;; dispatch
|
||||||
|
|
||||||
|
(cl-defmethod cg-bid--ai-bid ((game cg-bid-game) seat)
|
||||||
|
"Pick and record a bid for AI SEAT per its policy."
|
||||||
|
(if (eq (cg-bid--policy seat) 'smart)
|
||||||
|
(cg-bid--ai-bid-smart game seat)
|
||||||
|
(cg-bid--ai-bid-basic game seat)))
|
||||||
|
|
||||||
|
(cl-defmethod cg-bid--ai-discard ((game cg-bid-game) seat)
|
||||||
|
"Have AI SEAT exchange the kitty per its policy."
|
||||||
|
(if (eq (cg-bid--policy seat) 'smart)
|
||||||
|
(cg-bid--ai-discard-smart game seat)
|
||||||
|
(cg-bid--ai-discard-basic game seat)))
|
||||||
|
|
||||||
|
(cl-defmethod cg-bid--ai-play ((game cg-bid-game) seat)
|
||||||
|
"Choose and play a card for AI SEAT per its policy."
|
||||||
|
(cond ((cg-bid--misere-p game) (cg-bid--ai-play-misere game seat))
|
||||||
|
((eq (cg-bid--policy seat) 'smart) (cg-bid--ai-play-smart game seat))
|
||||||
|
(t (cg-bid--ai-play-positive game seat))))
|
||||||
|
|
||||||
|
(defun cg-bid--ai-play-misere (game seat)
|
||||||
|
"Trick-play for AI SEAT during a misère.
|
||||||
|
The contractor sheds its highest card that still loses (or ducks
|
||||||
|
lowest when leading); defenders simply play low."
|
||||||
|
(let* ((trump 'nullo)
|
||||||
|
(led (cg-get game :led))
|
||||||
|
(hand (cg-bid--hand game seat))
|
||||||
|
(legal (cg-bid-legal-cards hand led trump))
|
||||||
|
(plays (cg-get game :trick))
|
||||||
|
(contractor (cg-get game :contractor))
|
||||||
|
card)
|
||||||
|
(cond
|
||||||
|
((/= seat contractor)
|
||||||
|
(setq card (cg-bid--lowest legal trump led)))
|
||||||
|
((null plays)
|
||||||
|
(setq card (cg-bid--lowest legal trump led)))
|
||||||
|
(t
|
||||||
|
(let* ((wseat (cg-bid-trick-winner plays trump led))
|
||||||
|
(bestp (cg-bid-power (cdr (assq wseat plays)) trump led))
|
||||||
|
(losers (cl-remove-if-not
|
||||||
|
(lambda (c) (< (cg-bid-power c trump led) bestp)) legal)))
|
||||||
|
(setq card (cg-bid--highest (or losers legal) trump led)))))
|
||||||
|
(cg-bid--play game seat card)))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Driver: run AI until the human must act
|
||||||
|
|
||||||
|
(defun cg-bid--ai-step (game)
|
||||||
|
"Perform one pending AI action in GAME. Return non-nil if it acted."
|
||||||
|
(pcase (cg-get game :phase)
|
||||||
|
('auction (unless (cg-bid--human-p (cg-get game :bidder))
|
||||||
|
(cg-bid--ai-bid game (cg-get game :bidder)) t))
|
||||||
|
('kitty (unless (cg-bid--human-p (cg-get game :contractor))
|
||||||
|
(cg-bid--ai-discard game (cg-get game :contractor)) t))
|
||||||
|
('play (unless (cg-bid--human-p (cg-get game :turn))
|
||||||
|
(cg-bid--ai-play game (cg-get game :turn)) t))
|
||||||
|
(_ nil)))
|
||||||
|
|
||||||
|
(cl-defmethod cg-bid--run ((game cg-bid-game))
|
||||||
|
"Advance GAME through AI actions until a human is needed or it ends."
|
||||||
|
(let ((guard 0))
|
||||||
|
(while (and (< (cl-incf guard) 400) (cg-bid--ai-step game)))))
|
||||||
|
|
||||||
|
(provide 'cg-bid)
|
||||||
|
;;; cg-bid.el ends here
|
||||||
142
cg-core.el
Normal file
142
cg-core.el
Normal file
|
|
@ -0,0 +1,142 @@
|
||||||
|
;;; cg-core.el --- Shared engine core 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.50
|
||||||
|
;; Package-Requires: ((emacs "26.1"))
|
||||||
|
;; Keywords: games
|
||||||
|
;; URL: https://github.com/corwin/card-games
|
||||||
|
|
||||||
|
;; 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:
|
||||||
|
|
||||||
|
;; A small EIEIO scaffolding shared by the games in this package. It
|
||||||
|
;; provides the abstract `cg-game' class with a plist "environment" for
|
||||||
|
;; mutable per-game state, the `cg-render' and `cg-won-p' generics, and
|
||||||
|
;; a handful of card and display utilities (suit glyphs, colour
|
||||||
|
;; helpers, a shuffle, and common faces).
|
||||||
|
;;
|
||||||
|
;; Cards are normally represented as a cons cell (SUIT . RANK) with suit
|
||||||
|
;; indices 0=Spades 1=Clubs 2=Diamonds 3=Hearts; games define their own
|
||||||
|
;; rank scales. nil conventionally denotes an empty slot.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'cl-lib)
|
||||||
|
(require 'eieio)
|
||||||
|
|
||||||
|
(defgroup card-games nil
|
||||||
|
"Play card games in Emacs."
|
||||||
|
:group 'games
|
||||||
|
:prefix "cg-")
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Engine base
|
||||||
|
|
||||||
|
(defcustom cg-keys 'emacs
|
||||||
|
"Keybinding scheme for the card games.
|
||||||
|
`emacs' follows Emacs conventions (arrow keys to move, RET to act,
|
||||||
|
g to redraw). `classic' additionally enables vi-style hjkl movement
|
||||||
|
and SPC as an action key. Takes effect the next time a game starts."
|
||||||
|
:type '(choice (const :tag "Emacs conventions" emacs)
|
||||||
|
(const :tag "Classic (adds hjkl, SPC)" classic))
|
||||||
|
:group 'card-games)
|
||||||
|
|
||||||
|
(defclass cg-game ()
|
||||||
|
((name :initarg :name :initform "game" :type string
|
||||||
|
:documentation "Human-readable game name.")
|
||||||
|
(env :initarg :env :initform nil
|
||||||
|
:documentation "Mutable per-game data, stored as a plist."))
|
||||||
|
"Abstract base class for card games."
|
||||||
|
:abstract t)
|
||||||
|
|
||||||
|
(cl-defgeneric cg-render (game)
|
||||||
|
"Return a propertized string depicting GAME.")
|
||||||
|
|
||||||
|
(cl-defgeneric cg-won-p (game)
|
||||||
|
"Return non-nil when GAME has been won.")
|
||||||
|
|
||||||
|
(cl-defmethod cg-get ((game cg-game) key)
|
||||||
|
"Return value for KEY in GAME's environment."
|
||||||
|
(plist-get (oref game env) key))
|
||||||
|
|
||||||
|
(cl-defmethod cg-put ((game cg-game) key value)
|
||||||
|
"Set KEY to VALUE in GAME's environment and return VALUE."
|
||||||
|
(oset game env (plist-put (oref game env) key value))
|
||||||
|
value)
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Cards and colours
|
||||||
|
|
||||||
|
(defconst cg-suits ["♠" "♣" "♦" "♥"]
|
||||||
|
"Suit glyphs indexed 0..3: spades, clubs, diamonds, hearts.")
|
||||||
|
|
||||||
|
(defconst cg-suit-names ["Spades" "Clubs" "Diamonds" "Hearts"]
|
||||||
|
"Suit names indexed to match `cg-suits'.")
|
||||||
|
|
||||||
|
(defsubst cg-red-suit-p (suit)
|
||||||
|
"Return non-nil when SUIT index denotes a red suit."
|
||||||
|
(memq suit '(2 3)))
|
||||||
|
|
||||||
|
(defsubst cg-sister-suit (suit)
|
||||||
|
"Return the other suit index of the same colour as SUIT."
|
||||||
|
(pcase suit (0 1) (1 0) (2 3) (3 2)))
|
||||||
|
|
||||||
|
(defun cg-shuffle (seq)
|
||||||
|
"Return a new list with the elements of SEQ in random order."
|
||||||
|
(let* ((v (vconcat seq))
|
||||||
|
(n (length v)))
|
||||||
|
(dotimes (i n)
|
||||||
|
(let ((j (+ i (random (- n i)))))
|
||||||
|
(cl-rotatef (aref v i) (aref v j))))
|
||||||
|
(append v nil)))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Shared faces
|
||||||
|
|
||||||
|
(defface cg-red-suit '((t :foreground "red3"))
|
||||||
|
"Face for red-suited cards." :group 'card-games)
|
||||||
|
|
||||||
|
(defface cg-cursor '((t :inverse-video t))
|
||||||
|
"Face for the cell or card under the cursor." :group 'card-games)
|
||||||
|
|
||||||
|
(defface cg-gap '((t :foreground "gray50"))
|
||||||
|
"Face for an empty slot." :group 'card-games)
|
||||||
|
|
||||||
|
(defface cg-hint '((t :foreground "green3" :weight bold))
|
||||||
|
"Face for a valid move target (a fillable gap)." :group 'card-games)
|
||||||
|
|
||||||
|
(defun cg-color (face attribute fallback)
|
||||||
|
"Return FACE's ATTRIBUTE colour if usable on this display, else FALLBACK.
|
||||||
|
Degrades gracefully when there is no theme/frame (e.g. in a terminal
|
||||||
|
or batch), so callers always get a drawable colour string."
|
||||||
|
(let ((c (ignore-errors (face-attribute face attribute nil t))))
|
||||||
|
(if (and (stringp c)
|
||||||
|
(not (string-prefix-p "unspecified" c))
|
||||||
|
(ignore-errors (color-defined-p c)))
|
||||||
|
c
|
||||||
|
fallback)))
|
||||||
|
|
||||||
|
(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."
|
||||||
|
(let ((amt (if (boundp 'text-scale-mode-amount) text-scale-mode-amount 0)))
|
||||||
|
(max 0.4 (min 4.0 (expt 1.15 amt)))))
|
||||||
|
|
||||||
|
(provide 'cg-core)
|
||||||
|
;;; cg-core.el ends here
|
||||||
850
cg-gaps.el
Normal file
850
cg-gaps.el
Normal file
|
|
@ -0,0 +1,850 @@
|
||||||
|
;;; cg-gaps.el --- Gaps-style row solitaires (Montana, Hell's Half-Acre) -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2026 Corwin Brust
|
||||||
|
|
||||||
|
;; Author: Corwin Brust <corwin@bru.st>
|
||||||
|
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||||
|
;; Version: 1.0.50
|
||||||
|
;; Package-Requires: ((emacs "26.1"))
|
||||||
|
;; Keywords: games
|
||||||
|
;; URL: https://github.com/corwin/card-games
|
||||||
|
|
||||||
|
;; 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:
|
||||||
|
|
||||||
|
;; The "gaps" family of solitaires: 48 cards dealt into four rows of
|
||||||
|
;; thirteen with four gaps. A gap is filled by the card one rank along
|
||||||
|
;; from the card to its left, of the same suit; the head gap of a row
|
||||||
|
;; takes the anchor rank in any suit.
|
||||||
|
;;
|
||||||
|
;; Two variants ship, demonstrating how a new game is *derived* by
|
||||||
|
;; subclassing the abstract `cg-gaps-game' and overriding two methods
|
||||||
|
;; (`cg-gaps--head' and `cg-gaps--step'):
|
||||||
|
;;
|
||||||
|
;; `cg-montana' Gaps / Montana: Two at the head, rows build
|
||||||
|
;; UP 2 3 4 ... K; nothing follows a King.
|
||||||
|
;; `cg-hells-half-acre' Hell's Half-Acre: King at the head, rows
|
||||||
|
;; build DOWN K Q J ... 2; nothing follows a Two.
|
||||||
|
;;
|
||||||
|
;; When stuck you may redeal (twice): each correct run from the head
|
||||||
|
;; stays, a gap opens just past it, and the rest are reshuffled.
|
||||||
|
;;
|
||||||
|
;; Renders as UNICODE text in a terminal and as SVG cards on a graphical
|
||||||
|
;; display; fillable gaps are highlighted. Play via `M-x card-game' or
|
||||||
|
;; the commands above.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'cg-core)
|
||||||
|
(require 'cg-svg)
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Cards
|
||||||
|
|
||||||
|
(defconst cg-gaps-ranks
|
||||||
|
["2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K"]
|
||||||
|
"Rank labels indexed 0..11 (Two through King).")
|
||||||
|
|
||||||
|
(defconst cg-gaps-rank-names
|
||||||
|
["Two" "Three" "Four" "Five" "Six" "Seven" "Eight" "Nine"
|
||||||
|
"Ten" "Jack" "Queen" "King"]
|
||||||
|
"Full rank names indexed to match `cg-gaps-ranks'.")
|
||||||
|
|
||||||
|
;; A card is a cons cell (SUIT . RANK); nil denotes a gap.
|
||||||
|
|
||||||
|
(defsubst cg-gaps-red-p (card)
|
||||||
|
"Return non-nil when CARD is a red suit (diamonds or hearts)."
|
||||||
|
(and card (cg-red-suit-p (car card))))
|
||||||
|
|
||||||
|
(defun cg-gaps-card-string (card)
|
||||||
|
"Return a short string for CARD, or a dot for a gap (nil)."
|
||||||
|
(if (null card)
|
||||||
|
"·"
|
||||||
|
(concat (aref cg-gaps-ranks (cdr card))
|
||||||
|
(aref cg-suits (car card)))))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Games — an abstract base and two subclasses
|
||||||
|
|
||||||
|
(defclass cg-gaps-game (cg-game)
|
||||||
|
((name :initform "Gaps"))
|
||||||
|
"Abstract base for gaps-style row solitaires.
|
||||||
|
Subclasses set the head rank and build direction by overriding
|
||||||
|
`cg-gaps--head' and `cg-gaps--step'."
|
||||||
|
:abstract t)
|
||||||
|
|
||||||
|
(cl-defgeneric cg-gaps--head (game)
|
||||||
|
"Return the rank index that anchors the head (left) of each row.")
|
||||||
|
(cl-defgeneric cg-gaps--step (game)
|
||||||
|
"Return the per-column rank increment: +1 ascending, -1 descending.")
|
||||||
|
(cl-defgeneric cg-gaps--vname (game)
|
||||||
|
"Return the human-readable variant name for GAME.")
|
||||||
|
|
||||||
|
(defclass cg-montana-game (cg-gaps-game)
|
||||||
|
((name :initform "Montana"))
|
||||||
|
"Gaps / Montana: a Two anchors the head; rows build up 2..K.")
|
||||||
|
(cl-defmethod cg-gaps--head ((_ cg-montana-game)) 0)
|
||||||
|
(cl-defmethod cg-gaps--step ((_ cg-montana-game)) 1)
|
||||||
|
(cl-defmethod cg-gaps--vname ((_ cg-montana-game)) "Gaps (Montana)")
|
||||||
|
|
||||||
|
(defclass cg-acre-game (cg-gaps-game)
|
||||||
|
((name :initform "Hell's Half-Acre"))
|
||||||
|
"Hell's Half-Acre: a King anchors the head; rows build down K..2.")
|
||||||
|
(cl-defmethod cg-gaps--head ((_ cg-acre-game)) 11)
|
||||||
|
(cl-defmethod cg-gaps--step ((_ cg-acre-game)) -1)
|
||||||
|
(cl-defmethod cg-gaps--vname ((_ cg-acre-game)) "Hell's Half-Acre")
|
||||||
|
|
||||||
|
(defalias 'cg-gaps--shuffle 'cg-shuffle)
|
||||||
|
|
||||||
|
(defun cg-gaps--full-deck ()
|
||||||
|
"Return the 48 playable cards (Two..King in every suit)."
|
||||||
|
(cl-loop for s below 4
|
||||||
|
append (cl-loop for r below 12 collect (cons s r))))
|
||||||
|
|
||||||
|
(cl-defmethod cg-gaps--deal ((game cg-gaps-game))
|
||||||
|
"Deal a fresh layout into GAME."
|
||||||
|
(random t)
|
||||||
|
(let ((cells (cg-gaps--shuffle (append (cg-gaps--full-deck)
|
||||||
|
(make-list 4 nil))))
|
||||||
|
(board (make-vector 4 nil)))
|
||||||
|
(dotimes (r 4)
|
||||||
|
(let ((row (make-vector 13 nil)))
|
||||||
|
(dotimes (c 13)
|
||||||
|
(aset row c (pop cells)))
|
||||||
|
(aset board r row)))
|
||||||
|
(cg-put game :board board)
|
||||||
|
(cg-put game :moves 0)
|
||||||
|
(cg-put game :redeals 2)
|
||||||
|
(cg-put game :cursor (cons 0 0))
|
||||||
|
(cg-put game :history nil)
|
||||||
|
(cg-put game :message
|
||||||
|
(format "Fill the gaps: each row one suit, %s. RET on a gap. ? = help."
|
||||||
|
(if (> (cg-gaps--step game) 0) "2 up to K" "K down to 2")))
|
||||||
|
game))
|
||||||
|
|
||||||
|
(defun cg-gaps--cell (board r c)
|
||||||
|
"Return the card at row R column C of BOARD (nil for a gap)."
|
||||||
|
(aref (aref board r) c))
|
||||||
|
|
||||||
|
(cl-defmethod cg-gaps--needed ((game cg-gaps-game) board r c)
|
||||||
|
"Return what may fill the gap at R, C of BOARD for GAME.
|
||||||
|
Returns the symbol `head' for a head gap, a (SUIT . RANK) card for any
|
||||||
|
other fillable gap, or nil if nothing fits."
|
||||||
|
(if (= c 0)
|
||||||
|
'head
|
||||||
|
(let ((left (cg-gaps--cell board r (1- c))))
|
||||||
|
(if (null left)
|
||||||
|
nil
|
||||||
|
(let ((nr (+ (cdr left) (cg-gaps--step game))))
|
||||||
|
(and (>= nr 0) (<= nr 11) (cons (car left) nr)))))))
|
||||||
|
|
||||||
|
(defun cg-gaps--find (board card)
|
||||||
|
"Return (ROW . COL) of CARD in BOARD, or nil if absent."
|
||||||
|
(catch 'hit
|
||||||
|
(dotimes (r 4)
|
||||||
|
(dotimes (c 13)
|
||||||
|
(when (equal (cg-gaps--cell board r c) card)
|
||||||
|
(throw 'hit (cons r c)))))
|
||||||
|
nil))
|
||||||
|
|
||||||
|
(defun cg-gaps--copy-board (board)
|
||||||
|
"Return a shallow copy of BOARD safe to mutate cell-by-cell."
|
||||||
|
(apply #'vector (mapcar #'copy-sequence (append board nil))))
|
||||||
|
|
||||||
|
(cl-defmethod cg-gaps--save-undo ((game cg-gaps-game))
|
||||||
|
"Push the current state of GAME onto its undo history."
|
||||||
|
(cg-put game :history
|
||||||
|
(cons (list (cg-gaps--copy-board (cg-get game :board))
|
||||||
|
(cg-get game :moves)
|
||||||
|
(cg-get game :redeals))
|
||||||
|
(cg-get game :history))))
|
||||||
|
|
||||||
|
(cl-defmethod cg-gaps--do-move ((game cg-gaps-game) r c card)
|
||||||
|
"Move CARD into the gap at R, C of GAME. Return non-nil on success."
|
||||||
|
(let* ((board (cg-get game :board))
|
||||||
|
(loc (cg-gaps--find board card)))
|
||||||
|
(if (not loc)
|
||||||
|
(progn (cg-put game :message
|
||||||
|
(format "The %s is not on the board?!"
|
||||||
|
(cg-gaps-card-string card)))
|
||||||
|
nil)
|
||||||
|
(cg-gaps--save-undo game)
|
||||||
|
(setf (aref (aref board (car loc)) (cdr loc)) nil)
|
||||||
|
(setf (aref (aref board r) c) card)
|
||||||
|
(cg-put game :moves (1+ (cg-get game :moves)))
|
||||||
|
(cg-put game :message (format "Moved %s." (cg-gaps-card-string card)))
|
||||||
|
t)))
|
||||||
|
|
||||||
|
(cl-defmethod cg-gaps--fill ((game cg-gaps-game) r c)
|
||||||
|
"Try to fill the gap at R, C of GAME. Return non-nil on success."
|
||||||
|
(let* ((board (cg-get game :board))
|
||||||
|
(cell (cg-gaps--cell board r c)))
|
||||||
|
(cond
|
||||||
|
(cell
|
||||||
|
(cg-put game :message "That cell is not a gap.") nil)
|
||||||
|
(t
|
||||||
|
(let ((needed (cg-gaps--needed game board r c)))
|
||||||
|
(cond
|
||||||
|
((null needed)
|
||||||
|
(cg-put game :message "Nothing can fill that gap.") nil)
|
||||||
|
((eq needed 'head)
|
||||||
|
(let ((suit (cg-gaps--read-head game)))
|
||||||
|
(and suit (cg-gaps--do-move game r c (cons suit (cg-gaps--head game))))))
|
||||||
|
(t
|
||||||
|
(cg-gaps--do-move game r c needed))))))))
|
||||||
|
|
||||||
|
(cl-defmethod cg-gaps--read-head ((game cg-gaps-game))
|
||||||
|
"Prompt for the suit of the head card of GAME. Return suit 0..3 or nil."
|
||||||
|
(let* ((name (aref cg-gaps-rank-names (cg-gaps--head game)))
|
||||||
|
(ch (read-char-choice
|
||||||
|
(format "Head gap — which %s? [s]pades [c]lubs [d]iamonds [h]earts (q=cancel): "
|
||||||
|
name)
|
||||||
|
'(?s ?c ?d ?h ?q))))
|
||||||
|
(cdr (assq ch '((?s . 0) (?c . 1) (?d . 2) (?h . 3))))))
|
||||||
|
|
||||||
|
(cl-defmethod cg-won-p ((game cg-gaps-game))
|
||||||
|
"Return non-nil when every row of GAME is a full suited run with a trailing gap."
|
||||||
|
(let ((board (cg-get game :board))
|
||||||
|
(head (cg-gaps--head game))
|
||||||
|
(step (cg-gaps--step game)))
|
||||||
|
(catch 'no
|
||||||
|
(dotimes (r 4)
|
||||||
|
(let* ((row (aref board r))
|
||||||
|
(c0 (aref row 0)))
|
||||||
|
(unless c0 (throw 'no nil))
|
||||||
|
(let ((suit (car c0)))
|
||||||
|
(dotimes (c 12)
|
||||||
|
(let ((cell (aref row c)))
|
||||||
|
(unless (and cell (= (car cell) suit)
|
||||||
|
(= (cdr cell) (+ head (* c step))))
|
||||||
|
(throw 'no nil))))
|
||||||
|
(when (aref row 12) (throw 'no nil)))))
|
||||||
|
t)))
|
||||||
|
|
||||||
|
(cl-defmethod cg-gaps--stuck-p ((game cg-gaps-game))
|
||||||
|
"Return non-nil when no gap of GAME can currently be filled."
|
||||||
|
(null (cg-gaps--hints game)))
|
||||||
|
|
||||||
|
(cl-defmethod cg-gaps--hints ((game cg-gaps-game))
|
||||||
|
"Return the list of (ROW . COL) gaps of GAME that can be filled now."
|
||||||
|
(let ((board (cg-get game :board))
|
||||||
|
(hints nil))
|
||||||
|
(dotimes (r 4)
|
||||||
|
(dotimes (c 13)
|
||||||
|
(when (and (null (cg-gaps--cell board r c))
|
||||||
|
(cg-gaps--needed game board r c))
|
||||||
|
(push (cons r c) hints))))
|
||||||
|
hints))
|
||||||
|
|
||||||
|
(cl-defmethod cg-gaps--prefix-len ((game cg-gaps-game) board r)
|
||||||
|
"Return the length of the correct run at the head of row R of BOARD."
|
||||||
|
(let ((row (aref board r))
|
||||||
|
(head (cg-gaps--head game))
|
||||||
|
(step (cg-gaps--step game))
|
||||||
|
(len 0))
|
||||||
|
(let ((c0 (aref row 0)))
|
||||||
|
(when (and c0 (= (cdr c0) head))
|
||||||
|
(let ((suit (car c0)) (i 0) (cont t))
|
||||||
|
(while (and cont (< i 12))
|
||||||
|
(let ((cell (aref row i)))
|
||||||
|
(if (and cell (= (car cell) suit)
|
||||||
|
(= (cdr cell) (+ head (* i step))))
|
||||||
|
(setq i (1+ i))
|
||||||
|
(setq cont nil))))
|
||||||
|
(setq len i))))
|
||||||
|
len))
|
||||||
|
|
||||||
|
(cl-defmethod cg-gaps--do-redeal ((game cg-gaps-game))
|
||||||
|
"Gather misplaced cards of GAME, reshuffle, and lay them back."
|
||||||
|
(let* ((board (cg-get game :board))
|
||||||
|
(lens (make-vector 4 0))
|
||||||
|
(kept nil))
|
||||||
|
(dotimes (r 4)
|
||||||
|
(let ((len (cg-gaps--prefix-len game board r)))
|
||||||
|
(aset lens r len)
|
||||||
|
(dotimes (i len) (push (cg-gaps--cell board r i) kept))))
|
||||||
|
(let* ((remaining
|
||||||
|
(cg-gaps--shuffle
|
||||||
|
(cl-remove-if (lambda (card) (cl-member card kept :test #'equal))
|
||||||
|
(cg-gaps--full-deck))))
|
||||||
|
(new (make-vector 4 nil)))
|
||||||
|
(dotimes (r 4)
|
||||||
|
(let ((row (make-vector 13 nil))
|
||||||
|
(len (aref lens r)))
|
||||||
|
(dotimes (i len)
|
||||||
|
(aset row i (cg-gaps--cell board r i)))
|
||||||
|
;; column LEN stays a gap.
|
||||||
|
(cl-loop for c from (1+ len) below 13
|
||||||
|
do (aset row c (pop remaining)))
|
||||||
|
(aset new r row)))
|
||||||
|
(cg-put game :board new))))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Rendering
|
||||||
|
|
||||||
|
(defun cg-gaps--header (game)
|
||||||
|
"Return the header text for GAME."
|
||||||
|
(format " ♠♣ %s ♦♥\n Moves: %-4d Redeals left: %d\n\n"
|
||||||
|
(cg-gaps--vname game) (cg-get game :moves) (cg-get game :redeals)))
|
||||||
|
|
||||||
|
(defun cg-gaps--footer (game)
|
||||||
|
"Return the footer text (just the current message) for GAME.
|
||||||
|
The control line is inserted separately by `cg-gaps--insert-controls',
|
||||||
|
where each key hint is itself the clickable button."
|
||||||
|
(format "\n %s\n" (cg-get game :message)))
|
||||||
|
|
||||||
|
(cl-defmethod cg-render ((game cg-gaps-game))
|
||||||
|
"Return a propertized string depicting GAME (console rendering)."
|
||||||
|
(let* ((board (cg-get game :board))
|
||||||
|
(cursor (cg-get game :cursor))
|
||||||
|
(cr (car cursor))
|
||||||
|
(cc (cdr cursor))
|
||||||
|
(hints (cg-gaps--hints game))
|
||||||
|
(out (list)))
|
||||||
|
(push (cg-gaps--header game) out)
|
||||||
|
(dotimes (r 4)
|
||||||
|
(dotimes (c 13)
|
||||||
|
(let* ((cell (cg-gaps--cell board r c))
|
||||||
|
(gapp (null cell))
|
||||||
|
(hintp (and gapp (member (cons r c) hints)))
|
||||||
|
(str (cond ((not gapp) (cg-gaps-card-string cell))
|
||||||
|
(hintp "+")
|
||||||
|
(t "·")))
|
||||||
|
(faces nil))
|
||||||
|
(when (cg-gaps-red-p cell) (push 'cg-red-suit faces))
|
||||||
|
(when hintp (push 'cg-hint faces))
|
||||||
|
(when (and gapp (not hintp)) (push 'cg-gap faces))
|
||||||
|
(when (and (= r cr) (= c cc)) (push 'cg-cursor faces))
|
||||||
|
(let ((content (propertize (format "%3s" str)
|
||||||
|
'face (or faces 'default))))
|
||||||
|
(push (propertize (concat " " content)
|
||||||
|
'cg-cell (cons r c)
|
||||||
|
'mouse-face 'highlight)
|
||||||
|
out))))
|
||||||
|
(push "\n" out))
|
||||||
|
(push (cg-gaps--footer game) out)
|
||||||
|
(apply #'concat (nreverse out))))
|
||||||
|
|
||||||
|
(defun cg-gaps--board-specs (board)
|
||||||
|
"Return BOARD as rows of SVG card specs for `cg-svg-grid-svg'."
|
||||||
|
(let ((rows nil))
|
||||||
|
(dotimes (r 4)
|
||||||
|
(let ((row nil))
|
||||||
|
(dotimes (c 13)
|
||||||
|
(let ((cell (cg-gaps--cell board r c)))
|
||||||
|
(push (and cell (cons (aref cg-gaps-ranks (cdr cell)) (car cell)))
|
||||||
|
row)))
|
||||||
|
(push (nreverse row) rows)))
|
||||||
|
(nreverse rows)))
|
||||||
|
|
||||||
|
(defconst cg-gaps--svg-card-w 46 "Base card width used by the SVG board.")
|
||||||
|
(defconst cg-gaps--svg-card-h 64 "Base card height used by the SVG board.")
|
||||||
|
(defconst cg-gaps--svg-gap 6 "Pixel gap between cards on the SVG board.")
|
||||||
|
(defconst cg-gaps--svg-pad 10 "Margin around the SVG board.")
|
||||||
|
|
||||||
|
(defcustom cg-gaps-svg-ui nil
|
||||||
|
"When non-nil (and on a graphical display), render the gaps board as a
|
||||||
|
single full-buffer SVG: the board fills the window with a status/controls
|
||||||
|
panel down the left side, mirroring the 500 full-SVG UI. Toggle with `v'."
|
||||||
|
:type 'boolean :group 'cg-svg)
|
||||||
|
|
||||||
|
(defcustom cg-gaps-svg-fill t
|
||||||
|
"When non-nil, size the full-SVG gaps UI to fill the window and re-fit on
|
||||||
|
window changes. Only used when `cg-gaps-svg-ui' is enabled."
|
||||||
|
:type 'boolean :group 'cg-svg)
|
||||||
|
|
||||||
|
(defun cg-gaps--insert-graphical (game)
|
||||||
|
"Insert the GUI (SVG) depiction of GAME into the current buffer."
|
||||||
|
(insert (cg-gaps--header game))
|
||||||
|
(let ((cg-svg-card-width cg-gaps--svg-card-w)
|
||||||
|
(cg-svg-card-height cg-gaps--svg-card-h)
|
||||||
|
(cg-svg-card-gap cg-gaps--svg-gap))
|
||||||
|
(insert-image
|
||||||
|
(cg-svg-image
|
||||||
|
(cg-svg-grid-svg (cg-gaps--board-specs (cg-get game :board))
|
||||||
|
:cursor (cg-get game :cursor)
|
||||||
|
:hints (cg-gaps--hints game)
|
||||||
|
:pad cg-gaps--svg-pad)
|
||||||
|
(cg-scale))))
|
||||||
|
(insert "\n")
|
||||||
|
(insert (cg-gaps--footer game)))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Interaction
|
||||||
|
|
||||||
|
(defvar-local cg-gaps--game nil
|
||||||
|
"The `cg-gaps-game' object played in the current buffer.")
|
||||||
|
|
||||||
|
(defun cg-gaps--goto-cell (r c)
|
||||||
|
"Move point onto the rendered cell at row R column C, if present."
|
||||||
|
(let ((target (cons r c))
|
||||||
|
(pos (point-min))
|
||||||
|
(found nil))
|
||||||
|
(while (and pos (not found))
|
||||||
|
(when (equal (get-text-property pos 'cg-cell) target)
|
||||||
|
(setq found pos))
|
||||||
|
(setq pos (next-single-property-change pos 'cg-cell)))
|
||||||
|
(when found (goto-char (1+ found)))))
|
||||||
|
|
||||||
|
(defun cg-gaps--key-button (key word cmd help)
|
||||||
|
"Insert a control where the KEY hint itself is the button running CMD.
|
||||||
|
Shown as \"key word\" (e.g. \"r redeal\"); HELP is the tooltip."
|
||||||
|
(insert-text-button (format "%s %s" key word)
|
||||||
|
'action (lambda (_) (call-interactively cmd))
|
||||||
|
'help-echo help 'follow-link t 'face 'link)
|
||||||
|
(insert " "))
|
||||||
|
|
||||||
|
(defun cg-gaps--insert-controls ()
|
||||||
|
"Insert a single control line.
|
||||||
|
Movement keys are a plain hint; the action keys double as their own
|
||||||
|
buttons (the keyboard hint *is* the button)."
|
||||||
|
(insert " ")
|
||||||
|
(insert (propertize "←→↑↓ move " 'face 'shadow))
|
||||||
|
(cg-gaps--key-button "RET" "fill" #'cg-gaps-fill "Fill the gap under the cursor")
|
||||||
|
(cg-gaps--key-button "r" "redeal" #'cg-gaps-redeal "Reshuffle the misplaced cards")
|
||||||
|
(cg-gaps--key-button "u" "undo" #'cg-gaps-undo "Undo the last move")
|
||||||
|
(cg-gaps--key-button "n" "new" #'cg-gaps-new "Deal a new game")
|
||||||
|
(cg-gaps--key-button "?" "help" #'cg-gaps-help "Show the rules and keys")
|
||||||
|
(insert "\n"))
|
||||||
|
|
||||||
|
(defun cg-gaps--redisplay ()
|
||||||
|
"Redraw the current Gaps buffer.
|
||||||
|
Full-buffer SVG when `cg-gaps-svg-ui'; otherwise an inline SVG board (or
|
||||||
|
UNICODE text on a terminal), each followed by the single control line."
|
||||||
|
(let ((game cg-gaps--game)
|
||||||
|
(inhibit-read-only t))
|
||||||
|
(setq-local mode-line-process (cg-gaps--mode-line game))
|
||||||
|
(erase-buffer)
|
||||||
|
(cond
|
||||||
|
((and cg-gaps-svg-ui (display-graphic-p))
|
||||||
|
(cg-gaps--insert-svg-ui game))
|
||||||
|
((display-graphic-p)
|
||||||
|
(cg-gaps--insert-graphical game)
|
||||||
|
(cg-gaps--insert-controls))
|
||||||
|
(t
|
||||||
|
(insert (cg-render game))
|
||||||
|
(cg-gaps--insert-controls)))
|
||||||
|
(if (display-graphic-p)
|
||||||
|
(goto-char (point-min))
|
||||||
|
(let ((cur (cg-get game :cursor)))
|
||||||
|
(cg-gaps--goto-cell (car cur) (cdr cur))))))
|
||||||
|
|
||||||
|
(defun cg-gaps--move (dr dc)
|
||||||
|
"Move the cursor by DR rows and DC columns, then redisplay."
|
||||||
|
(let* ((game cg-gaps--game)
|
||||||
|
(cur (cg-get game :cursor))
|
||||||
|
(r (min 3 (max 0 (+ (car cur) dr))))
|
||||||
|
(c (min 12 (max 0 (+ (cdr cur) dc)))))
|
||||||
|
(cg-put game :cursor (cons r c))
|
||||||
|
(cg-gaps--redisplay)))
|
||||||
|
|
||||||
|
(defun cg-gaps-left () "Move cursor left." (interactive) (cg-gaps--move 0 -1))
|
||||||
|
(defun cg-gaps-right () "Move cursor right." (interactive) (cg-gaps--move 0 1))
|
||||||
|
(defun cg-gaps-up () "Move cursor up." (interactive) (cg-gaps--move -1 0))
|
||||||
|
(defun cg-gaps-down () "Move cursor down." (interactive) (cg-gaps--move 1 0))
|
||||||
|
|
||||||
|
(defun cg-gaps--after-move ()
|
||||||
|
"Check for a win or a stuck position and report it."
|
||||||
|
(let ((game cg-gaps--game))
|
||||||
|
(cond
|
||||||
|
((cg-won-p game)
|
||||||
|
(cg-put game :message
|
||||||
|
(format "\U0001F389 Solved in %d moves! Press n for a new game."
|
||||||
|
(cg-get game :moves))))
|
||||||
|
((cg-gaps--stuck-p game)
|
||||||
|
(cg-put game :message
|
||||||
|
(if (> (cg-get game :redeals) 0)
|
||||||
|
(format "Stuck! Press r to redeal (%d left)."
|
||||||
|
(cg-get game :redeals))
|
||||||
|
"Stuck, and no redeals left. Press n for a new game."))))
|
||||||
|
(cg-gaps--redisplay)
|
||||||
|
(message "%s" (cg-get game :message))))
|
||||||
|
|
||||||
|
(defun cg-gaps-fill ()
|
||||||
|
"Fill the gap under the cursor."
|
||||||
|
(interactive)
|
||||||
|
(let* ((game cg-gaps--game)
|
||||||
|
(cur (cg-get game :cursor)))
|
||||||
|
(if (cg-gaps--fill game (car cur) (cdr cur))
|
||||||
|
(cg-gaps--after-move)
|
||||||
|
(cg-gaps--redisplay))))
|
||||||
|
|
||||||
|
(defun cg-gaps-redeal ()
|
||||||
|
"Reshuffle and redeal the misplaced cards, if redeals remain."
|
||||||
|
(interactive)
|
||||||
|
(let ((game cg-gaps--game))
|
||||||
|
(if (<= (cg-get game :redeals) 0)
|
||||||
|
(progn (cg-put game :message "No redeals left.")
|
||||||
|
(cg-gaps--redisplay))
|
||||||
|
(cg-gaps--save-undo game)
|
||||||
|
(cg-gaps--do-redeal game)
|
||||||
|
(cg-put game :redeals (1- (cg-get game :redeals)))
|
||||||
|
(cg-put game :message
|
||||||
|
(format "Redealt. %d redeals left." (cg-get game :redeals)))
|
||||||
|
(cg-gaps--after-move))))
|
||||||
|
|
||||||
|
(defun cg-gaps-undo ()
|
||||||
|
"Undo the last move or redeal."
|
||||||
|
(interactive)
|
||||||
|
(let* ((game cg-gaps--game)
|
||||||
|
(hist (cg-get game :history)))
|
||||||
|
(if (null hist)
|
||||||
|
(progn (cg-put game :message "Nothing to undo.")
|
||||||
|
(cg-gaps--redisplay))
|
||||||
|
(let ((snap (car hist)))
|
||||||
|
(cg-put game :board (nth 0 snap))
|
||||||
|
(cg-put game :moves (nth 1 snap))
|
||||||
|
(cg-put game :redeals (nth 2 snap))
|
||||||
|
(cg-put game :history (cdr hist))
|
||||||
|
(cg-put game :message "Undone.")
|
||||||
|
(cg-gaps--redisplay)))))
|
||||||
|
|
||||||
|
(defun cg-gaps-new ()
|
||||||
|
"Start a new game in the current buffer."
|
||||||
|
(interactive)
|
||||||
|
(cg-gaps--deal cg-gaps--game)
|
||||||
|
(cg-gaps--redisplay))
|
||||||
|
|
||||||
|
(defun cg-gaps--xy->cell (px py)
|
||||||
|
"Map pixel coordinates PX, PY on the SVG board to a (ROW . COL), or nil."
|
||||||
|
(let* ((w cg-gaps--svg-card-w) (h cg-gaps--svg-card-h)
|
||||||
|
(g cg-gaps--svg-gap) (pad cg-gaps--svg-pad))
|
||||||
|
(when (and (>= px pad) (>= py pad))
|
||||||
|
(let* ((col (/ (- px pad) (+ w g)))
|
||||||
|
(row (/ (- py pad) (+ h g)))
|
||||||
|
(xin (- px pad (* col (+ w g))))
|
||||||
|
(yin (- py pad (* row (+ h g)))))
|
||||||
|
(when (and (< col 13) (< row 4) (<= xin w) (<= yin h))
|
||||||
|
(cons row col))))))
|
||||||
|
|
||||||
|
(defun cg-gaps-mouse (event)
|
||||||
|
"Fill the gap clicked by EVENT (or move the cursor there).
|
||||||
|
Dispatches to the full-SVG UI when active; otherwise hit-tests the inline
|
||||||
|
SVG board (pixel) or the text grid (text property)."
|
||||||
|
(interactive "e")
|
||||||
|
(let ((start (event-start event)))
|
||||||
|
(if (and cg-gaps-svg-ui (display-graphic-p) (posn-image start))
|
||||||
|
(cg-gaps--svg-ui-click start)
|
||||||
|
(let ((cell (if (and (display-graphic-p) (posn-image start))
|
||||||
|
(let ((xy (posn-object-x-y start)) (s (cg-scale)))
|
||||||
|
(and xy (cg-gaps--xy->cell (round (/ (car xy) s))
|
||||||
|
(round (/ (cdr xy) s)))))
|
||||||
|
(let ((pos (posn-point start)))
|
||||||
|
(and pos (get-text-property pos 'cg-cell))))))
|
||||||
|
(when cell
|
||||||
|
(cg-put cg-gaps--game :cursor cell)
|
||||||
|
(cg-gaps-fill))))))
|
||||||
|
|
||||||
|
(defun cg-gaps-help ()
|
||||||
|
"Show a one-line reminder of the controls."
|
||||||
|
(interactive)
|
||||||
|
(let ((game cg-gaps--game))
|
||||||
|
(message "%s"
|
||||||
|
(format "%s: move to a highlighted gap and RET to fill it (a %s anchors the head). r=redeal u=undo n=new q=quit."
|
||||||
|
(if game (cg-gaps--vname game) "Gaps")
|
||||||
|
(if game (aref cg-gaps-rank-names (cg-gaps--head game)) "card")))))
|
||||||
|
|
||||||
|
(defun cg-gaps--mode-line (game)
|
||||||
|
"Return the mode-line status string for GAME."
|
||||||
|
(cond ((cg-won-p game) " [Solved!]")
|
||||||
|
((cg-gaps--stuck-p game)
|
||||||
|
(if (> (cg-get game :redeals) 0) " [Stuck — r to redeal]" " [Stuck]"))
|
||||||
|
(t (format " [moves %d · redeals %d]"
|
||||||
|
(cg-get game :moves) (cg-get game :redeals)))))
|
||||||
|
|
||||||
|
(defun cg-gaps-zoom-in ()
|
||||||
|
"Enlarge the cards." (interactive) (text-scale-increase 1) (cg-gaps--redisplay))
|
||||||
|
(defun cg-gaps-zoom-out ()
|
||||||
|
"Shrink the cards." (interactive) (text-scale-decrease 1) (cg-gaps--redisplay))
|
||||||
|
(defun cg-gaps-zoom-reset ()
|
||||||
|
"Reset the card size." (interactive) (text-scale-set 0) (cg-gaps--redisplay))
|
||||||
|
|
||||||
|
(defun cg-gaps-redraw ()
|
||||||
|
"Redraw the board (e.g. after a theme or frame change)."
|
||||||
|
(interactive)
|
||||||
|
(cg-gaps--redisplay))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; Frameless full-SVG UI (opt-in; see `cg-gaps-svg-ui')
|
||||||
|
|
||||||
|
(defconst cg-gaps--ui-w 820 "Default full-SVG gaps canvas width.")
|
||||||
|
(defconst cg-gaps--ui-h 380 "Default full-SVG gaps canvas height.")
|
||||||
|
|
||||||
|
(defvar-local cg-gaps--regions nil
|
||||||
|
"Plist of clickable regions for the full-SVG gaps UI.")
|
||||||
|
(defvar-local cg-gaps--ui-last-size nil
|
||||||
|
"Last window pixel size used to render the full-SVG gaps UI.")
|
||||||
|
|
||||||
|
(defun cg-gaps--in-rect (px py rect)
|
||||||
|
"Return non-nil when PX,PY lie inside RECT (X Y W H)."
|
||||||
|
(and rect (>= px (nth 0 rect)) (< px (+ (nth 0 rect) (nth 2 rect)))
|
||||||
|
(>= py (nth 1 rect)) (< py (+ (nth 1 rect) (nth 3 rect)))))
|
||||||
|
|
||||||
|
(defun cg-gaps--ui-text (svg str x y size color &optional bold anchor)
|
||||||
|
"Draw text STR on SVG at X,Y (SIZE, COLOR); ANCHOR defaults to start."
|
||||||
|
(let ((a (list :x (round x) :y (round y) :font-size (round size)
|
||||||
|
:fill color :text-anchor (or anchor "start")
|
||||||
|
:font-family cg-svg-font-family)))
|
||||||
|
(when bold (setq a (append a (list :font-weight "bold"))))
|
||||||
|
(apply #'svg-text svg str a)))
|
||||||
|
|
||||||
|
(defun cg-gaps--ui-label (svg str x y size)
|
||||||
|
"Draw an all-caps, letter-spaced section label on SVG."
|
||||||
|
(svg-text svg (upcase str) :x (round x) :y (round y) :font-size (round size)
|
||||||
|
:fill "#8fc79b" :text-anchor "start" :font-family cg-svg-font-family
|
||||||
|
:font-weight "bold" :letter-spacing "2"))
|
||||||
|
|
||||||
|
(defun cg-gaps--ui-divider (svg x1 x2 y)
|
||||||
|
"Draw a faint horizontal divider on SVG."
|
||||||
|
(svg-line svg x1 y x2 y :stroke "#1b6b35" :stroke-width 1))
|
||||||
|
|
||||||
|
(defun cg-gaps--draw-panel (svg game h lpw fs)
|
||||||
|
"Draw the left status/controls panel (width LPW, scale FS).
|
||||||
|
Return a plist of clickable control regions."
|
||||||
|
(let* ((regions nil)
|
||||||
|
(F (lambda (n) (round (* n fs))))
|
||||||
|
(px0 (funcall F 14)) (pxr (- lpw (funcall F 12)))
|
||||||
|
(dl (funcall F 8)) (dr (- lpw (funcall F 8)))
|
||||||
|
(cxp (/ lpw 2)) (y 0))
|
||||||
|
(svg-rectangle svg 6 6 (- lpw 8) (- h 12) :rx 10 :fill "#0d4a22" :fill-opacity 0.9
|
||||||
|
:stroke "#0a3a1a" :stroke-width 1)
|
||||||
|
(setq y (funcall F 30))
|
||||||
|
(cg-svg--text svg (cg-gaps--vname game) cxp y (funcall F 15) "#f1c40f" t)
|
||||||
|
(setq y (+ y (funcall F 14))) (cg-gaps--ui-divider svg dl dr y)
|
||||||
|
;; stats
|
||||||
|
(setq y (+ y (funcall F 22)))
|
||||||
|
(cg-gaps--ui-text svg "Moves" px0 y (funcall F 13) "#eaffea")
|
||||||
|
(svg-text svg (number-to-string (cg-get game :moves)) :x pxr :y y
|
||||||
|
:font-size (funcall F 14) :fill "#eaffea" :text-anchor "end"
|
||||||
|
:font-family cg-svg-font-family :font-weight "bold")
|
||||||
|
(setq y (+ y (funcall F 20)))
|
||||||
|
(cg-gaps--ui-text svg "Redeals left" px0 y (funcall F 13) "#eaffea")
|
||||||
|
(svg-text svg (number-to-string (cg-get game :redeals)) :x pxr :y y
|
||||||
|
:font-size (funcall F 14) :fill "#eaffea" :text-anchor "end"
|
||||||
|
:font-family cg-svg-font-family :font-weight "bold")
|
||||||
|
(setq y (+ y (funcall F 16))) (cg-gaps--ui-divider svg dl dr y)
|
||||||
|
;; rules
|
||||||
|
(setq y (+ y (funcall F 20)))
|
||||||
|
(cg-gaps--ui-label svg "Rules" px0 (- y (funcall F 6)) (funcall F 10))
|
||||||
|
(setq y (+ y (funcall F 16)))
|
||||||
|
(cg-gaps--ui-text svg (format "Head: %s"
|
||||||
|
(aref cg-gaps-rank-names (cg-gaps--head game)))
|
||||||
|
px0 y (funcall F 12) "#cfeccf")
|
||||||
|
(setq y (+ y (funcall F 16)))
|
||||||
|
(cg-gaps--ui-text svg (if (> (cg-gaps--step game) 0) "Build up 2..K"
|
||||||
|
"Build down K..2")
|
||||||
|
px0 y (funcall F 12) "#cfeccf")
|
||||||
|
(setq y (+ y (funcall F 16)) )
|
||||||
|
(cg-gaps--ui-text svg "One suit per row" px0 y (funcall F 12) "#9fd0a8")
|
||||||
|
(setq y (+ y (funcall F 14))) (cg-gaps--ui-divider svg dl dr y)
|
||||||
|
;; controls: the key shown on each button is the keyboard shortcut
|
||||||
|
(setq y (+ y (funcall F 20)))
|
||||||
|
(let* ((bw (- lpw px0 (funcall F 12))) (bh (funcall F 26)) (bg (funcall F 8))
|
||||||
|
(canredeal (> (cg-get game :redeals) 0))
|
||||||
|
(canundo (and (cg-get game :history) t))
|
||||||
|
(defs (list (list :redeal "R" "Redeal" canredeal)
|
||||||
|
(list :undo "U" "Undo" canundo)
|
||||||
|
(list :new "N" "New" t)
|
||||||
|
(list :help "?" "Help" t))))
|
||||||
|
(dolist (d defs)
|
||||||
|
(let* ((key (nth 0 d)) (kc (nth 1 d)) (word (nth 2 d)) (on (nth 3 d))
|
||||||
|
(rect (list px0 y bw bh)))
|
||||||
|
(svg-rectangle svg px0 y bw bh :rx 6
|
||||||
|
:fill (if on "#14401f" "#0e2a15")
|
||||||
|
:fill-opacity (if on 0.9 0.5)
|
||||||
|
:stroke "#0a3a1a" :stroke-width 1)
|
||||||
|
(cg-gaps--ui-text svg kc (+ px0 (funcall F 10)) (+ y (round (* bh 0.68)))
|
||||||
|
(funcall F 13) (if on "#f1c40f" "#5f7f68") t)
|
||||||
|
(cg-gaps--ui-text svg word (+ px0 (funcall F 30)) (+ y (round (* bh 0.68)))
|
||||||
|
(funcall F 13) (if on "#eaffea" "#5f7f68"))
|
||||||
|
(setq regions (plist-put regions key rect))
|
||||||
|
(setq y (+ y bh bg)))))
|
||||||
|
;; status message, wrapped to the panel
|
||||||
|
(let ((msg (cg-get game :message)))
|
||||||
|
(when (and msg (> (length msg) 0))
|
||||||
|
(let ((m (if (> (length msg) (max 18 (round (/ (- lpw px0 (funcall F 12))
|
||||||
|
(* 0.55 (funcall F 11))))))
|
||||||
|
(substring msg 0 (max 18 (round (/ (- lpw px0 (funcall F 12))
|
||||||
|
(* 0.55 (funcall F 11))))))
|
||||||
|
msg)))
|
||||||
|
(cg-gaps--ui-text svg m px0 (- h (funcall F 14)) (funcall F 11) "#9fd0a8"))))
|
||||||
|
regions))
|
||||||
|
|
||||||
|
(defun cg-gaps--ui-svg (game &optional w h)
|
||||||
|
"Return (SVG . REGIONS) for the full-buffer gaps UI of GAME (W by H).
|
||||||
|
The board scales to fill the area beside a proportional left panel."
|
||||||
|
(let* ((W (or w cg-gaps--ui-w)) (H (or h cg-gaps--ui-h))
|
||||||
|
(svg (svg-create W H)) (regions nil)
|
||||||
|
(fs (max 1.0 (min 2.2 (/ (+ (/ (float W) cg-gaps--ui-w)
|
||||||
|
(/ (float H) cg-gaps--ui-h)) 2.0))))
|
||||||
|
(pscale (max 1.0 (min 1.7 (/ (float W) cg-gaps--ui-w))))
|
||||||
|
(lpw (round (* 190 pscale)))
|
||||||
|
(bx (+ lpw 14)) (by 10)
|
||||||
|
(aw (- W bx 14)) (ah (- H by 10))
|
||||||
|
(board (cg-get game :board))
|
||||||
|
(cur (cg-get game :cursor)) (cr (car cur)) (cc (cdr cur))
|
||||||
|
(hints (cg-gaps--hints game))
|
||||||
|
(g (max 4 (round (* 6 fs))))
|
||||||
|
(cww (/ (- aw (* 12 g)) 13))
|
||||||
|
(chh (/ (- ah (* 3 g)) 4))
|
||||||
|
(aspect (/ 64.0 46.0))
|
||||||
|
(cw (max 18 (min cww (round (/ chh aspect)))))
|
||||||
|
(ch (round (* cw aspect)))
|
||||||
|
(bw (+ (* 13 cw) (* 12 g)))
|
||||||
|
(bh (+ (* 4 ch) (* 3 g)))
|
||||||
|
(x0 (+ bx (max 0 (/ (- aw bw) 2))))
|
||||||
|
(y0 (+ by (max 0 (/ (- ah bh) 2)))))
|
||||||
|
;; felt background + play-area panel
|
||||||
|
(svg-gradient svg "cg-gfelt" 'radial '((0 . "#1a7a38") (100 . "#0c4720")))
|
||||||
|
(svg-rectangle svg 0 0 W H :rx 14 :gradient "cg-gfelt")
|
||||||
|
(svg-rectangle svg (- bx 6) by (+ aw 12) ah :rx 12
|
||||||
|
:fill "#000000" :fill-opacity 0.10
|
||||||
|
:stroke "#0e5226" :stroke-width 2)
|
||||||
|
;; board
|
||||||
|
(let ((cg-svg-card-width cw) (cg-svg-card-height ch))
|
||||||
|
(dotimes (r 4)
|
||||||
|
(dotimes (c 13)
|
||||||
|
(let* ((cell (cg-gaps--cell board r c))
|
||||||
|
(spec (and cell (cons (aref cg-gaps-ranks (cdr cell)) (car cell))))
|
||||||
|
(x (+ x0 (* c (+ cw g)))) (y (+ y0 (* r (+ ch g))))
|
||||||
|
(hl (and (= r cr) (= c cc)))
|
||||||
|
(hint (and (null cell) (member (cons r c) hints) t)))
|
||||||
|
(cg-svg--draw-spec svg x y spec hl hint)))))
|
||||||
|
(setq regions (plist-put regions :board (list x0 y0 cw ch g)))
|
||||||
|
(setq regions (append regions (cg-gaps--draw-panel svg game H lpw fs)))
|
||||||
|
(cons svg regions)))
|
||||||
|
|
||||||
|
(defun cg-gaps--ui-cell (px py geom)
|
||||||
|
"Map pixel PX,PY to a (ROW . COL) given board GEOM (X0 Y0 CW CH G), or nil."
|
||||||
|
(when geom
|
||||||
|
(let ((x0 (nth 0 geom)) (y0 (nth 1 geom)) (cw (nth 2 geom))
|
||||||
|
(ch (nth 3 geom)) (g (nth 4 geom)))
|
||||||
|
(when (and (>= px x0) (>= py y0))
|
||||||
|
(let* ((col (/ (- px x0) (+ cw g))) (row (/ (- py y0) (+ ch g)))
|
||||||
|
(xin (- px x0 (* col (+ cw g)))) (yin (- py y0 (* row (+ ch g)))))
|
||||||
|
(when (and (< col 13) (< row 4) (<= xin cw) (<= yin ch))
|
||||||
|
(cons row col)))))))
|
||||||
|
|
||||||
|
(defun cg-gaps--svg-ui-click (start)
|
||||||
|
"Dispatch a click at posn START within the full-SVG gaps UI."
|
||||||
|
(let* ((xy (posn-object-x-y start)) (s (cg-scale))
|
||||||
|
(px (round (/ (car xy) s))) (py (round (/ (cdr xy) s)))
|
||||||
|
(game cg-gaps--game) (rg cg-gaps--regions))
|
||||||
|
(cond
|
||||||
|
((cg-gaps--in-rect px py (plist-get rg :redeal)) (cg-gaps-redeal))
|
||||||
|
((cg-gaps--in-rect px py (plist-get rg :undo)) (cg-gaps-undo))
|
||||||
|
((cg-gaps--in-rect px py (plist-get rg :new)) (cg-gaps-new))
|
||||||
|
((cg-gaps--in-rect px py (plist-get rg :help)) (cg-gaps-help))
|
||||||
|
(t (let ((cell (cg-gaps--ui-cell px py (plist-get rg :board))))
|
||||||
|
(when cell (cg-put game :cursor cell) (cg-gaps-fill)))))))
|
||||||
|
|
||||||
|
(defun cg-gaps--insert-svg-ui (game)
|
||||||
|
"Insert the full-buffer SVG gaps UI for GAME and record its regions."
|
||||||
|
(let* ((win (get-buffer-window (current-buffer)))
|
||||||
|
(fill (and cg-gaps-svg-fill win))
|
||||||
|
(w (if fill (max 640 (window-body-width win t)) cg-gaps--ui-w))
|
||||||
|
(h (if fill (max 320 (- (window-body-height win t) 4)) cg-gaps--ui-h))
|
||||||
|
(sr (cg-gaps--ui-svg game w h)))
|
||||||
|
(when fill (setq cg-gaps--ui-last-size (cons (window-body-width win t)
|
||||||
|
(window-body-height win t))))
|
||||||
|
(setq cg-gaps--regions (cdr sr))
|
||||||
|
(insert-image (cg-svg-image (car sr) (if fill 1.0 (cg-scale))))))
|
||||||
|
|
||||||
|
(defun cg-gaps--fit (&rest _)
|
||||||
|
"Re-render the full-SVG gaps UI to fit the window after a config change."
|
||||||
|
(when (and cg-gaps--game cg-gaps-svg-ui cg-gaps-svg-fill
|
||||||
|
(eq major-mode 'cg-gaps-mode))
|
||||||
|
(let ((win (get-buffer-window (current-buffer))))
|
||||||
|
(when win
|
||||||
|
(let ((sz (cons (window-body-width win t) (window-body-height win t))))
|
||||||
|
(unless (equal sz cg-gaps--ui-last-size)
|
||||||
|
(setq cg-gaps--ui-last-size sz)
|
||||||
|
(cg-gaps--redisplay)))))))
|
||||||
|
|
||||||
|
(defun cg-gaps-toggle-svg-ui ()
|
||||||
|
"Toggle the full-buffer SVG board for the gaps games."
|
||||||
|
(interactive)
|
||||||
|
(setq cg-gaps-svg-ui (not cg-gaps-svg-ui))
|
||||||
|
(setq cg-gaps--ui-last-size nil)
|
||||||
|
(cg-gaps--redisplay)
|
||||||
|
(message "Full-SVG board %s" (if cg-gaps-svg-ui "enabled" "disabled")))
|
||||||
|
|
||||||
|
(defvar cg-gaps-mode-map
|
||||||
|
(let ((map (make-sparse-keymap)))
|
||||||
|
(define-key map (kbd "<left>") #'cg-gaps-left)
|
||||||
|
(define-key map (kbd "<right>") #'cg-gaps-right)
|
||||||
|
(define-key map (kbd "<up>") #'cg-gaps-up)
|
||||||
|
(define-key map (kbd "<down>") #'cg-gaps-down)
|
||||||
|
(define-key map (kbd "RET") #'cg-gaps-fill)
|
||||||
|
(define-key map "g" #'cg-gaps-redraw)
|
||||||
|
(define-key map "r" #'cg-gaps-redeal)
|
||||||
|
(define-key map "u" #'cg-gaps-undo)
|
||||||
|
(define-key map "n" #'cg-gaps-new)
|
||||||
|
(define-key map "?" #'cg-gaps-help)
|
||||||
|
(define-key map "+" #'cg-gaps-zoom-in)
|
||||||
|
(define-key map "=" #'cg-gaps-zoom-in)
|
||||||
|
(define-key map "-" #'cg-gaps-zoom-out)
|
||||||
|
(define-key map "0" #'cg-gaps-zoom-reset)
|
||||||
|
(define-key map "v" #'cg-gaps-toggle-svg-ui)
|
||||||
|
(define-key map [mouse-1] #'cg-gaps-mouse)
|
||||||
|
map)
|
||||||
|
"Keymap for `cg-gaps-mode' (Emacs style; see `cg-keys').")
|
||||||
|
|
||||||
|
(defun cg-gaps--classic-keymap ()
|
||||||
|
"Return a copy of `cg-gaps-mode-map' with vi-style hjkl and SPC added."
|
||||||
|
(let ((map (copy-keymap cg-gaps-mode-map)))
|
||||||
|
(define-key map "h" #'cg-gaps-left)
|
||||||
|
(define-key map "l" #'cg-gaps-right)
|
||||||
|
(define-key map "k" #'cg-gaps-up)
|
||||||
|
(define-key map "j" #'cg-gaps-down)
|
||||||
|
(define-key map (kbd "SPC") #'cg-gaps-fill)
|
||||||
|
map))
|
||||||
|
|
||||||
|
(define-derived-mode cg-gaps-mode special-mode "Gaps"
|
||||||
|
"Major mode for playing the gaps family of solitaires."
|
||||||
|
(setq-local cursor-type 'box)
|
||||||
|
(setq-local truncate-lines t)
|
||||||
|
(add-hook 'window-configuration-change-hook #'cg-gaps--fit nil t)
|
||||||
|
(when (eq cg-keys 'classic)
|
||||||
|
(use-local-map (cg-gaps--classic-keymap))))
|
||||||
|
|
||||||
|
(defun cg-gaps--play (class)
|
||||||
|
"Start a gaps-style game of CLASS in its own buffer."
|
||||||
|
(let* ((game (cg-gaps--deal (make-instance class)))
|
||||||
|
(buf (get-buffer-create (format "*%s*" (cg-gaps--vname game)))))
|
||||||
|
(with-current-buffer buf
|
||||||
|
(cg-gaps-mode)
|
||||||
|
(setq cg-gaps--game game)
|
||||||
|
(cg-gaps--redisplay))
|
||||||
|
(switch-to-buffer buf)))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun cg-montana ()
|
||||||
|
"Play Gaps / Montana solitaire (Two at the head, build up 2..K)."
|
||||||
|
(interactive)
|
||||||
|
(cg-gaps--play 'cg-montana-game))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun cg-hells-half-acre ()
|
||||||
|
"Play Hell's Half-Acre solitaire (King at the head, build down K..2)."
|
||||||
|
(interactive)
|
||||||
|
(cg-gaps--play 'cg-acre-game))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defalias 'cg-gaps #'cg-montana
|
||||||
|
"Alias for `cg-montana'.")
|
||||||
|
|
||||||
|
(provide 'cg-gaps)
|
||||||
|
;;; cg-gaps.el ends here
|
||||||
381
cg-svg.el
Normal file
381
cg-svg.el
Normal file
|
|
@ -0,0 +1,381 @@
|
||||||
|
;;; cg-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.50
|
||||||
|
;; Package-Requires: ((emacs "26.1"))
|
||||||
|
;; Keywords: games
|
||||||
|
;; URL: https://github.com/corwin/card-games
|
||||||
|
|
||||||
|
;; 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.
|
||||||
|
;;
|
||||||
|
;; `cg-svg-cards-svg' lays specs out in a row; `cg-svg-grid-svg' lays
|
||||||
|
;; rows out as a grid. Both return an svg object; wrap with
|
||||||
|
;; `cg-svg-image' to insert or `cg-svg-to-string' to serialize.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'svg)
|
||||||
|
(require 'cg-core)
|
||||||
|
|
||||||
|
(defgroup cg-svg nil
|
||||||
|
"SVG rendering for card games."
|
||||||
|
:group 'card-games
|
||||||
|
:prefix "cg-svg-")
|
||||||
|
|
||||||
|
(defcustom cg-svg-card-width 56
|
||||||
|
"Card width in pixels."
|
||||||
|
:type 'integer :group 'cg-svg)
|
||||||
|
|
||||||
|
(defcustom cg-svg-card-height 80
|
||||||
|
"Card height in pixels."
|
||||||
|
:type 'integer :group 'cg-svg)
|
||||||
|
|
||||||
|
(defcustom cg-svg-card-gap 8
|
||||||
|
"Pixels between adjacent cards."
|
||||||
|
:type 'integer :group 'cg-svg)
|
||||||
|
|
||||||
|
(defcustom cg-svg-card-shadow t
|
||||||
|
"When non-nil, draw a soft drop shadow under each card."
|
||||||
|
:type 'boolean :group 'cg-svg)
|
||||||
|
|
||||||
|
(defcustom cg-svg-font-family "Helvetica, Arial, sans-serif"
|
||||||
|
"Font family used for ranks, pips and indices."
|
||||||
|
:type 'string :group 'cg-svg)
|
||||||
|
|
||||||
|
(defcustom cg-svg-theme-colors t
|
||||||
|
"When non-nil, derive the highlight ring and card back from the
|
||||||
|
active Emacs theme (with the colour variables below as fallbacks)."
|
||||||
|
:type 'boolean :group 'cg-svg)
|
||||||
|
|
||||||
|
(defcustom cg-svg-card-back 'dots
|
||||||
|
"Pattern drawn on a face-down card back."
|
||||||
|
:type '(choice (const dots) (const rings) (const solid)) :group 'cg-svg)
|
||||||
|
|
||||||
|
(defcustom cg-svg-four-color nil
|
||||||
|
"When non-nil use a four-colour deck: clubs green, diamonds blue-purple
|
||||||
|
\(spades stay black, hearts red)."
|
||||||
|
:type 'boolean :group 'cg-svg)
|
||||||
|
|
||||||
|
(defconst cg-svg-corner-radius 6
|
||||||
|
"Corner radius of a drawn card.")
|
||||||
|
|
||||||
|
(defvar cg-svg-red-color "#c0392b" "Colour for red suits.")
|
||||||
|
(defvar cg-svg-black-color "#2c3e50" "Colour for black suits.")
|
||||||
|
(defvar cg-svg-club-color "#1a8a3c" "Clubs colour in a four-colour deck.")
|
||||||
|
(defvar cg-svg-diamond-color "#3b3fb0" "Diamonds colour in a four-colour deck.")
|
||||||
|
(defvar cg-svg-joker-color "#8e44ad" "Colour for the Joker.")
|
||||||
|
(defvar cg-svg-face-color "#fdfdfb" "Card face fill.")
|
||||||
|
(defvar cg-svg-court-color "#f6f2e8" "Court-card inner panel fill.")
|
||||||
|
(defvar cg-svg-border-color "#566573" "Card border colour.")
|
||||||
|
(defvar cg-svg-back-color "#27496d" "Card back fill.")
|
||||||
|
(defvar cg-svg-back-trim "#9fb3cf" "Card back inner trim/dots.")
|
||||||
|
(defvar cg-svg-highlight-color "#f1c40f" "Cursor/selection highlight.")
|
||||||
|
(defvar cg-svg-gap-color "#95a5a6" "Empty-slot outline colour.")
|
||||||
|
|
||||||
|
(defun cg-svg--highlight ()
|
||||||
|
"Resolve the cursor/selection ring colour (theme-aware)."
|
||||||
|
(if cg-svg-theme-colors
|
||||||
|
(cg-color 'region :background cg-svg-highlight-color)
|
||||||
|
cg-svg-highlight-color))
|
||||||
|
|
||||||
|
(defun cg-svg--back-fill ()
|
||||||
|
"Resolve the card-back fill colour (theme-aware)."
|
||||||
|
(if cg-svg-theme-colors
|
||||||
|
(cg-color 'mode-line :background cg-svg-back-color)
|
||||||
|
cg-svg-back-color))
|
||||||
|
|
||||||
|
(defun cg-svg--court-fill (suit)
|
||||||
|
"Return a faint suit-tinted fill for a court card of SUIT."
|
||||||
|
(cond ((eq suit 'joker) "#f3eafa")
|
||||||
|
((cg-red-suit-p suit) "#fbeceb")
|
||||||
|
(t "#eef2f6")))
|
||||||
|
|
||||||
|
(defvar cg-svg-hint-color "#27ae60" "Colour ringing a valid move target.")
|
||||||
|
|
||||||
|
(defun cg-svg--hint ()
|
||||||
|
"Resolve the valid-move hint colour (theme-aware)."
|
||||||
|
(if cg-svg-theme-colors
|
||||||
|
(cg-color 'success :foreground cg-svg-hint-color)
|
||||||
|
cg-svg-hint-color))
|
||||||
|
|
||||||
|
(defconst cg-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 cg-svg--suit-color (suit)
|
||||||
|
"Return the ink colour for SUIT (0-3 or the symbol `joker')."
|
||||||
|
(cond ((eq suit 'joker) cg-svg-joker-color)
|
||||||
|
(cg-svg-four-color
|
||||||
|
(pcase suit (0 cg-svg-black-color) (1 cg-svg-club-color)
|
||||||
|
(2 cg-svg-diamond-color) (3 cg-svg-red-color)
|
||||||
|
(_ cg-svg-black-color)))
|
||||||
|
((cg-red-suit-p suit) cg-svg-red-color)
|
||||||
|
(t cg-svg-black-color)))
|
||||||
|
|
||||||
|
(defun cg-svg--suit-glyph (suit)
|
||||||
|
"Return the glyph for SUIT (0-3 or the symbol `joker')."
|
||||||
|
(if (eq suit 'joker) "★" (aref cg-suits suit)))
|
||||||
|
|
||||||
|
(defun cg-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 cg-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 cg-svg--index (svg x y w h rank glyph color flip)
|
||||||
|
"Draw a stacked RANK/GLYPH index in COLOR on SVG.
|
||||||
|
Top-left normally; 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))
|
||||||
|
(cg-svg--text svg rank ix ry rs color t tr))
|
||||||
|
(cg-svg--text svg glyph ix gy gs color nil tr)))
|
||||||
|
|
||||||
|
(defun cg-svg--pip (svg px py size glyph color flip)
|
||||||
|
"Draw a single pip GLYPH of SIZE in COLOR centred at PX, PY on SVG."
|
||||||
|
(cg-svg--text svg glyph px (+ py (* size 0.36)) size color nil
|
||||||
|
(and flip (format "rotate(180 %d %d)" (round px) (round py)))))
|
||||||
|
|
||||||
|
(defun cg-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 cg-svg--pip-layout))))
|
||||||
|
(dolist (pos layout)
|
||||||
|
(cg-svg--pip svg (+ x mx (* (car pos) iw)) (+ y my (* (cdr pos) ih))
|
||||||
|
ps glyph color (> (cdr pos) 0.5)))))
|
||||||
|
|
||||||
|
(defun cg-svg--draw-ace (svg x y w h glyph color)
|
||||||
|
"Draw a single large central pip (an ace) in COLOR on SVG."
|
||||||
|
(cg-svg--pip svg (+ x (/ w 2.0)) (+ y (/ h 2.0)) (round (* h 0.42))
|
||||||
|
glyph color nil))
|
||||||
|
|
||||||
|
(defun cg-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.
|
||||||
|
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* ((mx (round (* w 0.15))) (my (round (* h 0.16)))
|
||||||
|
(bx (+ x mx)) (by (+ y my))
|
||||||
|
(bw (- w (* 2 mx))) (bh (- h (* 2 my)))
|
||||||
|
(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 (cg-svg--court-fill suit)
|
||||||
|
:stroke color :stroke-width 1)
|
||||||
|
(cg-svg--text svg rank (+ x (/ w 2.0)) (+ y (* h 0.54)) (* h 0.34) color t)
|
||||||
|
(cg-svg--text svg glyph (+ x (/ w 2.0)) (+ y (* h 0.76)) (* h 0.20) color)))
|
||||||
|
|
||||||
|
(defun cg-svg--draw-joker (svg x y w h color)
|
||||||
|
"Draw the joker face in COLOR on SVG."
|
||||||
|
(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--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'."
|
||||||
|
(svg-rectangle svg x y w h :rx r :ry r :fill (cg-svg--back-fill)
|
||||||
|
: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
|
||||||
|
('solid nil)
|
||||||
|
('rings
|
||||||
|
(svg-rectangle svg (+ x 8) (+ y 8) (- w 16) (- h 16) :rx 5 :fill "none"
|
||||||
|
: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)))
|
||||||
|
(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--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 cg-svg-face-color
|
||||||
|
:stroke cg-svg-border-color :stroke-width 1)
|
||||||
|
(let ((color (cg-svg--suit-color suit))
|
||||||
|
(glyph (cg-svg--suit-glyph suit)))
|
||||||
|
(cg-svg--index svg x y w h rank glyph color nil)
|
||||||
|
(cg-svg--index svg x y w h rank glyph color t)
|
||||||
|
(cond
|
||||||
|
((eq suit 'joker) (cg-svg--draw-joker svg x y w h color))
|
||||||
|
((member rank '("J" "Q" "K")) (cg-svg--draw-court svg x y w h rank glyph color suit))
|
||||||
|
((equal rank "A") (cg-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))
|
||||||
|
(cg-svg--draw-pips svg x y w h n glyph color)
|
||||||
|
(cg-svg--text svg glyph (+ x (/ w 2.0)) (+ y (* h 0.6))
|
||||||
|
(* h 0.40) color)))))))
|
||||||
|
|
||||||
|
(cl-defun cg-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 cg-svg-card-width)
|
||||||
|
(h cg-svg-card-height)
|
||||||
|
(r cg-svg-corner-radius))
|
||||||
|
(when (and cg-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 cg-svg-gap-color :stroke-width 1.5
|
||||||
|
:stroke-dasharray "4,4"))
|
||||||
|
(down (cg-svg--draw-back svg x y w h r))
|
||||||
|
(t (cg-svg--draw-face svg x y w h r rank suit)))
|
||||||
|
(when hint
|
||||||
|
(svg-rectangle svg (- x 2) (- y 2) (+ w 4) (+ h 4) :rx (+ r 1)
|
||||||
|
:fill "none" :stroke (cg-svg--hint) :stroke-width 2
|
||||||
|
:stroke-dasharray "3,3"))
|
||||||
|
(when highlight
|
||||||
|
(let ((hl (cg-svg--highlight)))
|
||||||
|
(svg-rectangle svg (- x 4) (- y 4) (+ w 8) (+ h 8) :rx (+ r 3)
|
||||||
|
:fill "none" :stroke hl :stroke-opacity 0.45 :stroke-width 6)
|
||||||
|
(svg-rectangle svg (- x 3) (- y 3) (+ w 6) (+ h 6) :rx (+ r 2)
|
||||||
|
:fill "none" :stroke hl :stroke-width 2.5)))))
|
||||||
|
|
||||||
|
(defun cg-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) (cg-svg-card svg x y :gap t :highlight highlight :hint hint))
|
||||||
|
((eq spec 'down) (cg-svg-card svg x y :down t :highlight highlight :hint hint))
|
||||||
|
(t (cg-svg-card svg x y :rank (car spec) :suit (cdr spec)
|
||||||
|
:highlight highlight :hint hint))))
|
||||||
|
|
||||||
|
(cl-defun cg-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 cg-svg-card-width)
|
||||||
|
(h cg-svg-card-height)
|
||||||
|
(step (max 1 (- (+ w cg-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)
|
||||||
|
(cg-svg--draw-spec svg x pad spec (and highlight (= i highlight)))
|
||||||
|
(setq x (+ x step) i (1+ i))))
|
||||||
|
svg))
|
||||||
|
|
||||||
|
(cl-defun cg-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 cg-svg-card-width)
|
||||||
|
(h cg-svg-card-height)
|
||||||
|
(gx cg-svg-card-gap)
|
||||||
|
(gy cg-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)
|
||||||
|
(cg-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 cg-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 cg-svg-to-string (svg)
|
||||||
|
"Return the serialized XML string for SVG."
|
||||||
|
(with-temp-buffer
|
||||||
|
(svg-print svg)
|
||||||
|
(buffer-string)))
|
||||||
|
|
||||||
|
(provide 'cg-svg)
|
||||||
|
;;; cg-svg.el ends here
|
||||||
216
test/card-games-tests.el
Normal file
216
test/card-games-tests.el
Normal file
|
|
@ -0,0 +1,216 @@
|
||||||
|
;;; card-games-tests.el --- ERT tests for card-games -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Run with: make test (or)
|
||||||
|
;; emacs -Q --batch -L . -L test -l test/card-games-tests.el \
|
||||||
|
;; -f ert-run-tests-batch-and-exit
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'ert)
|
||||||
|
(require 'cl-lib)
|
||||||
|
(require 'card-games)
|
||||||
|
|
||||||
|
;;;; cg-core
|
||||||
|
|
||||||
|
(ert-deftest cgt-core-color-fallback ()
|
||||||
|
(should (equal "#123456" (cg-color 'no-such-face-xyzzy :background "#123456"))))
|
||||||
|
|
||||||
|
;;;; Gaps
|
||||||
|
|
||||||
|
(ert-deftest cgt-gaps-deal ()
|
||||||
|
(let* ((g (cg-gaps--deal (make-instance 'cg-montana-game)))
|
||||||
|
(b (cg-get g :board)) (cards 0) (gaps 0))
|
||||||
|
(dotimes (r 4) (dotimes (c 13)
|
||||||
|
(if (cg-gaps--cell b r c) (cl-incf cards) (cl-incf gaps))))
|
||||||
|
(should (= cards 48)) (should (= gaps 4))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-gaps-win ()
|
||||||
|
(let ((g (make-instance 'cg-montana-game)) (b (make-vector 4 nil)))
|
||||||
|
(dotimes (r 4)
|
||||||
|
(let ((row (make-vector 13 nil)))
|
||||||
|
(dotimes (c 12) (aset row c (cons r c)))
|
||||||
|
(aset b r row)))
|
||||||
|
(cg-put g :board b)
|
||||||
|
(should (cg-won-p g))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-acre-win ()
|
||||||
|
;; King-head descending: row r col c == (suit r . (- 11 c)), gap at col 12
|
||||||
|
(let ((g (make-instance 'cg-acre-game)) (b (make-vector 4 nil)))
|
||||||
|
(dotimes (r 4)
|
||||||
|
(let ((row (make-vector 13 nil)))
|
||||||
|
(dotimes (c 12) (aset row c (cons r (- 11 c))))
|
||||||
|
(aset b r row)))
|
||||||
|
(cg-put g :board b)
|
||||||
|
(should (cg-won-p g))
|
||||||
|
;; head gap wants a King; right of a Two is dead
|
||||||
|
(should (eq 'head (cg-gaps--needed g b 0 0)))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-acre-needed ()
|
||||||
|
(let ((g (make-instance 'cg-acre-game)) (b (make-vector 4 nil)))
|
||||||
|
(dotimes (r 4) (aset b r (make-vector 13 nil)))
|
||||||
|
;; left neighbour King(11) at (0,0): gap (0,1) wants Queen(10) same suit
|
||||||
|
(aset (aref b 0) 0 (cons 0 11))
|
||||||
|
(should (equal (cons 0 10) (cg-gaps--needed g b 0 1)))
|
||||||
|
;; left neighbour Two(0): nothing follows -> nil (Two is the dead end)
|
||||||
|
(aset (aref b 1) 0 (cons 0 0))
|
||||||
|
(should (null (cg-gaps--needed g b 1 1)))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-gaps-hit ()
|
||||||
|
(dotimes (r 4) (dotimes (c 13)
|
||||||
|
(let ((px (+ cg-gaps--svg-pad (* c (+ cg-gaps--svg-card-w cg-gaps--svg-gap))
|
||||||
|
(/ cg-gaps--svg-card-w 2)))
|
||||||
|
(py (+ cg-gaps--svg-pad (* r (+ cg-gaps--svg-card-h cg-gaps--svg-gap))
|
||||||
|
(/ cg-gaps--svg-card-h 2))))
|
||||||
|
(should (equal (cons r c) (cg-gaps--xy->cell px py)))))))
|
||||||
|
|
||||||
|
;;;; 500
|
||||||
|
|
||||||
|
(ert-deftest cgt-bid-deck () (should (= 45 (length (cg-bid--full-deck)))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-bid-power ()
|
||||||
|
(should (> (cg-bid-power cg-bid-joker 0 0) (cg-bid-power '(0 . 7) 0 0)))
|
||||||
|
(should (> (cg-bid-power '(0 . 7) 0 0) (cg-bid-power '(1 . 7) 0 0)))
|
||||||
|
(should (< (cg-bid-power '(2 . 10) 0 3) 100)))
|
||||||
|
|
||||||
|
(ert-deftest cgt-bid-trick ()
|
||||||
|
(should (= 2 (cg-bid-trick-winner
|
||||||
|
'((0 . (3 . 10)) (1 . (3 . 0)) (2 . (0 . 0)) (3 . (2 . 10))) 0 3))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-bid-follow ()
|
||||||
|
(should (equal '((1 . 7)) (cg-bid-legal-cards '((1 . 7) (1 . 0) (3 . 0)) 0 0))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-bid-sort-display ()
|
||||||
|
(should (cg-bid-joker-p
|
||||||
|
(car (cg-bid-sort-display (list '(3 . 10) cg-bid-joker '(0 . 7)) 0)))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-bid-south-hit ()
|
||||||
|
(dolist (n '(1 5 10 15))
|
||||||
|
(cl-destructuring-bind (x0 step y) (cg-bid--south-layout n)
|
||||||
|
(dotimes (i n)
|
||||||
|
(should (equal i (cg-bid--south-hit (+ x0 (* i step) 2) (+ y 5) n)))))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-bid-full-game ()
|
||||||
|
(let ((cg-bid--human-seats nil))
|
||||||
|
(dotimes (_ 12)
|
||||||
|
(let ((g (cg-bid--deal (make-instance 'cg-bid-game))) (guard 0))
|
||||||
|
(cg-bid--run g)
|
||||||
|
(while (and (not (eq (cg-get g :phase) 'gameover)) (< (cl-incf guard) 4000))
|
||||||
|
(cg-bid--deal g (mod (1+ (cg-get g :dealer)) 4)) (cg-bid--run g))
|
||||||
|
(should (eq 'gameover (cg-get g :phase)))))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-bid-smart-beats-basic ()
|
||||||
|
(let ((w0 0) (w1 0))
|
||||||
|
(random "ert-h2h")
|
||||||
|
(dotimes (_ 50)
|
||||||
|
(let ((cg-bid--human-seats nil)
|
||||||
|
(cg-bid-ai-policies (vector 'smart 'basic 'smart 'basic))
|
||||||
|
(g (cg-bid--deal (make-instance 'cg-bid-game))) (guard 0))
|
||||||
|
(cg-bid--run g)
|
||||||
|
(while (and (not (eq (cg-get g :phase) 'gameover)) (< (cl-incf guard) 4000))
|
||||||
|
(cg-bid--deal g (mod (1+ (cg-get g :dealer)) 4)) (cg-bid--run g))
|
||||||
|
(pcase (cg-get g :game-over) (0 (cl-incf w0)) (1 (cl-incf w1)))))
|
||||||
|
(should (> w0 (* 1.8 w1)))))
|
||||||
|
|
||||||
|
;;;; SVG
|
||||||
|
|
||||||
|
(ert-deftest cgt-svg-builds ()
|
||||||
|
(should (stringp (cg-svg-to-string
|
||||||
|
(cg-svg-grid-svg (list (list (cons "A" 0) (cons nil 'joker) 'down nil))))))
|
||||||
|
(should (stringp (cg-svg-to-string
|
||||||
|
(cg-bid--table-svg (cg-bid--deal (make-instance 'cg-bid-game)))))))
|
||||||
|
|
||||||
|
;;;; Chooser
|
||||||
|
|
||||||
|
(ert-deftest cgt-chooser-registry ()
|
||||||
|
(should (assoc "500 (Bid)" card-games-list))
|
||||||
|
(should (commandp 'card-game)))
|
||||||
|
|
||||||
|
(provide 'card-games-tests)
|
||||||
|
;;; card-games-tests.el ends here
|
||||||
|
|
||||||
|
(ert-deftest cgt-ai-step ()
|
||||||
|
;; ai-step advances within a hand; the caller deals the next hand at 'done.
|
||||||
|
(let ((cg-bid--human-seats nil)
|
||||||
|
(g (cg-bid--deal (make-instance 'cg-bid-game))) (guard 0))
|
||||||
|
(while (and (not (eq (cg-get g :phase) 'gameover)) (< (cl-incf guard) 6000))
|
||||||
|
(unless (cg-bid--ai-step g)
|
||||||
|
(cg-bid--deal g (mod (1+ (cg-get g :dealer)) 4))))
|
||||||
|
(should (eq 'gameover (cg-get g :phase)))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-card-back-presets ()
|
||||||
|
(dolist (cg-svg-card-back '(dots rings solid))
|
||||||
|
(should (stringp (cg-svg-to-string
|
||||||
|
(cg-svg-cards-svg (list 'down)))))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-set-theme ()
|
||||||
|
(let ((inhibit-message t)) ; keep the theme banner out of test output
|
||||||
|
(card-games-set-theme 'dark)
|
||||||
|
(should (equal "#23272e" cg-bid-felt-color))
|
||||||
|
(card-games-set-theme 'classic)
|
||||||
|
(should (equal "#15692f" cg-bid-felt-color))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-scale ()
|
||||||
|
(require 'face-remap)
|
||||||
|
(let ((text-scale-mode-amount 0)) (should (= 1.0 (cg-scale))))
|
||||||
|
(let ((text-scale-mode-amount 2)) (should (> (cg-scale) 1.0)))
|
||||||
|
(let ((text-scale-mode-amount -2)) (should (< (cg-scale) 1.0))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-mode-line-announce ()
|
||||||
|
(let ((g (cg-bid--deal (make-instance 'cg-bid-game))))
|
||||||
|
(should (stringp (cg-bid--mode-line g)))
|
||||||
|
(should (string-match-p "bid" (cg-bid--mode-line g)))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-gaps-mode-line ()
|
||||||
|
(let ((g (cg-gaps--deal (make-instance 'cg-montana-game))))
|
||||||
|
(should (string-match-p "moves" (cg-gaps--mode-line g)))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-keys-default ()
|
||||||
|
(should (eq cg-keys 'emacs))
|
||||||
|
(should (commandp 'cg-gaps-redraw))
|
||||||
|
(should (commandp 'cg-bid-redraw))
|
||||||
|
;; g redraws (not new)
|
||||||
|
(should (eq 'cg-gaps-redraw (lookup-key cg-gaps-mode-map "g")))
|
||||||
|
(should (eq 'cg-bid-redraw (lookup-key cg-bid-mode-map "g"))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-keys-classic ()
|
||||||
|
;; emacs map has no h/SPC binding; classic adds them
|
||||||
|
(should-not (lookup-key cg-gaps-mode-map "h"))
|
||||||
|
(should (eq 'cg-gaps-left (lookup-key (cg-gaps--classic-keymap) "h")))
|
||||||
|
(should (eq 'cg-bid-left (lookup-key (cg-bid--classic-keymap) "h"))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-svgui-builds ()
|
||||||
|
(let ((g (cg-bid--deal (make-instance 'cg-bid-game))))
|
||||||
|
(cg-put g :phase 'auction) (cg-put g :bidder 0)
|
||||||
|
(let ((sr (cg-bid--ui-svg g)))
|
||||||
|
(should (stringp (cg-svg-to-string (car sr))))
|
||||||
|
;; available bids have clickable rects; a cell centre maps back to its bid
|
||||||
|
(let* ((bids (plist-get (cdr sr) :bids)) (e (car bids))
|
||||||
|
(r (cdr e)) (cx (+ (nth 0 r) (/ (nth 2 r) 2))) (cy (+ (nth 1 r) (/ (nth 3 r) 2))))
|
||||||
|
(should (eq (car e) (cg-bid--region-bid cx cy (cdr sr))))))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-gaps-svgui-builds ()
|
||||||
|
;; the full-SVG gaps UI builds, and a cell centre maps back to its (row . col)
|
||||||
|
(let ((g (cg-gaps--deal (make-instance 'cg-montana-game))))
|
||||||
|
(let* ((sr (cg-gaps--ui-svg g 820 380))
|
||||||
|
(geom (plist-get (cdr sr) :board))
|
||||||
|
(x0 (nth 0 geom)) (y0 (nth 1 geom))
|
||||||
|
(cw (nth 2 geom)) (ch (nth 3 geom)) (gp (nth 4 geom)))
|
||||||
|
(should (stringp (cg-svg-to-string (car sr))))
|
||||||
|
(should (plist-get (cdr sr) :new)) ; control regions present
|
||||||
|
(should (equal (cons 2 3)
|
||||||
|
(cg-gaps--ui-cell (+ x0 (* 3 (+ cw gp)) (/ cw 2))
|
||||||
|
(+ y0 (* 2 (+ ch gp)) (/ ch 2))
|
||||||
|
geom))))))
|
||||||
|
|
||||||
|
(ert-deftest cgt-classic-folds-controls ()
|
||||||
|
;; graphical classic UI: one action-button row, no textual key-help
|
||||||
|
(with-temp-buffer
|
||||||
|
(cg-bid-mode)
|
||||||
|
(setq cg-bid--game (cg-bid--deal (make-instance 'cg-bid-game)))
|
||||||
|
(let ((cg-bid-svg-ui nil) (inhibit-read-only t))
|
||||||
|
(cg-bid--insert-graphical cg-bid--game)
|
||||||
|
(cg-bid--insert-buttons cg-bid--game))
|
||||||
|
(let ((s (buffer-string)))
|
||||||
|
(should-not (string-match-p "RET\\] play card" s)) ; key-help removed
|
||||||
|
(should (string-match-p "Help" s)) ; button row present
|
||||||
|
(should-not (string-match-p "New" s))))) ; no mid-hand new deal
|
||||||
Loading…
Add table
Add a link
Reference in a new issue