Compare commits
10 commits
| Author | SHA1 | Date | |
|---|---|---|---|
| ff7a9f6e49 | |||
| 99cf31930b | |||
| 209ebdc02a | |||
| 6379127e17 | |||
|
1a59003b13 | ||
|
|
ade2f38ee3 | ||
|
|
640aaca1ae | ||
|
|
3b55d780b0 | ||
|
|
f8873fb8fa | ||
|
|
9d3ec08d3c |
51 changed files with 15674 additions and 15066 deletions
113
LIFT.md
Normal file
113
LIFT.md
Normal file
|
|
@ -0,0 +1,113 @@
|
|||
# LIFT · card-game — CANDIDATE
|
||||
|
||||
Session 2026-08-03. Everything here is CANDIDATE until Corwin says otherwise.
|
||||
Scope: only the repo (`card-game.el`) was mounted — not the `card-game` project
|
||||
wrapper the brief named, not `dungeon`, not `c4/`. The sandbox had no system
|
||||
Emacs (apt blocked, non-root), but the recorded micromamba recipe delivered a
|
||||
userspace Emacs 30 — so the oracle below was RUN this session, not quoted.
|
||||
|
||||
## 1. What it IS
|
||||
|
||||
**card-games** v1.0.91 ("pretest2: playtest"): a GNU ELPA-style Emacs package
|
||||
of ~30 card games over one small EIEIO engine (`cg-core.el`, 324 lines).
|
||||
Abstract `cg-game` (name + plist `env` + current renderer) with `cg-render` /
|
||||
`cg-won-p` generics; family base classes (`cg-solitaire-game`, `cg-trick-game`,
|
||||
`cg-rummy-game`→`cg-tablemeld-game`, `cg-fish-game`, `cg-patience-game`,
|
||||
`cg-gaps-game`) carry shared rules; each game is a small subclass. Display is a
|
||||
separate seam: renderer "skins" (`text`, `svg`, `svg-fill`) registered by name,
|
||||
each mapping clicks back to game actions via rectangle→action region lists.
|
||||
Cards are `(SUIT . RANK)` conses, suits indexed 0=♠ 1=♣ 2=♦ 3=♥, rank scales
|
||||
per-game, `nil` = empty slot. Ships an Info manual, a Makefile exposing the
|
||||
full lifecycle, network play for 500 (`cg-bid-host`/`cg-bid-join`), and a
|
||||
150-test ERT suite. Maintenance-stage; published at code.bru.st/corwin/card-game.
|
||||
|
||||
## 2. The oracle (the ONE thing that already fails loudly)
|
||||
|
||||
**`make test` — test/card-games-tests.el, 150 `ert-deftest`s, batch exit
|
||||
nonzero on any failure — and `release:` refuses to package without it**
|
||||
(`release: distclean version readme test tarball`). The suite header documents
|
||||
the exact no-make invocation:
|
||||
|
||||
emacs -Q --batch -L . -L test -l test/card-games-tests.el \
|
||||
-f ert-run-tests-batch-and-exit
|
||||
|
||||
**RUN this session** (userspace Emacs 30, tree exported from git HEAD objects
|
||||
into /tmp — no mount-desync exposure): **150/150 passed, 0 unexpected, 15.4s,
|
||||
exit 0** (2026-08-03 20:07:52-0500). Secondary gate also run: batch
|
||||
byte-compile of all 24 EL files — **clean, zero warnings**. Remaining gate
|
||||
family not run here: `checkdoc`, `lint`.
|
||||
|
||||
## 3. What C4 takes FROM it
|
||||
|
||||
Each claim names the tool that fails it.
|
||||
|
||||
- **The renderer-seam pattern.** One game model, N display treatments,
|
||||
registered by name, never subclassing the game per treatment; clicks map
|
||||
back through declared `(RECT . ACTION)` regions; `cg-color` degrades to a
|
||||
drawable fallback in batch/terminal. This is the house answer to "one truth,
|
||||
two representations" for any C4 surface with console + graphical faces.
|
||||
*Fails-it:* `cgt-render-registry` and kin in the suite.
|
||||
- **Taxonomy-by-family engine reuse.** Engine → family base → thin game
|
||||
subclass; 30 games prove the substrate. The C4RP shared-substrate story
|
||||
working in miniature. *Fails-it:* the per-family ERT groups.
|
||||
- **The oracle discipline itself.** One test file, one batch line, wired into
|
||||
`make test` and gating `release`. rewire-order says go first with the
|
||||
project that has an oracle — this one HAS one. *Fails-it:* itself.
|
||||
- **Org→MD canonicity, implemented.** README.org is source; `build.el` (ox-md,
|
||||
never-signal, `CARD_GAMES_ORG` override) exports; a pre-commit hook keeps
|
||||
README.md in step. ORG-NATIVE stance made mechanical. *Fails-it (host):*
|
||||
`make readme && git diff --exit-code README.md` — empty diff = in step.
|
||||
Not proven here (needs Emacs); the md-newer-than-org mtimes are consistent
|
||||
but mtime is never a tiebreaker.
|
||||
- **Version fan-out.** Single `VERSION` in the Makefile; `make version`
|
||||
regenerates `doc/version.texi`; bump patch z for every releasable set.
|
||||
*Fails-it (ran, passed):* `grep '^;; Version:' *.el | sort -u` — one value,
|
||||
1.0.91, across 24 headers + Makefile + pkg.el + version.texi.
|
||||
- **Scars kept as comments.** The release tar archives an explicit file list
|
||||
because ".": "the growing output tarball … is never read mid-write — which
|
||||
is what caused 'tar: .: file changed as we read it'." The failure mode rides
|
||||
with the fix. Liftable practice, not just this instance.
|
||||
|
||||
## 4. Vocabulary (for the `dungeon:cards` negotiation)
|
||||
|
||||
Dungeon is not mounted; I cannot see its side. This is card-game's offer,
|
||||
one-sided, plus the C4 terms this repo does not use.
|
||||
|
||||
**card-game has, C4/dungeon must match or map:** card `(SUIT . RANK)`;
|
||||
**suit index order 0♠ 1♣ 2♦ 3♥** (black-black-red-red — NOT bridge order
|
||||
♣♦♥♠; first and likeliest silent-drift item, negotiate before any shared
|
||||
register); per-game rank scales (no global ace-high/low); `joker`; `nil` =
|
||||
empty slot; `sister-suit` (same-colour partner); renderer/"skin"/"treatment";
|
||||
`env` (per-game plist); region/action click maps; pile nouns — foundation,
|
||||
tableau, stock, waste, reserve, cell, gap, hand, trick, book, bags, meld,
|
||||
house (Russian Bank), crib/peg, capture. Shuffle is Fisher-Yates over Emacs
|
||||
`random` — seedability for replay/net determinism is a negotiation point,
|
||||
not currently a promise.
|
||||
|
||||
**C4 has, this repo does not:** run-level, oracle (the word; it has the
|
||||
thing), vocab/register, lift, candidate/canon, run-card, instrument. The repo
|
||||
predates the register; nothing in it will collide, but nothing anchors it
|
||||
either.
|
||||
|
||||
## 5. Run-level evidence (guess was ~4)
|
||||
|
||||
The Makefile exposes the lifecycle as named signals: `compile`, `test`,
|
||||
`checkdoc`, `lint`, `package`, `elpa`, `release`, `info`, `hooks` — with
|
||||
self-test gating release, install via standard package.el, and enablement via
|
||||
`M-x card-game` plus a shipped Info manual. From this sandbox I verified only
|
||||
static signals. The run-level scale itself lives in `c4/`, deliberately not
|
||||
mounted — I hold no instrument for the pin; evidence reads at-or-above the
|
||||
guess, and the pin stays with Corwin.
|
||||
|
||||
## 6. Session receipts
|
||||
|
||||
- No system Emacs (uid 1174, apt blocked); micromamba userspace Emacs 30
|
||||
worked (recipe from session memory). Oracle run 150/150; compile clean.
|
||||
Mount-vs-HEAD spot-check agreed on 4 files before the run (no desync seen).
|
||||
- Memory drift found and corrected in session notes: tree is at 1.0.91 /
|
||||
30 games / 150 tests (notes said 1.0.60 / 5 games / 88).
|
||||
- org-c4 brief arrived in the same paste; org-c4 is not mounted — not
|
||||
executable here, untouched.
|
||||
- Git reads were object-reads only (`git log`); no index-touching commands
|
||||
on the mount. Tree tarballs and `*~` files are `.gitignore`d by design.
|
||||
- This file is untracked on purpose: CANDIDATE, his pen to bless, never mine.
|
||||
16
Makefile
16
Makefile
|
|
@ -2,8 +2,8 @@
|
|||
EMACS ?= emacs
|
||||
PKG = card-games
|
||||
VERSION = 1.0.91
|
||||
# Source files in dependency order (cg-core first).
|
||||
EL = cg-core.el cg-svg.el cg-render.el cg-net.el cg-bid.el cg-gaps.el cg-bid-ui.el cg-bid-net.el cg-solitaire.el cg-trick.el cg-eights.el cg-patience.el cg-president.el cg-rummy.el cg-rum500.el cg-handfoot.el cg-match.el cg-cribbage.el cg-scopa.el cg-trick-ext.el cg-spite.el cg-bridge.el cg-crapette.el card-games.el
|
||||
# Source files in dependency order (card-games-core first).
|
||||
EL = card-games-core.el card-games-svg.el card-games-render.el card-games-net.el card-games-bid.el card-games-gaps.el card-games-bid-ui.el card-games-bid-net.el card-games-solitaire.el card-games-trick.el card-games-eights.el card-games-patience.el card-games-president.el card-games-rummy.el card-games-rum500.el card-games-handfoot.el card-games-match.el card-games-cribbage.el card-games-scopa.el card-games-trick-ext.el card-games-spite.el card-games-bridge.el card-games-crapette.el card-games.el
|
||||
ELC = $(EL:.el=.elc)
|
||||
PKGDESC = $(PKG)-pkg.el
|
||||
TARDIR = $(PKG)-$(VERSION)
|
||||
|
|
@ -20,7 +20,7 @@ TEXI2PDF ?= texi2pdf
|
|||
README = README.md
|
||||
EXTRA = README.org $(README) $(PKGDESC) $(MANUAL) $(VERTEXI) $(IMAGES)
|
||||
|
||||
.PHONY: all compile test clean distclean checkdoc lint package tarball elpa release help \
|
||||
.PHONY: all compile test clean distclean checkdoc lint check package tarball elpa release help \
|
||||
info info-emacs html pdf docclean version readme hooks
|
||||
|
||||
help:
|
||||
|
|
@ -29,6 +29,7 @@ help:
|
|||
@echo " test run the ERT test suite"
|
||||
@echo " checkdoc run checkdoc on all sources"
|
||||
@echo " lint run package-lint (if installed)"
|
||||
@echo " check compile + checkdoc + lint + test (the full gate)"
|
||||
@echo " version regenerate $(VERTEXI) from VERSION"
|
||||
@echo " readme export README.org -> README.md (Emacs batch)"
|
||||
@echo " hooks install the git pre-commit hook"
|
||||
|
|
@ -50,8 +51,13 @@ compile:
|
|||
test:
|
||||
$(BATCH) -L test -l test/$(PKG)-tests.el -f ert-run-tests-batch-and-exit
|
||||
|
||||
# One gate a contributor (or CI) can run: the same quality tools MELPA
|
||||
# asks for -- byte-compile, checkdoc, package-lint -- plus the ERT suite.
|
||||
check: compile checkdoc lint test
|
||||
@echo "card-games $(VERSION): compile + checkdoc + lint + tests all green"
|
||||
|
||||
checkdoc:
|
||||
$(BATCH) --eval "(progn (dolist (f '($(EL))) (checkdoc-file f)))"
|
||||
$(BATCH) --eval "(progn (dolist (f '($(EL))) (checkdoc-file (symbol-name f))))"
|
||||
|
||||
lint:
|
||||
-$(BATCH) --eval "(progn (require 'package) (package-initialize) \
|
||||
|
|
@ -82,7 +88,7 @@ elpa: tarball
|
|||
# (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) build.el hooks Makefile .gitignore test
|
||||
release: distclean version readme test tarball
|
||||
release: distclean version readme check tarball
|
||||
rm -f $(SRCTAR)
|
||||
tar --transform 's,^,$(TARDIR)/,' \
|
||||
--exclude='*.elc' --exclude='*.tar' --exclude='*.tar.gz' \
|
||||
|
|
|
|||
120
README.md
120
README.md
|
|
@ -6,7 +6,7 @@ mouse on a graphical display.
|
|||
|
||||
|
||||
On a graphical display the cards are drawn as SVG; in a terminal they
|
||||
fall back to UNICODE glyphs (customize `card-game-symbols`). You can
|
||||
fall back to UNICODE glyphs (customize `card-games-symbols`). You can
|
||||
switch how every game is drawn from the menu – `text` (UNICODE),
|
||||
`svg` (drawn cards), or `full` (a full-window SVG table) – and dial the
|
||||
computer opponents between `easy`, `normal`, and `hard`.
|
||||
|
|
@ -17,79 +17,79 @@ choose **Card Games**, or `M-x info RET (card-games) RET`.
|
|||
|
||||
# Games
|
||||
|
||||
To open the game menu type `M-x card-game`, or start a game directly
|
||||
To open the game menu type `M-x card-games`, or start a game directly
|
||||
with its command. From the menu you can also switch the card treatment
|
||||
(text / SVG / full-window) and the AI difficulty.
|
||||
|
||||
|
||||
## Trick-taking
|
||||
|
||||
- `cg-bid` – 500 (Bid). Win the auction, name the trump suit, then take
|
||||
- `card-games-bid` – 500 (Bid). Win the auction, name the trump suit, then take
|
||||
tricks with your partner to reach 500 points before the opposing pair.
|
||||
Also playable live over the network (`M-x cg-bid-host` / `cg-bid-join`).
|
||||
- `cg-hearts` – Hearts. Avoid taking hearts and the Queen of Spades, or
|
||||
Also playable live over the network (`M-x card-games-bid-host` / `card-games-bid-join`).
|
||||
- `card-games-hearts` – Hearts. Avoid taking hearts and the Queen of Spades, or
|
||||
take them all to "shoot the moon"; lowest score loses.
|
||||
- `cg-spades` – Spades. Partnership bidding to 500; spades are always
|
||||
- `card-games-spades` – Spades. Partnership bidding to 500; spades are always
|
||||
trump. Make your side's combined bid, mind the bags, dare a nil.
|
||||
- `cg-whist` – Whist. Trump is the turned card, there is no bidding;
|
||||
- `card-games-whist` – Whist. Trump is the turned card, there is no bidding;
|
||||
score one point for each trick past the book of six.
|
||||
- `cg-ohhell` – Oh Hell. The hand shrinks each round; bid the exact
|
||||
- `card-games-ohhell` – Oh Hell. The hand shrinks each round; bid the exact
|
||||
number of tricks you will take, no more and no fewer.
|
||||
|
||||
|
||||
## Solitaire
|
||||
|
||||
- `cg-montana` – Montana (also called Gaps). Each row is anchored by a
|
||||
- `card-games-montana` – Montana (also called Gaps). Each row is anchored by a
|
||||
Two and built upward in one suit, 2 through King; slide cards into the
|
||||
gaps until all four rows are sorted.
|
||||
- `cg-gaps` – an alias for `cg-montana`.
|
||||
- `cg-hells-half-acre` – the build-down variant: each row is anchored by
|
||||
- `card-games-gaps` – an alias for `card-games-montana`.
|
||||
- `card-games-hells-half-acre` – the build-down variant: each row is anchored by
|
||||
a King and built downward, King through 2.
|
||||
- `cg-klondike` – Klondike, the classic "Solitaire": build the four
|
||||
- `card-games-klondike` – Klondike, the classic "Solitaire": build the four
|
||||
foundations up by suit from the Ace.
|
||||
- `cg-freecell` – FreeCell: every card in view, four free cells, a game
|
||||
- `card-games-freecell` – FreeCell: every card in view, four free cells, a game
|
||||
of nearly pure skill.
|
||||
- `cg-spider` – Spider (two decks): build down regardless of suit, but
|
||||
- `card-games-spider` – Spider (two decks): build down regardless of suit, but
|
||||
only same-suit runs move; clear eight King-to-Ace runs.
|
||||
- `cg-yukon` – Yukon: Klondike's layout dealt mostly face up, with any
|
||||
- `card-games-yukon` – Yukon: Klondike's layout dealt mostly face up, with any
|
||||
buried group movable and no stock.
|
||||
- `cg-canfield` – Canfield: a 13-card reserve and a foundation base rank
|
||||
- `card-games-canfield` – Canfield: a 13-card reserve and a foundation base rank
|
||||
set by the deal; foundations wrap King to Ace.
|
||||
- `cg-forty-thieves` – Forty Thieves: two decks, ten columns, eight
|
||||
- `card-games-forty-thieves` – Forty Thieves: two decks, ten columns, eight
|
||||
foundations, build down by suit, and no second pass through the stock.
|
||||
- `cg-scorpion` – Scorpion: build down by suit and free any buried group
|
||||
- `card-games-scorpion` – Scorpion: build down by suit and free any buried group
|
||||
to assemble four King-to-Ace runs.
|
||||
- `cg-golf` – Golf: clear the layout by playing exposed cards one rank
|
||||
- `card-games-golf` – Golf: clear the layout by playing exposed cards one rank
|
||||
above or below the waste top.
|
||||
- `cg-tripeaks` – TriPeaks: the same, on three overlapping peaks, with
|
||||
- `card-games-tripeaks` – TriPeaks: the same, on three overlapping peaks, with
|
||||
Ace-King wrapping for long chains.
|
||||
- `cg-pyramid` – Pyramid: remove pairs of exposed cards whose ranks sum
|
||||
- `card-games-pyramid` – Pyramid: remove pairs of exposed cards whose ranks sum
|
||||
to thirteen; Kings go alone.
|
||||
|
||||
|
||||
## Shedding and climbing
|
||||
|
||||
- `cg-eights` – Crazy Eights. Match the suit or rank of the discard;
|
||||
- `card-games-eights` – Crazy Eights. Match the suit or rank of the discard;
|
||||
eights are wild and let you name the next suit.
|
||||
- `cg-president` – President (Scum). Climb: play one to four of a rank,
|
||||
- `card-games-president` – President (Scum). Climb: play one to four of a rank,
|
||||
beat it or pass; first out rules, last out scrubs, and the roles trade
|
||||
cards on the next deal.
|
||||
|
||||
|
||||
## Rummy
|
||||
|
||||
- `cg-gin` – Gin Rummy. A two-handed duel: draw or take the discard,
|
||||
- `card-games-gin` – Gin Rummy. A two-handed duel: draw or take the discard,
|
||||
build sets and runs, and knock once your deadwood is ten or less, or go
|
||||
gin with none; your opponent then lays off and may undercut you. First
|
||||
to 100 wins.
|
||||
- `cg-rummy-basic` – Rummy. Meld sets and runs onto the table and lay
|
||||
- `card-games-rummy-basic` – Rummy. Meld sets and runs onto the table and lay
|
||||
cards off onto them; empty your hand to go out and score the cards left
|
||||
in the other hands.
|
||||
- `cg-rum500` – Rummy 500. As above, but you score the cards you lay
|
||||
- `card-games-rum500` – Rummy 500. As above, but you score the cards you lay
|
||||
down and lose the cards left in your hand; first past 500 wins. Take a
|
||||
buried discard card with `T`: you take it and every card above it, and
|
||||
meld the chosen card at once.
|
||||
- `cg-handfoot` – Hand & Foot. A partnership Canasta cousin: play a hand
|
||||
- `card-games-handfoot` – Hand & Foot. A partnership Canasta cousin: play a hand
|
||||
and then a foot, build books of a rank with Twos and Jokers wild, and go
|
||||
out once your side has completed two of them. Each round opens with a
|
||||
rising go-down minimum (50, 90, 120, 150); red threes are bonus cards;
|
||||
|
|
@ -99,48 +99,48 @@ with its command. From the menu you can also switch the card treatment
|
|||
|
||||
## Matching
|
||||
|
||||
- `cg-go-fish` – Go Fish. Ask another player for a rank you hold;
|
||||
- `card-games-go-fish` – Go Fish. Ask another player for a rank you hold;
|
||||
collect all four to lay down a book, and make the most books.
|
||||
- `cg-old-maid` – Old Maid. One Queen is set aside; discard pairs and
|
||||
- `card-games-old-maid` – Old Maid. One Queen is set aside; discard pairs and
|
||||
draw blind from your neighbour, and do not be left with the odd Queen.
|
||||
|
||||
|
||||
## Pegging
|
||||
|
||||
- `cg-cribbage` – Cribbage. Lay two cards to the crib, cut a starter,
|
||||
- `card-games-cribbage` – Cribbage. Lay two cards to the crib, cut a starter,
|
||||
peg toward 31, then count fifteens, pairs, runs, flushes, and his nobs.
|
||||
Two-handed to 121.
|
||||
|
||||
|
||||
## Capturing
|
||||
|
||||
- `cg-scopa` – Scopa. A 40-card deck; capture table cards by value and
|
||||
- `card-games-scopa` – Scopa. A 40-card deck; capture table cards by value and
|
||||
sweep the board for a scopa. Score cards, coins, the sette bello, and
|
||||
primiera to 11.
|
||||
- `cg-casino` – Casino. The full deck; capture by pairs and sums and
|
||||
- `card-games-casino` – Casino. The full deck; capture by pairs and sums and
|
||||
score cards, spades, the casinos, and aces to 21.
|
||||
|
||||
|
||||
## More trick-taking
|
||||
|
||||
- `cg-euchre` – Euchre. A 24-card deck with the two bowers; order up or
|
||||
- `card-games-euchre` – Euchre. A 24-card deck with the two bowers; order up or
|
||||
call trump and take three of five tricks. Partnership to 10.
|
||||
- `cg-pitch` – Auction Pitch. Bid for the pitch; your first lead sets
|
||||
- `card-games-pitch` – Auction Pitch. Bid for the pitch; your first lead sets
|
||||
trump. Score High, Low, Jack, and Game; first to 7.
|
||||
- `cg-briscola` – Briscola. A fixed trump turned from the deal and no
|
||||
- `card-games-briscola` – Briscola. A fixed trump turned from the deal and no
|
||||
obligation to follow suit; capture the Aces and Threes. Partnership to
|
||||
61 of the 120 points.
|
||||
|
||||
|
||||
## Climbing patience
|
||||
|
||||
- `cg-spite` – Spite & Malice. Race the computer to empty your goal
|
||||
- `card-games-spite` – Spite & Malice. Race the computer to empty your goal
|
||||
pile onto shared centre piles that build Ace to Queen; Kings are wild.
|
||||
|
||||
|
||||
## Bridge
|
||||
|
||||
- `cg-bridge` – Contract Bridge. A full auction (bids, pass, double,
|
||||
- `card-games-bridge` – Contract Bridge. A full auction (bids, pass, double,
|
||||
redouble), play with the dummy exposed, and classic rubber scoring with
|
||||
vulnerability. You are South; when you declare you play the dummy too.
|
||||
The bidding AI is a small natural system, sensible but no expert.
|
||||
|
|
@ -148,7 +148,7 @@ with its command. From the menu you can also switch the card treatment
|
|||
|
||||
## Two-player patience
|
||||
|
||||
- `cg-russian-bank` / `cg-crapette` – Russian Bank (Crapette). A race
|
||||
- `card-games-russian-bank` / `card-games-crapette` – Russian Bank (Crapette). A race
|
||||
against the computer: build the eight shared foundations up by suit,
|
||||
build the shared houses down in alternating colour, and empty your
|
||||
reserve to win. Load your cards onto your opponent's piles when the
|
||||
|
|
@ -160,7 +160,7 @@ with its command. From the menu you can also switch the card treatment
|
|||
|
||||
# TODO
|
||||
|
||||
- [X] make the suit symbols customizable (`cg-symbols`) and obey them
|
||||
- [X] make the suit symbols customizable (`card-games-symbols`) and obey them
|
||||
- [X] a Texinfo manual
|
||||
- [ ] finish `checkdoc` docstrings across the per-game files
|
||||
(the shared engine files are clean; `make compile` is warning-free)
|
||||
|
|
@ -187,9 +187,9 @@ ELPA archive), the whole collection loads from the single `card-games`
|
|||
feature:
|
||||
|
||||
(use-package card-games
|
||||
:commands (card-game cg-klondike cg-bid cg-hearts cg-gin cg-crapette))
|
||||
:commands (card-games card-games-klondike card-games-bid card-games-hearts card-games-gin card-games-crapette))
|
||||
|
||||
Then `M-x card-game` for the menu.
|
||||
Then `M-x card-games` for the menu.
|
||||
|
||||
|
||||
## From a local ELPA archive
|
||||
|
|
@ -203,7 +203,7 @@ Then `M-x card-game` for the menu.
|
|||
|
||||
## Manually
|
||||
|
||||
Put the `cg-*.el` and `card-games.el` files on your `load-path` and
|
||||
Put the `card-games-*.el` and `card-games.el` files on your `load-path` and
|
||||
`(require 'card-games)`.
|
||||
|
||||
|
||||
|
|
@ -225,7 +225,7 @@ graphical display.
|
|||
|
||||
- 500: `b` bid, `p` pass, arrows + `RET` to play (or click a card),
|
||||
`n` next hand / new game, `?` help.
|
||||
- Gaps: arrows to move (or `hjkl` when `cg-keys` is `classic`), `RET` to
|
||||
- Gaps: arrows to move (or `hjkl` when `card-games-keys` is `classic`), `RET` to
|
||||
fill a gap (or click it), `r` redeal, `u` undo, `n` new, `?` help.
|
||||
- Klondike / FreeCell / Spider / Yukon: arrows move between piles, `RET`
|
||||
picks up a movable run and drops it, `f` sends a card to a foundation,
|
||||
|
|
@ -249,8 +249,8 @@ mouse: click cards, board slots, buttons, and the slider.
|
|||
This is a 1.0.91 pre-test snapshot. To try it:
|
||||
|
||||
1. `make compile && make test` – should be warning-free and all green.
|
||||
2. `M-x card-game` opens the menu, or jump straight in, e.g.
|
||||
`M-x cg-klondike`, `M-x cg-bid` (500), `M-x cg-gin`, `M-x cg-handfoot`.
|
||||
2. `M-x card-games` opens the menu, or jump straight in, e.g.
|
||||
`M-x card-games-klondike`, `M-x card-games-bid` (500), `M-x card-games-gin`, `M-x card-games-handfoot`.
|
||||
3. On a graphical display, press `v` in 500 for the full-window SVG
|
||||
table and play entirely with the mouse: click a bid, click five kitty
|
||||
cards and the **Discard** button, click cards to play, move the **Card
|
||||
|
|
@ -262,31 +262,31 @@ finds confusing or unreachable, rules bugs, and rendering glitches.
|
|||
|
||||
# Customization
|
||||
|
||||
`M-x customize-group RET cg-svg` and `RET card-games`:
|
||||
`M-x customize-group RET card-games-svg` and `RET card-games`:
|
||||
|
||||
- `cg-ai-level` – how hard the computer plays: `easy`, `normal`, or
|
||||
`hard` (also on the `M-x card-game` menu, or `M-x
|
||||
- `card-games-ai-level` – how hard the computer plays: `easy`, `normal`, or
|
||||
`hard` (also on the `M-x card-games` menu, or `M-x
|
||||
card-games-set-ai-level`).
|
||||
- `card-games-treatment` – how the games are drawn: `text`, `svg`, or
|
||||
`full` (also on the menu, or `M-x card-games-set-treatment`).
|
||||
- `cg-svg-theme-colors` – derive the highlight ring and card backs
|
||||
- `card-games-svg-theme-colors` – derive the highlight ring and card backs
|
||||
from your theme (on by default).
|
||||
- `cg-svg-highlight-color` – the cursor/selection ring (gold 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` – the card-back design: `dots`, `rings`, `solid`,
|
||||
- `card-games-svg-highlight-color` – the cursor/selection ring (gold by default).
|
||||
- `card-games-bid-felt-color` – the 500 table felt.
|
||||
- `card-games-svg-card-width`, `card-games-svg-card-height`, `card-games-svg-card-shadow`,
|
||||
`card-games-svg-font-family` – card appearance.
|
||||
- `card-games-svg-card-back` – the card-back design: `dots`, `rings`, `solid`,
|
||||
`lattice`, `waves`, `diamond`, an Emacs-logo back (`emacs`,
|
||||
`emacs-classic`, `gnu`, `splash`), or `random` (the default – picks
|
||||
one for the session; `M-x cg-svg-shuffle-card-back` rolls a new one).
|
||||
- `cg-svg-emacs-logo` – the emblem on the full-window table:
|
||||
one for the session; `M-x card-games-svg-shuffle-card-back` rolls a new one).
|
||||
- `card-games-svg-emacs-logo` – the emblem on the full-window table:
|
||||
`modern` (default), `classic`, `gnu`, `splash`, `drawn`, or `none`.
|
||||
- `cg-symbols` – the Unicode suit glyphs (and the joker) drawn on cards.
|
||||
- `cg-svg-four-color` – draw a four-colour deck (clubs green, diamonds
|
||||
- `card-games-symbols` – the Unicode suit glyphs (and the joker) drawn on cards.
|
||||
- `card-games-svg-four-color` – draw a four-colour deck (clubs green, diamonds
|
||||
blue-purple).
|
||||
- `cg-keys` – `emacs` (default) or `classic` (adds vi-style `hjkl` and
|
||||
- `card-games-keys` – `emacs` (default) or `classic` (adds vi-style `hjkl` and
|
||||
`SPC`).
|
||||
- `cg-bid-animate`, `cg-bid-ai-delay`, `cg-bid-trick-pause` – pace the
|
||||
- `card-games-bid-animate`, `card-games-bid-ai-delay`, `card-games-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).
|
||||
|
||||
|
|
|
|||
120
README.org
120
README.org
|
|
@ -10,7 +10,7 @@ mouse on a graphical display.
|
|||
[[file:doc/images/klondike.png]]
|
||||
|
||||
On a graphical display the cards are drawn as SVG; in a terminal they
|
||||
fall back to UNICODE glyphs (customize ~card-game-symbols~). You can
|
||||
fall back to UNICODE glyphs (customize ~card-games-symbols~). You can
|
||||
switch how every game is drawn from the menu -- ~text~ (UNICODE),
|
||||
~svg~ (drawn cards), or ~full~ (a full-window SVG table) -- and dial the
|
||||
computer opponents between ~easy~, ~normal~, and ~hard~.
|
||||
|
|
@ -20,71 +20,71 @@ choose *Card Games*, or ~M-x info RET (card-games) RET~.
|
|||
|
||||
* Games
|
||||
|
||||
To open the game menu type ~M-x card-game~, or start a game directly
|
||||
To open the game menu type ~M-x card-games~, or start a game directly
|
||||
with its command. From the menu you can also switch the card treatment
|
||||
(text / SVG / full-window) and the AI difficulty.
|
||||
|
||||
** Trick-taking
|
||||
- ~cg-bid~ -- 500 (Bid). Win the auction, name the trump suit, then take
|
||||
- ~card-games-bid~ -- 500 (Bid). Win the auction, name the trump suit, then take
|
||||
tricks with your partner to reach 500 points before the opposing pair.
|
||||
Also playable live over the network (~M-x cg-bid-host~ / ~cg-bid-join~).
|
||||
- ~cg-hearts~ -- Hearts. Avoid taking hearts and the Queen of Spades, or
|
||||
Also playable live over the network (~M-x card-games-bid-host~ / ~card-games-bid-join~).
|
||||
- ~card-games-hearts~ -- Hearts. Avoid taking hearts and the Queen of Spades, or
|
||||
take them all to "shoot the moon"; lowest score loses.
|
||||
- ~cg-spades~ -- Spades. Partnership bidding to 500; spades are always
|
||||
- ~card-games-spades~ -- Spades. Partnership bidding to 500; spades are always
|
||||
trump. Make your side's combined bid, mind the bags, dare a nil.
|
||||
- ~cg-whist~ -- Whist. Trump is the turned card, there is no bidding;
|
||||
- ~card-games-whist~ -- Whist. Trump is the turned card, there is no bidding;
|
||||
score one point for each trick past the book of six.
|
||||
- ~cg-ohhell~ -- Oh Hell. The hand shrinks each round; bid the exact
|
||||
- ~card-games-ohhell~ -- Oh Hell. The hand shrinks each round; bid the exact
|
||||
number of tricks you will take, no more and no fewer.
|
||||
|
||||
** Solitaire
|
||||
- ~cg-montana~ -- Montana (also called Gaps). Each row is anchored by a
|
||||
- ~card-games-montana~ -- Montana (also called Gaps). Each row is anchored by a
|
||||
Two and built upward in one suit, 2 through King; slide cards into the
|
||||
gaps until all four rows are sorted.
|
||||
- ~cg-gaps~ -- an alias for ~cg-montana~.
|
||||
- ~cg-hells-half-acre~ -- the build-down variant: each row is anchored by
|
||||
- ~card-games-gaps~ -- an alias for ~card-games-montana~.
|
||||
- ~card-games-hells-half-acre~ -- the build-down variant: each row is anchored by
|
||||
a King and built downward, King through 2.
|
||||
- ~cg-klondike~ -- Klondike, the classic "Solitaire": build the four
|
||||
- ~card-games-klondike~ -- Klondike, the classic "Solitaire": build the four
|
||||
foundations up by suit from the Ace.
|
||||
- ~cg-freecell~ -- FreeCell: every card in view, four free cells, a game
|
||||
- ~card-games-freecell~ -- FreeCell: every card in view, four free cells, a game
|
||||
of nearly pure skill.
|
||||
- ~cg-spider~ -- Spider (two decks): build down regardless of suit, but
|
||||
- ~card-games-spider~ -- Spider (two decks): build down regardless of suit, but
|
||||
only same-suit runs move; clear eight King-to-Ace runs.
|
||||
- ~cg-yukon~ -- Yukon: Klondike's layout dealt mostly face up, with any
|
||||
- ~card-games-yukon~ -- Yukon: Klondike's layout dealt mostly face up, with any
|
||||
buried group movable and no stock.
|
||||
- ~cg-canfield~ -- Canfield: a 13-card reserve and a foundation base rank
|
||||
- ~card-games-canfield~ -- Canfield: a 13-card reserve and a foundation base rank
|
||||
set by the deal; foundations wrap King to Ace.
|
||||
- ~cg-forty-thieves~ -- Forty Thieves: two decks, ten columns, eight
|
||||
- ~card-games-forty-thieves~ -- Forty Thieves: two decks, ten columns, eight
|
||||
foundations, build down by suit, and no second pass through the stock.
|
||||
- ~cg-scorpion~ -- Scorpion: build down by suit and free any buried group
|
||||
- ~card-games-scorpion~ -- Scorpion: build down by suit and free any buried group
|
||||
to assemble four King-to-Ace runs.
|
||||
- ~cg-golf~ -- Golf: clear the layout by playing exposed cards one rank
|
||||
- ~card-games-golf~ -- Golf: clear the layout by playing exposed cards one rank
|
||||
above or below the waste top.
|
||||
- ~cg-tripeaks~ -- TriPeaks: the same, on three overlapping peaks, with
|
||||
- ~card-games-tripeaks~ -- TriPeaks: the same, on three overlapping peaks, with
|
||||
Ace-King wrapping for long chains.
|
||||
- ~cg-pyramid~ -- Pyramid: remove pairs of exposed cards whose ranks sum
|
||||
- ~card-games-pyramid~ -- Pyramid: remove pairs of exposed cards whose ranks sum
|
||||
to thirteen; Kings go alone.
|
||||
|
||||
** Shedding and climbing
|
||||
- ~cg-eights~ -- Crazy Eights. Match the suit or rank of the discard;
|
||||
- ~card-games-eights~ -- Crazy Eights. Match the suit or rank of the discard;
|
||||
eights are wild and let you name the next suit.
|
||||
- ~cg-president~ -- President (Scum). Climb: play one to four of a rank,
|
||||
- ~card-games-president~ -- President (Scum). Climb: play one to four of a rank,
|
||||
beat it or pass; first out rules, last out scrubs, and the roles trade
|
||||
cards on the next deal.
|
||||
|
||||
** Rummy
|
||||
- ~cg-gin~ -- Gin Rummy. A two-handed duel: draw or take the discard,
|
||||
- ~card-games-gin~ -- Gin Rummy. A two-handed duel: draw or take the discard,
|
||||
build sets and runs, and knock once your deadwood is ten or less, or go
|
||||
gin with none; your opponent then lays off and may undercut you. First
|
||||
to 100 wins.
|
||||
- ~cg-rummy-basic~ -- Rummy. Meld sets and runs onto the table and lay
|
||||
- ~card-games-rummy-basic~ -- Rummy. Meld sets and runs onto the table and lay
|
||||
cards off onto them; empty your hand to go out and score the cards left
|
||||
in the other hands.
|
||||
- ~cg-rum500~ -- Rummy 500. As above, but you score the cards you lay
|
||||
- ~card-games-rum500~ -- Rummy 500. As above, but you score the cards you lay
|
||||
down and lose the cards left in your hand; first past 500 wins. Take a
|
||||
buried discard card with ~T~: you take it and every card above it, and
|
||||
meld the chosen card at once.
|
||||
- ~cg-handfoot~ -- Hand & Foot. A partnership Canasta cousin: play a hand
|
||||
- ~card-games-handfoot~ -- Hand & Foot. A partnership Canasta cousin: play a hand
|
||||
and then a foot, build books of a rank with Twos and Jokers wild, and go
|
||||
out once your side has completed two of them. Each round opens with a
|
||||
rising go-down minimum (50, 90, 120, 150); red threes are bonus cards;
|
||||
|
|
@ -92,44 +92,44 @@ with its command. From the menu you can also switch the card treatment
|
|||
two matching naturals.
|
||||
|
||||
** Matching
|
||||
- ~cg-go-fish~ -- Go Fish. Ask another player for a rank you hold;
|
||||
- ~card-games-go-fish~ -- Go Fish. Ask another player for a rank you hold;
|
||||
collect all four to lay down a book, and make the most books.
|
||||
- ~cg-old-maid~ -- Old Maid. One Queen is set aside; discard pairs and
|
||||
- ~card-games-old-maid~ -- Old Maid. One Queen is set aside; discard pairs and
|
||||
draw blind from your neighbour, and do not be left with the odd Queen.
|
||||
|
||||
** Pegging
|
||||
- ~cg-cribbage~ -- Cribbage. Lay two cards to the crib, cut a starter,
|
||||
- ~card-games-cribbage~ -- Cribbage. Lay two cards to the crib, cut a starter,
|
||||
peg toward 31, then count fifteens, pairs, runs, flushes, and his nobs.
|
||||
Two-handed to 121.
|
||||
|
||||
** Capturing
|
||||
- ~cg-scopa~ -- Scopa. A 40-card deck; capture table cards by value and
|
||||
- ~card-games-scopa~ -- Scopa. A 40-card deck; capture table cards by value and
|
||||
sweep the board for a scopa. Score cards, coins, the sette bello, and
|
||||
primiera to 11.
|
||||
- ~cg-casino~ -- Casino. The full deck; capture by pairs and sums and
|
||||
- ~card-games-casino~ -- Casino. The full deck; capture by pairs and sums and
|
||||
score cards, spades, the casinos, and aces to 21.
|
||||
|
||||
** More trick-taking
|
||||
- ~cg-euchre~ -- Euchre. A 24-card deck with the two bowers; order up or
|
||||
- ~card-games-euchre~ -- Euchre. A 24-card deck with the two bowers; order up or
|
||||
call trump and take three of five tricks. Partnership to 10.
|
||||
- ~cg-pitch~ -- Auction Pitch. Bid for the pitch; your first lead sets
|
||||
- ~card-games-pitch~ -- Auction Pitch. Bid for the pitch; your first lead sets
|
||||
trump. Score High, Low, Jack, and Game; first to 7.
|
||||
- ~cg-briscola~ -- Briscola. A fixed trump turned from the deal and no
|
||||
- ~card-games-briscola~ -- Briscola. A fixed trump turned from the deal and no
|
||||
obligation to follow suit; capture the Aces and Threes. Partnership to
|
||||
61 of the 120 points.
|
||||
|
||||
** Climbing patience
|
||||
- ~cg-spite~ -- Spite & Malice. Race the computer to empty your goal
|
||||
- ~card-games-spite~ -- Spite & Malice. Race the computer to empty your goal
|
||||
pile onto shared centre piles that build Ace to Queen; Kings are wild.
|
||||
|
||||
** Bridge
|
||||
- ~cg-bridge~ -- Contract Bridge. A full auction (bids, pass, double,
|
||||
- ~card-games-bridge~ -- Contract Bridge. A full auction (bids, pass, double,
|
||||
redouble), play with the dummy exposed, and classic rubber scoring with
|
||||
vulnerability. You are South; when you declare you play the dummy too.
|
||||
The bidding AI is a small natural system, sensible but no expert.
|
||||
|
||||
** Two-player patience
|
||||
- ~cg-russian-bank~ / ~cg-crapette~ -- Russian Bank (Crapette). A race
|
||||
- ~card-games-russian-bank~ / ~card-games-crapette~ -- Russian Bank (Crapette). A race
|
||||
against the computer: build the eight shared foundations up by suit,
|
||||
build the shared houses down in alternating colour, and empty your
|
||||
reserve to win. Load your cards onto your opponent's piles when the
|
||||
|
|
@ -139,7 +139,7 @@ with its command. From the menu you can also switch the card treatment
|
|||
empty house). The opponent plays all three difficulty levels.
|
||||
|
||||
* TODO
|
||||
- [X] make the suit symbols customizable (~cg-symbols~) and obey them
|
||||
- [X] make the suit symbols customizable (~card-games-symbols~) and obey them
|
||||
- [X] a Texinfo manual
|
||||
- [ ] finish ~checkdoc~ docstrings across the per-game files
|
||||
(the shared engine files are clean; ~make compile~ is warning-free)
|
||||
|
|
@ -161,9 +161,9 @@ ELPA archive), the whole collection loads from the single ~card-games~
|
|||
feature:
|
||||
#+begin_src emacs-lisp
|
||||
(use-package card-games
|
||||
:commands (card-game cg-klondike cg-bid cg-hearts cg-gin cg-crapette))
|
||||
:commands (card-games card-games-klondike card-games-bid card-games-hearts card-games-gin card-games-crapette))
|
||||
#+end_src
|
||||
Then ~M-x card-game~ for the menu.
|
||||
Then ~M-x card-games~ for the menu.
|
||||
|
||||
** From a local ELPA archive
|
||||
#+begin_src
|
||||
|
|
@ -176,7 +176,7 @@ make elpa # builds dist/ (archive-contents + tar)
|
|||
#+end_src
|
||||
|
||||
** Manually
|
||||
Put the ~cg-*.el~ and ~card-games.el~ files on your ~load-path~ and
|
||||
Put the ~card-games-*.el~ and ~card-games.el~ files on your ~load-path~ and
|
||||
~(require 'card-games)~.
|
||||
|
||||
* Manual
|
||||
|
|
@ -194,7 +194,7 @@ graphical display.
|
|||
|
||||
- 500: ~b~ bid, ~p~ pass, arrows + ~RET~ to play (or click a card),
|
||||
~n~ next hand / new game, ~?~ help.
|
||||
- Gaps: arrows to move (or ~hjkl~ when ~cg-keys~ is ~classic~), ~RET~ to
|
||||
- Gaps: arrows to move (or ~hjkl~ when ~card-games-keys~ is ~classic~), ~RET~ to
|
||||
fill a gap (or click it), ~r~ redeal, ~u~ undo, ~n~ new, ~?~ help.
|
||||
- Klondike / FreeCell / Spider / Yukon: arrows move between piles, ~RET~
|
||||
picks up a movable run and drops it, ~f~ sends a card to a foundation,
|
||||
|
|
@ -215,8 +215,8 @@ mouse: click cards, board slots, buttons, and the slider.
|
|||
* Testing
|
||||
This is a 1.0.91 pre-test snapshot. To try it:
|
||||
1. ~make compile && make test~ -- should be warning-free and all green.
|
||||
2. ~M-x card-game~ opens the menu, or jump straight in, e.g.
|
||||
~M-x cg-klondike~, ~M-x cg-bid~ (500), ~M-x cg-gin~, ~M-x cg-handfoot~.
|
||||
2. ~M-x card-games~ opens the menu, or jump straight in, e.g.
|
||||
~M-x card-games-klondike~, ~M-x card-games-bid~ (500), ~M-x card-games-gin~, ~M-x card-games-handfoot~.
|
||||
3. On a graphical display, press ~v~ in 500 for the full-window SVG
|
||||
table and play entirely with the mouse: click a bid, click five kitty
|
||||
cards and the *Discard* button, click cards to play, move the *Card
|
||||
|
|
@ -226,30 +226,30 @@ Feedback most wanted: anything a mouse-only player who is new to Emacs
|
|||
finds confusing or unreachable, rules bugs, and rendering glitches.
|
||||
|
||||
* Customization
|
||||
~M-x customize-group RET cg-svg~ and ~RET card-games~:
|
||||
- ~cg-ai-level~ -- how hard the computer plays: ~easy~, ~normal~, or
|
||||
~hard~ (also on the ~M-x card-game~ menu, or ~M-x
|
||||
~M-x customize-group RET card-games-svg~ and ~RET card-games~:
|
||||
- ~card-games-ai-level~ -- how hard the computer plays: ~easy~, ~normal~, or
|
||||
~hard~ (also on the ~M-x card-games~ menu, or ~M-x
|
||||
card-games-set-ai-level~).
|
||||
- ~card-games-treatment~ -- how the games are drawn: ~text~, ~svg~, or
|
||||
~full~ (also on the menu, or ~M-x card-games-set-treatment~).
|
||||
- ~cg-svg-theme-colors~ -- derive the highlight ring and card backs
|
||||
- ~card-games-svg-theme-colors~ -- derive the highlight ring and card backs
|
||||
from your theme (on by default).
|
||||
- ~cg-svg-highlight-color~ -- the cursor/selection ring (gold 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~ -- the card-back design: ~dots~, ~rings~, ~solid~,
|
||||
- ~card-games-svg-highlight-color~ -- the cursor/selection ring (gold by default).
|
||||
- ~card-games-bid-felt-color~ -- the 500 table felt.
|
||||
- ~card-games-svg-card-width~, ~card-games-svg-card-height~, ~card-games-svg-card-shadow~,
|
||||
~card-games-svg-font-family~ -- card appearance.
|
||||
- ~card-games-svg-card-back~ -- the card-back design: ~dots~, ~rings~, ~solid~,
|
||||
~lattice~, ~waves~, ~diamond~, an Emacs-logo back (~emacs~,
|
||||
~emacs-classic~, ~gnu~, ~splash~), or ~random~ (the default -- picks
|
||||
one for the session; ~M-x cg-svg-shuffle-card-back~ rolls a new one).
|
||||
- ~cg-svg-emacs-logo~ -- the emblem on the full-window table:
|
||||
one for the session; ~M-x card-games-svg-shuffle-card-back~ rolls a new one).
|
||||
- ~card-games-svg-emacs-logo~ -- the emblem on the full-window table:
|
||||
~modern~ (default), ~classic~, ~gnu~, ~splash~, ~drawn~, or ~none~.
|
||||
- ~cg-symbols~ -- the Unicode suit glyphs (and the joker) drawn on cards.
|
||||
- ~cg-svg-four-color~ -- draw a four-colour deck (clubs green, diamonds
|
||||
- ~card-games-symbols~ -- the Unicode suit glyphs (and the joker) drawn on cards.
|
||||
- ~card-games-svg-four-color~ -- draw a four-colour deck (clubs green, diamonds
|
||||
blue-purple).
|
||||
- ~cg-keys~ -- ~emacs~ (default) or ~classic~ (adds vi-style ~hjkl~ and
|
||||
- ~card-games-keys~ -- ~emacs~ (default) or ~classic~ (adds vi-style ~hjkl~ and
|
||||
~SPC~).
|
||||
- ~cg-bid-animate~, ~cg-bid-ai-delay~, ~cg-bid-trick-pause~ -- pace the
|
||||
- ~card-games-bid-animate~, ~card-games-bid-ai-delay~, ~card-games-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).
|
||||
|
||||
|
|
|
|||
428
card-games-bid-net.el
Normal file
428
card-games-bid-net.el
Normal file
|
|
@ -0,0 +1,428 @@
|
|||
;;; card-games-bid-net.el --- Networked live 500 (Bid) -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Live multiplayer 500 over `card-games-net'. One Emacs hosts with
|
||||
;; `card-games-bid-host'; up to three others join with `card-games-bid-join'. The host
|
||||
;; owns the canonical game and sits South (seat 0); joining players take
|
||||
;; seats West, North and East in turn. Any seat left open when play
|
||||
;; begins is driven by the existing AI, so a table of one human and
|
||||
;; three robots, or four humans, or anything between, all work.
|
||||
;;
|
||||
;; The host is authoritative: a client sends a move "intent" (bid, pass,
|
||||
;; discard or play); the host validates it, applies it to the canonical
|
||||
;; game, lets the AI take any open seats, then broadcasts a fresh view
|
||||
;; to every client. Each client receives a per-seat view rotated so the
|
||||
;; recipient sits South: it sees only its own cards, opponents collapse
|
||||
;; to face-down counts, and the kitty stays hidden until won. Because a
|
||||
;; client's view places itself at seat 0, the ordinary single-player
|
||||
;; commands and renderer work unchanged for everyone.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-net)
|
||||
(require 'card-games-bid)
|
||||
(require 'card-games-bid-ui)
|
||||
|
||||
(defcustom card-games-bid-shuffle-partners nil
|
||||
"When non-nil, randomize seating when a hosted game starts.
|
||||
The host keeps South; joined players are shuffled among West, North and
|
||||
East, so it is chance, not arrival order, that decides who partners whom."
|
||||
:type 'boolean :group 'card-games-net)
|
||||
|
||||
(defvar card-games-bid--net-role nil
|
||||
"Role of this Emacs in a live game: `host', `client', or nil (solo).")
|
||||
|
||||
(defvar card-games-bid--net-seat 0
|
||||
"This player's absolute seat in a live game (the host is always 0).")
|
||||
|
||||
(defvar card-games-bid--applying-remote nil
|
||||
"Bound non-nil while the host applies a remote player's move.
|
||||
While set, prompts that would block the host (such as nominating a suit
|
||||
for a Joker lead) fall back to an automatic choice.")
|
||||
|
||||
;;;; Per-seat state filter (host -> client)
|
||||
|
||||
(defun card-games-bid--rot (x seat)
|
||||
"Rotate absolute seat X into SEAT's frame so SEAT becomes 0.
|
||||
Return nil when X is nil."
|
||||
(and x (mod (- x seat) 4)))
|
||||
|
||||
(defun card-games-bid--rot-team (team seat)
|
||||
"Rotate TEAM index (0 or 1) into SEAT's frame.
|
||||
Return nil when TEAM is nil."
|
||||
(and team (if (cl-oddp seat) (- 1 team) team)))
|
||||
|
||||
(defun card-games-bid--rotate-vec4 (vec seat)
|
||||
"Return a fresh 4-vector whose element I is VEC element (I+SEAT) mod 4."
|
||||
(let ((v (make-vector 4 nil)))
|
||||
(dotimes (i 4) (aset v i (aref vec (mod (+ i seat) 4))))
|
||||
v))
|
||||
|
||||
(cl-defmethod card-games-net-game-state ((game card-games-bid-game) &optional seat)
|
||||
"Return GAME's shared state for SEAT, rotated so SEAT sits South.
|
||||
Other players' hands collapse to face-down counts, the kitty is hidden,
|
||||
and a hand exposed by an open misère is revealed to everyone."
|
||||
(let ((seat (or seat 0)))
|
||||
(if (null (card-games-get game :hands))
|
||||
;; Lobby: nothing dealt yet.
|
||||
(list :phase (or (card-games-get game :phase) 'lobby)
|
||||
:message (or (card-games-get game :message) "Waiting for players…")
|
||||
:hand-no (or (card-games-get game :hand-no) 0))
|
||||
(let* ((hands (card-games-get game :hands))
|
||||
(exposed (card-games-get game :exposed))
|
||||
(rhands (make-vector 4 nil))
|
||||
(scores (card-games-get game :scores)))
|
||||
(dotimes (i 4)
|
||||
(let* ((abs (mod (+ i seat) 4))
|
||||
(cards (aref hands abs)))
|
||||
(aset rhands i
|
||||
(if (or (= abs seat) (eql abs exposed))
|
||||
(copy-sequence cards)
|
||||
(make-list (length cards) (cons 0 0))))))
|
||||
(list
|
||||
:hands rhands
|
||||
:kitty nil
|
||||
:phase (card-games-get game :phase)
|
||||
:contract (card-games-get game :contract)
|
||||
:contractor (card-games-bid--rot (card-games-get game :contractor) seat)
|
||||
:high-bid (card-games-get game :high-bid)
|
||||
:high-bidder (card-games-bid--rot (card-games-get game :high-bidder) seat)
|
||||
:bidder (card-games-bid--rot (card-games-get game :bidder) seat)
|
||||
:dealer (card-games-bid--rot (card-games-get game :dealer) seat)
|
||||
:passed (card-games-bid--rotate-vec4 (card-games-get game :passed) seat)
|
||||
:turn (card-games-bid--rot (card-games-get game :turn) seat)
|
||||
:leader (card-games-bid--rot (card-games-get game :leader) seat)
|
||||
:led (card-games-get game :led)
|
||||
:trick (mapcar (lambda (p) (cons (card-games-bid--rot (car p) seat) (cdr p)))
|
||||
(card-games-get game :trick))
|
||||
:last-trick (mapcar (lambda (p) (cons (card-games-bid--rot (car p) seat) (cdr p)))
|
||||
(card-games-get game :last-trick))
|
||||
:tricks (card-games-bid--rotate-vec4 (card-games-get game :tricks) seat)
|
||||
:ntricks (card-games-get game :ntricks)
|
||||
:exposed (card-games-bid--rot exposed seat)
|
||||
:scores (if (cl-oddp seat) (cons (cdr scores) (car scores)) scores)
|
||||
:game-over (card-games-bid--rot-team (card-games-get game :game-over) seat)
|
||||
:hand-no (card-games-get game :hand-no)
|
||||
:hand-result (card-games-get game :hand-result)
|
||||
:message (card-games-get game :message)
|
||||
:log (card-games-get game :log)
|
||||
:log-scroll (card-games-get game :log-scroll)
|
||||
:you seat)))))
|
||||
|
||||
(cl-defmethod card-games-net-set-game-state ((game card-games-bid-game) state)
|
||||
"Install host STATE into GAME on a client, keeping the local cursor and scroll."
|
||||
(let ((old (oref game env)))
|
||||
(oset game env state)
|
||||
(dolist (k '(:cursor :marks :log-scroll))
|
||||
(card-games-put game k (and (plist-member old k) (plist-get old k))))))
|
||||
|
||||
;;;; Apply a move on the host
|
||||
|
||||
(defun card-games-bid--net-holds-p (hand cards)
|
||||
"Return non-nil when every card in CARDS is present in HAND.
|
||||
Multiplicity counts: naming one held card five times is not holding
|
||||
five cards. Cards are (SUIT . RANK) conses compared with `equal'."
|
||||
(let ((left (copy-sequence hand)))
|
||||
(catch 'missing
|
||||
(dolist (c cards t)
|
||||
(if (member c left)
|
||||
(setq left (cl-remove c left :test #'equal :count 1))
|
||||
(throw 'missing nil))))))
|
||||
|
||||
(cl-defmethod card-games-net-apply-move ((game card-games-bid-game) seat move)
|
||||
"Apply MOVE made by absolute SEAT to the host's 500 GAME.
|
||||
MOVE is (bid BID), (pass), (discard CARD...) or (play CARD). Return
|
||||
non-nil when the move was legal and applied, so the host broadcasts."
|
||||
(let ((phase (card-games-get game :phase)) (ok nil))
|
||||
(pcase move
|
||||
(`(bid ,bid)
|
||||
(when (and (eq phase 'auction) (eql (card-games-get game :bidder) seat))
|
||||
(card-games-bid--auction-act game seat bid) (setq ok t)))
|
||||
(`(pass)
|
||||
(when (and (eq phase 'auction) (eql (card-games-get game :bidder) seat))
|
||||
(card-games-bid--auction-act game seat nil) (setq ok t)))
|
||||
(`(discard . ,cards)
|
||||
(when (and (eq phase 'kitty) (eql (card-games-get game :contractor) seat)
|
||||
(= (length cards) 5)
|
||||
(card-games-bid--net-holds-p (card-games-bid--hand game seat) cards))
|
||||
(card-games-bid--discard game seat cards) (setq ok t)))
|
||||
(`(play ,card)
|
||||
(when (and (eq phase 'play) (eql (card-games-get game :turn) seat)
|
||||
(member card (card-games-bid-legal-cards
|
||||
(card-games-bid--hand game seat)
|
||||
(card-games-get game :led)
|
||||
(card-games-bid-trump (card-games-get game :contract)))))
|
||||
(let ((card-games-bid--applying-remote t)) (card-games-bid--play game seat card))
|
||||
(setq ok t))))
|
||||
(when ok
|
||||
(let ((card-games-bid--applying-remote t)) (card-games-bid--run game))
|
||||
(card-games-bid--net-host-refresh))
|
||||
ok))
|
||||
|
||||
(defun card-games-bid--net-nominate-advice (orig game seat)
|
||||
"Around advice for `card-games-bid--nominate-suit'.
|
||||
While the host applies a remote move (ORIG GAME SEAT), pick the longest
|
||||
suit automatically instead of prompting."
|
||||
(if card-games-bid--applying-remote
|
||||
(let ((counts (make-vector 4 0)) (best 0))
|
||||
(dolist (c (card-games-bid--hand game seat))
|
||||
(unless (card-games-bid-joker-p c) (cl-incf (aref counts (car c)))))
|
||||
(dotimes (s 4) (when (> (aref counts s) (aref counts best)) (setq best s)))
|
||||
best)
|
||||
(funcall orig game seat)))
|
||||
(advice-add 'card-games-bid--nominate-suit :around #'card-games-bid--net-nominate-advice)
|
||||
|
||||
;;;; Host bookkeeping and display
|
||||
|
||||
(defun card-games-bid--net-host-refresh ()
|
||||
"Redraw the host's own table buffer."
|
||||
(let ((buf (get-buffer "*500 Bid*")))
|
||||
(when (buffer-live-p buf)
|
||||
(with-current-buffer buf (card-games-bid--redisplay)))))
|
||||
|
||||
(defun card-games-bid--net-broadcast-advice (&rest _)
|
||||
"After advice on `card-games-bid--refresh' that broadcasts when hosting."
|
||||
(when (and (eq card-games-bid--net-role 'host) (card-games-net-hosting-p))
|
||||
(card-games-net-host-broadcast)))
|
||||
(advice-add 'card-games-bid--refresh :after #'card-games-bid--net-broadcast-advice)
|
||||
|
||||
(defun card-games-bid--net-lobby-display ()
|
||||
"Show the host's pre-game lobby of seats."
|
||||
(let ((buf (get-buffer "*500 Bid*")))
|
||||
(when (buffer-live-p buf)
|
||||
(with-current-buffer buf
|
||||
(let ((inhibit-read-only t)
|
||||
(seats (cl-remove-duplicates card-games-bid--human-seats)))
|
||||
(erase-buffer)
|
||||
(insert "\n 500 — LIVE TABLE (hosting)\n\n")
|
||||
(dotimes (s 4)
|
||||
(insert (format " %-6s %s\n" (aref card-games-bid-seat-names s)
|
||||
(cond ((= s 0) "you (host)")
|
||||
((memq s seats) "joined")
|
||||
(t "open — AI will fill")))))
|
||||
(insert "\n Press s to start now")
|
||||
(when card-games-bid-shuffle-partners (insert " (partners shuffled)"))
|
||||
(insert ".\n")
|
||||
(goto-char (point-min)))))))
|
||||
|
||||
(defun card-games-bid--net-shuffle-seats ()
|
||||
"Randomly reassign joined clients among seats 1, 2 and 3.
|
||||
The host keeps South (seat 0)."
|
||||
(let ((clients (and card-games-net--host
|
||||
(cl-remove-if-not #'process-live-p
|
||||
(card-games-net-host-clients card-games-net--host))))
|
||||
(seats (card-games-shuffle (list 1 2 3))))
|
||||
(dolist (p clients) (process-put p 'card-games-net-seat (pop seats)))
|
||||
(setq card-games-bid--human-seats
|
||||
(cons 0 (mapcar (lambda (p) (process-get p 'card-games-net-seat)) clients)))))
|
||||
|
||||
(defun card-games-bid--net-start ()
|
||||
"Deal and begin the hosted game, AI filling any open seat."
|
||||
(let ((game card-games-bid--game))
|
||||
(when card-games-bid-shuffle-partners (card-games-bid--net-shuffle-seats))
|
||||
(setq card-games-bid--human-seats (cl-remove-duplicates card-games-bid--human-seats))
|
||||
(card-games-bid--deal game 3)
|
||||
(let ((card-games-bid--applying-remote t)) (card-games-bid--run game))
|
||||
(card-games-bid--net-host-refresh)
|
||||
(card-games-net-host-broadcast)))
|
||||
|
||||
(defun card-games-bid--net-on-connect (host seat)
|
||||
"Host hook: a client has joined at SEAT (HOST is the server struct)."
|
||||
(when (eq card-games-bid--net-role 'host)
|
||||
(if (> seat 3)
|
||||
;; Table full: turn the latecomer away.
|
||||
(let ((p (cl-find seat (card-games-net-host-clients host)
|
||||
:key (lambda (q) (process-get q 'card-games-net-seat)))))
|
||||
(when p (card-games-net--send p '(:type full)) (delete-process p)))
|
||||
(cl-pushnew seat card-games-bid--human-seats)
|
||||
(card-games-bid--net-lobby-display)
|
||||
(message "Player joined at %s." (aref card-games-bid-seat-names seat))
|
||||
(when (= (length (cl-remove-duplicates card-games-bid--human-seats)) 4)
|
||||
(card-games-bid--net-start)))))
|
||||
|
||||
;;;; Client display
|
||||
|
||||
(defun card-games-bid--net-client-update (game)
|
||||
"Redraw the client's buffer after the host sends new state for GAME."
|
||||
(let ((buf (get-buffer "*500 Bid*")))
|
||||
(when (buffer-live-p buf)
|
||||
(with-current-buffer buf
|
||||
(if (memq (card-games-get game :phase) '(lobby nil))
|
||||
(let ((inhibit-read-only t))
|
||||
(erase-buffer)
|
||||
(insert "\n 500 — connected to host.\n\n "
|
||||
(or (card-games-get game :message)
|
||||
"Waiting for the host to start…")
|
||||
"\n")
|
||||
(goto-char (point-min)))
|
||||
(card-games-bid--redisplay))))))
|
||||
|
||||
;;;; Client move interception
|
||||
|
||||
(defun card-games-bid--net-client-bid-advice (orig)
|
||||
"Around advice on `card-games-bid-make-bid' (ORIG): send the bid, do not apply it."
|
||||
(if (eq card-games-bid--net-role 'client)
|
||||
(let ((game card-games-bid--game))
|
||||
(if (or (not (eq (card-games-get game :phase) 'auction))
|
||||
(/= (card-games-get game :bidder) 0))
|
||||
(progn (card-games-put game :message "Not your turn to bid.")
|
||||
(card-games-bid--redisplay))
|
||||
(let* ((legal (card-games-bid--legal-bids game))
|
||||
(completion-ignore-case t)
|
||||
(choices (append
|
||||
(mapcar (lambda (b)
|
||||
(cons (format "%-4s %s (%d)"
|
||||
(card-games-bid--code b)
|
||||
(card-games-bid-name b)
|
||||
(card-games-bid-value b))
|
||||
b))
|
||||
legal)
|
||||
'(("Pass" . pass))))
|
||||
(pick (completing-read
|
||||
"Your bid (e.g. 7H, 8NT, NL; or Pass): "
|
||||
(mapcar #'car choices) nil t))
|
||||
(sel (cdr (assoc pick choices))))
|
||||
(card-games-net-send-move (if (eq sel 'pass) '(pass) (list 'bid sel)))
|
||||
(card-games-put game :message "Bid sent — waiting…")
|
||||
(card-games-bid--redisplay))))
|
||||
(funcall orig)))
|
||||
(advice-add 'card-games-bid-make-bid :around #'card-games-bid--net-client-bid-advice)
|
||||
|
||||
(defun card-games-bid--net-client-pass-advice (orig)
|
||||
"Around advice on `card-games-bid-pass' (ORIG): send a pass, do not apply it."
|
||||
(if (eq card-games-bid--net-role 'client)
|
||||
(let ((game card-games-bid--game))
|
||||
(if (or (not (eq (card-games-get game :phase) 'auction))
|
||||
(/= (card-games-get game :bidder) 0))
|
||||
(progn (card-games-put game :message "Not your turn to bid.")
|
||||
(card-games-bid--redisplay))
|
||||
(card-games-net-send-move '(pass))
|
||||
(card-games-put game :message "Pass sent — waiting…")
|
||||
(card-games-bid--redisplay)))
|
||||
(funcall orig)))
|
||||
(advice-add 'card-games-bid-pass :around #'card-games-bid--net-client-pass-advice)
|
||||
|
||||
(defun card-games-bid--net-client-select-advice (orig)
|
||||
"Around advice on `card-games-bid-select' (ORIG): send a play, or mark locally."
|
||||
(if (eq card-games-bid--net-role 'client)
|
||||
(let* ((game card-games-bid--game)
|
||||
(phase (card-games-get game :phase))
|
||||
(card (card-games-bid--current-card)))
|
||||
(pcase phase
|
||||
('kitty
|
||||
(when (eql (card-games-get game :contractor) 0)
|
||||
(let ((marks (card-games-get game :marks)))
|
||||
(card-games-put game :marks (if (member card marks)
|
||||
(remove card marks)
|
||||
(cons card marks)))
|
||||
(card-games-put game :message
|
||||
(format "%d of 5 marked for discard."
|
||||
(length (card-games-get game :marks))))
|
||||
(card-games-bid--redisplay))))
|
||||
('play
|
||||
(cond
|
||||
((/= (card-games-get game :turn) 0)
|
||||
(card-games-put game :message "Not your turn.") (card-games-bid--redisplay))
|
||||
((null card) (card-games-bid--redisplay))
|
||||
(t (card-games-net-send-move (list 'play card))
|
||||
(card-games-put game :message "Card sent — waiting…")
|
||||
(card-games-bid--redisplay))))
|
||||
(_ (card-games-bid--redisplay))))
|
||||
(funcall orig)))
|
||||
(advice-add 'card-games-bid-select :around #'card-games-bid--net-client-select-advice)
|
||||
|
||||
(defun card-games-bid--net-client-discard-advice (orig)
|
||||
"Around advice on `card-games-bid-discard-marked' (ORIG): send the discard intent."
|
||||
(if (eq card-games-bid--net-role 'client)
|
||||
(let* ((game card-games-bid--game) (marks (card-games-get game :marks)))
|
||||
(cond
|
||||
((not (eq (card-games-get game :phase) 'kitty))
|
||||
(card-games-put game :message "Nothing to discard now.") (card-games-bid--redisplay))
|
||||
((/= (length marks) 5)
|
||||
(card-games-put game :message
|
||||
(format "Mark exactly 5 (have %d)." (length marks)))
|
||||
(card-games-bid--redisplay))
|
||||
(t (card-games-net-send-move (cons 'discard marks))
|
||||
(card-games-put game :marks nil)
|
||||
(card-games-put game :message "Discard sent — waiting…")
|
||||
(card-games-bid--redisplay))))
|
||||
(funcall orig)))
|
||||
(advice-add 'card-games-bid-discard-marked :around #'card-games-bid--net-client-discard-advice)
|
||||
|
||||
;;;; Commands
|
||||
|
||||
(defun card-games-bid-start-now ()
|
||||
"Start a hosted game immediately, AI filling any empty seats."
|
||||
(interactive)
|
||||
(if (and (eq card-games-bid--net-role 'host)
|
||||
(eq (card-games-get card-games-bid--game :phase) 'lobby))
|
||||
(card-games-bid--net-start)
|
||||
(message "Not hosting a lobby.")))
|
||||
(define-key card-games-bid-mode-map "s" #'card-games-bid-start-now)
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-bid-host (port)
|
||||
"Host a live game of 500 on PORT. Others join with `card-games-bid-join'."
|
||||
(interactive (list (read-number "Host on port: " card-games-net-port)))
|
||||
(let ((buf (get-buffer-create "*500 Bid*")))
|
||||
(with-current-buffer buf
|
||||
(card-games-bid-mode)
|
||||
(setq card-games-bid--game (make-instance 'card-games-bid-game)
|
||||
card-games-bid--net-role 'host
|
||||
card-games-bid--net-seat 0
|
||||
card-games-bid--human-seats '(0))
|
||||
(card-games-put card-games-bid--game :phase 'lobby)
|
||||
(card-games-put card-games-bid--game :message "Lobby")
|
||||
(card-games-net-host-start card-games-bid--game port)
|
||||
(setf (card-games-net-host-next-seat card-games-net--host) 1)
|
||||
(add-hook 'card-games-net-connect-functions #'card-games-bid--net-on-connect)
|
||||
(card-games-bid--net-lobby-display))
|
||||
(switch-to-buffer buf)
|
||||
(message "Hosting 500 on port %d — waiting for players (press s to start)."
|
||||
port)))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-bid-join (host port name)
|
||||
"Join a hosted game of 500 at HOST and PORT as NAME."
|
||||
(interactive (list (read-string "Host: " "127.0.0.1")
|
||||
(read-number "Port: " card-games-net-port)
|
||||
(read-string "Your name: " (user-login-name))))
|
||||
(let ((buf (get-buffer-create "*500 Bid*")))
|
||||
(with-current-buffer buf
|
||||
(card-games-bid-mode)
|
||||
(setq card-games-bid--game (make-instance 'card-games-bid-game)
|
||||
card-games-bid--net-role 'client
|
||||
card-games-bid--human-seats '(0))
|
||||
(card-games-put card-games-bid--game :phase 'lobby)
|
||||
(card-games-put card-games-bid--game :message "Connecting…")
|
||||
(add-hook 'card-games-net-state-functions #'card-games-bid--net-client-update)
|
||||
(card-games-net-connect host port name card-games-bid--game)
|
||||
(card-games-bid--net-client-update card-games-bid--game))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
(provide 'card-games-bid-net)
|
||||
;;; card-games-bid-net.el ends here
|
||||
1259
card-games-bid-ui.el
Normal file
1259
card-games-bid-ui.el
Normal file
File diff suppressed because it is too large
Load diff
843
card-games-bid.el
Normal file
843
card-games-bid.el
Normal file
|
|
@ -0,0 +1,843 @@
|
|||
;;; card-games-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.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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 `card-games-bid' command live in card-games-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 'card-games-core)
|
||||
|
||||
|
||||
;;;; Cards specific to 500
|
||||
|
||||
(defconst card-games-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 card-games-bid-jack 7 "Rank index of the Jack.")
|
||||
(defconst card-games-bid-joker '(4 . 0) "Canonical Joker card; suit index 4.")
|
||||
|
||||
(defsubst card-games-bid-joker-p (card)
|
||||
"Return non-nil when CARD is the Joker."
|
||||
(and (consp card) (= (car card) 4)))
|
||||
|
||||
(defun card-games-bid-card-string (card)
|
||||
"Return a short label for CARD."
|
||||
(cond
|
||||
((null card) "--")
|
||||
((card-games-bid-joker-p card) "Jk")
|
||||
(t (concat (aref card-games-bid-ranks (cdr card)) (card-games-suit-glyph (car card))))))
|
||||
|
||||
(defun card-games-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 card-games-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 card-games-bid-label (bid) "Return BID's label string." (nth 0 bid))
|
||||
(defsubst card-games-bid-name (bid) "Return BID's full name." (nth 1 bid))
|
||||
(defsubst card-games-bid-value (bid) "Return BID's score value." (nth 2 bid))
|
||||
(defsubst card-games-bid-tricks (bid) "Return BID's trick target." (nth 3 bid))
|
||||
(defsubst card-games-bid-trump (bid) "Return BID's trump suit." (nth 4 bid))
|
||||
(defsubst card-games-bid-open-p (bid) "Return non-nil when BID is an open misère." (nth 5 bid))
|
||||
(defsubst card-games-bid-nullo-p (bid) "Return non-nil when BID is a nullo (misère)." (eq (card-games-bid-trump bid) 'nullo))
|
||||
|
||||
|
||||
;;;; Card power and trick logic
|
||||
|
||||
(defun card-games-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
|
||||
((card-games-bid-joker-p card) (if (memq trump '(nt nullo)) 'joker trump))
|
||||
((and (numberp trump)
|
||||
(= (cdr card) card-games-bid-jack)
|
||||
(= (car card) (card-games-sister-suit trump)))
|
||||
trump)
|
||||
(t (car card))))
|
||||
|
||||
(defun card-games-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 (card-games-bid-effective-suit card trump)))
|
||||
(cond
|
||||
((card-games-bid-joker-p card) 1000)
|
||||
((and (numberp trump) (eq es trump))
|
||||
(cond
|
||||
((and (= (cdr card) card-games-bid-jack) (= (car card) trump)) 900) ; right bower
|
||||
((= (cdr card) card-games-bid-jack) 899) ; left bower
|
||||
(t (+ 800 (cdr card)))))
|
||||
((eq es led) (+ 100 (cdr card)))
|
||||
(t (cdr card)))))
|
||||
|
||||
(defun card-games-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 `card-games-bid-power'."
|
||||
(car (cl-reduce
|
||||
(lambda (best p)
|
||||
(if (> (card-games-bid-power (cdr p) trump led)
|
||||
(card-games-bid-power (cdr best) trump led))
|
||||
p best))
|
||||
plays)))
|
||||
|
||||
(defun card-games-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 (card-games-bid-effective-suit c trump) led))
|
||||
hand)))
|
||||
(or follow hand))))
|
||||
|
||||
(defun card-games-bid-sort-hand (hand trump)
|
||||
"Return HAND sorted for display under TRUMP: trumps first, then by suit."
|
||||
(sort (copy-sequence hand)
|
||||
(lambda (a b)
|
||||
(let* (( at (and (numberp trump)
|
||||
(eq (card-games-bid-effective-suit a trump) trump)))
|
||||
(bt (and (numberp trump)
|
||||
(eq (card-games-bid-effective-suit b trump) trump)))
|
||||
(aj (card-games-bid-joker-p a))
|
||||
(bj (card-games-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)
|
||||
(> (card-games-bid-power a (or trump 'nt) nil)
|
||||
(card-games-bid-power b (or trump 'nt) nil))))))))))
|
||||
|
||||
|
||||
(defun card-games-bid--display-key (card trump)
|
||||
"Return an ascending display sort key for CARD under TRUMP.
|
||||
Trumps (and the Joker) sort first, strongest first; the remaining
|
||||
suits are grouped spades, hearts, clubs, diamonds, high rank first."
|
||||
(cond
|
||||
((card-games-bid-joker-p card) 0)
|
||||
((and (numberp trump) (eq (card-games-bid-effective-suit card trump) trump))
|
||||
(- 1000 (card-games-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 card-games-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) (< (card-games-bid--display-key a trump)
|
||||
(card-games-bid--display-key b trump)))))
|
||||
|
||||
|
||||
;;;; Game object and dealing
|
||||
|
||||
(defclass card-games-bid-game (card-games-game)
|
||||
((name :initform "500 Bid"))
|
||||
"The partnership trick-taking game 500.")
|
||||
|
||||
(defvar card-games-bid--human-seats '(0)
|
||||
"List of seats controlled by a human player. South is seat 0.")
|
||||
|
||||
(defconst card-games-bid-seat-names ["South" "West" "North" "East"]
|
||||
"Seat labels; partners sit opposite (0/2 and 1/3).")
|
||||
|
||||
(defsubst card-games-bid--human-p (seat)
|
||||
"Return non-nil when SEAT is played by a human."
|
||||
(memq seat card-games-bid--human-seats))
|
||||
|
||||
(defsubst card-games-bid--partner (seat) "Return SEAT's partner seat." (mod (+ seat 2) 4))
|
||||
(defsubst card-games-bid--team (seat) "Return SEAT's team index (0 or 1)." (mod seat 2)) ; 0 -> team 0 (S/N), 1 -> team 1 (W/E)
|
||||
|
||||
(cl-defmethod card-games-bid--deal ((game card-games-bid-game) &optional dealer)
|
||||
"Deal a fresh hand into GAME. DEALER defaults to East so South bids first."
|
||||
(random t)
|
||||
(let ((deck (card-games-shuffle (card-games-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))))
|
||||
(card-games-put game :hands hands)
|
||||
(card-games-put game :kitty deck) ; remaining 5 cards
|
||||
(card-games-put game :dealer dealer)
|
||||
(card-games-put game :phase 'auction)
|
||||
(card-games-put game :passed (make-vector 4 nil))
|
||||
(card-games-put game :high-bid nil)
|
||||
(card-games-put game :high-bidder nil)
|
||||
(card-games-put game :bidder (mod (1+ dealer) 4)) ; left of dealer bids first
|
||||
(card-games-put game :contract nil)
|
||||
(card-games-put game :contractor nil)
|
||||
(card-games-put game :trick nil)
|
||||
(card-games-put game :last-trick nil)
|
||||
(card-games-put game :led nil)
|
||||
(card-games-put game :leader nil)
|
||||
(card-games-put game :tricks (make-vector 4 0))
|
||||
(card-games-put game :ntricks 0)
|
||||
(card-games-put game :exposed nil)
|
||||
(card-games-put game :cursor 0)
|
||||
(card-games-put game :marks nil)
|
||||
(card-games-put game :hand-result nil)
|
||||
(unless (card-games-get game :scores) (card-games-put game :scores (cons 0 0)))
|
||||
(unless (plist-member (oref game env) :game-over)
|
||||
(card-games-put game :game-over nil))
|
||||
(unless (card-games-get game :hand-no) (card-games-put game :hand-no 0))
|
||||
(card-games-put game :hand-no (1+ (card-games-get game :hand-no)))
|
||||
(card-games-bid--note game "— Hand %d —" (card-games-get game :hand-no))
|
||||
(card-games-put game :message
|
||||
(format "Auction: %s to bid." (aref card-games-bid-seat-names
|
||||
(card-games-get game :bidder))))
|
||||
game))
|
||||
|
||||
(defun card-games-bid--hand (game seat) "Return SEAT's hand in GAME." (aref (card-games-get game :hands) seat))
|
||||
(defun card-games-bid--set-hand (game seat cards) "Set SEAT's hand in GAME to CARDS." (aset (card-games-get game :hands) seat cards))
|
||||
|
||||
|
||||
;;;; Auction
|
||||
|
||||
(defun card-games-bid--legal-bids (game)
|
||||
"Return GAME's schedule entries that outbid the current high bid."
|
||||
(let ((hv (if (card-games-get game :high-bid)
|
||||
(card-games-bid-value (card-games-get game :high-bid)) 0)))
|
||||
(cl-remove-if-not (lambda (b) (> (card-games-bid-value b) hv)) card-games-bid-schedule)))
|
||||
|
||||
(defun card-games-bid--active-seats (game)
|
||||
"Return GAME's seats that have not passed."
|
||||
(cl-loop for s below 4
|
||||
unless (aref (card-games-get game :passed) s) collect s))
|
||||
|
||||
(defun card-games-bid--next-bidder (game from)
|
||||
"Return GAME's 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 (card-games-get game :passed) s) return s))
|
||||
|
||||
(defun card-games-bid--note (game fmt &rest args)
|
||||
"Append a narrative line (FMT with ARGS) to GAME's message log."
|
||||
(card-games-put game :log (cons (apply #'format fmt args) (card-games-get game :log)))
|
||||
(card-games-put game :log-scroll 0))
|
||||
|
||||
(cl-defmethod card-games-bid--auction-act ((game card-games-bid-game) seat bid)
|
||||
"Record GAME SEAT's action: BID is a schedule entry, or nil to pass."
|
||||
(if bid
|
||||
(progn (card-games-put game :high-bid bid)
|
||||
(card-games-put game :high-bidder seat)
|
||||
(card-games-put game :message
|
||||
(format "%s bids %s."
|
||||
(aref card-games-bid-seat-names seat) (card-games-bid-label bid)))
|
||||
(card-games-bid--note game "%s bids %s."
|
||||
(aref card-games-bid-seat-names seat) (card-games-bid-label bid)))
|
||||
(aset (card-games-get game :passed) seat t)
|
||||
(card-games-put game :message (format "%s passes." (aref card-games-bid-seat-names seat)))
|
||||
(card-games-bid--note game "%s passes." (aref card-games-bid-seat-names seat)))
|
||||
(let ((active (card-games-bid--active-seats game)))
|
||||
(cond
|
||||
;; everyone passed with no bid -> throw in
|
||||
((and (null (card-games-get game :high-bid)) (null active))
|
||||
(card-games-bid--deal game (mod (1+ (card-games-get game :dealer)) 4))
|
||||
(card-games-put game :message "All passed — redeal."))
|
||||
;; one bidder left standing -> contract is set
|
||||
((and (card-games-get game :high-bid) (= (length active) 1))
|
||||
(card-games-bid--begin-contract game))
|
||||
(t
|
||||
(card-games-put game :bidder (card-games-bid--next-bidder game seat))))))
|
||||
|
||||
(cl-defmethod card-games-bid--begin-contract ((game card-games-bid-game))
|
||||
"Set GAME's winning contract and move to the kitty phase."
|
||||
(let* ((contractor (card-games-get game :high-bidder))
|
||||
(bid (card-games-get game :high-bid)))
|
||||
(card-games-put game :contractor contractor)
|
||||
(card-games-put game :contract bid)
|
||||
(card-games-put game :phase 'kitty)
|
||||
;; contractor takes the kitty into hand
|
||||
(card-games-bid--set-hand game contractor
|
||||
(append (card-games-bid--hand game contractor)
|
||||
(card-games-get game :kitty)))
|
||||
(card-games-put game :kitty nil)
|
||||
(card-games-put game :leader contractor)
|
||||
(card-games-put game :turn contractor)
|
||||
(card-games-put game :message
|
||||
(format "%s won the auction with %s (%s). Kitty taken."
|
||||
(aref card-games-bid-seat-names contractor)
|
||||
(card-games-bid-label bid) (card-games-bid-name bid)))
|
||||
(card-games-bid--note game "%s won the bid: %s."
|
||||
(aref card-games-bid-seat-names contractor) (card-games-bid-label bid))))
|
||||
|
||||
|
||||
;;;; Kitty discard
|
||||
|
||||
(cl-defmethod card-games-bid--discard ((game card-games-bid-game) seat cards)
|
||||
"Have GAME SEAT discard CARDS (a list of 5) and start play."
|
||||
(card-games-bid--set-hand game seat
|
||||
(cl-set-difference (card-games-bid--hand game seat) cards
|
||||
:test #'equal))
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :turn (card-games-get game :contractor))
|
||||
(card-games-put game :leader (card-games-get game :contractor))
|
||||
(card-games-put game :led nil)
|
||||
(card-games-put game :trick nil)
|
||||
(card-games-put game :cursor 0)
|
||||
(card-games-put game :message
|
||||
(format "Play! %s leads."
|
||||
(aref card-games-bid-seat-names (card-games-get game :contractor)))))
|
||||
|
||||
|
||||
;;;; Seat order (a partner sits out during a misère)
|
||||
|
||||
(defun card-games-bid--misere-p (game)
|
||||
"Return non-nil when GAME's current contract is a nullo/misère."
|
||||
(let ((c (card-games-get game :contract))) (and c (card-games-bid-nullo-p c))))
|
||||
|
||||
(defun card-games-bid--sitter (game)
|
||||
"Return GAME's seat sitting out (contractor's partner) in a misère, else nil."
|
||||
(and (card-games-bid--misere-p game)
|
||||
(card-games-bid--partner (card-games-get game :contractor))))
|
||||
|
||||
(defun card-games-bid--in-play-p (game seat)
|
||||
"Return non-nil when SEAT takes part in GAME's current hand."
|
||||
(not (eql seat (card-games-bid--sitter game))))
|
||||
|
||||
(defun card-games-bid--num-players (game)
|
||||
"Return GAME's seats playing to each trick (3 in misère, else 4)."
|
||||
(if (card-games-bid--misere-p game) 3 4))
|
||||
|
||||
(defun card-games-bid--next-seat (game seat)
|
||||
"Return GAME's next in-play seat clockwise from SEAT."
|
||||
(let ((n (mod (1+ seat) 4)))
|
||||
(if (card-games-bid--in-play-p game n) n (mod (1+ n) 4))))
|
||||
|
||||
|
||||
;;;; Trick play
|
||||
|
||||
(cl-defmethod card-games-bid--play ((game card-games-bid-game) seat card)
|
||||
"Have GAME SEAT play CARD into the current trick and advance."
|
||||
(let* ((trump (card-games-bid-trump (card-games-get game :contract)))
|
||||
(led (card-games-get game :led))
|
||||
(lead-p (null (card-games-get game :trick))))
|
||||
;; remove card from hand
|
||||
(card-games-bid--set-hand game seat
|
||||
(cl-remove card (card-games-bid--hand game seat)
|
||||
:test #'equal :count 1))
|
||||
(card-games-put game :trick (append (card-games-get game :trick) (list (cons seat card))))
|
||||
(card-games-bid--note game "%s %s the %s."
|
||||
(aref card-games-bid-seat-names seat)
|
||||
(if lead-p "leads" "plays")
|
||||
(card-games-bid-card-string card))
|
||||
;; establish led suit
|
||||
(unless led
|
||||
(setq led (card-games-bid-effective-suit card trump))
|
||||
;; joker led in no-trump nominates a suit
|
||||
(when (and (eq led 'joker))
|
||||
(setq led (card-games-bid--nominate-suit game seat)))
|
||||
(card-games-put game :led led))
|
||||
(if (= (length (card-games-get game :trick)) (card-games-bid--num-players game))
|
||||
(card-games-bid--finish-trick game)
|
||||
(card-games-put game :turn (card-games-bid--next-seat game seat)))))
|
||||
|
||||
(defun card-games-bid--nominate-suit (game seat)
|
||||
"Choose the suit GAME SEAT nominates when the Joker leads under no-trump."
|
||||
(let ((hand (card-games-bid--hand game seat)))
|
||||
(if (card-games-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 (card-games-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 card-games-bid--finish-trick ((game card-games-bid-game))
|
||||
"Resolve GAME's completed trick, award it, and set up the next."
|
||||
(let* ((trump (card-games-bid-trump (card-games-get game :contract)))
|
||||
(led (card-games-get game :led))
|
||||
(plays (card-games-get game :trick))
|
||||
(winner (card-games-bid-trick-winner plays trump led)))
|
||||
(cl-incf (aref (card-games-get game :tricks) winner))
|
||||
(card-games-put game :ntricks (1+ (card-games-get game :ntricks)))
|
||||
(card-games-put game :last-trick plays)
|
||||
(card-games-put game :trick nil)
|
||||
(card-games-put game :led nil)
|
||||
(card-games-put game :leader winner)
|
||||
(card-games-put game :turn winner)
|
||||
(card-games-put game :message
|
||||
(format "%s wins the trick (%s)."
|
||||
(aref card-games-bid-seat-names winner)
|
||||
(mapconcat (lambda (p) (card-games-bid-card-string (cdr p))) plays " ")))
|
||||
(card-games-bid--note game "%s wins the trick." (aref card-games-bid-seat-names winner))
|
||||
;; open misère: expose the contractor's hand after the first trick
|
||||
(when (and (card-games-bid-open-p (card-games-get game :contract))
|
||||
(= (card-games-get game :ntricks) 1))
|
||||
(card-games-put game :exposed (card-games-get game :contractor)))
|
||||
;; hand over after ten tricks
|
||||
(when (= (card-games-get game :ntricks) 10)
|
||||
(card-games-bid--score-hand game))))
|
||||
|
||||
|
||||
;;;; Scoring
|
||||
|
||||
(cl-defmethod card-games-bid--score-hand ((game card-games-bid-game))
|
||||
"Score GAME's completed hand per the Avondale schedule."
|
||||
(let* ((bid (card-games-get game :contract))
|
||||
(contractor (card-games-get game :contractor))
|
||||
(cteam (card-games-bid--team contractor))
|
||||
(tricks (card-games-get game :tricks))
|
||||
(side (+ (aref tricks contractor)
|
||||
(aref tricks (card-games-bid--partner contractor))))
|
||||
(opp (- 10 side))
|
||||
(scores (card-games-get game :scores))
|
||||
(delta-c 0) (delta-o 0) (made nil) result)
|
||||
(cond
|
||||
((card-games-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 (card-games-bid-value bid) (- (card-games-bid-value bid)))))
|
||||
(t
|
||||
(setq made (>= side (card-games-bid-tricks bid)))
|
||||
(if made
|
||||
(setq delta-c (if (and (= side 10) (< (card-games-bid-value bid) 250))
|
||||
250 (card-games-bid-value bid)))
|
||||
(setq delta-c (- (card-games-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))))
|
||||
(card-games-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 card-games-bid-seat-names contractor)
|
||||
(if made "MADE" "was SET on")
|
||||
(card-games-bid-label bid)
|
||||
(aref card-games-bid-seat-names contractor)
|
||||
(aref card-games-bid-seat-names (card-games-bid--partner contractor))
|
||||
side (if (= side 1) "" "s")
|
||||
(if (= cteam 0) "You/North" "West/East")
|
||||
delta-c
|
||||
(if (and (not (card-games-bid-nullo-p bid)) (> delta-o 0))
|
||||
(format ", opponents +%d" delta-o) "")))
|
||||
(card-games-put game :phase 'done)
|
||||
(card-games-put game :hand-result result)
|
||||
(card-games-bid--note game "%s" result)
|
||||
(let ((winner (card-games-bid--check-gameover game made cteam)))
|
||||
(card-games-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 (card-games-get game :scores)) (cdr (card-games-get game :scores)))
|
||||
(concat result " — press n for the next hand."))))))
|
||||
|
||||
(cl-defmethod card-games-bid--check-gameover ((game card-games-bid-game) made cteam)
|
||||
"End 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 (card-games-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
|
||||
(card-games-put game :game-over winner)
|
||||
(card-games-put game :phase 'gameover))
|
||||
winner))
|
||||
|
||||
|
||||
;;;; Basic AI
|
||||
|
||||
(defvar card-games-bid-ai-policies (vector 'smart 'smart 'smart 'smart)
|
||||
"Per-seat AI policy vector; each element is `smart' or `basic'.")
|
||||
|
||||
(defvar card-games-bid-ai-partner-help 1.0
|
||||
"Tricks the smart bidder assumes its partner will contribute.")
|
||||
|
||||
(defun card-games-bid--policy (seat)
|
||||
"Return the AI policy symbol for SEAT."
|
||||
(aref card-games-bid-ai-policies seat))
|
||||
|
||||
;;; shared helpers
|
||||
|
||||
(defun card-games-bid--lowest (cards trump led)
|
||||
"Return the weakest of CARDS given TRUMP and LED."
|
||||
(car (sort (copy-sequence cards)
|
||||
(lambda (a b) (< (card-games-bid-power a trump led)
|
||||
(card-games-bid-power b trump led))))))
|
||||
|
||||
(defun card-games-bid--highest (cards trump led)
|
||||
"Return the strongest of CARDS given TRUMP and LED."
|
||||
(car (sort (copy-sequence cards)
|
||||
(lambda (a b) (> (card-games-bid-power a trump led)
|
||||
(card-games-bid-power b trump led))))))
|
||||
|
||||
(defun card-games-bid--trump-cards (hand trump)
|
||||
"Return HAND's trump cards under TRUMP (Joker and bowers included)."
|
||||
(cl-remove-if-not
|
||||
(lambda (c) (or (card-games-bid-joker-p c)
|
||||
(and (numberp trump) (eq (card-games-bid-effective-suit c trump) trump))))
|
||||
hand))
|
||||
|
||||
(defun card-games-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 (card-games-bid-joker-p c))
|
||||
(eq (card-games-bid-effective-suit c trump) suit)))
|
||||
hand))
|
||||
|
||||
;;; basic policy (original heuristics)
|
||||
|
||||
(defun card-games-bid--ai-estimate (hand trump)
|
||||
"Rough trick estimate for HAND if TRUMP (0-3 or `nt') were the contract."
|
||||
(let ((joker (cl-some #'card-games-bid-joker-p hand))
|
||||
(aces 0) (kings 0) (trumps 0))
|
||||
(dolist (c hand)
|
||||
(unless (card-games-bid-joker-p c)
|
||||
(cond
|
||||
((and (numberp trump) (eq (card-games-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 card-games-bid--ai-best-contract (hand)
|
||||
"Return (TRUMP . EST) for the strongest contract HAND suggests (basic)."
|
||||
(let ((best (cons 'nt (card-games-bid--ai-estimate hand 'nt))))
|
||||
(dotimes (s 4)
|
||||
(let ((e (card-games-bid--ai-estimate hand s)))
|
||||
(when (> e (cdr best)) (setq best (cons s e)))))
|
||||
best))
|
||||
|
||||
(defun card-games-bid--ai-bid-basic (game seat)
|
||||
"Pick and record a bid (or pass) for GAME AI SEAT using the basic estimate."
|
||||
(let* ((hand (card-games-bid--hand game seat))
|
||||
(best (card-games-bid--ai-best-contract hand))
|
||||
(trump (car best))
|
||||
(est (min 10 (cdr best)))
|
||||
(maxval (cl-loop for b in card-games-bid-schedule
|
||||
when (and (eq (card-games-bid-trump b) trump)
|
||||
(= (card-games-bid-tricks b) est))
|
||||
return (card-games-bid-value b)))
|
||||
(legal (card-games-bid--legal-bids game))
|
||||
(choice (and maxval (>= est 6)
|
||||
(car (cl-remove-if-not
|
||||
(lambda (b) (<= (card-games-bid-value b) maxval))
|
||||
legal)))))
|
||||
(card-games-bid--auction-act game seat choice)))
|
||||
|
||||
(defun card-games-bid--ai-discard-basic (game seat)
|
||||
"Discard GAME SEAT's five weakest cards (basic)."
|
||||
(let* ((trump (card-games-bid-trump (card-games-get game :contract)))
|
||||
(sorted (card-games-bid-sort-hand (card-games-bid--hand game seat) trump))
|
||||
(discard (last sorted 5)))
|
||||
(card-games-bid--discard game seat discard)))
|
||||
|
||||
(defun card-games-bid--ai-play-positive (game seat)
|
||||
"Trick-play for GAME AI SEAT under a suit or no-trump contract (basic)."
|
||||
(let* ((trump (card-games-bid-trump (card-games-get game :contract)))
|
||||
(led (card-games-get game :led))
|
||||
(hand (card-games-bid--hand game seat))
|
||||
(legal (card-games-bid-legal-cards hand led trump))
|
||||
(plays (card-games-get game :trick))
|
||||
card)
|
||||
(if (null plays)
|
||||
(setq card (or (cl-find-if
|
||||
(lambda (c) (and (not (card-games-bid-joker-p c)) (= (cdr c) 10)
|
||||
(or (not (numberp trump))
|
||||
(/= (card-games-bid-effective-suit c trump) trump))))
|
||||
legal)
|
||||
(card-games-bid--lowest legal trump led)))
|
||||
(let* ((winner (card-games-bid-trick-winner plays trump led))
|
||||
(partner-winning (= (card-games-bid--partner seat) winner))
|
||||
(best-power (card-games-bid-power (cdr (assq winner plays)) trump led)))
|
||||
(if partner-winning
|
||||
(setq card (card-games-bid--lowest legal trump led))
|
||||
(let ((winners (cl-remove-if-not
|
||||
(lambda (c) (> (card-games-bid-power c trump led) best-power))
|
||||
legal)))
|
||||
(setq card (if winners
|
||||
(card-games-bid--lowest winners trump led)
|
||||
(card-games-bid--lowest legal trump led)))))))
|
||||
(card-games-bid--play game seat card)))
|
||||
|
||||
;;; smart policy
|
||||
|
||||
(defun card-games-bid--eval-suit (hand trump)
|
||||
"Estimate tricks (float) for a suit TRUMP contract from HAND."
|
||||
(let* ((trumps (card-games-bid--trump-cards hand trump))
|
||||
(nt (length trumps))
|
||||
(high (cl-count-if (lambda (c) (>= (card-games-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 (card-games-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 card-games-bid--eval-nt (hand)
|
||||
"Estimate tricks (float) for a no-trump contract from HAND."
|
||||
(let ((est (if (cl-some #'card-games-bid-joker-p hand) 1.0 0.0)))
|
||||
(dotimes (s 4)
|
||||
(let* ((cs (card-games-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 card-games-bid--best-smart (hand)
|
||||
"Return (TRUMP . EST-float) for the best contract HAND suggests (smart)."
|
||||
(let ((best (cons 'nt (card-games-bid--eval-nt hand))))
|
||||
(dotimes (s 4)
|
||||
(let ((e (card-games-bid--eval-suit hand s)))
|
||||
(when (> e (cdr best)) (setq best (cons s e)))))
|
||||
best))
|
||||
|
||||
(defun card-games-bid--ai-bid-smart (game seat)
|
||||
"Pick and record a bid (or pass) for GAME AI SEAT using the smart evaluation."
|
||||
(let* ((hand (card-games-bid--hand game seat))
|
||||
(best (card-games-bid--best-smart hand))
|
||||
(trump (car best))
|
||||
(est (min 10 (floor (+ (cdr best) card-games-bid-ai-partner-help))))
|
||||
(maxval (cl-loop for b in card-games-bid-schedule
|
||||
when (and (eq (card-games-bid-trump b) trump)
|
||||
(= (card-games-bid-tricks b) est))
|
||||
return (card-games-bid-value b)))
|
||||
(legal (card-games-bid--legal-bids game))
|
||||
(choice (and maxval (>= est 6)
|
||||
(car (cl-remove-if-not
|
||||
(lambda (b) (<= (card-games-bid-value b) maxval))
|
||||
legal)))))
|
||||
(card-games-bid--auction-act game seat choice)))
|
||||
|
||||
(defun card-games-bid--ai-discard-smart (game seat)
|
||||
"For GAME SEAT, discard to keep trumps and aces and void short suits for ruffs."
|
||||
(let* ((trump (card-games-bid-trump (card-games-get game :contract)))
|
||||
(hand (card-games-bid--hand game seat))
|
||||
(cand '()))
|
||||
(dolist (c hand)
|
||||
(unless (or (card-games-bid-joker-p c) (= (cdr c) 10)
|
||||
(and (numberp trump) (eq (card-games-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 (card-games-bid-sort-hand hand trump) 5))))
|
||||
(card-games-bid--discard game seat discard)))))
|
||||
|
||||
(defun card-games-bid--lead-low-long (hand trump legal)
|
||||
"Lead the lowest card of HAND's longest side suit, from LEGAL (TRUMP set)."
|
||||
(let ((best-suit nil) (best-len -1))
|
||||
(dotimes (s 4)
|
||||
(unless (and (numberp trump) (= s trump))
|
||||
(let ((len (length (card-games-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 (card-games-bid-joker-p c))
|
||||
(eq (card-games-bid-effective-suit c trump) best-suit)))
|
||||
legal))))
|
||||
(card-games-bid--lowest (or cs legal) trump nil))))
|
||||
|
||||
(defun card-games-bid--ai-play-smart (game seat)
|
||||
"Trick-play for GAME 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 (card-games-bid-trump (card-games-get game :contract)))
|
||||
(led (card-games-get game :led))
|
||||
(hand (card-games-bid--hand game seat))
|
||||
(legal (card-games-bid-legal-cards hand led trump))
|
||||
(plays (card-games-get game :trick))
|
||||
(contractor (card-games-get game :contractor))
|
||||
(declarer-side (= (card-games-bid--team seat) (card-games-bid--team contractor)))
|
||||
card)
|
||||
(cond
|
||||
((null plays)
|
||||
(let* ((trumps (and (numberp trump) (card-games-bid--trump-cards hand trump)))
|
||||
(hi (cl-count-if (lambda (c) (>= (card-games-bid-power c trump trump) 809))
|
||||
(or trumps '()))))
|
||||
(setq card
|
||||
(cond
|
||||
((and declarer-side (numberp trump) trumps
|
||||
(or (>= (length trumps) 4) (>= hi 2)))
|
||||
(card-games-bid--highest trumps trump trump))
|
||||
((cl-find-if (lambda (c)
|
||||
(and (not (card-games-bid-joker-p c)) (= (cdr c) 10)
|
||||
(or (not (numberp trump))
|
||||
(/= (card-games-bid-effective-suit c trump) trump))))
|
||||
legal))
|
||||
(t (card-games-bid--lead-low-long hand trump legal))))))
|
||||
(t
|
||||
(let* ((winner (card-games-bid-trick-winner plays trump led))
|
||||
(partner-winning (= (card-games-bid--partner seat) winner))
|
||||
(best-power (card-games-bid-power (cdr (assq winner plays)) trump led)))
|
||||
(setq card
|
||||
(if partner-winning
|
||||
(card-games-bid--lowest legal trump led)
|
||||
(let ((winners (cl-remove-if-not
|
||||
(lambda (c) (> (card-games-bid-power c trump led) best-power))
|
||||
legal)))
|
||||
(if winners (card-games-bid--lowest winners trump led)
|
||||
(card-games-bid--lowest legal trump led))))))))
|
||||
(card-games-bid--play game seat card)))
|
||||
|
||||
;;; dispatch
|
||||
|
||||
(cl-defmethod card-games-bid--ai-bid ((game card-games-bid-game) seat)
|
||||
"Pick and record a bid for GAME AI SEAT per its policy."
|
||||
(if (eq (card-games-bid--policy seat) 'smart)
|
||||
(card-games-bid--ai-bid-smart game seat)
|
||||
(card-games-bid--ai-bid-basic game seat)))
|
||||
|
||||
(cl-defmethod card-games-bid--ai-discard ((game card-games-bid-game) seat)
|
||||
"Have GAME AI SEAT exchange the kitty per its policy."
|
||||
(if (eq (card-games-bid--policy seat) 'smart)
|
||||
(card-games-bid--ai-discard-smart game seat)
|
||||
(card-games-bid--ai-discard-basic game seat)))
|
||||
|
||||
(cl-defmethod card-games-bid--ai-play ((game card-games-bid-game) seat)
|
||||
"Choose and play a card for GAME AI SEAT per its policy."
|
||||
(cond ((card-games-bid--misere-p game) (card-games-bid--ai-play-misere game seat))
|
||||
((eq (card-games-bid--policy seat) 'smart) (card-games-bid--ai-play-smart game seat))
|
||||
(t (card-games-bid--ai-play-positive game seat))))
|
||||
|
||||
(defun card-games-bid--ai-play-misere (game seat)
|
||||
"Trick-play for GAME 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 (card-games-get game :led))
|
||||
(hand (card-games-bid--hand game seat))
|
||||
(legal (card-games-bid-legal-cards hand led trump))
|
||||
(plays (card-games-get game :trick))
|
||||
(contractor (card-games-get game :contractor))
|
||||
card)
|
||||
(cond
|
||||
((/= seat contractor)
|
||||
(setq card (card-games-bid--lowest legal trump led)))
|
||||
((null plays)
|
||||
(setq card (card-games-bid--lowest legal trump led)))
|
||||
(t
|
||||
(let* ((wseat (card-games-bid-trick-winner plays trump led))
|
||||
(bestp (card-games-bid-power (cdr (assq wseat plays)) trump led))
|
||||
(losers (cl-remove-if-not
|
||||
(lambda (c) (< (card-games-bid-power c trump led) bestp)) legal)))
|
||||
(setq card (card-games-bid--highest (or losers legal) trump led)))))
|
||||
(card-games-bid--play game seat card)))
|
||||
|
||||
|
||||
;;;; Driver: run AI until the human must act
|
||||
|
||||
(defun card-games-bid--ai-step (game)
|
||||
"Perform one pending AI action in GAME. Return non-nil if it acted."
|
||||
(pcase (card-games-get game :phase)
|
||||
('auction (unless (card-games-bid--human-p (card-games-get game :bidder))
|
||||
(card-games-bid--ai-bid game (card-games-get game :bidder)) t))
|
||||
('kitty (unless (card-games-bid--human-p (card-games-get game :contractor))
|
||||
(card-games-bid--ai-discard game (card-games-get game :contractor)) t))
|
||||
('play (unless (card-games-bid--human-p (card-games-get game :turn))
|
||||
(card-games-bid--ai-play game (card-games-get game :turn)) t))
|
||||
(_ nil)))
|
||||
|
||||
(cl-defmethod card-games-bid--run ((game card-games-bid-game))
|
||||
"Advance GAME through AI actions until a human is needed or it ends."
|
||||
(let ((guard 0))
|
||||
(while (and (< (cl-incf guard) 400) (card-games-bid--ai-step game)))))
|
||||
|
||||
(provide 'card-games-bid)
|
||||
;;; card-games-bid.el ends here
|
||||
875
card-games-bridge.el
Normal file
875
card-games-bridge.el
Normal file
|
|
@ -0,0 +1,875 @@
|
|||
;;; card-games-bridge.el --- Contract Bridge with rubber scoring -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Contract Bridge: you are South, partnered with North, against East and
|
||||
;; West. Each deal has an auction -- bids of a level (1-7) and a strain
|
||||
;; (clubs, diamonds, hearts, spades, or no-trump), plus Pass, Double, and
|
||||
;; Redouble -- followed by the play of thirteen tricks with the dummy (the
|
||||
;; declarer's partner) exposed. Scoring is the classic rubber game: trick
|
||||
;; points below the line race toward game, and bonuses, overtricks, and
|
||||
;; penalties go above; two games win the rubber.
|
||||
;;
|
||||
;; When you are declarer you play both your own hand and the dummy; when
|
||||
;; you defend you play your own cards and the computer plays the rest.
|
||||
;;
|
||||
;; The bidding AI is a deliberately small natural system (it opens on
|
||||
;; about twelve points, raises to game with a fit, and overcalls a good
|
||||
;; long suit); it reaches sensible contracts but is no expert. Cards use
|
||||
;; the package cons (SUIT . RANK), SUIT 0 spades, 1 clubs, 2 diamonds,
|
||||
;; 3 hearts, RANK 0 (Two) .. 12 (Ace).
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-svg)
|
||||
|
||||
(defconst card-games-bridge-ranks
|
||||
["2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K" "A"]
|
||||
"Rank labels indexed 0 (Two) .. 12 (Ace).")
|
||||
|
||||
(defconst card-games-bridge-strains ["♣" "♦" "♥" "♠" "NT"]
|
||||
"Strain glyphs indexed 0 clubs, 1 diamonds, 2 hearts, 3 spades, 4 no-trump.")
|
||||
|
||||
(defconst card-games-bridge--strain-suit [1 2 3 0 nil]
|
||||
"Map a strain index to its trump suit index (nil for no-trump).")
|
||||
|
||||
(defconst card-games-bridge--suit-strain [3 0 1 2]
|
||||
"Map a suit index (0 S,1 C,2 D,3 H) to its strain index.")
|
||||
|
||||
(defconst card-games-bridge-seat-names ["South" "West" "North" "East"]
|
||||
"Seat names indexed 0..3 clockwise from the human.")
|
||||
|
||||
(defclass card-games-bridge-game (card-games-game)
|
||||
((vname :initform "Bridge"))
|
||||
"A game of contract Bridge.")
|
||||
|
||||
(defun card-games-bridge-card-string (card)
|
||||
"Return a short string for CARD."
|
||||
(if (null card) "·"
|
||||
(concat (aref card-games-bridge-ranks (cdr card)) (card-games-suit-glyph (car card)))))
|
||||
|
||||
(defun card-games-bridge--sort (cards)
|
||||
"Return CARDS sorted by suit then rank (high first) for display."
|
||||
(sort (copy-sequence cards)
|
||||
(lambda (a b) (if (= (car a) (car b)) (> (cdr a) (cdr b)) (< (car a) (car b))))))
|
||||
|
||||
(defun card-games-bridge--deck ()
|
||||
"Return a fresh shuffled 52-card deck."
|
||||
(random t)
|
||||
(card-games-shuffle (cl-loop for s below 4 append
|
||||
(cl-loop for r below 13 collect (cons s r)))))
|
||||
|
||||
;;;; Hand evaluation
|
||||
|
||||
(defun card-games-bridge--hcp (hand)
|
||||
"Return the high-card points of HAND (A=4 K=3 Q=2 J=1)."
|
||||
(let ((p 0))
|
||||
(dolist (c hand p)
|
||||
(setq p (+ p (pcase (cdr c) (12 4) (11 3) (10 2) (9 1) (_ 0)))))))
|
||||
|
||||
(defun card-games-bridge--suit-len (hand suit)
|
||||
"Return how many cards of SUIT are in HAND."
|
||||
(cl-count suit hand :key #'car))
|
||||
|
||||
(defun card-games-bridge--longest (hand)
|
||||
"Return the suit index HAND has most of (ties prefer majors, then spades)."
|
||||
(let ((best 0) (bestn -1))
|
||||
;; check in order hearts, diamonds, clubs, spades so spades win ties last
|
||||
(dolist (s '(3 2 1 0))
|
||||
(let ((n (card-games-bridge--suit-len hand s)))
|
||||
(when (>= n bestn) (setq bestn n best s))))
|
||||
best))
|
||||
|
||||
(defun card-games-bridge--balanced-p (hand)
|
||||
"Return non-nil when HAND has a balanced shape (no void/singleton)."
|
||||
(let ((doubletons 0) (ok t))
|
||||
(dotimes (s 4)
|
||||
(let ((n (card-games-bridge--suit-len hand s)))
|
||||
(when (< n 2) (setq ok nil))
|
||||
(when (= n 2) (setq doubletons (1+ doubletons)))))
|
||||
(and ok (<= doubletons 1))))
|
||||
|
||||
;;;; Auction mechanics
|
||||
|
||||
(defsubst card-games-bridge--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
|
||||
(defsubst card-games-bridge--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
|
||||
(defsubst card-games-bridge--side (s) "Return the partnership side (0 or 1) of seat S." (mod s 2))
|
||||
|
||||
(cl-defmethod card-games-bridge--deal ((game card-games-bridge-game))
|
||||
"Deal a fresh Bridge hand into GAME, leaving it ready for the auction."
|
||||
(let ((deck (card-games-bridge--deck)) (hands (make-vector 4 nil)))
|
||||
(dotimes (s 4)
|
||||
(aset hands s (card-games-bridge--sort (cl-loop repeat 13 collect (pop deck)))))
|
||||
(card-games-put game :hands hands)
|
||||
(card-games-put game :calls nil) ; list of (SEAT . CALL), newest first
|
||||
(card-games-put game :contract nil) ; (LEVEL . STRAIN)
|
||||
(card-games-put game :declarer nil)
|
||||
(card-games-put game :doubled 0)
|
||||
(card-games-put game :dealer (or (card-games-get game :dealer) 0))
|
||||
(card-games-put game :bidder (card-games-get game :dealer))
|
||||
(card-games-put game :phase 'auction)
|
||||
(card-games-put game :cursor 0)
|
||||
(card-games-put game :bid-level 1) ; UI: level being composed
|
||||
(card-games-put game :bid-strain 0)
|
||||
(card-games-put game :trick nil)
|
||||
(card-games-put game :tricks 0) ; declarer-side tricks won
|
||||
(card-games-put game :dummy nil)
|
||||
(card-games-put game :exposed nil)
|
||||
(unless (card-games-get game :below) (card-games-put game :below (make-vector 2 0)))
|
||||
(unless (card-games-get game :above) (card-games-put game :above (make-vector 2 0)))
|
||||
(unless (card-games-get game :games) (card-games-put game :games (make-vector 2 0)))
|
||||
(unless (card-games-get game :vul) (card-games-put game :vul (make-vector 2 nil)))
|
||||
(card-games-put game :message "Auction: compose a bid and press RET, or p/d to pass/double.")
|
||||
game))
|
||||
|
||||
(defun card-games-bridge--high-bid (game)
|
||||
"Return GAME's highest (LEVEL . STRAIN) bid so far, or nil."
|
||||
(cl-loop for (_s . call) in (card-games-get game :calls)
|
||||
when (consp call) return call))
|
||||
|
||||
(defun card-games-bridge--high-bidder (game)
|
||||
"Return the GAME seat that made the highest bid, or nil."
|
||||
(cl-loop for (s . call) in (card-games-get game :calls)
|
||||
when (consp call) return s))
|
||||
|
||||
(defun card-games-bridge--call> (a b)
|
||||
"Return non-nil when bid A is higher than bid B (each (LEVEL . STRAIN))."
|
||||
(or (null b)
|
||||
(> (car a) (car b))
|
||||
(and (= (car a) (car b)) (> (cdr a) (cdr b)))))
|
||||
|
||||
(defun card-games-bridge--legal-call-p (game call)
|
||||
"Return non-nil when CALL is legal now in GAME."
|
||||
(let ((high (card-games-bridge--high-bid game))
|
||||
(hb (card-games-bridge--high-bidder game)))
|
||||
(pcase call
|
||||
('pass t)
|
||||
('double (and high (/= (card-games-bridge--side hb) (card-games-bridge--side (card-games-get game :bidder)))
|
||||
(= (card-games-get game :doubled) 0)))
|
||||
('redouble (and high (= (card-games-bridge--side hb) (card-games-bridge--side (card-games-get game :bidder)))
|
||||
(= (card-games-get game :doubled) 1)))
|
||||
(_ (and (consp call) (>= (car call) 1) (<= (car call) 7)
|
||||
(card-games-bridge--call> call high))))))
|
||||
|
||||
(defun card-games-bridge--apply-call (game seat call)
|
||||
"Record CALL by SEAT in GAME and update doubling state."
|
||||
(card-games-put game :calls (cons (cons seat call) (card-games-get game :calls)))
|
||||
(pcase call
|
||||
('double (card-games-put game :doubled 1))
|
||||
('redouble (card-games-put game :doubled 2))
|
||||
((pred consp) (card-games-put game :doubled 0)))
|
||||
(card-games-put game :bidder (mod (1+ seat) 4)))
|
||||
|
||||
(defun card-games-bridge--auction-done-p (game)
|
||||
"Return non-nil when GAME's auction has ended.
|
||||
Sets up the contract (or a pass-out) as a side effect."
|
||||
(let* ((calls (card-games-get game :calls)) (n (length calls)))
|
||||
(cond
|
||||
;; four passes with no bid: passed out
|
||||
((and (= n 4) (cl-every (lambda (c) (eq (cdr c) 'pass)) calls))
|
||||
(card-games-put game :phase 'passed-out) t)
|
||||
;; a bid then three passes
|
||||
((and (card-games-bridge--high-bid game)
|
||||
(>= n 3)
|
||||
(cl-every (lambda (c) (eq (cdr c) 'pass))
|
||||
(cl-subseq calls 0 3)))
|
||||
(card-games-bridge--establish-contract game) t)
|
||||
(t nil))))
|
||||
|
||||
(defun card-games-bridge--establish-contract (game)
|
||||
"Set GAME's contract, declarer, and start of play from the auction."
|
||||
(let* ((bid (card-games-bridge--high-bid game))
|
||||
(side (card-games-bridge--side (card-games-bridge--high-bidder game)))
|
||||
(strain (cdr bid))
|
||||
(declarer
|
||||
;; first player of SIDE to have named STRAIN
|
||||
(cl-loop for (s . call) in (reverse (card-games-get game :calls))
|
||||
when (and (consp call) (= (cdr call) strain)
|
||||
(= (card-games-bridge--side s) side))
|
||||
return s)))
|
||||
(card-games-put game :contract bid)
|
||||
(card-games-put game :declarer declarer)
|
||||
(card-games-put game :dummy (mod (+ declarer 2) 4))
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :leader (mod (1+ declarer) 4))
|
||||
(card-games-put game :turn (mod (1+ declarer) 4))
|
||||
(card-games-put game :trick nil)
|
||||
(card-games-put game :tricks 0)
|
||||
(card-games-put game :cursor 0)
|
||||
(card-games-put game :message
|
||||
(format "Contract: %s by %s. %s leads."
|
||||
(card-games-bridge--contract-string game)
|
||||
(aref card-games-bridge-seat-names declarer)
|
||||
(aref card-games-bridge-seat-names (card-games-get game :leader))))))
|
||||
|
||||
(defun card-games-bridge--contract-string (game)
|
||||
"Return a label for GAME's contract, e.g. \"4NT x\"."
|
||||
(let ((c (card-games-get game :contract)) (d (card-games-get game :doubled)))
|
||||
(if (null c) "passed out"
|
||||
(format "%d%s%s" (car c) (aref card-games-bridge-strains (cdr c))
|
||||
(pcase d (1 " x") (2 " xx") (_ ""))))))
|
||||
|
||||
;;;; Play mechanics
|
||||
|
||||
(defun card-games-bridge--trump (game)
|
||||
"Return the trump suit index for GAME, or nil for no-trump."
|
||||
(and (card-games-get game :contract) (aref card-games-bridge--strain-suit (cdr (card-games-get game :contract)))))
|
||||
|
||||
(defun card-games-bridge--led-suit (game)
|
||||
"Return the suit led to GAME's current trick, or nil."
|
||||
(let ((tr (card-games-get game :trick)))
|
||||
(and tr (car (cdr (car (last tr)))))))
|
||||
|
||||
(defun card-games-bridge--legal-play-p (game seat card)
|
||||
"Return non-nil when SEAT may play CARD in GAME now (follow suit if able)."
|
||||
(let ((hand (card-games-bridge--hand game seat)) (led (card-games-bridge--led-suit game)))
|
||||
(and (member card hand)
|
||||
(or (null led)
|
||||
(= (car card) led)
|
||||
(not (cl-some (lambda (c) (= (car c) led)) hand))))))
|
||||
|
||||
(defun card-games-bridge--legal-plays (game seat)
|
||||
"Return SEAT's legal cards in GAME now."
|
||||
(cl-remove-if-not (lambda (c) (card-games-bridge--legal-play-p game seat c))
|
||||
(card-games-bridge--hand game seat)))
|
||||
|
||||
(defun card-games-bridge--trick-winner (plays trump)
|
||||
"Return the winning seat of complete PLAYS, given TRUMP ((SEAT . CARD) order)."
|
||||
(let ((best (car plays)))
|
||||
(dolist (p (cdr plays))
|
||||
(let ((bc (cdr best)) (pc (cdr p)))
|
||||
(cond
|
||||
((and trump (= (car pc) trump) (/= (car bc) trump)) (setq best p))
|
||||
((and (= (car pc) (car bc)) (> (cdr pc) (cdr bc))) (setq best p)))))
|
||||
(car best)))
|
||||
|
||||
(defun card-games-bridge--play-card (game seat card)
|
||||
"Have SEAT play CARD in GAME; resolve and score the trick when complete."
|
||||
(card-games-bridge--set-hand game seat (remove card (card-games-bridge--hand game seat)))
|
||||
(card-games-put game :trick (cons (cons seat card) (card-games-get game :trick)))
|
||||
;; expose the dummy after the opening lead
|
||||
(unless (card-games-get game :exposed)
|
||||
(card-games-put game :exposed t))
|
||||
(if (= 4 (length (card-games-get game :trick)))
|
||||
(let ((w (card-games-bridge--trick-winner (reverse (card-games-get game :trick))
|
||||
(card-games-bridge--trump game))))
|
||||
(when (= (card-games-bridge--side w) (card-games-bridge--side (card-games-get game :declarer)))
|
||||
(card-games-put game :tricks (1+ (card-games-get game :tricks))))
|
||||
(card-games-put game :trick nil)
|
||||
(card-games-put game :leader w)
|
||||
(card-games-put game :turn w)
|
||||
(card-games-put game :last-winner w)
|
||||
(when (cl-every #'null (append (card-games-get game :hands) nil))
|
||||
(card-games-bridge--score-deal game))
|
||||
w)
|
||||
(card-games-put game :turn (mod (1+ seat) 4))
|
||||
nil))
|
||||
|
||||
;;;; Scoring (rubber)
|
||||
|
||||
(defun card-games-bridge--undertrick-points (n doubled vul)
|
||||
"Return defender points for N undertricks at DOUBLED level and VUL state."
|
||||
(cond
|
||||
((= doubled 0) (* n (if vul 100 50)))
|
||||
(t (let ((mult (if (= doubled 2) 2 1)) (sum 0))
|
||||
(dotimes (i n)
|
||||
(setq sum (+ sum (* mult (if vul (if (= i 0) 200 300)
|
||||
(cond ((= i 0) 100) ((< i 3) 200) (t 300)))))))
|
||||
sum))))
|
||||
|
||||
(defun card-games-bridge--deal-score (level strain doubled vul tricks)
|
||||
"Return a plist scoring a contract result.
|
||||
LEVEL/STRAIN/DOUBLED describe the contract, VUL the declarer's
|
||||
vulnerability, and TRICKS the declarer side's trick count. Keys:
|
||||
:below contracted points, :datk declarer bonus points above the line,
|
||||
:defend defender points, :result tricks over/under the contract."
|
||||
(let* ((need (+ 6 level)) (result (- tricks need))
|
||||
(mult (pcase doubled (0 1) (1 2) (2 4)))
|
||||
(below 0) (datk 0) (defend 0))
|
||||
(if (>= result 0)
|
||||
(progn
|
||||
(setq below (* mult (if (= strain 4) (+ 40 (* 30 (1- level)))
|
||||
(* (if (<= strain 1) 20 30) level))))
|
||||
(when (> result 0)
|
||||
(setq datk (+ datk (if (= doubled 0)
|
||||
(* result (if (= strain 4) 30 (if (<= strain 1) 20 30)))
|
||||
(* result (* (if (= doubled 2) 2 1) (if vul 200 100)))))))
|
||||
(when (> doubled 0) (setq datk (+ datk (if (= doubled 2) 100 50))))
|
||||
(cond ((= level 6) (setq datk (+ datk (if vul 750 500))))
|
||||
((= level 7) (setq datk (+ datk (if vul 1500 1000))))))
|
||||
(setq defend (card-games-bridge--undertrick-points (- result) doubled vul)))
|
||||
(list :below below :datk datk :defend defend :result result)))
|
||||
|
||||
(defun card-games-bridge--score-deal (game)
|
||||
"Score the finished deal into GAME's rubber state."
|
||||
(let* ((c (card-games-get game :contract)) (level (car c)) (strain (cdr c))
|
||||
(decl (card-games-get game :declarer)) (side (card-games-bridge--side decl))
|
||||
(opp (- 1 side)) (doubled (card-games-get game :doubled))
|
||||
(vul (aref (card-games-get game :vul) side))
|
||||
(sc (card-games-bridge--deal-score level strain doubled vul (card-games-get game :tricks)))
|
||||
(below (card-games-get game :below)) (above (card-games-get game :above)))
|
||||
(aset below side (+ (aref below side) (plist-get sc :below)))
|
||||
(aset above side (+ (aref above side) (plist-get sc :datk)))
|
||||
(aset above opp (+ (aref above opp) (plist-get sc :defend)))
|
||||
(card-games-put game :deal-result sc)
|
||||
;; game / rubber bookkeeping
|
||||
(when (>= (aref below side) 100)
|
||||
(let ((games (card-games-get game :games)))
|
||||
(aset games side (1+ (aref games side)))
|
||||
(aset (card-games-get game :vul) side t)
|
||||
(aset below 0 0) (aset below 1 0)
|
||||
(when (>= (aref games side) 2)
|
||||
(aset above side (+ (aref above side)
|
||||
(if (>= (aref games opp) 1) 500 700)))
|
||||
(card-games-put game :rubber-winner side))))
|
||||
(card-games-put game :phase 'scored)
|
||||
(card-games-put game :message
|
||||
(format "%s: %s. %s"
|
||||
(card-games-bridge--contract-string game)
|
||||
(let ((r (plist-get sc :result)))
|
||||
(cond ((>= r 0) (format "made +%d" r))
|
||||
(t (format "down %d" (- r)))))
|
||||
(if (card-games-get game :rubber-winner)
|
||||
(format "%s win the rubber! (n: new rubber)"
|
||||
(if (= side 0) "You and North" "East and West"))
|
||||
"(n: next deal)")))))
|
||||
|
||||
;;;; AI -- bidding
|
||||
|
||||
(cl-defmethod card-games-bridge--ai-call ((game card-games-bridge-game) seat)
|
||||
"Return a call for GAME AI SEAT from a small natural system."
|
||||
(let* ((hand (card-games-bridge--hand game seat)) (hcp (card-games-bridge--hcp hand))
|
||||
(high (card-games-bridge--high-bid game)) (hb (card-games-bridge--high-bidder game))
|
||||
(ours (and high (= (card-games-bridge--side hb) (card-games-bridge--side seat)))))
|
||||
(cond
|
||||
((null high) ; opening
|
||||
(cond ((and (card-games-bridge--balanced-p hand) (>= hcp 15) (<= hcp 17)) (cons 1 4))
|
||||
((and (card-games-bridge--balanced-p hand) (>= hcp 20) (<= hcp 21)) (cons 2 4))
|
||||
((>= hcp 12)
|
||||
(let ((suit (card-games-bridge--longest hand)))
|
||||
(cons 1 (aref card-games-bridge--suit-strain suit))))
|
||||
(t 'pass)))
|
||||
(ours ; partner has the contract
|
||||
(let* ((est (+ hcp 13)) (hl (car high)) (hs (cdr high))
|
||||
(fit (or (= hs 4)
|
||||
(>= (card-games-bridge--suit-len
|
||||
hand (aref card-games-bridge--strain-suit hs)) 3))))
|
||||
(if (and fit (>= est 26) (< hl 4)
|
||||
(card-games-bridge--legal-call-p
|
||||
game (cond ((= hs 4) (cons 3 4))
|
||||
((>= hs 2) (cons 4 hs))
|
||||
(t (cons 5 hs)))))
|
||||
(cond ((= hs 4) (cons 3 4)) ((>= hs 2) (cons 4 hs)) (t (cons 5 hs)))
|
||||
'pass)))
|
||||
(t ; opponents have the contract
|
||||
(let* ((suit (card-games-bridge--longest hand))
|
||||
(len (card-games-bridge--suit-len hand suit))
|
||||
(st (aref card-games-bridge--suit-strain suit))
|
||||
(cand (if (> st (cdr high)) (cons (car high) st)
|
||||
(cons (1+ (car high)) st))))
|
||||
(if (and (>= hcp 11) (>= len 5) (<= (car cand) 3)
|
||||
(card-games-bridge--legal-call-p game cand))
|
||||
cand 'pass))))))
|
||||
|
||||
;;;; AI -- play
|
||||
|
||||
(cl-defmethod card-games-bridge--ai-play ((game card-games-bridge-game) seat)
|
||||
"Return a card for GAME AI SEAT: win cheaply or shed low."
|
||||
(let* ((legal (card-games-bridge--legal-plays game seat))
|
||||
(trump (card-games-bridge--trump game)) (trick (card-games-get game :trick)))
|
||||
(if (null trick)
|
||||
;; leading: low from the longest non-trump suit, else lowest
|
||||
(car (sort (copy-sequence legal)
|
||||
(lambda (a b) (< (cdr a) (cdr b)))))
|
||||
(let* ((order (reverse trick))
|
||||
(cur (card-games-bridge--trick-winner order trump))
|
||||
(partner (= (card-games-bridge--side cur) (card-games-bridge--side seat)))
|
||||
(winners (cl-remove-if-not
|
||||
(lambda (c) (= seat (card-games-bridge--trick-winner
|
||||
(append order (list (cons seat c))) trump)))
|
||||
legal)))
|
||||
(cond
|
||||
;; partner already winning: throw the lowest card
|
||||
((and partner (>= (length trick) 1))
|
||||
(car (sort (copy-sequence legal) (lambda (a b) (< (cdr a) (cdr b))))))
|
||||
;; can win: take it with the cheapest winner
|
||||
(winners (car (sort winners (lambda (a b) (< (cdr a) (cdr b))))))
|
||||
;; cannot win: discard lowest
|
||||
(t (car (sort (copy-sequence legal) (lambda (a b) (< (cdr a) (cdr b)))))))))))
|
||||
|
||||
(defun card-games-bridge--controls (game)
|
||||
"Return the GAME seats the human controls during play."
|
||||
(let ((decl (card-games-get game :declarer)))
|
||||
(cond ((null decl) nil)
|
||||
((= decl 0) '(0 2)) ; South declares: play hand + dummy
|
||||
((= decl 2) nil) ; North declares: AI plays both
|
||||
(t '(0))))) ; South defends
|
||||
|
||||
(defun card-games-bridge--auto-seat-p (game seat)
|
||||
"Return non-nil when SEAT is played automatically (by AI) in GAME."
|
||||
(not (memq seat (card-games-bridge--controls game))))
|
||||
|
||||
(defun card-games-bridge--run-play (game)
|
||||
"Advance GAME's AI plays until a human seat must act or the deal ends."
|
||||
(let ((guard 0))
|
||||
(while (and (eq (card-games-get game :phase) 'play)
|
||||
(card-games-bridge--auto-seat-p game (card-games-get game :turn))
|
||||
(< guard 60))
|
||||
(setq guard (1+ guard))
|
||||
(card-games-bridge--play-card game (card-games-get game :turn)
|
||||
(card-games-bridge--ai-play game (card-games-get game :turn))))))
|
||||
|
||||
(defun card-games-bridge--run-auction (game)
|
||||
"Advance GAME's auction through AI seats until South must call or it ends."
|
||||
(let ((guard 0))
|
||||
(while (and (eq (card-games-get game :phase) 'auction) (/= (card-games-get game :bidder) 0)
|
||||
(< guard 40))
|
||||
(setq guard (1+ guard))
|
||||
(let* ((s (card-games-get game :bidder)) (call (card-games-bridge--ai-call game s)))
|
||||
(unless (card-games-bridge--legal-call-p game call) (setq call 'pass))
|
||||
(card-games-bridge--apply-call game s call)
|
||||
(card-games-bridge--auction-done-p game)))
|
||||
(when (eq (card-games-get game :phase) 'play) (card-games-bridge--run-play game))))
|
||||
|
||||
;;;; UI
|
||||
|
||||
(defvar-local card-games-bridge--game nil "The Bridge game in the current buffer.")
|
||||
|
||||
(defun card-games-bridge--hand-by-suit (cards)
|
||||
"Return CARDS grouped into four lines by suit, as a string."
|
||||
(let ((out '()))
|
||||
(dolist (s '(0 3 2 1)) ; S H D C
|
||||
(let ((in (card-games-bridge--sort (cl-remove-if-not (lambda (c) (= (car c) s)) cards))))
|
||||
(push (format " %s %s\n" (card-games-suit-glyph s)
|
||||
(if in (mapconcat (lambda (c) (aref card-games-bridge-ranks (cdr c))) in " ")
|
||||
"--"))
|
||||
out)))
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(defun card-games-bridge--auction-string (game)
|
||||
"Return a compact record of GAME's auction so far."
|
||||
(let ((calls (reverse (card-games-get game :calls))) (out '()))
|
||||
(dolist (sc calls)
|
||||
(push (format "%s:%s" (aref card-games-bridge-seat-names (car sc))
|
||||
(pcase (cdr sc)
|
||||
('pass "pass") ('double "X") ('redouble "XX")
|
||||
(c (format "%d%s" (car c) (aref card-games-bridge-strains (cdr c))))))
|
||||
out))
|
||||
(if out (mapconcat #'identity (nreverse out) " ") "(no calls yet)")))
|
||||
|
||||
(defcustom card-games-bridge-svg-cards t
|
||||
"When non-nil, draw cards as SVG images on a graphical display."
|
||||
:type 'boolean :group 'card-games)
|
||||
|
||||
(defun card-games-bridge--spec (card)
|
||||
"Return the card-games-svg display spec (RANK-STRING . SUIT) for CARD."
|
||||
(cons (aref card-games-bridge-ranks (cdr card)) (car card)))
|
||||
|
||||
(cl-defun card-games-bridge--svg-row (cards &key cursor hints region-tag)
|
||||
"Return an SVG row for CARDS with CURSOR and HINTS, clickable via REGION-TAG."
|
||||
(card-games-svg-hand-image (mapcar #'card-games-bridge--spec cards)
|
||||
:cursor cursor :hints hints
|
||||
:overlap (if (> (length cards) 11)
|
||||
(max 0 (- card-games-svg-card-width 26)) 0)
|
||||
:region-tag region-tag))
|
||||
|
||||
(defun card-games-bridge--draw-backs (svg x y n)
|
||||
"Draw up to three overlapped backs on SVG at X, Y for a hand of N cards."
|
||||
(let ((k (min (max n 0) 3)) (xx x))
|
||||
(dotimes (_ k) (card-games-svg-card svg xx y :down t) (setq xx (+ xx 16)))))
|
||||
|
||||
(defun card-games-bridge--svg (game)
|
||||
"Return an SVG board for the Bridge GAME (four seats, dummy exposed)."
|
||||
(let* ((w card-games-svg-card-width) (h card-games-svg-card-height) (gap card-games-svg-card-gap) (pad 16)
|
||||
(phase (card-games-get game :phase)) (cursor (card-games-get game :cursor))
|
||||
(turn (card-games-get game :turn)) (dummy (card-games-get game :dummy))
|
||||
(exposed (card-games-get game :exposed)) (trick (card-games-get game :trick))
|
||||
(act (if (and (eq phase 'play) (memq turn (card-games-bridge--controls game))) turn 0))
|
||||
(ahand (card-games-bridge--sort (card-games-bridge--hand game act)))
|
||||
(n (length ahand))
|
||||
(overlap (cond ((> n 11) (- w 26)) ((> n 8) 20) (t 0)))
|
||||
(step (max 14 (- (+ w gap) overlap)))
|
||||
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
|
||||
(width (max (+ fanw (* 2 pad)) 760))
|
||||
(cx (/ width 2))
|
||||
(y-title 6) (y-info 24) (y-north 62)
|
||||
(y-tn (+ y-north h 20))
|
||||
(cyc (+ y-tn (round (* h 0.5))))
|
||||
(y-ts (+ cyc (round (* h 0.15))))
|
||||
(y-hand (+ y-ts h 42))
|
||||
(height (+ y-hand h 30))
|
||||
(svg (svg-create width height))
|
||||
(lc (card-games-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels
|
||||
((txt (str x y &optional sz bold)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family card-games-svg-font-family (and bold '(:font-weight "bold"))))
|
||||
(seat (s x y)
|
||||
(if (and exposed (eql s dummy) (/= s act))
|
||||
(let ((cs (card-games-bridge--sort (card-games-bridge--hand game s))) (xx x))
|
||||
(dolist (c cs)
|
||||
(let ((sp (card-games-bridge--spec c)))
|
||||
(card-games-svg-card svg xx y :rank (car sp) :suit (cdr sp)))
|
||||
(setq xx (+ xx 15))))
|
||||
(card-games-bridge--draw-backs svg x (+ y 6) (length (card-games-bridge--hand game s))))
|
||||
(txt (format "%s%s%s" (aref card-games-bridge-seat-names s)
|
||||
(if (eql s dummy) " (dummy)" "")
|
||||
(if (= turn s) " <-" ""))
|
||||
x y 11))
|
||||
(trick-card (s x y)
|
||||
(let ((play (assq s trick)))
|
||||
(when play
|
||||
(let ((sp (card-games-bridge--spec (cdr play))))
|
||||
(card-games-svg-card svg x y :rank (car sp) :suit (cdr sp)))))))
|
||||
(txt "Bridge" pad (+ y-title 12) 13 t)
|
||||
(txt (format "Games N-S %d E-W %d Below %d/%d Above %d/%d"
|
||||
(aref (card-games-get game :games) 0) (aref (card-games-get game :games) 1)
|
||||
(aref (card-games-get game :below) 0) (aref (card-games-get game :below) 1)
|
||||
(aref (card-games-get game :above) 0) (aref (card-games-get game :above) 1))
|
||||
pad (+ y-info 8) 11)
|
||||
(pcase phase
|
||||
('auction
|
||||
(txt (format "Auction: %s" (card-games-bridge--auction-string game)) pad (+ y-info 24) 11)
|
||||
(txt (format "Your bid: %d %s (arrows compose, RET bids)"
|
||||
(card-games-get game :bid-level)
|
||||
(aref card-games-bridge-strains (card-games-get game :bid-strain)))
|
||||
pad (+ y-info 40) 11))
|
||||
((or 'play 'scored 'passed-out)
|
||||
(txt (format "Contract: %s by %s Declarer tricks: %d"
|
||||
(card-games-bridge--contract-string game)
|
||||
(if (card-games-get game :declarer)
|
||||
(aref card-games-bridge-seat-names (card-games-get game :declarer)) "--")
|
||||
(card-games-get game :tricks))
|
||||
pad (+ y-info 24) 11)))
|
||||
(seat 2 (- cx 40) y-north)
|
||||
(seat 1 pad cyc)
|
||||
(seat 3 (- width pad 110) cyc)
|
||||
(when (eq phase 'play)
|
||||
(trick-card 2 (- cx (/ w 2)) y-tn)
|
||||
(trick-card 0 (- cx (/ w 2)) y-ts)
|
||||
(trick-card 1 (- cx w (round (* w 0.4))) (round (- cyc (* h 0.25))))
|
||||
(trick-card 3 (+ cx (round (* w 0.4))) (round (- cyc (* h 0.25)))))
|
||||
(txt (format "%s%s" (aref card-games-bridge-seat-names act)
|
||||
(cond ((eq phase 'auction) " (you)")
|
||||
((= act 0) " (you)")
|
||||
(t " (dummy -- you play)")))
|
||||
pad (- y-hand 6) 11)
|
||||
(let ((x (max pad (- (/ width 2) (/ fanw 2)))) (i 0)
|
||||
(legalp (and (eq phase 'play) (= turn act))))
|
||||
(dolist (c ahand)
|
||||
(let ((sp (card-games-bridge--spec c)) (curp (= i cursor))
|
||||
(hintp (and legalp (card-games-bridge--legal-play-p game act c))))
|
||||
(card-games-svg-card svg x y-hand :rank (car sp) :suit (cdr sp)
|
||||
:highlight curp :hint hintp)
|
||||
(push (cons (list x y-hand (if (= i (1- n)) w step) h) (cons 'hand i)) regions))
|
||||
(setq x (+ x step) i (1+ i))))
|
||||
(txt (or (card-games-get game :message) "") pad (- height 8) 12))
|
||||
(propertize "*" 'display (card-games-svg-image svg (card-games-scale)) 'card-games-regions (nreverse regions))))
|
||||
|
||||
(cl-defmethod card-games-render ((game card-games-bridge-game))
|
||||
"Return a depiction of the Bridge GAME: SVG board if graphical, else text."
|
||||
(if (and card-games-bridge-svg-cards (display-graphic-p))
|
||||
(card-games-bridge--svg game)
|
||||
(card-games-bridge--render-text game)))
|
||||
|
||||
(defun card-games-bridge--render-text (game)
|
||||
"Return a plain-text depiction of the Bridge GAME."
|
||||
(let* ((out '()) (phase (card-games-get game :phase)) (cursor (card-games-get game :cursor)))
|
||||
(push " Bridge\n" out)
|
||||
(push (format " Rubber: You/North games %d East/West games %d%s\n"
|
||||
(aref (card-games-get game :games) 0) (aref (card-games-get game :games) 1)
|
||||
(let ((v (card-games-get game :vul)))
|
||||
(format " (vul: %s)"
|
||||
(cond ((and (aref v 0) (aref v 1)) "both")
|
||||
((aref v 0) "N-S") ((aref v 1) "E-W") (t "none")))))
|
||||
out)
|
||||
(push (format " Below: You/N %d E/W %d Above: You/N %d E/W %d\n\n"
|
||||
(aref (card-games-get game :below) 0) (aref (card-games-get game :below) 1)
|
||||
(aref (card-games-get game :above) 0) (aref (card-games-get game :above) 1))
|
||||
out)
|
||||
(pcase phase
|
||||
('auction
|
||||
(push (format " Auction so far: %s\n\n" (card-games-bridge--auction-string game)) out)
|
||||
(push (format " Compose: %d %s (Up/Down level, Left/Right strain)\n\n"
|
||||
(card-games-get game :bid-level)
|
||||
(aref card-games-bridge-strains (card-games-get game :bid-strain)))
|
||||
out))
|
||||
((or 'play 'scored 'passed-out)
|
||||
(push (format " Contract: %s by %s Declarer tricks: %d\n"
|
||||
(card-games-bridge--contract-string game)
|
||||
(if (card-games-get game :declarer)
|
||||
(aref card-games-bridge-seat-names (card-games-get game :declarer)) "--")
|
||||
(card-games-get game :tricks))
|
||||
out)
|
||||
(when (and (card-games-get game :exposed) (card-games-get game :dummy))
|
||||
(push (format "\n Dummy (%s):\n "
|
||||
(aref card-games-bridge-seat-names (card-games-get game :dummy))) out)
|
||||
(if (and card-games-bridge-svg-cards (display-graphic-p))
|
||||
(push (card-games-bridge--svg-row
|
||||
(card-games-bridge--sort (card-games-bridge--hand game (card-games-get game :dummy)))) out)
|
||||
(push (card-games-bridge--hand-by-suit (card-games-bridge--hand game (card-games-get game :dummy))) out)))
|
||||
(push "\n Trick: " out)
|
||||
(cond
|
||||
((null (card-games-get game :trick)) (push "(empty)" out))
|
||||
((and card-games-bridge-svg-cards (display-graphic-p))
|
||||
(push (concat (mapconcat (lambda (p) (aref card-games-bridge-seat-names (car p)))
|
||||
(reverse (card-games-get game :trick)) " ") " ") out)
|
||||
(push (card-games-bridge--svg-row (mapcar #'cdr (reverse (card-games-get game :trick)))) out))
|
||||
(t (dolist (p (reverse (card-games-get game :trick)))
|
||||
(push (format "%s:%s " (aref card-games-bridge-seat-names (car p))
|
||||
(card-games-bridge-card-string (cdr p))) out))))
|
||||
(push "\n" out)))
|
||||
;; the human's hand (South), or the seat being played from when it is dummy
|
||||
(let* ((act (if (and (eq phase 'play) (memq (card-games-get game :turn)
|
||||
(card-games-bridge--controls game)))
|
||||
(card-games-get game :turn) 0))
|
||||
(hand (card-games-bridge--sort (card-games-bridge--hand game act))))
|
||||
(push (format "\n %s%s:\n "
|
||||
(aref card-games-bridge-seat-names act)
|
||||
(cond ((eq phase 'auction) " (you)")
|
||||
((= act 0) " (you)")
|
||||
(t " (dummy, you play)")))
|
||||
out)
|
||||
(cond
|
||||
((and (eq phase 'play) card-games-bridge-svg-cards (display-graphic-p))
|
||||
(let ((hi '()) (i 0))
|
||||
(dolist (c hand)
|
||||
(when (and (= (card-games-get game :turn) act) (card-games-bridge--legal-play-p game act c))
|
||||
(push i hi))
|
||||
(setq i (1+ i)))
|
||||
(push (card-games-bridge--svg-row hand :cursor cursor :hints hi :region-tag 'hand) out)))
|
||||
((eq phase 'play)
|
||||
(let ((i 0))
|
||||
(dolist (c hand)
|
||||
(let ((cs (card-games-bridge-card-string c)) (faces nil))
|
||||
(when (card-games-red-suit-p (car c)) (push 'card-games-red-suit faces))
|
||||
(when (and (= (card-games-get game :turn) act)
|
||||
(card-games-bridge--legal-play-p game act c)) (push 'card-games-hint faces))
|
||||
(when (= i cursor) (push 'card-games-cursor faces))
|
||||
(push (propertize (format "%4s" cs) 'face (or faces 'default)) out))
|
||||
(setq i (1+ i)))))
|
||||
(t (push (card-games-bridge--hand-by-suit hand) out))))
|
||||
(push (format "\n\n %s\n" (card-games-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod card-games-render-apply ((g card-games-bridge-game) action)
|
||||
"Apply click ACTION on G's hand: select that card and play it."
|
||||
(pcase action
|
||||
(`(hand . ,i) (card-games-put g :cursor i) (card-games-bridge-play))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun card-games-bridge--redisplay ()
|
||||
"Redraw the current Bridge buffer."
|
||||
(let ((game card-games-bridge--game) (inhibit-read-only t))
|
||||
(setq card-games-current-game game card-games-redisplay-function #'card-games-bridge--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))
|
||||
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
|
||||
|
||||
;;;; Auction commands
|
||||
|
||||
(defun card-games-bridge-bid-level-up ()
|
||||
"Raise the level being composed."
|
||||
(interactive)
|
||||
(let ((g card-games-bridge--game))
|
||||
(card-games-put g :bid-level (min 7 (1+ (card-games-get g :bid-level))))
|
||||
(card-games-bridge--redisplay)))
|
||||
|
||||
(defun card-games-bridge-bid-level-down ()
|
||||
"Lower the level being composed."
|
||||
(interactive)
|
||||
(let ((g card-games-bridge--game))
|
||||
(card-games-put g :bid-level (max 1 (1- (card-games-get g :bid-level))))
|
||||
(card-games-bridge--redisplay)))
|
||||
|
||||
(defun card-games-bridge-bid-strain-left ()
|
||||
"Move the composed strain down (toward clubs)."
|
||||
(interactive)
|
||||
(let ((g card-games-bridge--game))
|
||||
(card-games-put g :bid-strain (max 0 (1- (card-games-get g :bid-strain))))
|
||||
(card-games-bridge--redisplay)))
|
||||
|
||||
(defun card-games-bridge-bid-strain-right ()
|
||||
"Move the composed strain up (toward no-trump)."
|
||||
(interactive)
|
||||
(let ((g card-games-bridge--game))
|
||||
(card-games-put g :bid-strain (min 4 (1+ (card-games-get g :bid-strain))))
|
||||
(card-games-bridge--redisplay)))
|
||||
|
||||
(defun card-games-bridge--after-call (g)
|
||||
"Resolve the end of the auction and run AI after South's call in G."
|
||||
(unless (card-games-bridge--auction-done-p g)
|
||||
(card-games-bridge--run-auction g))
|
||||
(when (eq (card-games-get g :phase) 'play) (card-games-bridge--run-play g))
|
||||
(card-games-bridge--redisplay))
|
||||
|
||||
(defun card-games-bridge-bid ()
|
||||
"Make the composed bid."
|
||||
(interactive)
|
||||
(let* ((g card-games-bridge--game)
|
||||
(call (cons (card-games-get g :bid-level) (card-games-get g :bid-strain))))
|
||||
(cond
|
||||
((not (eq (card-games-get g :phase) 'auction)) (card-games-put g :message "Not bidding now."))
|
||||
((/= (card-games-get g :bidder) 0) (card-games-put g :message "Not your turn."))
|
||||
((not (card-games-bridge--legal-call-p g call))
|
||||
(card-games-put g :message "That bid is too low."))
|
||||
(t (card-games-bridge--apply-call g 0 call) (card-games-bridge--after-call g)))
|
||||
(card-games-bridge--redisplay)))
|
||||
|
||||
(defun card-games-bridge-pass ()
|
||||
"Pass in the auction."
|
||||
(interactive)
|
||||
(let ((g card-games-bridge--game))
|
||||
(if (and (eq (card-games-get g :phase) 'auction) (= (card-games-get g :bidder) 0))
|
||||
(progn (card-games-bridge--apply-call g 0 'pass) (card-games-bridge--after-call g))
|
||||
(card-games-put g :message "Nothing to pass on."))
|
||||
(card-games-bridge--redisplay)))
|
||||
|
||||
(defun card-games-bridge-double ()
|
||||
"Double (or redouble) in the auction."
|
||||
(interactive)
|
||||
(let* ((g card-games-bridge--game)
|
||||
(call (if (= (card-games-get g :doubled) 1) 'redouble 'double)))
|
||||
(if (and (eq (card-games-get g :phase) 'auction) (= (card-games-get g :bidder) 0)
|
||||
(card-games-bridge--legal-call-p g call))
|
||||
(progn (card-games-bridge--apply-call g 0 call) (card-games-bridge--after-call g))
|
||||
(card-games-put g :message "You cannot double now."))
|
||||
(card-games-bridge--redisplay)))
|
||||
|
||||
;;;; Play commands
|
||||
|
||||
(defun card-games-bridge--act-hand (g)
|
||||
"Return the hand G's cursor currently indexes (the seat to act)."
|
||||
(let ((act (if (memq (card-games-get g :turn) (card-games-bridge--controls g)) (card-games-get g :turn) 0)))
|
||||
(card-games-bridge--sort (card-games-bridge--hand g act))))
|
||||
|
||||
(defun card-games-bridge-left ()
|
||||
"Move the cursor left."
|
||||
(interactive)
|
||||
(let* ((g card-games-bridge--game) (n (length (card-games-bridge--act-hand g))))
|
||||
(cond ((eq (card-games-get g :phase) 'auction) (card-games-bridge-bid-strain-left))
|
||||
(t (when (> n 0) (card-games-put g :cursor (mod (1- (card-games-get g :cursor)) n)))
|
||||
(card-games-bridge--redisplay)))))
|
||||
|
||||
(defun card-games-bridge-right ()
|
||||
"Move the cursor right."
|
||||
(interactive)
|
||||
(let* ((g card-games-bridge--game) (n (length (card-games-bridge--act-hand g))))
|
||||
(cond ((eq (card-games-get g :phase) 'auction) (card-games-bridge-bid-strain-right))
|
||||
(t (when (> n 0) (card-games-put g :cursor (mod (1+ (card-games-get g :cursor)) n)))
|
||||
(card-games-bridge--redisplay)))))
|
||||
|
||||
(defun card-games-bridge-up ()
|
||||
"Raise the bid level (auction only)."
|
||||
(interactive)
|
||||
(if (eq (card-games-get card-games-bridge--game :phase) 'auction) (card-games-bridge-bid-level-up)
|
||||
(card-games-bridge--redisplay)))
|
||||
|
||||
(defun card-games-bridge-down ()
|
||||
"Lower the bid level (auction only)."
|
||||
(interactive)
|
||||
(if (eq (card-games-get card-games-bridge--game :phase) 'auction) (card-games-bridge-bid-level-down)
|
||||
(card-games-bridge--redisplay)))
|
||||
|
||||
(defun card-games-bridge-play ()
|
||||
"Play the cursor card, or make the composed bid during the auction."
|
||||
(interactive)
|
||||
(let ((g card-games-bridge--game))
|
||||
(if (eq (card-games-get g :phase) 'auction)
|
||||
(card-games-bridge-bid)
|
||||
(let* ((turn (card-games-get g :turn)))
|
||||
(cond
|
||||
((not (eq (card-games-get g :phase) 'play)) (card-games-put g :message "Press n to continue."))
|
||||
((not (memq turn (card-games-bridge--controls g)))
|
||||
(card-games-put g :message "Wait for your turn."))
|
||||
(t (let ((card (nth (card-games-get g :cursor) (card-games-bridge--sort (card-games-bridge--hand g turn)))))
|
||||
(if (or (null card) (not (card-games-bridge--legal-play-p g turn card)))
|
||||
(card-games-put g :message "You must follow suit.")
|
||||
(card-games-bridge--play-card g turn card)
|
||||
(card-games-put g :cursor 0)
|
||||
(when (eq (card-games-get g :phase) 'play) (card-games-bridge--run-play g))))))
|
||||
(card-games-bridge--redisplay)))))
|
||||
|
||||
(defun card-games-bridge-new ()
|
||||
"Deal the next hand, or a fresh rubber when one is over."
|
||||
(interactive)
|
||||
(let ((g card-games-bridge--game))
|
||||
(when (or (card-games-get g :rubber-winner))
|
||||
(card-games-put g :below (make-vector 2 0)) (card-games-put g :above (make-vector 2 0))
|
||||
(card-games-put g :games (make-vector 2 0)) (card-games-put g :vul (make-vector 2 nil))
|
||||
(card-games-put g :rubber-winner nil))
|
||||
(card-games-put g :dealer (mod (1+ (or (card-games-get g :dealer) 0)) 4))
|
||||
(card-games-bridge--deal g)
|
||||
(card-games-bridge--run-auction g)
|
||||
(card-games-bridge--redisplay)))
|
||||
|
||||
(defun card-games-bridge-redraw () "Redraw." (interactive) (card-games-bridge--redisplay))
|
||||
(defun card-games-bridge-help () "Describe the controls." (interactive)
|
||||
(message "Auction: Up/Down level, Left/Right strain, RET bid, p pass, d double. Play: arrows + RET. n: next"))
|
||||
|
||||
(defvar card-games-bridge-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'card-games-card-click)
|
||||
(define-key map "+" #'card-games-card-zoom-in)
|
||||
(define-key map "=" #'card-games-card-zoom-in)
|
||||
(define-key map "-" #'card-games-card-zoom-out)
|
||||
(define-key map "0" #'card-games-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'card-games-bridge-left)
|
||||
(define-key map (kbd "<right>") #'card-games-bridge-right)
|
||||
(define-key map (kbd "<up>") #'card-games-bridge-up)
|
||||
(define-key map (kbd "<down>") #'card-games-bridge-down)
|
||||
(define-key map (kbd "RET") #'card-games-bridge-play)
|
||||
(define-key map "p" #'card-games-bridge-pass)
|
||||
(define-key map "d" #'card-games-bridge-double)
|
||||
(define-key map "n" #'card-games-bridge-new)
|
||||
(define-key map "g" #'card-games-bridge-redraw)
|
||||
(define-key map "?" #'card-games-bridge-help)
|
||||
(define-key map "q" #'card-games-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `card-games-bridge-mode'.")
|
||||
|
||||
(define-derived-mode card-games-bridge-mode special-mode "Bridge"
|
||||
"Major mode for contract Bridge."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type card-games-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-bridge ()
|
||||
"Play contract Bridge against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Bridge*")))
|
||||
(with-current-buffer buf
|
||||
(card-games-bridge-mode)
|
||||
(setq card-games-bridge--game (card-games-bridge-game))
|
||||
(card-games-put card-games-bridge--game :dealer 0)
|
||||
(card-games-bridge--deal card-games-bridge--game)
|
||||
(card-games-bridge--run-auction card-games-bridge--game)
|
||||
(card-games-bridge--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
(provide 'card-games-bridge)
|
||||
;;; card-games-bridge.el ends here
|
||||
|
|
@ -1,11 +1,10 @@
|
|||
;;; cg-core.el --- Shared engine core for card games -*- lexical-binding: t; -*-
|
||||
;;; card-games-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.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
|
|
@ -25,8 +24,8 @@
|
|||
;;; 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
|
||||
;; provides the abstract `card-games-game' class with a plist "environment" for
|
||||
;; mutable per-game state, the `card-games-render' and `card-games-won-p' generics, and
|
||||
;; a handful of card and display utilities (suit glyphs, colour
|
||||
;; helpers, a shuffle, and common faces).
|
||||
;;
|
||||
|
|
@ -42,15 +41,15 @@
|
|||
(defgroup card-games nil
|
||||
"Play card games in Emacs."
|
||||
:group 'games
|
||||
:prefix "cg-")
|
||||
:prefix "card-games-")
|
||||
|
||||
(defcustom cg-card-scale 1.0
|
||||
(defcustom card-games-card-scale 1.0
|
||||
"Card-size multiplier applied on top of any text scaling.
|
||||
Adjust with the card-size slider or the zoom keys (+/-/0)."
|
||||
:type 'number :group 'card-games)
|
||||
|
||||
(defcustom cg-cursor-type nil
|
||||
"Cursor shape in card-game buffers.
|
||||
(defcustom card-games-cursor-type nil
|
||||
"Cursor shape in card-games buffers.
|
||||
Card-game buffers are display surfaces -- you act on the highlighted
|
||||
card or board cell, not on the text cursor -- so the text cursor is
|
||||
hidden by default (nil), which also stops it blinking without touching
|
||||
|
|
@ -64,7 +63,7 @@ to show a cursor instead."
|
|||
|
||||
;;;; Engine base
|
||||
|
||||
(defcustom cg-keys 'emacs
|
||||
(defcustom card-games-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
|
||||
|
|
@ -73,38 +72,38 @@ and SPC as an action key. Takes effect the next time a game starts."
|
|||
(const :tag "Classic (adds hjkl, SPC)" classic))
|
||||
:group 'card-games)
|
||||
|
||||
(defcustom cg-ai-level 'normal
|
||||
(defcustom card-games-ai-level 'normal
|
||||
"Difficulty of the computer opponents, where a game supports it.
|
||||
`easy' plays a quick, simple game, `normal' plays soundly, and `hard'
|
||||
thinks a little harder. Honoured by Russian Bank (Crapette) and the
|
||||
trick-taking games so far; other games ignore it for now. Change it from
|
||||
the `card-game' menu or with `card-games-set-ai-level'."
|
||||
the `card-games' menu or with `card-games-set-ai-level'."
|
||||
:type '(choice (const :tag "Easy" easy)
|
||||
(const :tag "Normal" normal)
|
||||
(const :tag "Hard" hard))
|
||||
:group 'card-games)
|
||||
|
||||
(defclass cg-game ()
|
||||
(defclass card-games-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.")
|
||||
(renderer :initarg :renderer :initform nil
|
||||
:documentation "Current `cg-renderer', or nil for the default."))
|
||||
:documentation "Current `card-games-renderer', or nil for the default."))
|
||||
"Abstract base class for card games."
|
||||
:abstract t)
|
||||
|
||||
(cl-defgeneric cg-render (game)
|
||||
(cl-defgeneric card-games-render (game)
|
||||
"Return a propertized string depicting GAME.")
|
||||
|
||||
(cl-defgeneric cg-won-p (game)
|
||||
(cl-defgeneric card-games-won-p (game)
|
||||
"Return non-nil when GAME has been won.")
|
||||
|
||||
(cl-defmethod cg-get ((game cg-game) key)
|
||||
(cl-defmethod card-games-get ((game card-games-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)
|
||||
(cl-defmethod card-games-put ((game card-games-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)
|
||||
|
|
@ -114,13 +113,13 @@ the `card-game' menu or with `card-games-set-ai-level'."
|
|||
|
||||
;; A renderer (a "skin") is a display treatment: it knows how to draw a
|
||||
;; game and how to map a click back to a game action. Treatments are
|
||||
;; EIEIO classes registered by name in `cg-renderers'; a game holds the
|
||||
;; EIEIO classes registered by name in `card-games-renderers'; a game holds the
|
||||
;; one it is currently drawn with. This lets a single game be shown as
|
||||
;; plain text, as SVG, or as a full-window SVG table without subclassing
|
||||
;; the game itself once per treatment. Concrete treatments and the
|
||||
;; game-specific drawing methods live in cg-render.el and the games.
|
||||
;; game-specific drawing methods live in card-games-render.el and the games.
|
||||
|
||||
(defclass cg-renderer ()
|
||||
(defclass card-games-renderer ()
|
||||
((name :initarg :name :initform 'text :type symbol
|
||||
:documentation "Symbol naming this treatment.")
|
||||
(regions :initarg :regions :initform nil
|
||||
|
|
@ -129,23 +128,23 @@ RECT being (X Y W H) in unscaled image pixels."))
|
|||
"Abstract base class for a display treatment (a \"skin\")."
|
||||
:abstract t)
|
||||
|
||||
(cl-defgeneric cg-renderer-draw (renderer game)
|
||||
(cl-defgeneric card-games-renderer-draw (renderer game)
|
||||
"Draw GAME under RENDERER by inserting into the current buffer.")
|
||||
|
||||
(cl-defgeneric cg-renderer-hit (renderer game position)
|
||||
(cl-defgeneric card-games-renderer-hit (renderer game position)
|
||||
"Map POSITION under RENDERER to an action on GAME.
|
||||
Return non-nil when the click was handled.")
|
||||
|
||||
(cl-defmethod cg-renderer-draw ((renderer cg-renderer) (game cg-game))
|
||||
(cl-defmethod card-games-renderer-draw ((renderer card-games-renderer) (game card-games-game))
|
||||
"Default method: signal that RENDERER cannot draw GAME."
|
||||
(error "No `cg-renderer-draw' for %s under the `%s' renderer"
|
||||
(error "No `card-games-renderer-draw' for %s under the `%s' renderer"
|
||||
(eieio-object-class-name game) (oref renderer name)))
|
||||
|
||||
(cl-defmethod cg-renderer-hit ((_renderer cg-renderer) (_game cg-game) _position)
|
||||
(cl-defmethod card-games-renderer-hit ((_renderer card-games-renderer) (_game card-games-game) _position)
|
||||
"Default method: treat the click as unhandled."
|
||||
nil)
|
||||
|
||||
(defun cg-regions-hit (regions px py)
|
||||
(defun card-games-regions-hit (regions px py)
|
||||
"Return the ACTION of the first region in REGIONS containing PX, PY.
|
||||
Each region is (RECT . ACTION) with RECT (X Y W H) in image pixels."
|
||||
(cl-loop for (rect . action) in regions
|
||||
|
|
@ -153,40 +152,40 @@ Each region is (RECT . ACTION) with RECT (X Y W H) in image pixels."
|
|||
when (and (>= px x) (< px (+ x w)) (>= py y) (< py (+ y h)))
|
||||
return action))
|
||||
|
||||
(cl-defgeneric cg-render-apply (game action)
|
||||
(cl-defgeneric card-games-render-apply (game action)
|
||||
"Perform ACTION (returned by a renderer hit) on GAME.
|
||||
Card-size actions (scale/zoom) are handled here; games specialise this
|
||||
for their own actions and delegate the rest with `cl-call-next-method'."
|
||||
(ignore game)
|
||||
(pcase action
|
||||
(`(scale . ,v) (setq cg-card-scale v) t)
|
||||
('zoom-in (setq cg-card-scale (min 3.0 (+ cg-card-scale 0.15))) t)
|
||||
('zoom-out (setq cg-card-scale (max 0.4 (- cg-card-scale 0.15))) t)
|
||||
('zoom-reset (setq cg-card-scale 1.0) t)
|
||||
(`(scale . ,v) (setq card-games-card-scale v) t)
|
||||
('zoom-in (setq card-games-card-scale (min 3.0 (+ card-games-card-scale 0.15))) t)
|
||||
('zoom-out (setq card-games-card-scale (max 0.4 (- card-games-card-scale 0.15))) t)
|
||||
('zoom-reset (setq card-games-card-scale 1.0) t)
|
||||
(_ nil)))
|
||||
|
||||
(defvar cg-renderers nil
|
||||
"Alist mapping a treatment name (a symbol) to a `cg-renderer' subclass.
|
||||
Populate it with `cg-register-renderer' and look entries up with
|
||||
`cg-make-renderer'.")
|
||||
(defvar card-games-renderers nil
|
||||
"Alist mapping a treatment name (a symbol) to a `card-games-renderer' subclass.
|
||||
Populate it with `card-games-register-renderer' and look entries up with
|
||||
`card-games-make-renderer'.")
|
||||
|
||||
(defun cg-register-renderer (name class)
|
||||
(defun card-games-register-renderer (name class)
|
||||
"Register renderer CLASS (an EIEIO class) under the treatment NAME."
|
||||
(setf (alist-get name cg-renderers) class))
|
||||
(setf (alist-get name card-games-renderers) class))
|
||||
|
||||
(defun cg-make-renderer (name)
|
||||
(defun card-games-make-renderer (name)
|
||||
"Return a fresh renderer instance for treatment NAME, or nil if unknown."
|
||||
(let ((class (alist-get name cg-renderers)))
|
||||
(let ((class (alist-get name card-games-renderers)))
|
||||
(and class (make-instance class :name name))))
|
||||
|
||||
(defun cg-renderer-names ()
|
||||
(defun card-games-renderer-names ()
|
||||
"Return the registered treatment names."
|
||||
(mapcar #'car cg-renderers))
|
||||
(mapcar #'car card-games-renderers))
|
||||
|
||||
|
||||
;;;; Cards and colours
|
||||
|
||||
(defcustom cg-symbols
|
||||
(defcustom card-games-symbols
|
||||
'((0 . "♠") (1 . "♣") (2 . "♦") (3 . "♥") (joker . "★"))
|
||||
"Glyphs used to draw suits, both as text and inside the SVG cards.
|
||||
The value is an alist mapping a suit index (0 spades, 1 clubs,
|
||||
|
|
@ -196,51 +195,84 @@ outlined suits \"♤\" \"♧\" \"♢\" \"♡\"."
|
|||
:type '(alist :key-type sexp :value-type string)
|
||||
:group 'card-games)
|
||||
|
||||
(defconst cg-suit-names ["Spades" "Clubs" "Diamonds" "Hearts"]
|
||||
(defconst card-games-suit-names ["Spades" "Clubs" "Diamonds" "Hearts"]
|
||||
"Suit names indexed 0..3 to match the suit indices used throughout.")
|
||||
|
||||
(defun cg-suit-glyph (suit)
|
||||
(defun card-games-suit-glyph (suit)
|
||||
"Return the glyph drawn for SUIT, a suit index 0-3 or the symbol `joker'.
|
||||
The glyphs are taken from `cg-symbols'."
|
||||
(or (cdr (assoc suit cg-symbols))
|
||||
(and (integerp suit) (aref cg-suit-names suit))
|
||||
The glyphs are taken from `card-games-symbols'."
|
||||
(or (cdr (assoc suit card-games-symbols))
|
||||
(and (integerp suit) (aref card-games-suit-names suit))
|
||||
"?"))
|
||||
|
||||
(defsubst cg-red-suit-p (suit)
|
||||
(defsubst card-games-red-suit-p (suit)
|
||||
"Return t when SUIT index denotes a red suit, else nil.
|
||||
Normalised to a boolean so callers may compare two results with `eq'
|
||||
\(diamonds and hearts are both red but `memq' returns different tails)."
|
||||
(and (memq suit '(2 3)) t))
|
||||
|
||||
(defsubst cg-sister-suit (suit)
|
||||
(defsubst card-games-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."
|
||||
(defvar card-games-shuffle-seed nil
|
||||
"When non-nil, `card-games-shuffle' is deterministic, seeded by this value.
|
||||
The value may be a number or a string. Bind it around a deal to
|
||||
reproduce that deal exactly -- for replays, for a deal shared between
|
||||
players, or for a repeatable test -- and the same seed yields the same
|
||||
order on every platform Emacs runs on. nil (the default) means an
|
||||
unpredictable shuffle drawn from the system `random'.")
|
||||
|
||||
(defun card-games-shuffle--seeded-index (seed i limit)
|
||||
"Return a deterministic index in [0, LIMIT) for step I under SEED.
|
||||
Uses `secure-hash', whose output is identical on every platform and
|
||||
Emacs build, so a seeded deal is reproducible and shareable. The 7
|
||||
hex digits taken span 28 bits, which stays a fixnum even on a 32-bit
|
||||
Emacs, so no bignum or overflow behaviour can vary the result."
|
||||
(let ((r (string-to-number
|
||||
(substring (secure-hash 'sha256 (format "%s|%d" seed i)) 0 7)
|
||||
16)))
|
||||
(mod r limit)))
|
||||
|
||||
(defun card-games-shuffle (seq &optional seed)
|
||||
"Return a new list with the elements of SEQ in random order.
|
||||
With a non-nil SEED, or a non-nil `card-games-shuffle-seed', the shuffle is
|
||||
deterministic: the same seed produces the same order on every platform,
|
||||
so a deal can be replayed or shared between players. An explicit SEED
|
||||
overrides `card-games-shuffle-seed'. The seed may be a number or a string.
|
||||
With no seed the order is unpredictable (system `random')."
|
||||
(let* ((v (vconcat seq))
|
||||
(n (length v)))
|
||||
(n (length v))
|
||||
(seed (or seed card-games-shuffle-seed)))
|
||||
(dotimes (i n)
|
||||
(let ((j (+ i (random (- n i)))))
|
||||
(let ((j (+ i (if seed
|
||||
(card-games-shuffle--seeded-index seed i (- n i))
|
||||
(random (- n i))))))
|
||||
(cl-rotatef (aref v i) (aref v j))))
|
||||
(append v nil)))
|
||||
|
||||
|
||||
;;;; Shared faces
|
||||
|
||||
(defface cg-red-suit '((t :foreground "red3"))
|
||||
(defface card-games-red-suit
|
||||
'((((background dark)) :foreground "#ff7961")
|
||||
(t :foreground "red3"))
|
||||
"Face for red-suited cards." :group 'card-games)
|
||||
|
||||
(defface cg-cursor '((t :inverse-video t))
|
||||
(defface card-games-cursor '((t :inverse-video t))
|
||||
"Face for the cell or card under the cursor." :group 'card-games)
|
||||
|
||||
(defface cg-gap '((t :foreground "gray50"))
|
||||
(defface card-games-gap
|
||||
'((((background dark)) :foreground "#a6a6a6")
|
||||
(t :foreground "#595959"))
|
||||
"Face for an empty slot." :group 'card-games)
|
||||
|
||||
(defface cg-hint '((t :foreground "green3" :weight bold))
|
||||
(defface card-games-hint
|
||||
'((((background dark)) :foreground "green3" :weight bold)
|
||||
(t :foreground "#207a3f" :weight bold))
|
||||
"Face for a valid move target (a fillable gap)." :group 'card-games)
|
||||
|
||||
(defun cg-color (face attribute fallback)
|
||||
(defun card-games-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."
|
||||
|
|
@ -251,74 +283,74 @@ or batch), so callers always get a drawable colour string."
|
|||
c
|
||||
fallback)))
|
||||
|
||||
(defun cg-scale ()
|
||||
(defun card-games-scale ()
|
||||
"Return the SVG card scale factor for the current buffer.
|
||||
Combines `cg-card-scale' with `text-scale-mode-amount', so both the
|
||||
Combines `card-games-card-scale' with `text-scale-mode-amount', so both the
|
||||
size slider and `text-scale-increase' enlarge the cards."
|
||||
(let ((amt (if (boundp 'text-scale-mode-amount) text-scale-mode-amount 0)))
|
||||
(max 0.3 (min 4.0 (* cg-card-scale (expt 1.15 amt))))))
|
||||
(max 0.3 (min 4.0 (* card-games-card-scale (expt 1.15 amt))))))
|
||||
|
||||
(defvar-local cg-current-game nil
|
||||
"The `cg-game' shown in the current buffer (for shared mouse/zoom).")
|
||||
(defvar-local card-games-current-game nil
|
||||
"The `card-games-game' shown in the current buffer (for shared mouse/zoom).")
|
||||
|
||||
(defvar-local cg-redisplay-function #'ignore
|
||||
(defvar-local card-games-redisplay-function #'ignore
|
||||
"Buffer-local function that redraws the current game's buffer.")
|
||||
|
||||
(defun cg-card-refresh ()
|
||||
"Redraw the current game buffer via `cg-redisplay-function'."
|
||||
(funcall cg-redisplay-function))
|
||||
(defun card-games-card-refresh ()
|
||||
"Redraw the current game buffer via `card-games-redisplay-function'."
|
||||
(funcall card-games-redisplay-function))
|
||||
|
||||
(defun cg-mouse-action (event)
|
||||
(defun card-games-mouse-action (event)
|
||||
"Return the action under mouse EVENT from the clicked image's region map.
|
||||
The clicked display string must carry a `cg-regions' text property."
|
||||
The clicked display string must carry a `card-games-regions' text property."
|
||||
(let* ((posn (event-start event)) (pt (posn-point posn))
|
||||
(regions (and pt (get-text-property pt 'cg-regions))))
|
||||
(regions (and pt (get-text-property pt 'card-games-regions))))
|
||||
(when regions
|
||||
(let ((xy (posn-object-x-y posn)) (sc (cg-scale)))
|
||||
(and xy (cg-regions-hit regions
|
||||
(let ((xy (posn-object-x-y posn)) (sc (card-games-scale)))
|
||||
(and xy (card-games-regions-hit regions
|
||||
(round (/ (car xy) sc)) (round (/ (cdr xy) sc))))))))
|
||||
|
||||
(defun cg-card-click (event)
|
||||
(defun card-games-card-click (event)
|
||||
"Dispatch mouse EVENT on a card or control to the current game."
|
||||
(interactive "e")
|
||||
(let ((action (cg-mouse-action event)))
|
||||
(when (and action cg-current-game)
|
||||
(cg-render-apply cg-current-game action)
|
||||
(cg-card-refresh))))
|
||||
(let ((action (card-games-mouse-action event)))
|
||||
(when (and action card-games-current-game)
|
||||
(card-games-render-apply card-games-current-game action)
|
||||
(card-games-card-refresh))))
|
||||
|
||||
(defun cg-card-zoom-in ()
|
||||
(defun card-games-card-zoom-in ()
|
||||
"Make the cards larger."
|
||||
(interactive)
|
||||
(setq cg-card-scale (min 3.0 (+ cg-card-scale 0.15))) (cg-card-refresh))
|
||||
(setq card-games-card-scale (min 3.0 (+ card-games-card-scale 0.15))) (card-games-card-refresh))
|
||||
|
||||
(defun cg-card-zoom-out ()
|
||||
(defun card-games-card-zoom-out ()
|
||||
"Make the cards smaller."
|
||||
(interactive)
|
||||
(setq cg-card-scale (max 0.4 (- cg-card-scale 0.15))) (cg-card-refresh))
|
||||
(setq card-games-card-scale (max 0.4 (- card-games-card-scale 0.15))) (card-games-card-refresh))
|
||||
|
||||
(defun cg-card-zoom-reset ()
|
||||
(defun card-games-card-zoom-reset ()
|
||||
"Reset the card size."
|
||||
(interactive)
|
||||
(setq cg-card-scale 1.0) (cg-card-refresh))
|
||||
(setq card-games-card-scale 1.0) (card-games-card-refresh))
|
||||
|
||||
(defun cg-insert-legend (text)
|
||||
(defun card-games-insert-legend (text)
|
||||
"Insert TEXT as a shadowed one-line control legend in the current buffer.
|
||||
Games call this at the foot of the board so the common controls -- a
|
||||
new deal, undo, help, and returning to the menu -- stay visible instead
|
||||
of hiding behind a keystroke."
|
||||
(insert (propertize (concat " " text "\n") 'face 'shadow)))
|
||||
|
||||
(defun cg-quit-to-menu ()
|
||||
"Leave the current game and return to the `card-game' chooser.
|
||||
(defun card-games-quit-to-menu ()
|
||||
"Leave the current game and return to the `card-games' chooser.
|
||||
Buries the game buffer and reopens the game list, so `q' takes the
|
||||
player back to where they started rather than to whatever buffer
|
||||
happened to be underneath. Falls back to `quit-window' when the
|
||||
chooser is not available (for example a game loaded on its own)."
|
||||
(interactive)
|
||||
(let ((game (current-buffer)))
|
||||
(if (fboundp 'card-game)
|
||||
(progn (card-game) (bury-buffer game))
|
||||
(if (fboundp 'card-games)
|
||||
(progn (card-games) (bury-buffer game))
|
||||
(quit-window))))
|
||||
|
||||
(provide 'cg-core)
|
||||
;;; cg-core.el ends here
|
||||
(provide 'card-games-core)
|
||||
;;; card-games-core.el ends here
|
||||
904
card-games-crapette.el
Normal file
904
card-games-crapette.el
Normal file
|
|
@ -0,0 +1,904 @@
|
|||
;;; card-games-crapette.el --- Russian Bank (Crapette), two-player vs AI -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Russian Bank -- also called Crapette -- is the competitive, two-player
|
||||
;; ancestor of the single-player patience in `card-games-solitaire'. You (South)
|
||||
;; play against one computer opponent (North).
|
||||
;;
|
||||
;; Two 52-card packs are used, one per player. In the centre sit eight
|
||||
;; FOUNDATIONS, built up by suit from the Ace, and eight HOUSES, built
|
||||
;; down in alternating colours; both are common ground either player may
|
||||
;; build on. Each player also has a 13-card RESERVE (its top card face
|
||||
;; up), a WASTE, and a face-down HAND. You win by getting rid of every
|
||||
;; card in your reserve, hand, and waste.
|
||||
;;
|
||||
;; On your turn you make as many legal moves as you like:
|
||||
;; - move the top of your reserve, your waste, or any house onto a
|
||||
;; foundation or a house;
|
||||
;; - move a whole SEQUENCE (a run built down in alternating colours)
|
||||
;; from one house to another -- but only when there are enough empty
|
||||
;; houses to have shifted it a card at a time; and
|
||||
;; - LOAD a card from your reserve or waste onto the opponent's reserve
|
||||
;; or waste when it is the same suit and one rank up or down.
|
||||
;;
|
||||
;; FOUNDATION PRIORITY and "STOP": a card that can go to a foundation must
|
||||
;; be played there before anything else. If you build a house, load your
|
||||
;; opponent, turn a card, or end your turn while a foundation play is
|
||||
;; waiting, your opponent calls "STOP!" and your turn ends at once. The
|
||||
;; piles that owe a foundation play are ringed in the hint colour. Set
|
||||
;; `card-games-crapette-stops' to nil for a gentler assist mode that blocks the
|
||||
;; slip with a reminder instead of ending your turn.
|
||||
;;
|
||||
;; When you can do no more, turn the top of your hand: if it fits
|
||||
;; somewhere you keep going, otherwise it goes to your waste and your turn
|
||||
;; ends.
|
||||
;;
|
||||
;; The AI observes foundation priority, empties its reserve first (the
|
||||
;; bottleneck), prefers loading its cards onto you, and looks one move
|
||||
;; ahead to rearrange the houses when that frees a stuck reserve or waste
|
||||
;; card. It never breaks foundation priority, so in practice only you can
|
||||
;; be "stopped".
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-svg)
|
||||
|
||||
(defconst card-games-crap-ranks
|
||||
["A" "2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K"]
|
||||
"Rank labels indexed 0 (Ace) .. 12 (King).")
|
||||
|
||||
(defcustom card-games-crapette-stops t
|
||||
"How Russian Bank enforces foundation priority on your turn.
|
||||
When non-nil (the competitive rule), the opponent calls \"stop\" and you
|
||||
forfeit the rest of your turn if you make any play other than an
|
||||
available foundation move. When nil, such a slip is simply blocked with
|
||||
a reminder and costs you nothing -- a gentler assist mode for learning."
|
||||
:type 'boolean :group 'card-games)
|
||||
|
||||
(defcustom card-games-crapette-svg-cards t
|
||||
"When non-nil, draw the board with SVG cards on a graphical display.
|
||||
Set to nil to force the plain-text board everywhere."
|
||||
:type 'boolean :group 'card-games)
|
||||
|
||||
(defclass card-games-crapette-game (card-games-game)
|
||||
((vname :initform "Russian Bank"))
|
||||
"Two-player Russian Bank (Crapette): you (South) versus one AI opponent.")
|
||||
|
||||
(defvar-local card-games-crap--game nil
|
||||
"The `card-games-crapette-game' played in the current buffer.")
|
||||
|
||||
(defvar card-games-crap--recording t
|
||||
"When nil, `card-games-crap--snapshot' does not record (used during the AI turn).")
|
||||
|
||||
|
||||
;;;; Cards
|
||||
|
||||
(defun card-games-crap--card-string (card)
|
||||
"Return a short label for CARD, or a dot for an empty pile."
|
||||
(if (null card) "·"
|
||||
(concat (aref card-games-crap-ranks (cdr card)) (card-games-suit-glyph (car card)))))
|
||||
|
||||
(defun card-games-crap--red-p (card)
|
||||
"Return non-nil when CARD is a red suit."
|
||||
(and card (card-games-red-suit-p (car card))))
|
||||
|
||||
(defun card-games-crap--spec (card)
|
||||
"Return the card-games-svg display spec (RANK-STRING . SUIT) for CARD, or nil."
|
||||
(and card (cons (aref card-games-crap-ranks (cdr card)) (car card))))
|
||||
|
||||
(defun card-games-crap--deck ()
|
||||
"Return one freshly shuffled 52-card deck."
|
||||
(let (cards)
|
||||
(dotimes (s 4) (dotimes (r 13) (push (cons s r) cards)))
|
||||
(card-games-shuffle cards)))
|
||||
|
||||
(defun card-games-crap--top (pile)
|
||||
"Return the top (last) card of PILE, or nil."
|
||||
(car (last pile)))
|
||||
|
||||
|
||||
;;;; Pile access
|
||||
|
||||
(defun card-games-crap--found (g i) "Foundation I of G." (aref (card-games-get g :found) i))
|
||||
(defun card-games-crap--house (g i) "House I of G." (aref (card-games-get g :houses) i))
|
||||
(defun card-games-crap--reserve (g p) "Player P's reserve list in G." (aref (card-games-get g :reserve) p))
|
||||
(defun card-games-crap--waste (g p) "Player P's waste list in G." (aref (card-games-get g :waste) p))
|
||||
(defun card-games-crap--hand (g p) "Player P's hand list in G." (aref (card-games-get g :hand) p))
|
||||
|
||||
|
||||
;;;; Dealing
|
||||
|
||||
(defun card-games-crap--deal (game)
|
||||
"Deal a fresh Russian Bank layout into GAME and return it."
|
||||
(let ((d0 (card-games-crap--deck)) (d1 (card-games-crap--deck))
|
||||
(found (make-vector 8 nil)) (houses (make-vector 8 nil))
|
||||
(reserve (make-vector 2 nil)) (waste (make-vector 2 nil))
|
||||
(hand (make-vector 2 nil)))
|
||||
(dotimes (i 4) (aset houses i (list (pop d0))))
|
||||
(dotimes (i 4) (aset houses (+ 4 i) (list (pop d1))))
|
||||
(aset reserve 0 (cl-loop repeat 13 collect (pop d0)))
|
||||
(aset reserve 1 (cl-loop repeat 13 collect (pop d1)))
|
||||
(aset hand 0 d0)
|
||||
(aset hand 1 d1)
|
||||
(card-games-put game :found found)
|
||||
(card-games-put game :houses houses)
|
||||
(card-games-put game :reserve reserve)
|
||||
(card-games-put game :waste waste)
|
||||
(card-games-put game :hand hand)
|
||||
(card-games-put game :turn 0)
|
||||
(card-games-put game :cursor 0)
|
||||
(card-games-put game :sel nil)
|
||||
(card-games-put game :moves 0)
|
||||
(card-games-put game :history nil)
|
||||
(card-games-put game :winner nil)
|
||||
(card-games-put game :message
|
||||
"Your turn. Foundations first -- skip one and North calls STOP! Build the houses or load North.")
|
||||
game))
|
||||
|
||||
|
||||
;;;; Legality
|
||||
|
||||
(defun card-games-crap--found-accepts (game i card)
|
||||
"Return non-nil when CARD may go onto foundation I of GAME."
|
||||
(and card
|
||||
(let ((f (card-games-crap--found game i)))
|
||||
(if (null f)
|
||||
(= (cdr card) 0) ; empty foundation takes an Ace
|
||||
(let ((top (card-games-crap--top f)))
|
||||
(and (= (car card) (car top))
|
||||
(= (cdr card) (1+ (cdr top)))))))))
|
||||
|
||||
(defun card-games-crap--house-accepts (game i card)
|
||||
"Return non-nil when CARD may go onto house I of GAME."
|
||||
(and card
|
||||
(let ((h (card-games-crap--house game i)))
|
||||
(if (null h)
|
||||
t ; empty house takes anything
|
||||
(card-games-crap--builds-down-p (card-games-crap--top h) card)))))
|
||||
|
||||
(defun card-games-crap--builds-down-p (upper lower)
|
||||
"Return non-nil when LOWER may sit on UPPER: one rank down, opposite colour."
|
||||
(and upper lower
|
||||
(= (cdr lower) (1- (cdr upper)))
|
||||
(not (eq (card-games-crap--red-p upper) (card-games-crap--red-p lower)))))
|
||||
|
||||
(defun card-games-crap--load-accepts (pile-top card)
|
||||
"Return non-nil when CARD may be loaded onto a pile whose top is PILE-TOP.
|
||||
Loading needs the same suit and a rank one step up or down."
|
||||
(and pile-top card
|
||||
(= (car pile-top) (car card))
|
||||
(= 1 (abs (- (cdr pile-top) (cdr card))))))
|
||||
|
||||
(defun card-games-crap--found-for (game card)
|
||||
"Return the index of a GAME foundation that would accept CARD, or nil."
|
||||
(cl-loop for i below 8 when (card-games-crap--found-accepts game i card) return i))
|
||||
|
||||
|
||||
;;;; Sequenced house moves
|
||||
|
||||
(defun card-games-crap--house-run (game i)
|
||||
"Return the movable top run of GAME house I as a list, bottom-to-top.
|
||||
The run is the longest sequence of cards at the top of the house that is
|
||||
built down in alternating colours."
|
||||
(let ((rev (reverse (card-games-crap--house game i)))) ; top-first
|
||||
(if (null rev) nil
|
||||
(let ((run (list (car rev))) (prev (car rev)))
|
||||
(catch 'done
|
||||
(dolist (c (cdr rev)) ; each C sits below PREV
|
||||
(if (card-games-crap--builds-down-p c prev)
|
||||
(progn (push c run) (setq prev c)) ; PREV builds down on C
|
||||
(throw 'done nil))))
|
||||
run))))
|
||||
|
||||
(defun card-games-crap--free-houses (game)
|
||||
"Return the number of empty houses in GAME."
|
||||
(cl-count-if #'null (append (card-games-get game :houses) nil)))
|
||||
|
||||
(defun card-games-crap--capacity (game dest-i)
|
||||
"Return how many cards may be moved as a group onto GAME house DEST-I.
|
||||
With F empty houses you may relay F+1 cards onto a non-empty house, or
|
||||
F onto an empty house (the destination itself cannot serve as a relay)."
|
||||
(let ((free (card-games-crap--free-houses game)))
|
||||
(if (card-games-crap--house game dest-i) (1+ free) free)))
|
||||
|
||||
(defun card-games-crap--house-move (game i j &optional want)
|
||||
"Move a legal sequence from house I onto house J in GAME.
|
||||
WANT, when given, is how many of the top cards to move onto an EMPTY
|
||||
house (default the whole run); it is ignored for a non-empty house, where
|
||||
the landing rank fixes the count. Return non-nil on success, the symbol
|
||||
`space' when the sequence is legal but there are too few empty houses,
|
||||
and nil when nothing fits."
|
||||
(if (= i j)
|
||||
nil
|
||||
(let* ((run (card-games-crap--house-run game i))
|
||||
(rlen (length run))
|
||||
(dst (card-games-crap--house game j))
|
||||
(dsttop (card-games-crap--top dst))
|
||||
(cap (card-games-crap--capacity game j))
|
||||
(n nil))
|
||||
(when (> rlen 0)
|
||||
(if (null dsttop)
|
||||
(setq n (min (or want rlen) rlen)) ; empty house: the chosen count
|
||||
(cl-loop for k from 0 below rlen ; RUN is bottom-to-top
|
||||
for card = (nth k run)
|
||||
when (card-games-crap--builds-down-p dsttop card)
|
||||
do (setq n (- rlen k)) (cl-return)))
|
||||
(cond
|
||||
((or (null n) (< n 1)) nil)
|
||||
((> n cap) 'space)
|
||||
(t
|
||||
(card-games-crap--snapshot game)
|
||||
(let* ((pile (card-games-crap--house game i))
|
||||
(keep (butlast pile n))
|
||||
(moved (last pile n)))
|
||||
(aset (card-games-get game :houses) i keep)
|
||||
(aset (card-games-get game :houses) j (append dst moved)))
|
||||
(card-games-put game :moves (1+ (card-games-get game :moves)))
|
||||
t))))))
|
||||
|
||||
|
||||
;;;; Spots (the cursor visits piles)
|
||||
|
||||
(defun card-games-crap--spots (_game)
|
||||
"Return the ordered list of (TYPE . INDEX) spots the cursor visits."
|
||||
(append (list '(res . 0) '(was . 0))
|
||||
(cl-loop for i below 8 collect (cons 'house i))
|
||||
(cl-loop for i below 8 collect (cons 'found i))
|
||||
(list '(res . 1) '(was . 1))))
|
||||
|
||||
(defun card-games-crap--sources (_game p)
|
||||
"Return the spots whose top card player P may pick up."
|
||||
(append (list (cons 'res p) (cons 'was p))
|
||||
(cl-loop for i below 8 collect (cons 'house i))))
|
||||
|
||||
(defun card-games-crap--spot-top (game spot)
|
||||
"Return the top card available at SPOT of GAME, or nil."
|
||||
(pcase (car spot)
|
||||
('res (card-games-crap--top (card-games-crap--reserve game (cdr spot))))
|
||||
('was (card-games-crap--top (card-games-crap--waste game (cdr spot))))
|
||||
('house (card-games-crap--top (card-games-crap--house game (cdr spot))))
|
||||
('found (card-games-crap--top (card-games-crap--found game (cdr spot))))))
|
||||
|
||||
(defun card-games-crap--source-p (spot p)
|
||||
"Return non-nil when SPOT is a pile player P may take a card from."
|
||||
(pcase (car spot)
|
||||
('res (= (cdr spot) p))
|
||||
('was (= (cdr spot) p))
|
||||
('house t)
|
||||
(_ nil)))
|
||||
|
||||
(defun card-games-crap--dest-ok (game from to card p)
|
||||
"Return non-nil when player P may move CARD from FROM to TO in GAME."
|
||||
(pcase (car to)
|
||||
('found (card-games-crap--found-accepts game (cdr to) card))
|
||||
('house (card-games-crap--house-accepts game (cdr to) card))
|
||||
((or 'res 'was)
|
||||
(and (= (cdr to) (- 1 p)) ; only onto the opponent
|
||||
(memq (car from) '(res was)) ; only your reserve/waste cards load
|
||||
(card-games-crap--load-accepts (card-games-crap--spot-top game to) card)))))
|
||||
|
||||
|
||||
;;;; Moving cards
|
||||
|
||||
(defun card-games-crap--snapshot (game)
|
||||
"Record GAME's mutable state for undo, unless recording is disabled."
|
||||
(when card-games-crap--recording
|
||||
(card-games-put game :history
|
||||
(cons (list (card-games-crap--copy-vec (card-games-get game :found))
|
||||
(card-games-crap--copy-vec (card-games-get game :houses))
|
||||
(card-games-crap--copy-vec (card-games-get game :reserve))
|
||||
(card-games-crap--copy-vec (card-games-get game :waste))
|
||||
(card-games-crap--copy-vec (card-games-get game :hand))
|
||||
(card-games-get game :turn))
|
||||
(card-games-get game :history)))))
|
||||
|
||||
(defun card-games-crap--copy-vec (v)
|
||||
"Return a copy of vector V with each element list copied."
|
||||
(vconcat (mapcar #'copy-sequence v)))
|
||||
|
||||
(defun card-games-crap--take (game spot)
|
||||
"Remove and return the top card of SPOT's pile in GAME."
|
||||
(pcase (car spot)
|
||||
('res (let* ((p (cdr spot)) (pile (card-games-crap--reserve game p)))
|
||||
(aset (card-games-get game :reserve) p (butlast pile 1)) (card-games-crap--top pile)))
|
||||
('was (let* ((p (cdr spot)) (pile (card-games-crap--waste game p)))
|
||||
(aset (card-games-get game :waste) p (butlast pile 1)) (card-games-crap--top pile)))
|
||||
('house (let* ((i (cdr spot)) (pile (card-games-crap--house game i)))
|
||||
(aset (card-games-get game :houses) i (butlast pile 1)) (card-games-crap--top pile)))))
|
||||
|
||||
(defun card-games-crap--place (game spot card)
|
||||
"Add CARD to the top of SPOT's pile in GAME."
|
||||
(pcase (car spot)
|
||||
('found (let ((i (cdr spot)))
|
||||
(aset (card-games-get game :found) i (append (card-games-crap--found game i) (list card)))))
|
||||
('house (let ((i (cdr spot)))
|
||||
(aset (card-games-get game :houses) i (append (card-games-crap--house game i) (list card)))))
|
||||
('res (let ((p (cdr spot)))
|
||||
(aset (card-games-get game :reserve) p (append (card-games-crap--reserve game p) (list card)))))
|
||||
('was (let ((p (cdr spot)))
|
||||
(aset (card-games-get game :waste) p (append (card-games-crap--waste game p) (list card)))))))
|
||||
|
||||
(defun card-games-crap--move (game from to p)
|
||||
"Move the top card of FROM onto TO in GAME for player P.
|
||||
Return non-nil when the move was legal and performed."
|
||||
(let ((card (card-games-crap--spot-top game from)))
|
||||
(when (and card (card-games-crap--source-p from p) (card-games-crap--dest-ok game from to card p))
|
||||
(card-games-crap--snapshot game)
|
||||
(card-games-crap--take game from)
|
||||
(card-games-crap--place game to card)
|
||||
(card-games-put game :moves (1+ (card-games-get game :moves)))
|
||||
t)))
|
||||
|
||||
(defun card-games-crap--do-move (game from to p &optional want)
|
||||
"Perform player P's move from FROM to TO in GAME.
|
||||
A house-to-house move may carry a legal sequence of cards (see
|
||||
`card-games-crap--house-move', to which WANT is passed); every other
|
||||
move carries a single card. Returns the same values as those
|
||||
functions (non-nil on success, `space' when a sequence is too long
|
||||
for the empty houses)."
|
||||
(if (and (eq (car from) 'house) (eq (car to) 'house))
|
||||
(card-games-crap--house-move game (cdr from) (cdr to) want)
|
||||
(card-games-crap--move game from to p)))
|
||||
|
||||
|
||||
;;;; Turn logic
|
||||
|
||||
(defun card-games-crap--forced (game p)
|
||||
"Return player P's GAME spots whose top card must go to a foundation."
|
||||
(let (out)
|
||||
(dolist (spot (card-games-crap--sources game p))
|
||||
(let ((card (card-games-crap--spot-top game spot)))
|
||||
(when (and card (card-games-crap--found-for game card)) (push spot out))))
|
||||
(nreverse out)))
|
||||
|
||||
(defun card-games-crap--card-playable (game p card)
|
||||
"Return non-nil when CARD has a legal destination in GAME for player P."
|
||||
(or (card-games-crap--found-for game card)
|
||||
(cl-loop for i below 8 thereis (card-games-crap--house-accepts game i card))
|
||||
(card-games-crap--load-accepts (card-games-crap--top (card-games-crap--reserve game (- 1 p))) card)
|
||||
(card-games-crap--load-accepts (card-games-crap--top (card-games-crap--waste game (- 1 p))) card)))
|
||||
|
||||
(defun card-games-crap--won-p (game p)
|
||||
"Return non-nil when GAME player P has emptied reserve, hand, and waste."
|
||||
(and (null (card-games-crap--reserve game p))
|
||||
(null (card-games-crap--hand game p))
|
||||
(null (card-games-crap--waste game p))))
|
||||
|
||||
(cl-defmethod card-games-won-p ((game card-games-crapette-game))
|
||||
"Return non-nil when you (South) have won GAME."
|
||||
(eq (card-games-get game :winner) 0))
|
||||
|
||||
(defun card-games-crap--msg (game s)
|
||||
"Set GAME's status message to S."
|
||||
(card-games-put game :message s))
|
||||
|
||||
(defun card-games-crap--after-human-move (game)
|
||||
"Note a win after a human move in GAME."
|
||||
(when (card-games-crap--won-p game 0)
|
||||
(card-games-put game :winner 0)
|
||||
(card-games-crap--msg game "You emptied your cards -- you win!")))
|
||||
|
||||
(defun card-games-crap--end-turn (game)
|
||||
"Pass GAME's turn from you to the AI, run it, and return control to you."
|
||||
(unless (card-games-get game :winner)
|
||||
(card-games-put game :sel nil)
|
||||
(card-games-put game :turn 1)
|
||||
(let ((card-games-crap--recording nil))
|
||||
(card-games-crap--ai-play game))
|
||||
(unless (card-games-get game :winner)
|
||||
(card-games-put game :turn 0)
|
||||
(card-games-put game :history nil))))
|
||||
|
||||
(defun card-games-crap--stop (game)
|
||||
"Enforce GAME's foundation priority, per `card-games-crapette-stops'.
|
||||
Call \"stop\" or block; return non-nil when the offending action must be
|
||||
abandoned by its caller."
|
||||
(when (card-games-crap--forced game 0)
|
||||
(if card-games-crapette-stops
|
||||
(let ((note "North calls STOP -- you must play to a foundation first!"))
|
||||
(message "%s" note)
|
||||
(card-games-put game :sel nil)
|
||||
(card-games-crap--end-turn game)
|
||||
(card-games-put game :message (concat note " " (card-games-get game :message))))
|
||||
(card-games-crap--msg game "Play to a foundation first (press f on a highlighted pile)."))
|
||||
t))
|
||||
|
||||
|
||||
;;;; The AI opponent (player 1)
|
||||
|
||||
(defun card-games-crap--ai-found-move (game)
|
||||
"Return an AI (SOURCE . FOUNDATION) foundation move for GAME, or nil."
|
||||
(cl-loop for spot in (card-games-crap--sources game 1)
|
||||
for card = (card-games-crap--spot-top game spot)
|
||||
for fi = (and card (card-games-crap--found-for game card))
|
||||
when fi return (cons spot (cons 'found fi))))
|
||||
|
||||
(defun card-games-crap--ai-unload-move (game)
|
||||
"Return GAME's best AI (SOURCE . DEST) move that empties reserve or waste.
|
||||
Emptying the RESERVE is the goal of the game, so it outscores the waste;
|
||||
LOADING a card onto you (which also burdens you) outscores building a
|
||||
house. Every such move reduces the AI's own cards, so its turn ends."
|
||||
(let ((best nil) (bestscore 0))
|
||||
(dolist (spot (list (cons 'res 1) (cons 'was 1)))
|
||||
(let ((card (card-games-crap--spot-top game spot))
|
||||
(base (if (eq (car spot) 'res) 40 0))) ; the reserve is the bottleneck
|
||||
(when card
|
||||
(dolist (dst (list (cons 'res 0) (cons 'was 0)))
|
||||
(when (card-games-crap--load-accepts (card-games-crap--spot-top game dst) card)
|
||||
(let ((sc (+ base 60))) ; loading: rid a card AND burden you
|
||||
(when (> sc bestscore)
|
||||
(setq bestscore sc best (cons spot dst))))))
|
||||
(cl-loop for i below 8
|
||||
when (card-games-crap--house-accepts game i card)
|
||||
do (let ((sc (+ base 50))) ; else build it onto a house
|
||||
(when (> sc bestscore)
|
||||
(setq bestscore sc best (cons spot (cons 'house i)))))
|
||||
(cl-return)))))
|
||||
best))
|
||||
|
||||
(defun card-games-crap--ai-enabling-move (game)
|
||||
"Return a GAME single-card house->house move that unlocks an unload, or nil.
|
||||
This is the crafty bit: when the AI cannot place its reserve or waste top
|
||||
anywhere, it looks one move ahead for a house rearrangement that would
|
||||
make such a placement legal. It only fires when no direct unload exists,
|
||||
and only when the shuffle genuinely opens one, so the turn still ends."
|
||||
(when (null (card-games-crap--ai-unload-move game))
|
||||
(catch 'found
|
||||
(dotimes (i 8)
|
||||
(dotimes (j 8)
|
||||
(let ((pilei (card-games-crap--house game i)) (pilej (card-games-crap--house game j)))
|
||||
(when (and (/= i j) pilei)
|
||||
(let ((card (card-games-crap--top pilei)))
|
||||
(when (card-games-crap--house-accepts game j card)
|
||||
(aset (card-games-get game :houses) i (butlast pilei 1))
|
||||
(aset (card-games-get game :houses) j (append pilej (list card)))
|
||||
(let ((opens (card-games-crap--ai-unload-move game)))
|
||||
(aset (card-games-get game :houses) i pilei)
|
||||
(aset (card-games-get game :houses) j pilej)
|
||||
(when opens
|
||||
(throw 'found (cons (cons 'house i) (cons 'house j)))))))))))
|
||||
nil)))
|
||||
|
||||
(defun card-games-crap--ai-greedy-move (game)
|
||||
"A simple first-fit unload move for GAME -- the `easy' AI.
|
||||
Empties the reserve or waste top onto the first legal spot, without the
|
||||
scoring or the house-rearranging lookahead of the tougher levels."
|
||||
(catch 'm
|
||||
(dolist (spot (list (cons 'res 1) (cons 'was 1)))
|
||||
(let ((card (card-games-crap--spot-top game spot)))
|
||||
(when card
|
||||
(dolist (dst (list (cons 'res 0) (cons 'was 0)))
|
||||
(when (card-games-crap--load-accepts (card-games-crap--spot-top game dst) card)
|
||||
(throw 'm (cons spot dst))))
|
||||
(cl-loop for i below 8
|
||||
when (card-games-crap--house-accepts game i card)
|
||||
do (throw 'm (cons spot (cons 'house i)))))))
|
||||
nil))
|
||||
|
||||
(defun card-games-crap--ai-play (game)
|
||||
"Play the AI opponent's whole turn on GAME, per `card-games-ai-level'."
|
||||
(let ((guard 0) (level card-games-ai-level))
|
||||
(catch 'done
|
||||
(while t
|
||||
(when (> (setq guard (1+ guard)) 800) (throw 'done nil))
|
||||
(when (card-games-crap--won-p game 1) (throw 'done nil))
|
||||
(let ((mv (or (card-games-crap--ai-found-move game)
|
||||
(if (eq level 'easy)
|
||||
(card-games-crap--ai-greedy-move game)
|
||||
(card-games-crap--ai-unload-move game))
|
||||
(and (eq level 'hard) (card-games-crap--ai-enabling-move game)))))
|
||||
(cond
|
||||
(mv (card-games-crap--move game (car mv) (cdr mv) 1))
|
||||
((card-games-crap--hand game 1)
|
||||
(let* ((hand (card-games-crap--hand game 1)) (card (card-games-crap--top hand)))
|
||||
(aset (card-games-get game :hand) 1 (butlast hand 1))
|
||||
(aset (card-games-get game :waste) 1 (append (card-games-crap--waste game 1) (list card)))
|
||||
(unless (card-games-crap--card-playable game 1 card) (throw 'done 'flip-end))))
|
||||
(t (throw 'done 'stuck))))))
|
||||
(if (card-games-crap--won-p game 1)
|
||||
(progn (card-games-put game :winner 1)
|
||||
(card-games-crap--msg game "Your opponent emptied their cards -- you lose."))
|
||||
(card-games-crap--msg game "Your opponent finished their turn. Your move."))))
|
||||
|
||||
|
||||
;;;; Rendering (text)
|
||||
|
||||
(defun card-games-crap--render (g)
|
||||
"Return a propertized depiction of Russian Bank game G."
|
||||
(let* ((spots (card-games-crap--spots g))
|
||||
(cur (nth (card-games-get g :cursor) spots))
|
||||
(sel (card-games-get g :sel))
|
||||
(forced (card-games-crap--forced g 0))
|
||||
(turn (card-games-get g :turn))
|
||||
(win (card-games-get g :winner)))
|
||||
(cl-flet ((cell (spot label)
|
||||
(let* ((card (card-games-crap--spot-top g spot))
|
||||
(txt (concat label (card-games-crap--card-string card)))
|
||||
(face (cond ((equal spot cur) 'card-games-cursor)
|
||||
((equal spot sel) 'card-games-hint)
|
||||
((member spot forced) 'card-games-hint)
|
||||
((card-games-crap--red-p card) 'card-games-red-suit)
|
||||
(t 'default))))
|
||||
(propertize (format "%-8s" txt) 'face face))))
|
||||
(concat
|
||||
(format " Russian Bank -- %s\n\n"
|
||||
(cond ((eq win 0) "you win!")
|
||||
((eq win 1) "you lose")
|
||||
((= turn 0) "your turn")
|
||||
(t "opponent's turn")))
|
||||
(format " Opponent (North) hand:%2d reserve:%2d waste:%2d\n "
|
||||
(length (card-games-crap--hand g 1)) (length (card-games-crap--reserve g 1))
|
||||
(length (card-games-crap--waste g 1)))
|
||||
(cell '(res . 1) "R:") (cell '(was . 1) "W:") "\n\n"
|
||||
" Foundations (build up by suit)\n "
|
||||
(cell '(found . 0) "") (cell '(found . 1) "")
|
||||
(cell '(found . 2) "") (cell '(found . 3) "") "\n "
|
||||
(cell '(found . 4) "") (cell '(found . 5) "")
|
||||
(cell '(found . 6) "") (cell '(found . 7) "") "\n\n"
|
||||
" Houses (build down, alternating colours)\n "
|
||||
(cell '(house . 0) "") (cell '(house . 1) "")
|
||||
(cell '(house . 2) "") (cell '(house . 3) "") "\n "
|
||||
(cell '(house . 4) "") (cell '(house . 5) "")
|
||||
(cell '(house . 6) "") (cell '(house . 7) "") "\n\n"
|
||||
(format " You (South) hand:%2d reserve:%2d waste:%2d\n "
|
||||
(length (card-games-crap--hand g 0)) (length (card-games-crap--reserve g 0))
|
||||
(length (card-games-crap--waste g 0)))
|
||||
(cell '(res . 0) "R:") (cell '(was . 0) "W:") "\n\n"
|
||||
(format " %s\n" (card-games-get g :message))
|
||||
(card-games-crap--holding-line g)))))
|
||||
|
||||
(defun card-games-crap--holding-line (g)
|
||||
"Return a line showing G's picked-up house run, marking the held top cards.
|
||||
Empty when nothing (or a single card) is held from a house."
|
||||
(let ((sel (card-games-get g :sel)))
|
||||
(if (not (and sel (eq (car sel) 'house)))
|
||||
""
|
||||
(let* ((run (card-games-crap--house-run g (cdr sel)))
|
||||
(m (length run))
|
||||
(held (min (or (card-games-get g :sel-n) m) m))
|
||||
(i 0) (parts nil))
|
||||
(if (< m 2)
|
||||
""
|
||||
(dolist (c run)
|
||||
(let ((on (>= i (- m held))))
|
||||
(push (propertize (concat (card-games-crap--card-string c) " ")
|
||||
'face (cond (on 'card-games-hint)
|
||||
((card-games-crap--red-p c) 'card-games-red-suit)
|
||||
(t 'shadow)))
|
||||
parts))
|
||||
(setq i (1+ i)))
|
||||
(concat " Holding: " (apply #'concat (nreverse parts))
|
||||
(format "(moving top %d of %d)\n" held m)))))))
|
||||
|
||||
(defun card-games-crap--svg (g)
|
||||
"Return (DISPLAY-STRING . REGIONS) drawing Russian Bank game G as SVG.
|
||||
REGIONS maps clicked rectangles to (TYPE . INDEX) spots."
|
||||
(let* ((w card-games-svg-card-width) (h card-games-svg-card-height)
|
||||
(gap card-games-svg-card-gap) (pad 12) (colgap 14)
|
||||
(vdown (max 16 (round (* h 0.26))))
|
||||
(spots (card-games-crap--spots g))
|
||||
(cur (nth (card-games-get g :cursor) spots))
|
||||
(sel (card-games-get g :sel))
|
||||
(forced (card-games-crap--forced g 0))
|
||||
(heldn (and sel (eq (car sel) 'house)
|
||||
(min (or (card-games-get g :sel-n) 0)
|
||||
(length (card-games-crap--house-run g (cdr sel))))))
|
||||
(houses (card-games-get g :houses))
|
||||
(maxlen (apply #'max 1 (mapcar #'length (append houses nil))))
|
||||
(fx (+ w gap)) (hx (+ w colgap))
|
||||
(width (+ (* 2 pad) (* 8 w) (* 7 colgap)))
|
||||
(y-title 6) (y-opp 34)
|
||||
(y-found (+ y-opp h 30))
|
||||
(y-house (+ y-found h 30))
|
||||
(house-h (+ h (* (1- maxlen) vdown)))
|
||||
(y-you (+ y-house house-h 28))
|
||||
(height (+ y-you h 34))
|
||||
(svg (svg-create width height))
|
||||
(lc (card-games-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels
|
||||
((txt (str x y &optional sz bold)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family card-games-svg-font-family
|
||||
(if bold (list :font-weight "bold") nil)))
|
||||
(curp (spot) (equal spot cur))
|
||||
(forcedp (spot) (and (member spot forced) t))
|
||||
(pile-cell (spot x y)
|
||||
(let ((spec (card-games-crap--spec (card-games-crap--spot-top g spot))))
|
||||
(if spec
|
||||
(card-games-svg-card svg x y :rank (car spec) :suit (cdr spec)
|
||||
:highlight (curp spot) :hint (forcedp spot))
|
||||
(card-games-svg-card svg x y :gap t :highlight (curp spot)))
|
||||
(push (cons (list x y w h) spot) regions))))
|
||||
(txt (format "Russian Bank -- %s"
|
||||
(cond ((eq (card-games-get g :winner) 0) "you win!")
|
||||
((eq (card-games-get g :winner) 1) "you lose")
|
||||
((= (card-games-get g :turn) 0) "your turn")
|
||||
(t "opponent's turn")))
|
||||
pad (+ y-title 12) 13 t)
|
||||
(txt (format "North reserve %d waste %d hand %d"
|
||||
(length (card-games-crap--reserve g 1)) (length (card-games-crap--waste g 1))
|
||||
(length (card-games-crap--hand g 1)))
|
||||
pad (- y-opp 4))
|
||||
(pile-cell '(res . 1) pad y-opp)
|
||||
(pile-cell '(was . 1) (+ pad fx) y-opp)
|
||||
(txt "Foundations" pad (- y-found 4))
|
||||
(dotimes (i 8) (pile-cell (cons 'found i) (+ pad (* i fx)) y-found))
|
||||
(txt "Houses" pad (- y-house 4))
|
||||
(dotimes (i 8)
|
||||
(let* ((x (+ pad (* i hx))) (s (cons 'house i))
|
||||
(pile (aref houses i)) (len (length pile)))
|
||||
(push (cons (list x y-house w house-h) s) regions)
|
||||
(if (= len 0)
|
||||
(card-games-svg-card svg x y-house :gap t :highlight (curp s))
|
||||
(let ((y y-house) (k 0))
|
||||
(dolist (card pile)
|
||||
(let ((spec (card-games-crap--spec card)) (topp (= k (1- len))))
|
||||
(card-games-svg-card svg x y :rank (car spec) :suit (cdr spec)
|
||||
:highlight (and topp (curp s))
|
||||
:hint (and topp (forcedp s)))
|
||||
(when (and (equal sel s) heldn (>= k (- len heldn)))
|
||||
(svg-rectangle svg (- x 3) (- y 3) (+ w 6) (+ h 6)
|
||||
:rx 8 :fill "none" :stroke "#4a90d9" :stroke-width 3)))
|
||||
(setq y (+ y vdown) k (1+ k)))))))
|
||||
(txt (format "You reserve %d waste %d hand %d"
|
||||
(length (card-games-crap--reserve g 0)) (length (card-games-crap--waste g 0))
|
||||
(length (card-games-crap--hand g 0)))
|
||||
pad (- y-you 4))
|
||||
(pile-cell '(res . 0) pad y-you)
|
||||
(pile-cell '(was . 0) (+ pad fx) y-you)
|
||||
(txt (card-games-get g :message) pad (- height 10) 12))
|
||||
(let ((rev (nreverse regions)))
|
||||
(cons (propertize "*" 'display (card-games-svg-image svg (card-games-scale))
|
||||
'card-games-regions rev)
|
||||
rev))))
|
||||
|
||||
(defun card-games-crap-mouse (event)
|
||||
"Handle click EVENT on the SVG board: select that pile and act on it."
|
||||
(interactive "e")
|
||||
(let* ((g card-games-crap--game) (spot (card-games-mouse-action event)))
|
||||
(when spot
|
||||
(let ((idx (cl-position spot (card-games-crap--spots g) :test #'equal)))
|
||||
(when idx (card-games-put g :cursor idx) (card-games-crap-act))))))
|
||||
|
||||
(cl-defmethod card-games-render ((game card-games-crapette-game))
|
||||
"Return a text depiction of GAME."
|
||||
(card-games-crap--render game))
|
||||
|
||||
(defun card-games-crap--redisplay ()
|
||||
"Redraw the current Russian Bank buffer (SVG on a graphical display)."
|
||||
(let ((g card-games-crap--game) (inhibit-read-only t))
|
||||
(setq card-games-current-game g)
|
||||
(setq-local card-games-redisplay-function #'card-games-crap--redisplay)
|
||||
(setq-local mode-line-process
|
||||
(format " [%s]"
|
||||
(cond ((eq (card-games-get g :winner) 0) "you win")
|
||||
((eq (card-games-get g :winner) 1) "you lose")
|
||||
((= (card-games-get g :turn) 0) "your turn")
|
||||
(t "opponent"))))
|
||||
(erase-buffer)
|
||||
(if (and card-games-crapette-svg-cards (display-graphic-p))
|
||||
(insert (car (card-games-crap--svg g)) "\n")
|
||||
(insert (card-games-crap--render g)))
|
||||
(card-games-insert-legend
|
||||
"arrows/click move · RET pick up/drop · [ ] group size · f foundation · SPC turn · e end · u undo · n new · q menu")
|
||||
(goto-char (point-min))))
|
||||
|
||||
|
||||
;;;; Commands
|
||||
|
||||
(defun card-games-crap--move-cursor (g d)
|
||||
"Move G's cursor by D spots and redisplay."
|
||||
(let ((n (length (card-games-crap--spots g))))
|
||||
(card-games-put g :cursor (mod (+ (card-games-get g :cursor) d) n)))
|
||||
(card-games-crap--redisplay))
|
||||
|
||||
(defun card-games-crap-left () "Move the cursor to the previous pile."
|
||||
(interactive) (card-games-crap--move-cursor card-games-crap--game -1))
|
||||
(defun card-games-crap-right () "Move the cursor to the next pile."
|
||||
(interactive) (card-games-crap--move-cursor card-games-crap--game 1))
|
||||
|
||||
(defun card-games-crap--your-turn-p (g)
|
||||
"Return non-nil when it is your move in G (and warn otherwise)."
|
||||
(cond ((card-games-get g :winner)
|
||||
(card-games-crap--msg g "The game is over -- press n for a new game.") nil)
|
||||
((/= (card-games-get g :turn) 0)
|
||||
(card-games-crap--msg g "Wait for your turn.") nil)
|
||||
(t t)))
|
||||
|
||||
(defun card-games-crap-act ()
|
||||
"Pick up the card under the cursor, or drop the picked-up card there."
|
||||
(interactive)
|
||||
(let* ((g card-games-crap--game) (spots (card-games-crap--spots g))
|
||||
(spot (nth (card-games-get g :cursor) spots)) (sel (card-games-get g :sel)))
|
||||
(when (card-games-crap--your-turn-p g)
|
||||
(if sel
|
||||
(unless (and (not (eq (car spot) 'found)) (card-games-crap--stop g))
|
||||
(let ((res (card-games-crap--do-move g sel spot 0 (card-games-get g :sel-n))))
|
||||
(cond
|
||||
((eq res 'space)
|
||||
(card-games-crap--msg g "Not enough empty houses to move that many cards."))
|
||||
(res (card-games-put g :sel nil) (card-games-put g :sel-n nil) (card-games-crap--after-human-move g))
|
||||
(t (card-games-crap--msg g "That card can't go there.")))))
|
||||
(if (and (card-games-crap--source-p spot 0) (card-games-crap--spot-top g spot))
|
||||
(let* ((top (card-games-crap--spot-top g spot))
|
||||
(run (and (eq (car spot) 'house) (card-games-crap--house-run g (cdr spot))))
|
||||
(n (length run)))
|
||||
(card-games-put g :sel spot)
|
||||
(card-games-put g :sel-n (max 1 n))
|
||||
(card-games-crap--msg g
|
||||
(if (> n 1)
|
||||
(format "Picked up a run of %d (%s on top) -- [ / ] to change how many, drop on a house."
|
||||
n (card-games-crap--card-string top))
|
||||
(format "Picked up %s -- choose where to drop it."
|
||||
(card-games-crap--card-string top)))))
|
||||
(card-games-crap--msg g "Nothing of yours to pick up there."))))
|
||||
(card-games-crap--redisplay)))
|
||||
|
||||
(defun card-games-crap-found ()
|
||||
"Send the card under the cursor (or the picked-up card) to a foundation."
|
||||
(interactive)
|
||||
(let* ((g card-games-crap--game) (spots (card-games-crap--spots g))
|
||||
(spot (nth (card-games-get g :cursor) spots)))
|
||||
(when (card-games-crap--your-turn-p g)
|
||||
(let* ((src (or (card-games-get g :sel) spot))
|
||||
(card (and (card-games-crap--source-p src 0) (card-games-crap--spot-top g src)))
|
||||
(fi (and card (card-games-crap--found-for g card))))
|
||||
(if (and fi (card-games-crap--move g src (cons 'found fi) 0))
|
||||
(progn (card-games-put g :sel nil) (card-games-crap--after-human-move g))
|
||||
(card-games-crap--msg g "No foundation accepts that card."))))
|
||||
(card-games-crap--redisplay)))
|
||||
|
||||
(defun card-games-crap--hold-adjust (d)
|
||||
"Change how many cards of a picked-up house run you hold, by D."
|
||||
(let* ((g card-games-crap--game) (sel (card-games-get g :sel)))
|
||||
(when (card-games-crap--your-turn-p g)
|
||||
(if (and sel (eq (car sel) 'house))
|
||||
(let* ((m (length (card-games-crap--house-run g (cdr sel))))
|
||||
(new (max 1 (min m (+ (or (card-games-get g :sel-n) m) d)))))
|
||||
(card-games-put g :sel-n new)
|
||||
(card-games-crap--msg g (format "Holding the top %d of %d -- drop on an empty house."
|
||||
new m)))
|
||||
(card-games-crap--msg g "Pick up a house run first, then [ and ] set how many to move.")))
|
||||
(card-games-crap--redisplay)))
|
||||
|
||||
(defun card-games-crap-hold-less ()
|
||||
"Hold one fewer card of the picked-up run."
|
||||
(interactive) (card-games-crap--hold-adjust -1))
|
||||
|
||||
(defun card-games-crap-hold-more ()
|
||||
"Hold one more card of the picked-up run."
|
||||
(interactive) (card-games-crap--hold-adjust 1))
|
||||
|
||||
(defun card-games-crap-draw ()
|
||||
"Turn the top card of your hand onto your waste.
|
||||
If it fits nowhere your turn ends."
|
||||
(interactive)
|
||||
(let ((g card-games-crap--game))
|
||||
(when (card-games-crap--your-turn-p g)
|
||||
(unless (card-games-crap--stop g)
|
||||
(if (null (card-games-crap--hand g 0))
|
||||
(card-games-crap--msg g "Your hand is empty -- press e to end your turn.")
|
||||
(card-games-crap--snapshot g)
|
||||
(let* ((hand (card-games-crap--hand g 0)) (card (card-games-crap--top hand)))
|
||||
(aset (card-games-get g :hand) 0 (butlast hand 1))
|
||||
(aset (card-games-get g :waste) 0 (append (card-games-crap--waste g 0) (list card)))
|
||||
(card-games-put g :sel nil)
|
||||
(if (card-games-crap--card-playable g 0 card)
|
||||
(card-games-crap--msg g (format "Turned %s onto your waste -- play on."
|
||||
(card-games-crap--card-string card)))
|
||||
(progn
|
||||
(card-games-crap--msg g (format "Turned %s -- nothing to do, your turn ends."
|
||||
(card-games-crap--card-string card)))
|
||||
(card-games-crap--end-turn g)))))))
|
||||
(card-games-crap--redisplay)))
|
||||
|
||||
(defun card-games-crap-end ()
|
||||
"End your turn and let the opponent play."
|
||||
(interactive)
|
||||
(let ((g card-games-crap--game))
|
||||
(when (card-games-crap--your-turn-p g)
|
||||
(unless (card-games-crap--stop g)
|
||||
(card-games-crap--msg g "You end your turn.")
|
||||
(card-games-crap--end-turn g)))
|
||||
(card-games-crap--redisplay)))
|
||||
|
||||
(defun card-games-crap-undo ()
|
||||
"Undo your last move this turn."
|
||||
(interactive)
|
||||
(let* ((g card-games-crap--game) (h (card-games-get g :history)))
|
||||
(if (null h)
|
||||
(card-games-crap--msg g "Nothing to undo.")
|
||||
(let ((s (car h)))
|
||||
(card-games-put g :found (nth 0 s)) (card-games-put g :houses (nth 1 s))
|
||||
(card-games-put g :reserve (nth 2 s)) (card-games-put g :waste (nth 3 s))
|
||||
(card-games-put g :hand (nth 4 s)) (card-games-put g :turn (nth 5 s))
|
||||
(card-games-put g :history (cdr h)) (card-games-put g :sel nil) (card-games-put g :winner nil)
|
||||
(card-games-crap--msg g "Undid a move.")))
|
||||
(card-games-crap--redisplay)))
|
||||
|
||||
(defun card-games-crap-new ()
|
||||
"Deal a fresh Russian Bank game."
|
||||
(interactive)
|
||||
(card-games-crap--deal card-games-crap--game)
|
||||
(card-games-crap--redisplay))
|
||||
|
||||
(defun card-games-crap-redraw () "Redraw the board." (interactive) (card-games-crap--redisplay))
|
||||
|
||||
(defun card-games-crap-help ()
|
||||
"Describe the controls."
|
||||
(interactive)
|
||||
(message
|
||||
"Arrows: move RET: pick up/drop [ ]: how many cards of a run f: to foundation SPC: turn a card e: end u: undo n: new q: menu"))
|
||||
|
||||
(defvar card-games-crapette-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map (kbd "<left>") #'card-games-crap-left)
|
||||
(define-key map (kbd "<right>") #'card-games-crap-right)
|
||||
(define-key map (kbd "<up>") #'card-games-crap-left)
|
||||
(define-key map (kbd "<down>") #'card-games-crap-right)
|
||||
(define-key map (kbd "RET") #'card-games-crap-act)
|
||||
(define-key map [mouse-1] #'card-games-crap-mouse)
|
||||
(define-key map "+" #'card-games-card-zoom-in)
|
||||
(define-key map "=" #'card-games-card-zoom-in)
|
||||
(define-key map "-" #'card-games-card-zoom-out)
|
||||
(define-key map "0" #'card-games-card-zoom-reset)
|
||||
(define-key map (kbd "SPC") #'card-games-crap-draw)
|
||||
(define-key map "f" #'card-games-crap-found)
|
||||
(define-key map "[" #'card-games-crap-hold-less)
|
||||
(define-key map "]" #'card-games-crap-hold-more)
|
||||
(define-key map "d" #'card-games-crap-draw)
|
||||
(define-key map "e" #'card-games-crap-end)
|
||||
(define-key map "u" #'card-games-crap-undo)
|
||||
(define-key map "n" #'card-games-crap-new)
|
||||
(define-key map "g" #'card-games-crap-redraw)
|
||||
(define-key map "?" #'card-games-crap-help)
|
||||
(define-key map "q" #'card-games-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `card-games-crapette-mode'.")
|
||||
|
||||
(define-derived-mode card-games-crapette-mode special-mode "Crapette"
|
||||
"Major mode for two-player Russian Bank (Crapette)."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type card-games-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-crapette ()
|
||||
"Play two-player Russian Bank (Crapette) against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Russian Bank (Crapette)*")))
|
||||
(with-current-buffer buf
|
||||
(card-games-crapette-mode)
|
||||
(setq card-games-crap--game (card-games-crap--deal (card-games-crapette-game)))
|
||||
(card-games-crap--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;###autoload
|
||||
(defalias 'card-games-russian-bank-duel #'card-games-crapette
|
||||
"Alias for `card-games-crapette'.")
|
||||
|
||||
(provide 'card-games-crapette)
|
||||
;;; card-games-crapette.el ends here
|
||||
527
card-games-cribbage.el
Normal file
527
card-games-cribbage.el
Normal file
|
|
@ -0,0 +1,527 @@
|
|||
;;; card-games-cribbage.el --- Cribbage, with pegging and the show -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Two-handed Cribbage to 121, against the computer.
|
||||
;;
|
||||
;; Each deal you lay two cards away to the crib (which belongs to the
|
||||
;; dealer), cut a starter, then play the pegging round -- adding cards
|
||||
;; toward 31 and scoring fifteens, pairs, runs, and the go. Then comes
|
||||
;; the show, where both hands and the crib are counted for fifteens,
|
||||
;; pairs, runs, flushes, and his nobs. The deal alternates.
|
||||
;;
|
||||
;; Cards use the package cons (SUIT . RANK), RANK 0 (Ace) .. 12 (King);
|
||||
;; for counting, an Ace is one, face cards ten, the rest their pip value.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-rummy)
|
||||
|
||||
(defcustom card-games-cribbage-target 121
|
||||
"Points needed to win a game of Cribbage."
|
||||
:type 'integer :group 'card-games)
|
||||
|
||||
(defclass card-games-cribbage-game (card-games-game)
|
||||
((vname :initform "Cribbage"))
|
||||
"A two-handed game of Cribbage.")
|
||||
|
||||
;;;; Scoring primitives
|
||||
|
||||
(defun card-games-crib--val (card)
|
||||
"Return CARD's counting value (Ace 1, faces 10, else pip)."
|
||||
(let ((r (cdr card))) (if (<= r 8) (1+ r) 10)))
|
||||
|
||||
(defun card-games-crib--count-15s (cards)
|
||||
"Return points for all subsets of CARDS summing to fifteen."
|
||||
(let ((n (length cards)) (vec (vconcat cards)) (count 0))
|
||||
(dotimes (mask (ash 1 n))
|
||||
(let ((sum 0))
|
||||
(dotimes (i n)
|
||||
(when (/= 0 (logand mask (ash 1 i)))
|
||||
(setq sum (+ sum (card-games-crib--val (aref vec i))))))
|
||||
(when (= sum 15) (setq count (+ count 2)))))
|
||||
count))
|
||||
|
||||
(defun card-games-crib--count-pairs (cards)
|
||||
"Return points for all pairs in CARDS."
|
||||
(let ((cnt (make-vector 13 0)) (tot 0))
|
||||
(dolist (c cards) (aset cnt (cdr c) (1+ (aref cnt (cdr c)))))
|
||||
(dotimes (r 13)
|
||||
(let ((k (aref cnt r))) (setq tot (+ tot (* k (1- k)))))) ; 2*C(k,2)=k*(k-1)
|
||||
tot))
|
||||
|
||||
(defun card-games-crib--count-runs (cards)
|
||||
"Return points for every run of three or more in CARDS (with multiplicity)."
|
||||
(let ((cnt (make-vector 13 0)) (total 0) (r 0))
|
||||
(dolist (c cards) (aset cnt (cdr c) (1+ (aref cnt (cdr c)))))
|
||||
(while (< r 13)
|
||||
(if (= 0 (aref cnt r)) (setq r (1+ r))
|
||||
(let ((len 0) (mult 1))
|
||||
(while (and (< r 13) (> (aref cnt r) 0))
|
||||
(setq len (1+ len) mult (* mult (aref cnt r)) r (1+ r)))
|
||||
(when (>= len 3) (setq total (+ total (* len mult)))))))
|
||||
total))
|
||||
|
||||
(defun card-games-crib--flush (hand starter is-crib)
|
||||
"Return flush points for the four-card HAND with STARTER.
|
||||
A crib (IS-CRIB) flush must include the starter."
|
||||
(let ((s (car (car hand))))
|
||||
(cond ((not (cl-every (lambda (c) (= (car c) s)) hand)) 0)
|
||||
((= (car starter) s) 5)
|
||||
(is-crib 0)
|
||||
(t 4))))
|
||||
|
||||
(defun card-games-crib--nobs (hand starter)
|
||||
"Return 1 when HAND has the Jack of the STARTER's suit, else 0."
|
||||
(if (cl-find-if (lambda (c) (and (= (cdr c) 10) (= (car c) (car starter)))) hand)
|
||||
1 0))
|
||||
|
||||
(defun card-games-crib--score-show (hand starter &optional is-crib)
|
||||
"Return the show score of the four-card HAND with STARTER.
|
||||
IS-CRIB applies the stricter crib flush rule."
|
||||
(let ((all (cons starter hand)))
|
||||
(+ (card-games-crib--count-15s all)
|
||||
(card-games-crib--count-pairs all)
|
||||
(card-games-crib--count-runs all)
|
||||
(card-games-crib--flush hand starter is-crib)
|
||||
(card-games-crib--nobs hand starter))))
|
||||
|
||||
(defun card-games-crib--peg-score (seq total)
|
||||
"Return pegging points for the play whose sequence is SEQ (newest first).
|
||||
TOTAL is the running count after the play."
|
||||
(let ((pts 0))
|
||||
(when (= total 15) (setq pts (+ pts 2)))
|
||||
(when (= total 31) (setq pts (+ pts 2)))
|
||||
;; pairs: leading same-rank run in SEQ
|
||||
(let ((r (cdr (car seq))) (m 0) (lst seq) (stop nil))
|
||||
(while (and lst (not stop))
|
||||
(if (= (cdr (car lst)) r) (setq m (1+ m) lst (cdr lst)) (setq stop t)))
|
||||
(setq pts (+ pts (pcase m (2 2) (3 6) (4 12) (_ 0)))))
|
||||
;; runs: largest k>=3 whose last k cards form a consecutive run
|
||||
(let ((best 0) (k (length seq)))
|
||||
(while (>= k 3)
|
||||
(let* ((lastk (cl-subseq seq 0 k))
|
||||
(ranks (sort (mapcar #'cdr lastk) #'<)))
|
||||
(when (and (= (length ranks) (length (delete-dups (copy-sequence ranks))))
|
||||
(= (- (car (last ranks)) (car ranks)) (1- k)))
|
||||
(setq best (max best k))))
|
||||
(setq k (1- k)))
|
||||
(setq pts (+ pts best)))
|
||||
pts))
|
||||
|
||||
;;;; Setup and flow
|
||||
|
||||
(defsubst card-games-crib--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
|
||||
(defsubst card-games-crib--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
|
||||
(defsubst card-games-crib--play (game s) "Return seat S's pegging-play cards in GAME." (aref (card-games-get game :play) s))
|
||||
(defsubst card-games-crib--set-play (game s v) "Set seat S's pegging-play cards in GAME to V." (aset (card-games-get game :play) s v))
|
||||
|
||||
(defun card-games-crib--who (s) "Return the display name of seat S." (if (= s 0) "You" "Computer"))
|
||||
|
||||
(cl-defmethod card-games-crib--deal ((game card-games-cribbage-game))
|
||||
"Deal a fresh Cribbage hand into GAME."
|
||||
(let ((deck (card-games-rummy-deck)) (hands (make-vector 2 nil)))
|
||||
(dotimes (s 2)
|
||||
(aset hands s (card-games-rummy-sort-hand (cl-loop repeat 6 collect (pop deck)))))
|
||||
(card-games-put game :hands hands)
|
||||
(card-games-put game :deck deck)
|
||||
(card-games-put game :crib nil)
|
||||
(card-games-put game :starter nil)
|
||||
(card-games-put game :phase 'discard)
|
||||
(card-games-put game :cursor 0)
|
||||
(card-games-put game :marks nil)
|
||||
(unless (card-games-get game :scores) (card-games-put game :scores (make-vector 2 0)))
|
||||
(unless (integerp (card-games-get game :dealer)) (card-games-put game :dealer 1))
|
||||
(card-games-put game :message "Discard two cards to the crib: SPC marks, m confirms.")
|
||||
game))
|
||||
|
||||
(defun card-games-crib--add (game s pts)
|
||||
"Add PTS to GAME seat S and end the game if it reaches the target."
|
||||
(when (> pts 0)
|
||||
(aset (card-games-get game :scores) s (+ (aref (card-games-get game :scores) s) pts))
|
||||
(when (>= (aref (card-games-get game :scores) s) card-games-cribbage-target)
|
||||
(card-games-put game :phase 'game-over)
|
||||
(card-games-put game :winner s))))
|
||||
|
||||
(defun card-games-crib--ai-discard (game s)
|
||||
"Return the two cards GAME seat S should lay away (keep the best four)."
|
||||
(let* ((hand (card-games-crib--hand game s)) (best nil) (bestv -1))
|
||||
(dolist (combo (card-games-rummy--combinations hand 4))
|
||||
(let ((v (card-games-crib--score-show combo '(0 . 0)))) ; rough: no starter
|
||||
(when (> v bestv) (setq bestv v best combo))))
|
||||
(cl-set-difference hand best :test #'equal)))
|
||||
|
||||
(cl-defmethod card-games-crib--start-play ((game card-games-cribbage-game))
|
||||
"Cut GAME's starter and begin the pegging round."
|
||||
(let* ((deck (card-games-get game :deck))
|
||||
(starter (nth (random (length deck)) deck))
|
||||
(dealer (card-games-get game :dealer)))
|
||||
(card-games-put game :starter starter)
|
||||
(when (= (cdr starter) 10) ; his heels: starter is a Jack
|
||||
(card-games-crib--add game dealer 2))
|
||||
(card-games-put game :play (vector (card-games-crib--hand game 0) (card-games-crib--hand game 1)))
|
||||
(card-games-put game :seq nil)
|
||||
(card-games-put game :total 0)
|
||||
(card-games-put game :go nil)
|
||||
(card-games-put game :last-player nil)
|
||||
(card-games-put game :pturn (- 1 dealer)) ; non-dealer leads
|
||||
(card-games-put game :phase (if (eq (card-games-get game :phase) 'game-over) 'game-over 'play))
|
||||
(card-games-put game :cursor 0)
|
||||
(card-games-put game :message
|
||||
(format "Pegging: %s leads. Starter is %s."
|
||||
(card-games-crib--who (- 1 dealer)) (card-games-rummy-card-string starter)))))
|
||||
|
||||
(defun card-games-crib--legal (game s)
|
||||
"Return GAME seat S's play-cards that fit under 31."
|
||||
(cl-remove-if (lambda (c) (> (card-games-crib--val c) (- 31 (card-games-get game :total))))
|
||||
(card-games-crib--play game s)))
|
||||
|
||||
(defun card-games-crib--peg-play (game s card)
|
||||
"Have GAME seat S play CARD into the pegging round, pegging any points."
|
||||
(card-games-crib--set-play game s (cl-remove card (card-games-crib--play game s) :test #'equal :count 1))
|
||||
(card-games-put game :seq (cons card (card-games-get game :seq)))
|
||||
(card-games-put game :total (+ (card-games-get game :total) (card-games-crib--val card)))
|
||||
(card-games-put game :last-player s)
|
||||
(card-games-put game :go nil)
|
||||
(let ((pts (card-games-crib--peg-score (card-games-get game :seq) (card-games-get game :total))))
|
||||
(card-games-crib--add game s pts)
|
||||
(card-games-put game :message
|
||||
(format "%s played %s (count %d)%s."
|
||||
(card-games-crib--who s) (card-games-rummy-card-string card) (card-games-get game :total)
|
||||
(if (> pts 0) (format " for %d" pts) ""))))
|
||||
(if (= (card-games-get game :total) 31)
|
||||
(card-games-crib--peg-reset game)
|
||||
(card-games-put game :pturn (- 1 s))))
|
||||
|
||||
(defun card-games-crib--peg-reset (game)
|
||||
"Reset GAME's running count; the player after the last to play leads."
|
||||
(card-games-put game :seq nil)
|
||||
(card-games-put game :total 0)
|
||||
(card-games-put game :go nil)
|
||||
(card-games-put game :pturn (- 1 (card-games-get game :last-player))))
|
||||
|
||||
(defun card-games-crib--peg-over-p (game)
|
||||
"Return non-nil when both GAME players have played out their cards."
|
||||
(and (null (card-games-crib--play game 0)) (null (card-games-crib--play game 1))))
|
||||
|
||||
(defun card-games-crib--peg-go (game s)
|
||||
"Handle GAME seat S being unable to play (a go)."
|
||||
(let ((other (- 1 s)))
|
||||
(if (card-games-crib--legal game other)
|
||||
(card-games-put game :pturn other) ; opponent plays on
|
||||
;; neither can play: last player pegs one for the go, then reset
|
||||
(when (card-games-get game :last-player)
|
||||
(card-games-crib--add game (card-games-get game :last-player) 1)
|
||||
(card-games-put game :message
|
||||
(format "%s pegs 1 for the go." (card-games-crib--who (card-games-get game :last-player)))))
|
||||
(card-games-crib--peg-reset game))))
|
||||
|
||||
(cl-defmethod card-games-crib--ai-play ((game card-games-cribbage-game) s)
|
||||
"Have GAME AI seat S play its best pegging card or declare a go."
|
||||
(let ((legal (card-games-crib--legal game s)))
|
||||
(if (null legal) (card-games-crib--peg-go game s)
|
||||
(let ((best (car legal)) (bestv -1))
|
||||
(dolist (c legal)
|
||||
(let* ((seq (cons c (card-games-get game :seq)))
|
||||
(tot (+ (card-games-get game :total) (card-games-crib--val c)))
|
||||
(v (card-games-crib--peg-score seq tot)))
|
||||
;; prefer points; tie-break toward keeping count off 5 and 21
|
||||
(when (or (> v bestv)
|
||||
(and (= v bestv) (> (card-games-crib--val c) (card-games-crib--val best))))
|
||||
(setq best c bestv v))))
|
||||
(card-games-crib--peg-play game s best)))))
|
||||
|
||||
(defun card-games-crib--peg-advance (game)
|
||||
"Run GAME's AI pegging until your turn or the round ends."
|
||||
(let ((guard 0))
|
||||
(while (and (eq (card-games-get game :phase) 'play) (not (card-games-crib--peg-over-p game))
|
||||
(/= (card-games-get game :pturn) 0) (< guard 200))
|
||||
(setq guard (1+ guard))
|
||||
(card-games-crib--ai-play game (card-games-get game :pturn))))
|
||||
;; if it is your turn but you have no legal play, auto-go
|
||||
(when (and (eq (card-games-get game :phase) 'play) (not (card-games-crib--peg-over-p game))
|
||||
(= (card-games-get game :pturn) 0) (null (card-games-crib--legal game 0)))
|
||||
(card-games-crib--peg-go game 0)
|
||||
(card-games-crib--peg-advance game))
|
||||
(when (and (eq (card-games-get game :phase) 'play) (card-games-crib--peg-over-p game))
|
||||
(card-games-crib--show game)))
|
||||
|
||||
(cl-defmethod card-games-crib--show ((game card-games-cribbage-game))
|
||||
"Count GAME's hands and crib, then set up the next deal."
|
||||
(let* ((starter (card-games-get game :starter))
|
||||
(dealer (card-games-get game :dealer)) (pone (- 1 dealer))
|
||||
(h-pone (card-games-crib--hand game pone)) (h-dealer (card-games-crib--hand game dealer))
|
||||
(crib (card-games-get game :crib))
|
||||
(s-pone (card-games-crib--score-show h-pone starter))
|
||||
(s-dealer (card-games-crib--score-show h-dealer starter))
|
||||
(s-crib (card-games-crib--score-show crib starter t)))
|
||||
;; count in order: non-dealer, dealer, crib (a player may win mid-count)
|
||||
(card-games-crib--add game pone s-pone)
|
||||
(when (not (eq (card-games-get game :phase) 'game-over)) (card-games-crib--add game dealer s-dealer))
|
||||
(when (not (eq (card-games-get game :phase) 'game-over)) (card-games-crib--add game dealer s-crib))
|
||||
(card-games-put game :show (list :pone s-pone :dealer s-dealer :crib s-crib))
|
||||
(unless (eq (card-games-get game :phase) 'game-over) (card-games-put game :phase 'show))
|
||||
(card-games-put game :message
|
||||
(format "Show: %s %d, %s %d, crib %d. %s"
|
||||
(card-games-crib--who pone) s-pone (card-games-crib--who dealer) s-dealer s-crib
|
||||
(if (eq (card-games-get game :phase) 'game-over)
|
||||
(format "%s wins! (n: new game)" (card-games-crib--who (card-games-get game :winner)))
|
||||
"(n: next deal)")))))
|
||||
|
||||
;;;; UI
|
||||
|
||||
(defvar-local card-games-crib--game nil "The Cribbage game in the current buffer.")
|
||||
|
||||
(defun card-games-crib--svg (game)
|
||||
"Return an SVG board for the Cribbage GAME (with a peg-track)."
|
||||
(let* ((w card-games-svg-card-width) (h card-games-svg-card-height) (gap card-games-svg-card-gap) (pad 16)
|
||||
(phase (card-games-get game :phase)) (scores (card-games-get game :scores))
|
||||
(hand (if (eq phase 'play) (card-games-crib--play game 0) (card-games-crib--hand game 0)))
|
||||
(n (length hand)) (cursor (card-games-get game :cursor)) (marks (card-games-get game :marks))
|
||||
(overlap (cond ((> n 11) (- w 24)) ((> n 8) 20) (t 0)))
|
||||
(step (max 14 (- (+ w gap) overlap)))
|
||||
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
|
||||
(target card-games-cribbage-target) (barw 220) (peg-h 14) (peg-gap 8)
|
||||
(y-title 6) (y-peg 26)
|
||||
(y-mid (+ y-peg (* 2 (+ peg-h peg-gap)) 18))
|
||||
(y-hand (+ y-mid h 44))
|
||||
(height (+ y-hand h 30))
|
||||
(width (max (+ fanw (* 2 pad)) (+ pad 90 barw 120) 620))
|
||||
(svg (svg-create width height))
|
||||
(lc (card-games-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels ((txt (str x y &optional sz bold)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family card-games-svg-font-family (and bold '(:font-weight "bold"))))
|
||||
(card-games-crib--peg (label sc y)
|
||||
(txt label pad (+ y 11) 12)
|
||||
(let ((bx (+ pad 90)))
|
||||
(svg-rectangle svg bx y barw peg-h :rx 4 :fill "none"
|
||||
:stroke lc :stroke-width 1)
|
||||
(svg-rectangle svg bx y
|
||||
(round (* barw (/ (float (min sc target)) target)))
|
||||
peg-h :rx 4 :fill "#3aa15a")
|
||||
(txt (format "%d" sc) (+ bx barw 8) (+ y 11) 12)))
|
||||
(crow (cards x y)
|
||||
(let ((xx x))
|
||||
(dolist (c cards)
|
||||
(let ((sp (card-games-rummy--card-spec c)))
|
||||
(card-games-svg-card svg xx y :rank (car sp) :suit (cdr sp)))
|
||||
(setq xx (+ xx (round (* w 0.5))))))))
|
||||
(txt (format "Cribbage (to %d)" target) pad (+ y-title 12) 13 t)
|
||||
(card-games-crib--peg "You" (aref scores 0) y-peg)
|
||||
(card-games-crib--peg "Computer" (aref scores 1) (+ y-peg peg-h peg-gap))
|
||||
(txt (format "%s deals" (card-games-crib--who (card-games-get game :dealer)))
|
||||
(+ pad 90 barw 60) (+ y-peg 11) 11)
|
||||
(let ((mx pad))
|
||||
(when (card-games-get game :starter)
|
||||
(let ((sp (card-games-rummy--card-spec (card-games-get game :starter))))
|
||||
(card-games-svg-card svg mx y-mid :rank (car sp) :suit (cdr sp))
|
||||
(txt "Starter" mx (+ y-mid h 13) 11)
|
||||
(setq mx (+ mx w gap 24))))
|
||||
(cond
|
||||
((eq phase 'play)
|
||||
(txt (format "Count: %d" (card-games-get game :total)) mx (- y-mid 4) 12)
|
||||
(crow (reverse (card-games-get game :seq)) mx y-mid))
|
||||
((memq phase '(show game-over))
|
||||
(when (card-games-get game :crib)
|
||||
(txt (format "Crib (%s)" (card-games-crib--who (card-games-get game :dealer))) mx (- y-mid 4) 11)
|
||||
(crow (card-games-get game :crib) mx y-mid)))))
|
||||
(txt (format "Your %s" (if (eq phase 'play) "cards" "hand")) pad (- y-hand 6) 11)
|
||||
(let ((x (max pad (- (/ width 2) (/ fanw 2)))) (i 0))
|
||||
(dolist (c hand)
|
||||
(let ((sp (card-games-rummy--card-spec c)) (curp (= i cursor))
|
||||
(markp (and marks (memq i marks))))
|
||||
(card-games-svg-card svg x y-hand :rank (car sp) :suit (cdr sp) :highlight curp)
|
||||
(when markp
|
||||
(svg-rectangle svg (- x 3) (- y-hand 3) (+ w 6) (+ h 6)
|
||||
:rx 8 :fill "none" :stroke "#4a90d9" :stroke-width 3))
|
||||
(push (cons (list x y-hand (if (= i (1- n)) w step) h) (cons 'hand i)) regions))
|
||||
(setq x (+ x step) i (1+ i))))
|
||||
(txt (or (card-games-get game :message) "") pad (- height 8) 12))
|
||||
(propertize "*" 'display (card-games-svg-image svg (card-games-scale)) 'card-games-regions (nreverse regions))))
|
||||
|
||||
(cl-defmethod card-games-render ((game card-games-cribbage-game))
|
||||
"Return a depiction of the Cribbage GAME: SVG board if graphical, else text."
|
||||
(if (and card-games-rummy-svg-cards (display-graphic-p))
|
||||
(card-games-crib--svg game)
|
||||
(card-games-crib--render-text game)))
|
||||
|
||||
(defun card-games-crib--render-text (game)
|
||||
"Return a plain-text depiction of the Cribbage GAME."
|
||||
(let* ((out '()) (scores (card-games-get game :scores)) (phase (card-games-get game :phase))
|
||||
(cursor (card-games-get game :cursor)))
|
||||
(push (format " Cribbage to %d\n\n" card-games-cribbage-target) out)
|
||||
(push (format " You %d Computer %d %s deals\n\n"
|
||||
(aref scores 0) (aref scores 1) (card-games-crib--who (card-games-get game :dealer)))
|
||||
out)
|
||||
(when (card-games-get game :starter)
|
||||
(push (format " Starter: %s\n" (card-games-rummy-card-string (card-games-get game :starter))) out))
|
||||
(when (eq phase 'play)
|
||||
(push (format " Count: %d\n Played: %s\n" (card-games-get game :total)
|
||||
(mapconcat #'card-games-rummy-card-string (reverse (card-games-get game :seq)) " "))
|
||||
out))
|
||||
(when (memq phase '(show game-over))
|
||||
(let ((sh (card-games-get game :show)))
|
||||
(when sh
|
||||
(push (format " Crib (%s): %s\n"
|
||||
(card-games-crib--who (card-games-get game :dealer))
|
||||
(mapconcat #'card-games-rummy-card-string (card-games-get game :crib) " ")) out))))
|
||||
(let* ((hand (if (eq phase 'play) (card-games-crib--play game 0) (card-games-crib--hand game 0))))
|
||||
(push (format "\n Your %s:\n " (if (eq phase 'play) "cards" "hand")) out)
|
||||
(push (card-games-rummy--render-cards hand cursor (card-games-get game :marks) nil 'hand) out))
|
||||
(push (format "\n\n %s\n" (card-games-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod card-games-render-apply ((g card-games-cribbage-game) action)
|
||||
"Apply a click ACTION on the hand to GAME G."
|
||||
(pcase action
|
||||
(`(hand . ,i) (card-games-put g :cursor i))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun card-games-crib--redisplay ()
|
||||
"Redraw the current Cribbage buffer."
|
||||
(let ((game card-games-crib--game) (inhibit-read-only t))
|
||||
(setq card-games-current-game game card-games-redisplay-function #'card-games-crib--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))
|
||||
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
|
||||
|
||||
(defun card-games-crib--cur-list (g)
|
||||
"Return seat 0's current card list in G (pegging plays or hand)."
|
||||
(if (eq (card-games-get g :phase) 'play) (card-games-crib--play g 0) (card-games-crib--hand g 0)))
|
||||
|
||||
(defun card-games-crib-left ()
|
||||
"Move the cursor left."
|
||||
(interactive)
|
||||
(let* ((g card-games-crib--game) (n (length (card-games-crib--cur-list g))))
|
||||
(when (> n 0) (card-games-put g :cursor (mod (1- (card-games-get g :cursor)) n)))
|
||||
(card-games-crib--redisplay)))
|
||||
|
||||
(defun card-games-crib-right ()
|
||||
"Move the cursor right."
|
||||
(interactive)
|
||||
(let* ((g card-games-crib--game) (n (length (card-games-crib--cur-list g))))
|
||||
(when (> n 0) (card-games-put g :cursor (mod (1+ (card-games-get g :cursor)) n)))
|
||||
(card-games-crib--redisplay)))
|
||||
|
||||
(defun card-games-crib-mark ()
|
||||
"Toggle a discard mark on the cursor card (discard phase)."
|
||||
(interactive)
|
||||
(let* ((g card-games-crib--game) (i (card-games-get g :cursor)) (marks (card-games-get g :marks)))
|
||||
(when (eq (card-games-get g :phase) 'discard)
|
||||
(card-games-put g :marks (if (memq i marks) (delq i marks)
|
||||
(if (>= (length marks) 2) marks (cons i marks)))))
|
||||
(card-games-crib--redisplay)))
|
||||
|
||||
(defun card-games-crib-confirm ()
|
||||
"Confirm your two crib discards and start play."
|
||||
(interactive)
|
||||
(let* ((g card-games-crib--game) (hand (card-games-crib--hand g 0))
|
||||
(marks (card-games-get g :marks)))
|
||||
(if (or (not (eq (card-games-get g :phase) 'discard)) (/= (length marks) 2))
|
||||
(progn (card-games-put g :message "Mark exactly two cards (SPC), then m.")
|
||||
(card-games-crib--redisplay))
|
||||
(let ((mine (mapcar (lambda (i) (nth i hand)) marks))
|
||||
(ai (card-games-crib--ai-discard g 1)))
|
||||
(card-games-crib--set-hand g 0 (cl-set-difference hand mine :test #'equal))
|
||||
(card-games-crib--set-hand g 1 (cl-set-difference (card-games-crib--hand g 1) ai :test #'equal))
|
||||
(card-games-put g :crib (append mine ai))
|
||||
(card-games-put g :marks nil) (card-games-put g :cursor 0)
|
||||
(card-games-crib--start-play g)
|
||||
(card-games-crib--peg-advance g)
|
||||
(card-games-crib--redisplay)))))
|
||||
|
||||
(defun card-games-crib-play ()
|
||||
"Play the cursor card in pegging, or declare a go if you cannot."
|
||||
(interactive)
|
||||
(let* ((g card-games-crib--game))
|
||||
(cond
|
||||
((not (eq (card-games-get g :phase) 'play)) (card-games-put g :message "Not the pegging round."))
|
||||
((/= (card-games-get g :pturn) 0) (card-games-put g :message "Not your turn."))
|
||||
((null (card-games-crib--legal g 0))
|
||||
(card-games-crib--peg-go g 0) (card-games-crib--peg-advance g))
|
||||
(t (let ((card (nth (card-games-get g :cursor) (card-games-crib--play g 0))))
|
||||
(if (or (null card) (> (card-games-crib--val card) (- 31 (card-games-get g :total))))
|
||||
(card-games-put g :message "That card would go over 31 -- choose another.")
|
||||
(card-games-crib--peg-play g 0 card)
|
||||
(card-games-put g :cursor 0)
|
||||
(card-games-crib--peg-advance g)))))
|
||||
(card-games-crib--redisplay)))
|
||||
|
||||
(defun card-games-crib-new ()
|
||||
"Start the next deal, or a new game when one is over."
|
||||
(interactive)
|
||||
(let ((g card-games-crib--game))
|
||||
(when (eq (card-games-get g :phase) 'game-over)
|
||||
(card-games-put g :scores (make-vector 2 0)) (card-games-put g :dealer 1))
|
||||
(card-games-put g :dealer (- 1 (card-games-get g :dealer))) ; alternate the deal
|
||||
(card-games-put g :show nil)
|
||||
(card-games-crib--deal g)
|
||||
(card-games-crib--redisplay)))
|
||||
|
||||
(defun card-games-crib-redraw () "Redraw." (interactive) (card-games-crib--redisplay))
|
||||
(defun card-games-crib-help () "Describe the controls." (interactive)
|
||||
(message "Arrows: choose SPC: mark (discard) m: confirm crib RET: play/go n: next g: redraw"))
|
||||
|
||||
(defvar card-games-cribbage-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'card-games-card-click)
|
||||
(define-key map "+" #'card-games-card-zoom-in)
|
||||
(define-key map "=" #'card-games-card-zoom-in)
|
||||
(define-key map "-" #'card-games-card-zoom-out)
|
||||
(define-key map "0" #'card-games-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'card-games-crib-left)
|
||||
(define-key map (kbd "<right>") #'card-games-crib-right)
|
||||
(define-key map (kbd "SPC") #'card-games-crib-mark)
|
||||
(define-key map "m" #'card-games-crib-confirm)
|
||||
(define-key map (kbd "RET") #'card-games-crib-play)
|
||||
(define-key map "n" #'card-games-crib-new)
|
||||
(define-key map "g" #'card-games-crib-redraw)
|
||||
(define-key map "?" #'card-games-crib-help)
|
||||
(define-key map "q" #'card-games-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `card-games-cribbage-mode'.")
|
||||
|
||||
(define-derived-mode card-games-cribbage-mode special-mode "Cribbage"
|
||||
"Major mode for Cribbage."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type card-games-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-cribbage ()
|
||||
"Play two-handed Cribbage against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Cribbage*")))
|
||||
(with-current-buffer buf
|
||||
(card-games-cribbage-mode)
|
||||
(setq card-games-crib--game (card-games-cribbage-game))
|
||||
(card-games-crib--deal card-games-crib--game)
|
||||
(card-games-crib--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
(provide 'card-games-cribbage)
|
||||
;;; card-games-cribbage.el ends here
|
||||
444
card-games-eights.el
Normal file
444
card-games-eights.el
Normal file
|
|
@ -0,0 +1,444 @@
|
|||
;;; card-games-eights.el --- Crazy Eights, a shedding card game -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Crazy Eights: shed your whole hand by matching the suit or rank of the
|
||||
;; card on top of the discard pile. Eights are wild -- play one any time
|
||||
;; and name the suit that must follow. If you cannot play, draw a card.
|
||||
;; You are the South player; the others are simple AI. This is the direct
|
||||
;; ancestor of UNO, and the shedding engine generalises to climbing games
|
||||
;; such as President.
|
||||
;;
|
||||
;; Cards are the package-standard cons (SUIT . RANK) with SUIT 0 spades,
|
||||
;; 1 clubs, 2 diamonds, 3 hearts and RANK 0 (the Two) .. 12 (the Ace).
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-svg)
|
||||
|
||||
(defconst card-games-eights-ranks
|
||||
["2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K" "A"]
|
||||
"Rank labels indexed 0 (Two) .. 12 (Ace).")
|
||||
|
||||
(defconst card-games-eights--wild 6 "Rank index of the wild Eight.")
|
||||
|
||||
(defcustom card-games-eights-players 3
|
||||
"Number of players in Crazy Eights, including you (2-4)."
|
||||
:type '(choice (const 2) (const 3) (const 4)) :group 'card-games)
|
||||
|
||||
(defun card-games-eights-card-string (card)
|
||||
"Return a short string for CARD."
|
||||
(if (null card) "·"
|
||||
(concat (aref card-games-eights-ranks (cdr card)) (card-games-suit-glyph (car card)))))
|
||||
|
||||
(defsubst card-games-eights-red-p (card) "Return non-nil when CARD is red." (and card (card-games-red-suit-p (car card))))
|
||||
|
||||
(defun card-games-eights--value (card)
|
||||
"Return the scoring value of CARD held at the end of a hand."
|
||||
(cond ((= (cdr card) card-games-eights--wild) 50)
|
||||
((>= (cdr card) 9) 10) ; J Q K
|
||||
((= (cdr card) 12) 1) ; (Ace handled above by >=9? no)
|
||||
(t (+ 2 (cdr card)))))
|
||||
|
||||
(defun card-games-eights--deck ()
|
||||
"Return a fresh shuffled 52-card deck."
|
||||
(random t)
|
||||
(card-games-shuffle (cl-loop for s below 4 append
|
||||
(cl-loop for r below 13 collect (cons s r)))))
|
||||
|
||||
(defclass card-games-eights-game (card-games-game)
|
||||
((vname :initform "Crazy Eights"))
|
||||
"A game of Crazy Eights.")
|
||||
|
||||
(defsubst card-games-eights--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
|
||||
(defsubst card-games-eights--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
|
||||
(defsubst card-games-eights--top (game) "Return the top card of GAME's discard pile." (car (card-games-get game :discard)))
|
||||
|
||||
(cl-defmethod card-games-eights--deal ((game card-games-eights-game))
|
||||
"Deal a fresh Crazy Eights hand into GAME."
|
||||
(let* ((n (max 2 (min 4 card-games-eights-players)))
|
||||
(deck (card-games-eights--deck))
|
||||
(per (if (= n 2) 7 5))
|
||||
(hands (make-vector n nil)))
|
||||
(dotimes (s n)
|
||||
(aset hands s (cl-loop repeat per collect (pop deck))))
|
||||
;; turn up a starter that is not an eight
|
||||
(let ((start (pop deck)))
|
||||
(while (= (cdr start) card-games-eights--wild)
|
||||
(setq deck (append deck (list start)) start (pop deck)))
|
||||
(card-games-put game :discard (list start))
|
||||
(card-games-put game :suit (car start)))
|
||||
(card-games-put game :stock deck)
|
||||
(card-games-put game :hands hands)
|
||||
(card-games-put game :nplayers n)
|
||||
(card-games-put game :turn 0)
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :passes 0)
|
||||
(card-games-put game :cursor 0)
|
||||
(unless (card-games-get game :scores) (card-games-put game :scores (make-vector n 0)))
|
||||
(card-games-put game :message "Match the suit or rank; eights are wild. d draws.")
|
||||
game))
|
||||
|
||||
(cl-defmethod card-games-eights--legal-p ((game card-games-eights-game) card)
|
||||
"Return non-nil when CARD may be played onto GAME's discard now."
|
||||
(or (= (cdr card) card-games-eights--wild)
|
||||
(= (car card) (card-games-get game :suit))
|
||||
(= (cdr card) (cdr (card-games-eights--top game)))))
|
||||
|
||||
(defun card-games-eights--legal-moves (game s)
|
||||
"Return the cards in GAME seat S's hand that may be played now."
|
||||
(cl-remove-if-not (lambda (c) (card-games-eights--legal-p game c))
|
||||
(card-games-eights--hand game s)))
|
||||
|
||||
(defun card-games-eights--best-suit (game s)
|
||||
"Return the suit most common in GAME seat S's hand (ignoring eights)."
|
||||
(let ((counts (make-vector 4 0)))
|
||||
(dolist (c (card-games-eights--hand game s))
|
||||
(unless (= (cdr c) card-games-eights--wild)
|
||||
(aset counts (car c) (1+ (aref counts (car c))))))
|
||||
(let ((best 0))
|
||||
(dotimes (i 4) (when (> (aref counts i) (aref counts best)) (setq best i)))
|
||||
best)))
|
||||
|
||||
(cl-defmethod card-games-eights--play ((game card-games-eights-game) s card &optional suit)
|
||||
"Have GAME seat S play CARD; SUIT names the next suit for a wild eight."
|
||||
(card-games-eights--set-hand game s (remove card (card-games-eights--hand game s)))
|
||||
(card-games-put game :discard (cons card (card-games-get game :discard)))
|
||||
(card-games-put game :suit (if (= (cdr card) card-games-eights--wild)
|
||||
(or suit (card-games-eights--best-suit game s))
|
||||
(car card)))
|
||||
(card-games-put game :passes 0)
|
||||
(if (null (card-games-eights--hand game s))
|
||||
(card-games-eights--finish game s)
|
||||
(card-games-put game :turn (mod (1+ s) (card-games-get game :nplayers)))))
|
||||
|
||||
(defun card-games-eights--draw-card (game s)
|
||||
"Move one card from GAME's stock to seat S's hand, recycling if needed.
|
||||
Return the drawn card, or nil when none is available."
|
||||
(when (and (null (card-games-get game :stock)) (cdr (card-games-get game :discard)))
|
||||
(let ((top (car (card-games-get game :discard))))
|
||||
(card-games-put game :stock (card-games-shuffle (cdr (card-games-get game :discard))))
|
||||
(card-games-put game :discard (list top))))
|
||||
(let ((stock (card-games-get game :stock)))
|
||||
(when stock
|
||||
(let ((card (car stock)))
|
||||
(card-games-put game :stock (cdr stock))
|
||||
(card-games-eights--set-hand game s (cons card (card-games-eights--hand game s)))
|
||||
card))))
|
||||
|
||||
(cl-defmethod card-games-eights--finish ((game card-games-eights-game) winner)
|
||||
"Record WINNER going out in GAME and score the other hands against them."
|
||||
(let ((sum 0))
|
||||
(dotimes (s (card-games-get game :nplayers))
|
||||
(unless (= s winner)
|
||||
(dolist (c (card-games-eights--hand game s))
|
||||
(setq sum (+ sum (card-games-eights--value c))))))
|
||||
(aset (card-games-get game :scores) winner (+ (aref (card-games-get game :scores) winner) sum))
|
||||
(card-games-put game :phase 'game-over)
|
||||
(card-games-put game :winner winner)
|
||||
(card-games-put game :message
|
||||
(format "%s goes out and scores %d. Press n for a new deal."
|
||||
(if (= winner 0) "You" (format "Player %d" winner)) sum))))
|
||||
|
||||
(cl-defmethod card-games-eights--ai-turn ((game card-games-eights-game) s)
|
||||
"Take GAME seat S's whole turn: play if able, else draw then play or pass."
|
||||
(let ((moves (card-games-eights--legal-moves game s)))
|
||||
(unless moves
|
||||
;; draw up to a small limit looking for a play
|
||||
(let ((tries 0))
|
||||
(while (and (not moves) (< tries 60) (card-games-eights--draw-card game s))
|
||||
(setq moves (card-games-eights--legal-moves game s) tries (1+ tries)))))
|
||||
(if moves
|
||||
;; prefer a non-eight of lowest value; keep eights for later
|
||||
(let* ((non (cl-remove-if (lambda (c) (= (cdr c) card-games-eights--wild)) moves))
|
||||
(pick (car (sort (copy-sequence (or non moves))
|
||||
(lambda (a b) (< (card-games-eights--value a)
|
||||
(card-games-eights--value b)))))))
|
||||
(card-games-eights--play game s pick))
|
||||
;; truly stuck: pass
|
||||
(card-games-put game :passes (1+ (card-games-get game :passes)))
|
||||
(card-games-put game :turn (mod (1+ s) (card-games-get game :nplayers))))))
|
||||
|
||||
(defun card-games-eights--run (game)
|
||||
"Advance GAME's AI seats until the human's turn or the hand ends."
|
||||
(while (and (eq (card-games-get game :phase) 'play)
|
||||
(/= (card-games-get game :turn) 0)
|
||||
(< (card-games-get game :passes) (card-games-get game :nplayers)))
|
||||
(card-games-eights--ai-turn game (card-games-get game :turn)))
|
||||
(when (>= (card-games-get game :passes) (card-games-get game :nplayers))
|
||||
(card-games-eights--deadlock game)))
|
||||
|
||||
(cl-defmethod card-games-eights--deadlock ((game card-games-eights-game))
|
||||
"End a GAME hand in which everyone passed; lowest hand value wins."
|
||||
(let ((best 0) (bestv most-positive-fixnum))
|
||||
(dotimes (s (card-games-get game :nplayers))
|
||||
(let ((v (apply #'+ (mapcar #'card-games-eights--value (card-games-eights--hand game s)))))
|
||||
(when (< v bestv) (setq bestv v best s))))
|
||||
(card-games-eights--finish game best)))
|
||||
|
||||
;;;; UI
|
||||
|
||||
(defvar-local card-games-eights--game nil "The Crazy Eights game in the current buffer.")
|
||||
|
||||
(defcustom card-games-eights-svg-cards t
|
||||
"When non-nil, draw the hand as SVG on a graphical display."
|
||||
:type 'boolean :group 'card-games)
|
||||
|
||||
(defun card-games-eights--spec (card)
|
||||
"Return the card-games-svg display spec (RANK-STRING . SUIT) for CARD."
|
||||
(cons (aref card-games-eights-ranks (cdr card)) (car card)))
|
||||
|
||||
(defun card-games-eights--board-svg (game)
|
||||
"Return an SVG board for the Crazy Eights GAME."
|
||||
(let* ((w card-games-svg-card-width) (h card-games-svg-card-height) (gap card-games-svg-card-gap) (pad 16)
|
||||
(hand (card-games-eights--hand game 0)) (n (length hand))
|
||||
(cursor (card-games-get game :cursor))
|
||||
(top (card-games-eights--top game)) (suit (card-games-get game :suit))
|
||||
(overlap (cond ((> n 11) (- w 24)) ((> n 8) 20) (t 0)))
|
||||
(step (max 14 (- (+ w gap) overlap)))
|
||||
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
|
||||
(np (card-games-get game :nplayers)) (nstock (length (card-games-get game :stock)))
|
||||
(y-title 6) (y-info 26)
|
||||
(y-mid (+ y-info (* (1- np) 16) 14))
|
||||
(y-hand (+ y-mid h 42))
|
||||
(height (+ y-hand h 30))
|
||||
(width (max (+ fanw (* 2 pad)) 560))
|
||||
(svg (svg-create width height))
|
||||
(lc (card-games-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels ((txt (str x y &optional sz bold)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family card-games-svg-font-family (and bold '(:font-weight "bold")))))
|
||||
(txt "Crazy Eights" pad (+ y-title 12) 13 t)
|
||||
(let ((yy (+ y-info 4)))
|
||||
(dotimes (s np)
|
||||
(unless (= s 0)
|
||||
(txt (format "Player %d: %d cards (score %d)" s
|
||||
(length (card-games-eights--hand game s)) (aref (card-games-get game :scores) s))
|
||||
pad yy 12)
|
||||
(setq yy (+ yy 16)))))
|
||||
(card-games-svg-card svg pad y-mid :down (> nstock 0) :gap (= nstock 0))
|
||||
(txt (format "Stock %d" nstock) pad (+ y-mid h 13) 11)
|
||||
(let ((dx (+ pad w gap 28)) (sp (card-games-eights--spec top)))
|
||||
(card-games-svg-card svg dx y-mid :rank (car sp) :suit (cdr sp))
|
||||
(txt "Discard" dx (+ y-mid h 13) 11)
|
||||
(let ((sx (+ dx w gap 34))
|
||||
(col (if (card-games-red-suit-p suit) "#c0392b" "#2c3e50")))
|
||||
(txt "Suit in play" sx (- y-mid 4) 11)
|
||||
(svg-text svg (card-games-suit-glyph suit) :x (+ sx 12) :y (+ y-mid 46)
|
||||
:font-size 44 :fill col :font-family card-games-svg-font-family)))
|
||||
(txt "Your hand" pad (- y-hand 6) 11)
|
||||
(let ((x (max pad (- (/ width 2) (/ fanw 2)))) (i 0))
|
||||
(dolist (c hand)
|
||||
(let ((sp (card-games-eights--spec c)) (curp (= i cursor))
|
||||
(hintp (card-games-eights--legal-p game c)))
|
||||
(card-games-svg-card svg x y-hand :rank (car sp) :suit (cdr sp)
|
||||
:highlight curp :hint hintp)
|
||||
(push (cons (list x y-hand (if (= i (1- n)) w step) h) (cons 'hand i)) regions))
|
||||
(setq x (+ x step) i (1+ i))))
|
||||
(txt (or (card-games-get game :message) "") pad (- height 8) 12))
|
||||
(propertize "*" 'display (card-games-svg-image svg (card-games-scale)) 'card-games-regions (nreverse regions))))
|
||||
|
||||
(cl-defmethod card-games-render ((game card-games-eights-game))
|
||||
"Return a depiction of GAME: an SVG board if graphical, else text."
|
||||
(if (and card-games-eights-svg-cards (display-graphic-p))
|
||||
(card-games-eights--board-svg game)
|
||||
(card-games-eights--render-text game)))
|
||||
|
||||
(defun card-games-eights--render-text (game)
|
||||
"Return a plain-text depiction of GAME."
|
||||
(let* ((out (list)) (top (card-games-eights--top game))
|
||||
(hand (card-games-eights--hand game 0)) (cursor (card-games-get game :cursor)))
|
||||
(push (format " Crazy Eights\n\n") out)
|
||||
(dotimes (s (card-games-get game :nplayers))
|
||||
(unless (= s 0)
|
||||
(push (format " Player %d: %d cards (score %d)\n"
|
||||
s (length (card-games-eights--hand game s))
|
||||
(aref (card-games-get game :scores) s)) out)))
|
||||
(push (format "\n Discard top: %s Suit in play: %s Stock: %d\n\n"
|
||||
(let ((cs (card-games-eights-card-string top)))
|
||||
(if (card-games-eights-red-p top) (propertize cs 'face 'card-games-red-suit) cs))
|
||||
(card-games-suit-glyph (card-games-get game :suit))
|
||||
(length (card-games-get game :stock)))
|
||||
out)
|
||||
(push (format " Your hand (score %d):\n " (aref (card-games-get game :scores) 0)) out)
|
||||
(if (and card-games-eights-svg-cards (display-graphic-p))
|
||||
(let ((hi '()) (i 0))
|
||||
(dolist (c hand) (when (card-games-eights--legal-p game c) (push i hi)) (setq i (1+ i)))
|
||||
(push (card-games-svg-hand-image (mapcar #'card-games-eights--spec hand)
|
||||
:cursor cursor :hints hi
|
||||
:overlap (if (> (length hand) 11)
|
||||
(max 0 (- card-games-svg-card-width 24)) 0)
|
||||
:region-tag 'hand)
|
||||
out))
|
||||
(let ((i 0))
|
||||
(dolist (c hand)
|
||||
(let ((cs (card-games-eights-card-string c)) (faces nil))
|
||||
(when (card-games-eights-red-p c) (push 'card-games-red-suit faces))
|
||||
(when (card-games-eights--legal-p game c) (push 'card-games-hint faces))
|
||||
(when (= i cursor) (push 'card-games-cursor faces))
|
||||
(push (propertize (format "%4s" cs) 'face (or faces 'default)) out))
|
||||
(setq i (1+ i)))))
|
||||
(push (format "\n\n %s\n" (card-games-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod card-games-render-apply ((g card-games-eights-game) action)
|
||||
"Apply a click ACTION on the hand to GAME G (a click also plays)."
|
||||
(pcase action
|
||||
(`(hand . ,i)
|
||||
(card-games-put g :cursor i)
|
||||
(when (and (eq (card-games-get g :phase) 'play) (= (card-games-get g :turn) 0))
|
||||
(card-games-eights-act)))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun card-games-eights--redisplay ()
|
||||
"Redraw the Crazy Eights buffer."
|
||||
(let ((game card-games-eights--game) (inhibit-read-only t))
|
||||
(setq card-games-current-game game card-games-redisplay-function #'card-games-eights--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))
|
||||
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
|
||||
|
||||
(defun card-games-eights--cursor-card (game)
|
||||
"Return the card under GAME's cursor in the human hand."
|
||||
(nth (card-games-get game :cursor) (card-games-eights--hand game 0)))
|
||||
|
||||
(defun card-games-eights-left ()
|
||||
"Move the hand cursor left."
|
||||
(interactive)
|
||||
(let* ((game card-games-eights--game) (n (length (card-games-eights--hand game 0))))
|
||||
(when (> n 0) (card-games-put game :cursor (mod (1- (card-games-get game :cursor)) n)))
|
||||
(card-games-eights--redisplay)))
|
||||
|
||||
(defun card-games-eights-right ()
|
||||
"Move the hand cursor right."
|
||||
(interactive)
|
||||
(let* ((game card-games-eights--game) (n (length (card-games-eights--hand game 0))))
|
||||
(when (> n 0) (card-games-put game :cursor (mod (1+ (card-games-get game :cursor)) n)))
|
||||
(card-games-eights--redisplay)))
|
||||
|
||||
(defun card-games-eights--choose-suit (game)
|
||||
"Return a suit the human names for a wild eight in GAME."
|
||||
(if noninteractive (card-games-eights--best-suit game 0)
|
||||
(let* ((names (mapcar (lambda (i) (cons (aref card-games-suit-names i) i)) '(0 1 2 3)))
|
||||
(pick (completing-read "Name the suit: " (mapcar #'car names) nil t)))
|
||||
(cdr (assoc pick names)))))
|
||||
|
||||
(defun card-games-eights-act ()
|
||||
"Play the selected card if it is legal."
|
||||
(interactive)
|
||||
(let* ((game card-games-eights--game) (card (card-games-eights--cursor-card game)))
|
||||
(cond
|
||||
((not (eq (card-games-get game :phase) 'play)) (card-games-put game :message "Press n for a new deal."))
|
||||
((/= (card-games-get game :turn) 0) (card-games-put game :message "Not your turn."))
|
||||
((null card) (card-games-put game :message "No card selected."))
|
||||
((not (card-games-eights--legal-p game card))
|
||||
(card-games-put game :message "That card does not match — draw with d if stuck."))
|
||||
(t (let ((suit (and (= (cdr card) card-games-eights--wild) (card-games-eights--choose-suit game))))
|
||||
(card-games-eights--play game 0 card suit)
|
||||
(card-games-put game :cursor 0)
|
||||
(card-games-eights--run game))))
|
||||
(card-games-eights--redisplay)))
|
||||
|
||||
(defun card-games-eights-draw ()
|
||||
"Draw a card; if the stock cannot help, pass your turn."
|
||||
(interactive)
|
||||
(let ((game card-games-eights--game))
|
||||
(when (eq (card-games-get game :phase) 'play)
|
||||
(if (= (card-games-get game :turn) 0)
|
||||
(let ((card (card-games-eights--draw-card game 0)))
|
||||
(if card
|
||||
(card-games-put game :message (format "You drew %s." (card-games-eights-card-string card)))
|
||||
(card-games-put game :passes (1+ (card-games-get game :passes)))
|
||||
(card-games-put game :turn (mod 1 (card-games-get game :nplayers)))
|
||||
(card-games-put game :message "Nothing to draw — you pass.")
|
||||
(card-games-eights--run game)))
|
||||
(card-games-put game :message "Not your turn.")))
|
||||
(card-games-eights--redisplay)))
|
||||
|
||||
(defun card-games-eights-pass ()
|
||||
"Pass your turn (only sensible after drawing with an empty stock)."
|
||||
(interactive)
|
||||
(let ((game card-games-eights--game))
|
||||
(when (and (eq (card-games-get game :phase) 'play) (= (card-games-get game :turn) 0))
|
||||
(card-games-put game :passes (1+ (card-games-get game :passes)))
|
||||
(card-games-put game :turn (mod 1 (card-games-get game :nplayers)))
|
||||
(card-games-eights--run game))
|
||||
(card-games-eights--redisplay)))
|
||||
|
||||
(defun card-games-eights-new ()
|
||||
"Deal a fresh hand."
|
||||
(interactive)
|
||||
(card-games-eights--deal card-games-eights--game)
|
||||
(card-games-eights--run card-games-eights--game)
|
||||
(card-games-eights--redisplay))
|
||||
|
||||
(defun card-games-eights-redraw () "Redraw." (interactive) (card-games-eights--redisplay))
|
||||
(defun card-games-eights-help ()
|
||||
"Describe the controls."
|
||||
(interactive)
|
||||
(message "Arrows or click: choose/play RET: play d: draw x: pass +/-: size n: new g: redraw"))
|
||||
|
||||
(defvar card-games-eights-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'card-games-card-click)
|
||||
(define-key map "+" #'card-games-card-zoom-in)
|
||||
(define-key map "=" #'card-games-card-zoom-in)
|
||||
(define-key map "-" #'card-games-card-zoom-out)
|
||||
(define-key map "0" #'card-games-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'card-games-eights-left)
|
||||
(define-key map (kbd "<right>") #'card-games-eights-right)
|
||||
(define-key map (kbd "RET") #'card-games-eights-act)
|
||||
(define-key map (kbd "SPC") #'card-games-eights-act)
|
||||
(define-key map "d" #'card-games-eights-draw)
|
||||
(define-key map "x" #'card-games-eights-pass)
|
||||
(define-key map "n" #'card-games-eights-new)
|
||||
(define-key map "g" #'card-games-eights-redraw)
|
||||
(define-key map "?" #'card-games-eights-help)
|
||||
(define-key map "q" #'card-games-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `card-games-eights-mode'.")
|
||||
|
||||
(define-derived-mode card-games-eights-mode special-mode "Crazy8"
|
||||
"Major mode for Crazy Eights."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type card-games-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-eights ()
|
||||
"Play Crazy Eights against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Crazy Eights*")))
|
||||
(with-current-buffer buf
|
||||
(card-games-eights-mode)
|
||||
(setq card-games-eights--game (card-games-eights-game))
|
||||
(card-games-eights--deal card-games-eights--game)
|
||||
(card-games-eights--run card-games-eights--game)
|
||||
(card-games-eights--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
(provide 'card-games-eights)
|
||||
;;; card-games-eights.el ends here
|
||||
868
card-games-gaps.el
Normal file
868
card-games-gaps.el
Normal file
|
|
@ -0,0 +1,868 @@
|
|||
;;; card-games-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.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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 `card-games-gaps-game' and overriding two methods
|
||||
;; (`card-games-gaps--head' and `card-games-gaps--step'):
|
||||
;;
|
||||
;; `card-games-montana' Gaps / Montana: Two at the head, rows build
|
||||
;; UP 2 3 4 ... K; nothing follows a King.
|
||||
;; `card-games-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-games' or
|
||||
;; the commands above.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-svg)
|
||||
(require 'card-games-render)
|
||||
|
||||
|
||||
;;;; Cards
|
||||
|
||||
(defconst card-games-gaps-ranks
|
||||
["2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K"]
|
||||
"Rank labels indexed 0..11 (Two through King).")
|
||||
|
||||
(defconst card-games-gaps-rank-names
|
||||
["Two" "Three" "Four" "Five" "Six" "Seven" "Eight" "Nine"
|
||||
"Ten" "Jack" "Queen" "King"]
|
||||
"Full rank names indexed to match `card-games-gaps-ranks'.")
|
||||
|
||||
;; A card is a cons cell (SUIT . RANK); nil denotes a gap.
|
||||
|
||||
(defsubst card-games-gaps-red-p (card)
|
||||
"Return non-nil when CARD is a red suit (diamonds or hearts)."
|
||||
(and card (card-games-red-suit-p (car card))))
|
||||
|
||||
(defun card-games-gaps-card-string (card)
|
||||
"Return a short string for CARD, or a dot for a gap (nil)."
|
||||
(if (null card)
|
||||
"·"
|
||||
(concat (aref card-games-gaps-ranks (cdr card))
|
||||
(card-games-suit-glyph (car card)))))
|
||||
|
||||
|
||||
;;;; Games — an abstract base and two subclasses
|
||||
|
||||
(defclass card-games-gaps-game (card-games-game)
|
||||
((name :initform "Gaps"))
|
||||
"Abstract base for gaps-style row solitaires.
|
||||
Subclasses set the head rank and build direction by overriding
|
||||
`card-games-gaps--head' and `card-games-gaps--step'."
|
||||
:abstract t)
|
||||
|
||||
(cl-defgeneric card-games-gaps--head (game)
|
||||
"Return the rank index that anchors the head (left) of each row in GAME.")
|
||||
(cl-defgeneric card-games-gaps--step (game)
|
||||
"Return GAME's per-column rank increment: +1 ascending, -1 descending.")
|
||||
(cl-defgeneric card-games-gaps--vname (game)
|
||||
"Return the human-readable variant name for GAME.")
|
||||
|
||||
(defclass card-games-montana-game (card-games-gaps-game)
|
||||
((name :initform "Montana"))
|
||||
"Gaps / Montana: a Two anchors the head; rows build up 2..K.")
|
||||
(cl-defmethod card-games-gaps--head ((_ card-games-montana-game)) "Montana anchors its head on the Two (rank 0)." 0)
|
||||
(cl-defmethod card-games-gaps--step ((_ card-games-montana-game)) "Montana builds up, +1 per column." 1)
|
||||
(cl-defmethod card-games-gaps--vname ((_ card-games-montana-game)) "Return Montana's display name." "Gaps (Montana)")
|
||||
|
||||
(defclass card-games-acre-game (card-games-gaps-game)
|
||||
((name :initform "Hell's Half-Acre"))
|
||||
"Hell's Half-Acre: a King anchors the head; rows build down K..2.")
|
||||
(cl-defmethod card-games-gaps--head ((_ card-games-acre-game)) "Hell's Half-Acre anchors its head on the King (rank 11)." 11)
|
||||
(cl-defmethod card-games-gaps--step ((_ card-games-acre-game)) "Hell's Half-Acre builds down, -1 per column." -1)
|
||||
(cl-defmethod card-games-gaps--vname ((_ card-games-acre-game)) "Return Hell's Half-Acre's display name." "Hell's Half-Acre")
|
||||
|
||||
(defalias 'card-games-gaps--shuffle 'card-games-shuffle)
|
||||
|
||||
(defun card-games-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 card-games-gaps--deal ((game card-games-gaps-game))
|
||||
"Deal a fresh layout into GAME."
|
||||
(random t)
|
||||
(let ((cells (card-games-gaps--shuffle (append (card-games-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)))
|
||||
(card-games-put game :board board)
|
||||
(card-games-put game :moves 0)
|
||||
(card-games-put game :redeals 2)
|
||||
(card-games-put game :cursor (cons 0 0))
|
||||
(card-games-put game :history nil)
|
||||
(card-games-put game :message
|
||||
(format
|
||||
"Each row one suit, %s. Move to a green + gap and press RET (or click it). ? = help."
|
||||
(if (> (card-games-gaps--step game) 0) "2 up to K" "K down to 2")))
|
||||
game))
|
||||
|
||||
(defun card-games-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 card-games-gaps--needed ((game card-games-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 (card-games-gaps--cell board r (1- c))))
|
||||
(if (null left)
|
||||
nil
|
||||
(let ((nr (+ (cdr left) (card-games-gaps--step game))))
|
||||
(and (>= nr 0) (<= nr 11) (cons (car left) nr)))))))
|
||||
|
||||
(defun card-games-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 (card-games-gaps--cell board r c) card)
|
||||
(throw 'hit (cons r c)))))
|
||||
nil))
|
||||
|
||||
(defun card-games-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 card-games-gaps--save-undo ((game card-games-gaps-game))
|
||||
"Push the current state of GAME onto its undo history."
|
||||
(card-games-put game :history
|
||||
(cons (list (card-games-gaps--copy-board (card-games-get game :board))
|
||||
(card-games-get game :moves)
|
||||
(card-games-get game :redeals))
|
||||
(card-games-get game :history))))
|
||||
|
||||
(cl-defmethod card-games-gaps--do-move ((game card-games-gaps-game) r c card)
|
||||
"Move CARD into the gap at R, C of GAME. Return non-nil on success."
|
||||
(let* ((board (card-games-get game :board))
|
||||
(loc (card-games-gaps--find board card)))
|
||||
(if (not loc)
|
||||
(progn (card-games-put game :message
|
||||
(format "The %s is not on the board?!"
|
||||
(card-games-gaps-card-string card)))
|
||||
nil)
|
||||
(card-games-gaps--save-undo game)
|
||||
(setf (aref (aref board (car loc)) (cdr loc)) nil)
|
||||
(setf (aref (aref board r) c) card)
|
||||
(card-games-put game :moves (1+ (card-games-get game :moves)))
|
||||
(card-games-put game :message (format "Moved %s." (card-games-gaps-card-string card)))
|
||||
t)))
|
||||
|
||||
(cl-defmethod card-games-gaps--fill ((game card-games-gaps-game) r c)
|
||||
"Try to fill the gap at R, C of GAME. Return non-nil on success."
|
||||
(let* ((board (card-games-get game :board))
|
||||
(cell (card-games-gaps--cell board r c)))
|
||||
(cond
|
||||
(cell
|
||||
(card-games-put game :message "That cell is not a gap.") nil)
|
||||
(t
|
||||
(let ((needed (card-games-gaps--needed game board r c)))
|
||||
(cond
|
||||
((null needed)
|
||||
(card-games-put game :message "Nothing can fill that gap.") nil)
|
||||
((eq needed 'head)
|
||||
(let ((suit (card-games-gaps--read-head game)))
|
||||
(and suit (card-games-gaps--do-move game r c (cons suit (card-games-gaps--head game))))))
|
||||
(t
|
||||
(card-games-gaps--do-move game r c needed))))))))
|
||||
|
||||
(cl-defmethod card-games-gaps--read-head ((game card-games-gaps-game))
|
||||
"Prompt for the suit of the head card of GAME. Return suit 0..3 or nil."
|
||||
(let* ((name (aref card-games-gaps-rank-names (card-games-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 card-games-won-p ((game card-games-gaps-game))
|
||||
"Return non-nil when every row of GAME is a full suited run with a trailing gap."
|
||||
(let ((board (card-games-get game :board))
|
||||
(head (card-games-gaps--head game))
|
||||
(step (card-games-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 card-games-gaps--stuck-p ((game card-games-gaps-game))
|
||||
"Return non-nil when no gap of GAME can currently be filled."
|
||||
(null (card-games-gaps--hints game)))
|
||||
|
||||
(cl-defmethod card-games-gaps--hints ((game card-games-gaps-game))
|
||||
"Return the list of (ROW . COL) gaps of GAME that can be filled now."
|
||||
(let ((board (card-games-get game :board))
|
||||
(hints nil))
|
||||
(dotimes (r 4)
|
||||
(dotimes (c 13)
|
||||
(when (and (null (card-games-gaps--cell board r c))
|
||||
(card-games-gaps--needed game board r c))
|
||||
(push (cons r c) hints))))
|
||||
hints))
|
||||
|
||||
(cl-defmethod card-games-gaps--prefix-len ((game card-games-gaps-game) board r)
|
||||
"Return the length of GAME's correct run at the head of row R of BOARD."
|
||||
(let ((row (aref board r))
|
||||
(head (card-games-gaps--head game))
|
||||
(step (card-games-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 card-games-gaps--do-redeal ((game card-games-gaps-game))
|
||||
"Gather misplaced cards of GAME, reshuffle, and lay them back."
|
||||
(let* ((board (card-games-get game :board))
|
||||
(lens (make-vector 4 0))
|
||||
(kept nil))
|
||||
(dotimes (r 4)
|
||||
(let ((len (card-games-gaps--prefix-len game board r)))
|
||||
(aset lens r len)
|
||||
(dotimes (i len) (push (card-games-gaps--cell board r i) kept))))
|
||||
(let* ((remaining
|
||||
(card-games-gaps--shuffle
|
||||
(cl-remove-if (lambda (card) (cl-member card kept :test #'equal))
|
||||
(card-games-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 (card-games-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)))
|
||||
(card-games-put game :board new))))
|
||||
|
||||
|
||||
;;;; Rendering
|
||||
|
||||
(defun card-games-gaps--header (game)
|
||||
"Return the header text for GAME."
|
||||
(format " ♠♣ %s ♦♥\n Moves: %-4d Redeals left: %d\n\n"
|
||||
(card-games-gaps--vname game) (card-games-get game :moves) (card-games-get game :redeals)))
|
||||
|
||||
(defun card-games-gaps--footer (game)
|
||||
"Return the footer text (just the current message) for GAME.
|
||||
The control line is inserted separately by `card-games-gaps--insert-controls',
|
||||
where each key hint is itself the clickable button."
|
||||
(format "\n %s\n" (card-games-get game :message)))
|
||||
|
||||
(cl-defmethod card-games-render ((game card-games-gaps-game))
|
||||
"Return a propertized string depicting GAME (console rendering)."
|
||||
(let* ((board (card-games-get game :board))
|
||||
(cursor (card-games-get game :cursor))
|
||||
(cr (car cursor))
|
||||
(cc (cdr cursor))
|
||||
(hints (card-games-gaps--hints game))
|
||||
(out (list)))
|
||||
(push (card-games-gaps--header game) out)
|
||||
(dotimes (r 4)
|
||||
(dotimes (c 13)
|
||||
(let* ((cell (card-games-gaps--cell board r c))
|
||||
(gapp (null cell))
|
||||
(hintp (and gapp (member (cons r c) hints)))
|
||||
(str (cond ((not gapp) (card-games-gaps-card-string cell))
|
||||
(hintp "+")
|
||||
(t "·")))
|
||||
(faces nil))
|
||||
(when (card-games-gaps-red-p cell) (push 'card-games-red-suit faces))
|
||||
(when hintp (push 'card-games-hint faces))
|
||||
(when (and gapp (not hintp)) (push 'card-games-gap faces))
|
||||
(when (and (= r cr) (= c cc)) (push 'card-games-cursor faces))
|
||||
(let ((content (propertize (format "%3s" str)
|
||||
'face (or faces 'default))))
|
||||
(push (propertize (concat " " content)
|
||||
'card-games-cell (cons r c)
|
||||
'mouse-face 'highlight)
|
||||
out))))
|
||||
(push "\n" out))
|
||||
(push (card-games-gaps--footer game) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(defun card-games-gaps--board-specs (board)
|
||||
"Return BOARD as rows of SVG card specs for `card-games-svg-grid-svg'."
|
||||
(let ((rows nil))
|
||||
(dotimes (r 4)
|
||||
(let ((row nil))
|
||||
(dotimes (c 13)
|
||||
(let ((cell (card-games-gaps--cell board r c)))
|
||||
(push (and cell (cons (aref card-games-gaps-ranks (cdr cell)) (car cell)))
|
||||
row)))
|
||||
(push (nreverse row) rows)))
|
||||
(nreverse rows)))
|
||||
|
||||
(defconst card-games-gaps--svg-card-w 46 "Base card width used by the SVG board.")
|
||||
(defconst card-games-gaps--svg-card-h 64 "Base card height used by the SVG board.")
|
||||
(defconst card-games-gaps--svg-gap 6 "Pixel gap between cards on the SVG board.")
|
||||
(defconst card-games-gaps--svg-pad 10 "Margin around the SVG board.")
|
||||
|
||||
(defcustom card-games-gaps-svg-ui nil
|
||||
"Whether to render the gaps board as one full-buffer SVG.
|
||||
When non-nil (and on a graphical display), 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 'card-games-svg)
|
||||
|
||||
(defcustom card-games-gaps-svg-fill t
|
||||
"Whether the full-SVG gaps UI fills the window and re-fits on size changes.
|
||||
Only used when `card-games-gaps-svg-ui' is enabled."
|
||||
:type 'boolean :group 'card-games-svg)
|
||||
|
||||
(defun card-games-gaps--insert-graphical (game)
|
||||
"Insert the GUI (SVG) depiction of GAME into the current buffer."
|
||||
(insert (card-games-gaps--header game))
|
||||
(let ((card-games-svg-card-width card-games-gaps--svg-card-w)
|
||||
(card-games-svg-card-height card-games-gaps--svg-card-h)
|
||||
(card-games-svg-card-gap card-games-gaps--svg-gap))
|
||||
(insert-image
|
||||
(card-games-svg-image
|
||||
(card-games-svg-grid-svg (card-games-gaps--board-specs (card-games-get game :board))
|
||||
:cursor (card-games-get game :cursor)
|
||||
:hints (card-games-gaps--hints game)
|
||||
:pad card-games-gaps--svg-pad)
|
||||
(card-games-scale))))
|
||||
(insert "\n")
|
||||
(insert (card-games-gaps--footer game)))
|
||||
|
||||
|
||||
;;;; Interaction
|
||||
|
||||
(defvar-local card-games-gaps--game nil
|
||||
"The `card-games-gaps-game' object played in the current buffer.")
|
||||
|
||||
(defun card-games-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 'card-games-cell) target)
|
||||
(setq found pos))
|
||||
(setq pos (next-single-property-change pos 'card-games-cell)))
|
||||
(when found (goto-char (1+ found)))))
|
||||
|
||||
(defun card-games-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 card-games-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))
|
||||
(card-games-gaps--key-button "RET" "fill" #'card-games-gaps-fill "Fill the gap under the cursor")
|
||||
(card-games-gaps--key-button "r" "redeal" #'card-games-gaps-redeal "Reshuffle the misplaced cards")
|
||||
(card-games-gaps--key-button "u" "undo" #'card-games-gaps-undo "Undo the last move")
|
||||
(card-games-gaps--key-button "n" "new" #'card-games-gaps-new "Deal a new game")
|
||||
(card-games-gaps--key-button "q" "menu" #'card-games-quit-to-menu "Back to the game list")
|
||||
(card-games-gaps--key-button "?" "help" #'card-games-gaps-help "Show the rules and keys")
|
||||
(insert "\n"))
|
||||
|
||||
(cl-defmethod card-games-renderer-draw ((_renderer card-games-text-renderer) (game card-games-gaps-game))
|
||||
"Draw the Gaps GAME as UNICODE text with the control line."
|
||||
(insert (card-games-render game))
|
||||
(card-games-gaps--insert-controls))
|
||||
|
||||
(cl-defmethod card-games-renderer-draw ((_renderer card-games-svg-renderer) (game card-games-gaps-game))
|
||||
"Draw the Gaps GAME as an inline SVG board with the control line."
|
||||
(card-games-gaps--insert-graphical game)
|
||||
(card-games-gaps--insert-controls))
|
||||
|
||||
(cl-defmethod card-games-renderer-draw ((_renderer card-games-svg-fill-renderer) (game card-games-gaps-game))
|
||||
"Draw the Gaps GAME as a full-window SVG table."
|
||||
(card-games-gaps--insert-svg-ui game))
|
||||
|
||||
(defun card-games-gaps--treatment ()
|
||||
"Return the display treatment symbol for the current Gaps buffer.
|
||||
Honours `card-games-gaps-svg-ui' and whether the display is graphical."
|
||||
(cond ((and card-games-gaps-svg-ui (display-graphic-p)) 'svg-fill)
|
||||
((display-graphic-p) 'svg)
|
||||
(t 'text)))
|
||||
|
||||
(defun card-games-gaps--redisplay ()
|
||||
"Redraw the current Gaps buffer through its renderer.
|
||||
The treatment is chosen by `card-games-gaps--treatment' and dispatched with
|
||||
`card-games-renderer-draw'."
|
||||
(let* ((game card-games-gaps--game)
|
||||
(inhibit-read-only t)
|
||||
(renderer (card-games-render-set-treatment game (card-games-gaps--treatment))))
|
||||
(setq-local mode-line-process (card-games-gaps--mode-line game))
|
||||
(erase-buffer)
|
||||
(card-games-renderer-draw renderer game)
|
||||
(if (display-graphic-p)
|
||||
(goto-char (point-min))
|
||||
(let ((cur (card-games-get game :cursor)))
|
||||
(card-games-gaps--goto-cell (car cur) (cdr cur))))))
|
||||
|
||||
(defun card-games-gaps--move (dr dc)
|
||||
"Move the cursor by DR rows and DC columns, then redisplay."
|
||||
(let* ((game card-games-gaps--game)
|
||||
(cur (card-games-get game :cursor))
|
||||
(r (min 3 (max 0 (+ (car cur) dr))))
|
||||
(c (min 12 (max 0 (+ (cdr cur) dc)))))
|
||||
(card-games-put game :cursor (cons r c))
|
||||
(card-games-gaps--redisplay)))
|
||||
|
||||
(defun card-games-gaps-left () "Move cursor left." (interactive) (card-games-gaps--move 0 -1))
|
||||
(defun card-games-gaps-right () "Move cursor right." (interactive) (card-games-gaps--move 0 1))
|
||||
(defun card-games-gaps-up () "Move cursor up." (interactive) (card-games-gaps--move -1 0))
|
||||
(defun card-games-gaps-down () "Move cursor down." (interactive) (card-games-gaps--move 1 0))
|
||||
|
||||
(defun card-games-gaps--after-move ()
|
||||
"Check for a win or a stuck position and report it."
|
||||
(let ((game card-games-gaps--game))
|
||||
(cond
|
||||
((card-games-won-p game)
|
||||
(card-games-put game :message
|
||||
(format "\U0001F389 Solved in %d moves! Press n for a new game."
|
||||
(card-games-get game :moves))))
|
||||
((card-games-gaps--stuck-p game)
|
||||
(card-games-put game :message
|
||||
(if (> (card-games-get game :redeals) 0)
|
||||
(format "Stuck! Press r to redeal (%d left)."
|
||||
(card-games-get game :redeals))
|
||||
"Stuck, and no redeals left. Press n for a new game."))))
|
||||
(card-games-gaps--redisplay)
|
||||
(message "%s" (card-games-get game :message))))
|
||||
|
||||
(defun card-games-gaps-fill ()
|
||||
"Fill the gap under the cursor."
|
||||
(interactive)
|
||||
(let* ((game card-games-gaps--game)
|
||||
(cur (card-games-get game :cursor)))
|
||||
(if (card-games-gaps--fill game (car cur) (cdr cur))
|
||||
(card-games-gaps--after-move)
|
||||
(card-games-gaps--redisplay))))
|
||||
|
||||
(defun card-games-gaps-redeal ()
|
||||
"Reshuffle and redeal the misplaced cards, if redeals remain."
|
||||
(interactive)
|
||||
(let ((game card-games-gaps--game))
|
||||
(if (<= (card-games-get game :redeals) 0)
|
||||
(progn (card-games-put game :message "No redeals left.")
|
||||
(card-games-gaps--redisplay))
|
||||
(card-games-gaps--save-undo game)
|
||||
(card-games-gaps--do-redeal game)
|
||||
(card-games-put game :redeals (1- (card-games-get game :redeals)))
|
||||
(card-games-put game :message
|
||||
(format "Redealt. %d redeals left." (card-games-get game :redeals)))
|
||||
(card-games-gaps--after-move))))
|
||||
|
||||
(defun card-games-gaps-undo ()
|
||||
"Undo the last move or redeal."
|
||||
(interactive)
|
||||
(let* ((game card-games-gaps--game)
|
||||
(hist (card-games-get game :history)))
|
||||
(if (null hist)
|
||||
(progn (card-games-put game :message "Nothing to undo.")
|
||||
(card-games-gaps--redisplay))
|
||||
(let ((snap (car hist)))
|
||||
(card-games-put game :board (nth 0 snap))
|
||||
(card-games-put game :moves (nth 1 snap))
|
||||
(card-games-put game :redeals (nth 2 snap))
|
||||
(card-games-put game :history (cdr hist))
|
||||
(card-games-put game :message "Undone.")
|
||||
(card-games-gaps--redisplay)))))
|
||||
|
||||
(defun card-games-gaps-new ()
|
||||
"Start a new game in the current buffer."
|
||||
(interactive)
|
||||
(card-games-gaps--deal card-games-gaps--game)
|
||||
(card-games-gaps--redisplay))
|
||||
|
||||
(defun card-games-gaps--xy->cell (px py)
|
||||
"Map pixel coordinates PX, PY on the SVG board to a (ROW . COL), or nil."
|
||||
(let* ((w card-games-gaps--svg-card-w) (h card-games-gaps--svg-card-h)
|
||||
(g card-games-gaps--svg-gap) (pad card-games-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 card-games-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 card-games-gaps-svg-ui (display-graphic-p) (posn-image start))
|
||||
(card-games-gaps--svg-ui-click start)
|
||||
(let ((cell (if (and (display-graphic-p) (posn-image start))
|
||||
(let ((xy (posn-object-x-y start)) (s (card-games-scale)))
|
||||
(and xy (card-games-gaps--xy->cell (round (/ (car xy) s))
|
||||
(round (/ (cdr xy) s)))))
|
||||
(let ((pos (posn-point start)))
|
||||
(and pos (get-text-property pos 'card-games-cell))))))
|
||||
(when cell
|
||||
(card-games-put card-games-gaps--game :cursor cell)
|
||||
(card-games-gaps-fill))))))
|
||||
|
||||
(defun card-games-gaps-help ()
|
||||
"Show a one-line reminder of the controls."
|
||||
(interactive)
|
||||
(let ((game card-games-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 (card-games-gaps--vname game) "Gaps")
|
||||
(if game (aref card-games-gaps-rank-names (card-games-gaps--head game)) "card")))))
|
||||
|
||||
(defun card-games-gaps--mode-line (game)
|
||||
"Return the mode-line status string for GAME."
|
||||
(cond ((card-games-won-p game) " [Solved!]")
|
||||
((card-games-gaps--stuck-p game)
|
||||
(if (> (card-games-get game :redeals) 0) " [Stuck — r to redeal]" " [Stuck]"))
|
||||
(t (format " [moves %d · redeals %d]"
|
||||
(card-games-get game :moves) (card-games-get game :redeals)))))
|
||||
|
||||
(defun card-games-gaps-zoom-in ()
|
||||
"Enlarge the cards." (interactive) (text-scale-increase 1) (card-games-gaps--redisplay))
|
||||
(defun card-games-gaps-zoom-out ()
|
||||
"Shrink the cards." (interactive) (text-scale-decrease 1) (card-games-gaps--redisplay))
|
||||
(defun card-games-gaps-zoom-reset ()
|
||||
"Reset the card size." (interactive) (text-scale-set 0) (card-games-gaps--redisplay))
|
||||
|
||||
(defun card-games-gaps-redraw ()
|
||||
"Redraw the board (e.g. after a theme or frame change)."
|
||||
(interactive)
|
||||
(card-games-gaps--redisplay))
|
||||
|
||||
|
||||
;;;; Frameless full-SVG UI (opt-in; see `card-games-gaps-svg-ui')
|
||||
|
||||
(defconst card-games-gaps--ui-w 820 "Default full-SVG gaps canvas width.")
|
||||
(defconst card-games-gaps--ui-h 380 "Default full-SVG gaps canvas height.")
|
||||
|
||||
(defvar-local card-games-gaps--regions nil
|
||||
"Plist of clickable regions for the full-SVG gaps UI.")
|
||||
(defvar-local card-games-gaps--ui-last-size nil
|
||||
"Last window pixel size used to render the full-SVG gaps UI.")
|
||||
|
||||
(defun card-games-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 card-games-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 card-games-svg-font-family)))
|
||||
(when bold (setq a (append a (list :font-weight "bold"))))
|
||||
(apply #'svg-text svg str a)))
|
||||
|
||||
(defun card-games-gaps--ui-label (svg str x y size)
|
||||
"Draw STR as an all-caps, letter-spaced section label on SVG at X, Y, SIZE."
|
||||
(svg-text svg (upcase str) :x (round x) :y (round y) :font-size (round size)
|
||||
:fill "#8fc79b" :text-anchor "start" :font-family card-games-svg-font-family
|
||||
:font-weight "bold" :letter-spacing "2"))
|
||||
|
||||
(defun card-games-gaps--ui-divider (svg x1 x2 y)
|
||||
"Draw a faint horizontal divider on SVG from X1 to X2 at height Y."
|
||||
(svg-line svg x1 y x2 y :stroke "#1b6b35" :stroke-width 1))
|
||||
|
||||
(defun card-games-gaps--draw-panel (svg game h lpw fs)
|
||||
"Draw GAME's left status/controls panel on SVG (height H, 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))
|
||||
(card-games-svg--text svg (card-games-gaps--vname game) cxp y (funcall F 15) "#f1c40f" t)
|
||||
(setq y (+ y (funcall F 14))) (card-games-gaps--ui-divider svg dl dr y)
|
||||
;; stats
|
||||
(setq y (+ y (funcall F 22)))
|
||||
(card-games-gaps--ui-text svg "Moves" px0 y (funcall F 13) "#eaffea")
|
||||
(svg-text svg (number-to-string (card-games-get game :moves)) :x pxr :y y
|
||||
:font-size (funcall F 14) :fill "#eaffea" :text-anchor "end"
|
||||
:font-family card-games-svg-font-family :font-weight "bold")
|
||||
(setq y (+ y (funcall F 20)))
|
||||
(card-games-gaps--ui-text svg "Redeals left" px0 y (funcall F 13) "#eaffea")
|
||||
(svg-text svg (number-to-string (card-games-get game :redeals)) :x pxr :y y
|
||||
:font-size (funcall F 14) :fill "#eaffea" :text-anchor "end"
|
||||
:font-family card-games-svg-font-family :font-weight "bold")
|
||||
(setq y (+ y (funcall F 16))) (card-games-gaps--ui-divider svg dl dr y)
|
||||
;; rules
|
||||
(setq y (+ y (funcall F 20)))
|
||||
(card-games-gaps--ui-label svg "Rules" px0 (- y (funcall F 6)) (funcall F 10))
|
||||
(setq y (+ y (funcall F 16)))
|
||||
(card-games-gaps--ui-text svg (format "Head: %s"
|
||||
(aref card-games-gaps-rank-names (card-games-gaps--head game)))
|
||||
px0 y (funcall F 12) "#cfeccf")
|
||||
(setq y (+ y (funcall F 16)))
|
||||
(card-games-gaps--ui-text svg (if (> (card-games-gaps--step game) 0) "Build up 2..K"
|
||||
"Build down K..2")
|
||||
px0 y (funcall F 12) "#cfeccf")
|
||||
(setq y (+ y (funcall F 16)) )
|
||||
(card-games-gaps--ui-text svg "One suit per row" px0 y (funcall F 12) "#9fd0a8")
|
||||
(setq y (+ y (funcall F 14))) (card-games-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 (> (card-games-get game :redeals) 0))
|
||||
(canundo (and (card-games-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)
|
||||
(card-games-gaps--ui-text svg kc (+ px0 (funcall F 10)) (+ y (round (* bh 0.68)))
|
||||
(funcall F 13) (if on "#f1c40f" "#5f7f68") t)
|
||||
(card-games-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 (card-games-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)))
|
||||
(card-games-gaps--ui-text svg m px0 (- h (funcall F 14)) (funcall F 11) "#9fd0a8"))))
|
||||
regions))
|
||||
|
||||
(defun card-games-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 card-games-gaps--ui-w)) (H (or h card-games-gaps--ui-h))
|
||||
(svg (svg-create W H)) (regions nil)
|
||||
(fs (max 1.0 (min 2.2 (/ (+ (/ (float W) card-games-gaps--ui-w)
|
||||
(/ (float H) card-games-gaps--ui-h)) 2.0))))
|
||||
(pscale (max 1.0 (min 1.7 (/ (float W) card-games-gaps--ui-w))))
|
||||
(lpw (round (* 190 pscale)))
|
||||
(bx (+ lpw 14)) (by 10)
|
||||
(aw (- W bx 14)) (ah (- H by 10))
|
||||
(board (card-games-get game :board))
|
||||
(cur (card-games-get game :cursor)) (cr (car cur)) (cc (cdr cur))
|
||||
(hints (card-games-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 "card-games-gfelt" 'radial '((0 . "#1a7a38") (100 . "#0c4720")))
|
||||
(svg-rectangle svg 0 0 W H :rx 14 :gradient "card-games-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 ((card-games-svg-card-width cw) (card-games-svg-card-height ch))
|
||||
(dotimes (r 4)
|
||||
(dotimes (c 13)
|
||||
(let* ((cell (card-games-gaps--cell board r c))
|
||||
(spec (and cell (cons (aref card-games-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)))
|
||||
(card-games-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 (card-games-gaps--draw-panel svg game H lpw fs)))
|
||||
(cons svg regions)))
|
||||
|
||||
(defun card-games-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 card-games-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 (card-games-scale))
|
||||
(px (round (/ (car xy) s))) (py (round (/ (cdr xy) s)))
|
||||
(game card-games-gaps--game) (rg card-games-gaps--regions))
|
||||
(cond
|
||||
((card-games-gaps--in-rect px py (plist-get rg :redeal)) (card-games-gaps-redeal))
|
||||
((card-games-gaps--in-rect px py (plist-get rg :undo)) (card-games-gaps-undo))
|
||||
((card-games-gaps--in-rect px py (plist-get rg :new)) (card-games-gaps-new))
|
||||
((card-games-gaps--in-rect px py (plist-get rg :help)) (card-games-gaps-help))
|
||||
(t (let ((cell (card-games-gaps--ui-cell px py (plist-get rg :board))))
|
||||
(when cell (card-games-put game :cursor cell) (card-games-gaps-fill)))))))
|
||||
|
||||
(defun card-games-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 card-games-gaps-svg-fill win))
|
||||
(w (if fill (max 640 (window-body-width win t)) card-games-gaps--ui-w))
|
||||
(h (if fill (max 320 (- (window-body-height win t) 4)) card-games-gaps--ui-h))
|
||||
(sr (card-games-gaps--ui-svg game w h)))
|
||||
(when fill (setq card-games-gaps--ui-last-size (cons (window-body-width win t)
|
||||
(window-body-height win t))))
|
||||
(setq card-games-gaps--regions (cdr sr))
|
||||
(insert-image (card-games-svg-image (car sr) (if fill 1.0 (card-games-scale))))))
|
||||
|
||||
(defun card-games-gaps--fit (&rest _)
|
||||
"Re-render the full-SVG gaps UI to fit the window after a config change."
|
||||
(when (and card-games-gaps--game card-games-gaps-svg-ui card-games-gaps-svg-fill
|
||||
(eq major-mode 'card-games-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 card-games-gaps--ui-last-size)
|
||||
(setq card-games-gaps--ui-last-size sz)
|
||||
(card-games-gaps--redisplay)))))))
|
||||
|
||||
(defun card-games-gaps-toggle-svg-ui ()
|
||||
"Toggle the full-buffer SVG board for the gaps games."
|
||||
(interactive)
|
||||
(setq card-games-gaps-svg-ui (not card-games-gaps-svg-ui))
|
||||
(setq card-games-gaps--ui-last-size nil)
|
||||
(card-games-gaps--redisplay)
|
||||
(message "Full-SVG board %s" (if card-games-gaps-svg-ui "enabled" "disabled")))
|
||||
|
||||
(defvar card-games-gaps-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map (kbd "<left>") #'card-games-gaps-left)
|
||||
(define-key map (kbd "<right>") #'card-games-gaps-right)
|
||||
(define-key map (kbd "<up>") #'card-games-gaps-up)
|
||||
(define-key map (kbd "<down>") #'card-games-gaps-down)
|
||||
(define-key map (kbd "RET") #'card-games-gaps-fill)
|
||||
(define-key map "g" #'card-games-gaps-redraw)
|
||||
(define-key map "r" #'card-games-gaps-redeal)
|
||||
(define-key map "u" #'card-games-gaps-undo)
|
||||
(define-key map "n" #'card-games-gaps-new)
|
||||
(define-key map "?" #'card-games-gaps-help)
|
||||
(define-key map "+" #'card-games-gaps-zoom-in)
|
||||
(define-key map "=" #'card-games-gaps-zoom-in)
|
||||
(define-key map "-" #'card-games-gaps-zoom-out)
|
||||
(define-key map "0" #'card-games-gaps-zoom-reset)
|
||||
(define-key map "v" #'card-games-gaps-toggle-svg-ui)
|
||||
(define-key map [mouse-1] #'card-games-gaps-mouse)
|
||||
(define-key map "q" #'card-games-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `card-games-gaps-mode' (Emacs style; see `card-games-keys').")
|
||||
|
||||
(defun card-games-gaps--classic-keymap ()
|
||||
"Return a copy of `card-games-gaps-mode-map' with vi-style hjkl and SPC added."
|
||||
(let ((map (copy-keymap card-games-gaps-mode-map)))
|
||||
(define-key map "h" #'card-games-gaps-left)
|
||||
(define-key map "l" #'card-games-gaps-right)
|
||||
(define-key map "k" #'card-games-gaps-up)
|
||||
(define-key map "j" #'card-games-gaps-down)
|
||||
(define-key map (kbd "SPC") #'card-games-gaps-fill)
|
||||
map))
|
||||
|
||||
(define-derived-mode card-games-gaps-mode special-mode "Gaps"
|
||||
"Major mode for playing the gaps family of solitaires."
|
||||
(setq-local cursor-type card-games-cursor-type)
|
||||
(setq-local truncate-lines t)
|
||||
(add-hook 'window-configuration-change-hook #'card-games-gaps--fit nil t)
|
||||
(when (eq card-games-keys 'classic)
|
||||
(use-local-map (card-games-gaps--classic-keymap))))
|
||||
|
||||
(defun card-games-gaps--play (class)
|
||||
"Start a gaps-style game of CLASS in its own buffer."
|
||||
(let* ((game (card-games-gaps--deal (make-instance class)))
|
||||
(buf (get-buffer-create (format "*%s*" (card-games-gaps--vname game)))))
|
||||
(with-current-buffer buf
|
||||
(card-games-gaps-mode)
|
||||
(setq card-games-gaps--game game)
|
||||
(card-games-gaps--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-montana ()
|
||||
"Play Gaps / Montana solitaire (Two at the head, build up 2..K)."
|
||||
(interactive)
|
||||
(card-games-gaps--play 'card-games-montana-game))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-hells-half-acre ()
|
||||
"Play Hell's Half-Acre solitaire (King at the head, build down K..2)."
|
||||
(interactive)
|
||||
(card-games-gaps--play 'card-games-acre-game))
|
||||
|
||||
;;;###autoload
|
||||
(defalias 'card-games-gaps #'card-games-montana
|
||||
"Alias for `card-games-montana'.")
|
||||
|
||||
(provide 'card-games-gaps)
|
||||
;;; card-games-gaps.el ends here
|
||||
796
card-games-handfoot.el
Normal file
796
card-games-handfoot.el
Normal file
|
|
@ -0,0 +1,796 @@
|
|||
;;; card-games-handfoot.el --- Hand and Foot, a partnership rummy -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Hand & Foot, a Canasta cousin played in partnerships. Each player is
|
||||
;; dealt two packets: a "hand" played first and a "foot" taken up once the
|
||||
;; hand is gone. Partners build *books* -- three or more cards of one
|
||||
;; rank, suits ignored -- on the table; a book of seven is complete (a
|
||||
;; "pile"), clean if it holds no wild card and dirty if it does. Twos and
|
||||
;; Jokers are wild. You go out, ending the round, once your side owns at
|
||||
;; least two complete books and you can empty your foot.
|
||||
;;
|
||||
;; You partner the North player against East and West, all three of them
|
||||
;; computer opponents. Mark cards with SPC, meld them with m, lay off onto
|
||||
;; a book with l, and discard with RET.
|
||||
;;
|
||||
;; This Hand & Foot includes the round-by-round go-down minimum (50, 90,
|
||||
;; 120, then 150), the red-three bonus (100 each, or 200 each for all four),
|
||||
;; and picking up the discard pile -- meld its top card with two matching
|
||||
;; naturals (`p') to take the top card plus several cards beneath it.
|
||||
;; Cards use the package cons
|
||||
;; (SUIT . RANK), RANK 0 (Ace) .. 12 (King), with jokers as (joker . 0).
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-rummy)
|
||||
|
||||
(defcustom card-games-handfoot-target 5000
|
||||
"Points a partnership needs to win Hand & Foot."
|
||||
:type 'integer :group 'card-games)
|
||||
|
||||
(defcustom card-games-handfoot-pickup-count 7
|
||||
"Cards taken (top included) when picking up the discard pile."
|
||||
:type 'integer :group 'card-games)
|
||||
|
||||
(defconst card-games-handfoot--minimums [50 90 120 150]
|
||||
"Initial go-down minimum by round, the last value repeating thereafter.")
|
||||
|
||||
(defconst card-games-handfoot--names ["You" "West" "North" "East"]
|
||||
"Seat labels; North is your partner.")
|
||||
|
||||
(defclass card-games-handfoot-game (card-games-rummy-game)
|
||||
((vname :initform "Hand & Foot"))
|
||||
"A game of Hand & Foot.")
|
||||
|
||||
;;;; Cards
|
||||
|
||||
(defun card-games-hf--wild-p (card)
|
||||
"Return non-nil when CARD is wild (a Joker or a Two)."
|
||||
(or (card-games-rummy-joker-p card) (= (cdr card) 1)))
|
||||
|
||||
(defun card-games-hf--three-p (card)
|
||||
"Return non-nil when CARD is a three (never meldable)."
|
||||
(and (not (card-games-rummy-joker-p card)) (= (cdr card) 2)))
|
||||
|
||||
(defun card-games-hf--red-three-p (card)
|
||||
"Return non-nil when CARD is a red three (a bonus card)."
|
||||
(and (not (card-games-rummy-joker-p card)) (= (cdr card) 2) (card-games-red-suit-p (car card))))
|
||||
|
||||
(defun card-games-hf-value (card)
|
||||
"Return the Hand & Foot point value of CARD."
|
||||
(cond ((card-games-rummy-joker-p card) 50)
|
||||
(t (let ((r (cdr card)))
|
||||
(cond ((= r 1) 20) ; Two (wild)
|
||||
((= r 0) 20) ; Ace
|
||||
((= r 2) 5) ; Three
|
||||
((<= r 6) 5) ; 4 5 6 7
|
||||
(t 10)))))) ; 8 9 10 J Q K
|
||||
|
||||
(defun card-games-hf--book-rank (cards)
|
||||
"Return the natural rank shared by CARDS, or nil if invalid."
|
||||
(let ((nats (cl-remove-if #'card-games-hf--wild-p cards)))
|
||||
(and nats
|
||||
(let ((r (cdr (car nats))))
|
||||
(and (cl-every (lambda (c) (= (cdr c) r)) nats)
|
||||
(/= r 2)
|
||||
r)))))
|
||||
|
||||
(defun card-games-hf--book-valid-p (cards)
|
||||
"Return non-nil when CARDS form a legal book."
|
||||
(let* ((nats (cl-remove-if #'card-games-hf--wild-p cards))
|
||||
(wilds (cl-remove-if-not #'card-games-hf--wild-p cards)))
|
||||
(and (>= (length cards) 3)
|
||||
(card-games-hf--book-rank cards)
|
||||
(>= (length nats) 2)
|
||||
(<= (length wilds) 3)
|
||||
(<= (length wilds) (length nats)))))
|
||||
|
||||
(defun card-games-hf--book-complete-p (cards) "Return non-nil when CARDS form a complete (7+ card) book." (>= (length cards) 7))
|
||||
(defun card-games-hf--book-clean-p (cards) "Return non-nil when CARDS is a clean book (no wilds)." (not (cl-some #'card-games-hf--wild-p cards)))
|
||||
|
||||
;;;; Setup
|
||||
|
||||
(defun card-games-hf--team (game s) "Return the team index of seat S in GAME." (mod s (card-games-get game :nteams)))
|
||||
|
||||
(cl-defmethod card-games-hf--deal ((game card-games-handfoot-game))
|
||||
"Deal a fresh round into GAME."
|
||||
(let* ((n (card-games-get game :nplayers))
|
||||
(decks (1+ n))
|
||||
(deck (card-games-rummy-deck decks 2))
|
||||
(hands (make-vector n nil)) (feet (make-vector n nil))
|
||||
(stage (make-vector n 0)))
|
||||
(dotimes (s n)
|
||||
(aset hands s (card-games-rummy-sort-hand (cl-loop repeat 11 collect (pop deck))))
|
||||
(aset feet s (card-games-rummy-sort-hand (cl-loop repeat 11 collect (pop deck)))))
|
||||
(card-games-put game :hands hands)
|
||||
(card-games-put game :feet feet)
|
||||
(card-games-put game :stage stage)
|
||||
(card-games-put game :books (make-vector (card-games-get game :nteams) nil))
|
||||
(card-games-put game :round (1+ (or (card-games-get game :round) -1)))
|
||||
(card-games-put game :down (make-vector (card-games-get game :nteams) nil))
|
||||
(card-games-put game :redthrees (make-vector (card-games-get game :nteams) nil))
|
||||
(card-games-put game :discard (list (pop deck)))
|
||||
(card-games-put game :stock deck)
|
||||
(dotimes (s n) (card-games-hf--collect-red-threes game s))
|
||||
(card-games-put game :turn 0)
|
||||
(card-games-put game :step 'draw)
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :cursor 0)
|
||||
(card-games-put game :marks nil)
|
||||
(card-games-put game :message "Your turn: s draws two cards.")
|
||||
game))
|
||||
|
||||
(defun card-games-hf--books (game team) "Return TEAM's books in GAME." (aref (card-games-get game :books) team))
|
||||
(defun card-games-hf--set-books (game team v) "Set TEAM's books in GAME to V." (aset (card-games-get game :books) team v))
|
||||
|
||||
(defun card-games-hf--down-p (game team)
|
||||
"Return non-nil when GAME TEAM has met this round's go-down minimum."
|
||||
(aref (card-games-get game :down) team))
|
||||
|
||||
(defun card-games-hf--min-for-round (game)
|
||||
"Return the go-down minimum for GAME's current round."
|
||||
(let ((r (or (card-games-get game :round) 0)))
|
||||
(aref card-games-handfoot--minimums
|
||||
(min r (1- (length card-games-handfoot--minimums))))))
|
||||
|
||||
(defun card-games-hf--collect-red-threes (game s)
|
||||
"Move GAME seat S's red threes to its team pile, drawing replacements.
|
||||
Return the number collected."
|
||||
(let ((team (card-games-hf--team game s)) (moved 0) (again t))
|
||||
(while again
|
||||
(setq again nil)
|
||||
(let ((rt (cl-find-if #'card-games-hf--red-three-p (card-games-rummy--hand game s))))
|
||||
(when rt
|
||||
(card-games-rummy--set-hand game s (card-games-rummy--remove1 rt (card-games-rummy--hand game s)))
|
||||
(aset (card-games-get game :redthrees) team
|
||||
(cons rt (aref (card-games-get game :redthrees) team)))
|
||||
(setq moved (1+ moved))
|
||||
(let ((stock (card-games-get game :stock)))
|
||||
(when stock
|
||||
(card-games-rummy--set-hand game s (card-games-rummy-sort-hand
|
||||
(cons (car stock) (card-games-rummy--hand game s))))
|
||||
(card-games-put game :stock (cdr stock))))
|
||||
(setq again t))))
|
||||
moved))
|
||||
|
||||
(defun card-games-hf--take-foot (game s)
|
||||
"Move GAME seat S onto its foot, collecting any red threes it has."
|
||||
(aset (card-games-get game :stage) s 1)
|
||||
(card-games-rummy--set-hand game s (aref (card-games-get game :feet) s))
|
||||
(card-games-hf--collect-red-threes game s))
|
||||
|
||||
(defun card-games-hf--pickup-eligible (game s)
|
||||
"Return non-nil when GAME seat S may pick up the discard pile.
|
||||
That needs two natural cards in hand matching a meldable top discard."
|
||||
(let ((top (card-games-rummy--top game)))
|
||||
(and top (not (card-games-hf--wild-p top)) (not (card-games-hf--three-p top))
|
||||
(>= (cl-count-if (lambda (c) (and (not (card-games-hf--wild-p c))
|
||||
(= (cdr c) (cdr top))))
|
||||
(card-games-rummy--hand game s))
|
||||
2))))
|
||||
|
||||
(defun card-games-hf--pickup (game s)
|
||||
"Have GAME seat S pick up the discard pile, melding its top card.
|
||||
Take the top card plus up to `card-games-handfoot-pickup-count' - 1 cards
|
||||
beneath it into hand, melding the top with two matching naturals. Return
|
||||
the top card, or nil if ineligible."
|
||||
(when (card-games-hf--pickup-eligible game s)
|
||||
(let* ((pile (card-games-get game :discard)) (top (car pile)) (rank (cdr top))
|
||||
(team (card-games-hf--team game s)) (books (card-games-hf--books game team))
|
||||
(nats (cl-remove-if-not
|
||||
(lambda (c) (and (not (card-games-hf--wild-p c)) (= (cdr c) rank)))
|
||||
(card-games-rummy--hand game s)))
|
||||
(two (list (nth 0 nats) (nth 1 nats)))
|
||||
(existing (cl-find-if
|
||||
(lambda (bk) (and (not (card-games-hf--book-complete-p bk))
|
||||
(equal (card-games-hf--book-rank bk) rank)))
|
||||
books))
|
||||
(rest (cdr pile))
|
||||
(ntake (min (1- card-games-handfoot-pickup-count) (length rest)))
|
||||
(take (cl-subseq rest 0 ntake))
|
||||
(remain (nthcdr ntake rest)))
|
||||
(dolist (c two)
|
||||
(card-games-rummy--set-hand game s (card-games-rummy--remove1 c (card-games-rummy--hand game s))))
|
||||
(if existing
|
||||
(setcar (memq existing books)
|
||||
(card-games-rummy-sort-hand (append (list top) two existing)))
|
||||
(card-games-hf--set-books game team
|
||||
(append books (list (card-games-rummy-sort-hand (cons top two))))))
|
||||
(card-games-put game :discard remain)
|
||||
(dolist (c take)
|
||||
(card-games-rummy--set-hand game s (card-games-rummy-sort-hand
|
||||
(cons c (card-games-rummy--hand game s)))))
|
||||
(card-games-hf--collect-red-threes game s)
|
||||
top)))
|
||||
|
||||
(defun card-games-hf--partition-books (cards)
|
||||
"Partition CARDS into valid books, or nil if they can't all be used.
|
||||
Naturals group by rank (each rank needs two), and wilds fill the groups."
|
||||
(if (or (null cards) (cl-some #'card-games-hf--three-p cards)) nil
|
||||
(let ((wilds (cl-remove-if-not #'card-games-hf--wild-p cards))
|
||||
(byrank (make-hash-table :test 'eql)) (groups '()) (ok t))
|
||||
(dolist (c cards)
|
||||
(unless (card-games-hf--wild-p c) (push c (gethash (cdr c) byrank))))
|
||||
(maphash (lambda (_r cs) (push cs groups)) byrank)
|
||||
(when (or (null groups) (cl-some (lambda (g) (< (length g) 2)) groups))
|
||||
(setq ok nil))
|
||||
(when ok
|
||||
(let ((w (copy-sequence wilds)) (books '()))
|
||||
(dolist (g (sort groups (lambda (a b) (< (length a) (length b)))))
|
||||
(let ((bk (copy-sequence g)))
|
||||
(while (and (< (length bk) 3) w) (push (pop w) bk))
|
||||
(push bk books)))
|
||||
(dolist (wcard w)
|
||||
(let ((tgt (cl-find-if
|
||||
(lambda (bk)
|
||||
(and (< (length bk) 7)
|
||||
(< (cl-count-if #'card-games-hf--wild-p bk) 3)
|
||||
(< (cl-count-if #'card-games-hf--wild-p bk)
|
||||
(cl-count-if-not #'card-games-hf--wild-p bk))))
|
||||
books)))
|
||||
(if tgt (setcar (memq tgt books) (cons wcard tgt)) (setq ok nil))))
|
||||
(if (and ok (cl-every #'card-games-hf--book-valid-p books)) books nil))))))
|
||||
|
||||
(defun card-games-hf--initial-meld (game s cards)
|
||||
"Lay CARDS as GAME seat S's initial meld, meeting the round minimum.
|
||||
Return non-nil when the team goes down."
|
||||
(let* ((books (card-games-hf--partition-books cards))
|
||||
(team (card-games-hf--team game s)))
|
||||
(when (and books
|
||||
(cl-subsetp cards (card-games-rummy--hand game s) :test #'equal)
|
||||
(>= (apply #'+ (mapcar #'card-games-hf-value cards))
|
||||
(card-games-hf--min-for-round game)))
|
||||
(dolist (c cards)
|
||||
(card-games-rummy--set-hand game s (card-games-rummy--remove1 c (card-games-rummy--hand game s))))
|
||||
(card-games-hf--set-books game team
|
||||
(append (card-games-hf--books game team)
|
||||
(mapcar #'card-games-rummy-sort-hand books)))
|
||||
(aset (card-games-get game :down) team t)
|
||||
t)))
|
||||
|
||||
(defun card-games-hf--ai-go-down (game s)
|
||||
"Try to lay GAME seat S's initial meld meeting the round minimum.
|
||||
Return non-nil when the team goes down."
|
||||
(let* ((hand (card-games-rummy--hand game s))
|
||||
(byrank (make-hash-table :test 'eql))
|
||||
(wilds (cl-remove-if-not #'card-games-hf--wild-p hand)) (cards '()))
|
||||
(dolist (c hand)
|
||||
(unless (or (card-games-hf--wild-p c) (card-games-hf--three-p c))
|
||||
(push c (gethash (cdr c) byrank))))
|
||||
(let ((w (copy-sequence wilds)))
|
||||
(maphash (lambda (_r cs)
|
||||
(cond ((>= (length cs) 3) (setq cards (append cs cards)))
|
||||
((and (= (length cs) 2) w)
|
||||
(setq cards (append cs (list (pop w)) cards)))))
|
||||
byrank))
|
||||
(when (and cards (>= (apply #'+ (mapcar #'card-games-hf-value cards))
|
||||
(card-games-hf--min-for-round game)))
|
||||
(card-games-hf--initial-meld game s cards))))
|
||||
|
||||
(defun card-games-hf--ai-meld (game s)
|
||||
"Meld for GAME seat S, going down only when the round minimum is met."
|
||||
(let ((team (card-games-hf--team game s)))
|
||||
(unless (card-games-hf--down-p game team) (card-games-hf--ai-go-down game s))
|
||||
(when (card-games-hf--down-p game team) (card-games-hf--ai-extend game s))))
|
||||
|
||||
;;;; Engine
|
||||
|
||||
(defun card-games-hf--draw2 (game s)
|
||||
"Draw two of GAME's stock cards into seat S's hand; nil if stock is empty."
|
||||
(let ((ok t))
|
||||
(dotimes (_ 2)
|
||||
(let ((stock (card-games-get game :stock)))
|
||||
(if (null stock) (setq ok nil)
|
||||
(card-games-rummy--set-hand game s (card-games-rummy-sort-hand
|
||||
(cons (car stock) (card-games-rummy--hand game s))))
|
||||
(card-games-put game :stock (cdr stock)))))
|
||||
ok))
|
||||
|
||||
(defun card-games-hf--meld (game s cards)
|
||||
"Have GAME seat S lay CARDS as a new team book; non-nil on win."
|
||||
(when (and (card-games-hf--book-valid-p cards)
|
||||
(cl-subsetp cards (card-games-rummy--hand game s) :test #'equal))
|
||||
(let ((team (card-games-hf--team game s)))
|
||||
(dolist (c cards)
|
||||
(card-games-rummy--set-hand game s (card-games-rummy--remove1 c (card-games-rummy--hand game s))))
|
||||
(card-games-hf--set-books game team
|
||||
(append (card-games-hf--books game team)
|
||||
(list (card-games-rummy-sort-hand (copy-sequence cards)))))
|
||||
t)))
|
||||
|
||||
(defun card-games-rummy--remove1 (card list)
|
||||
"Return LIST with one copy of CARD (an `equal' match) removed."
|
||||
(let ((seen nil))
|
||||
(cl-remove-if (lambda (c) (and (not seen) (equal c card) (setq seen t))) list)))
|
||||
|
||||
(defun card-games-hf--layoff (game s card)
|
||||
"Lay CARD off from seat S onto a GAME team book; non-nil on success."
|
||||
(let* ((team (card-games-hf--team game s)) (books (card-games-hf--books game team)) (done nil))
|
||||
(catch 'hit
|
||||
(dolist (bk books)
|
||||
(unless (card-games-hf--book-complete-p bk)
|
||||
(let ((cand (cons card bk)))
|
||||
(when (card-games-hf--book-valid-p cand)
|
||||
(card-games-rummy--set-hand game s (card-games-rummy--remove1 card (card-games-rummy--hand game s)))
|
||||
(setcar (memq bk books) (card-games-rummy-sort-hand cand))
|
||||
(setq done t)
|
||||
(throw 'hit t))))))
|
||||
done))
|
||||
|
||||
(defun card-games-hf--advance (game s)
|
||||
"After a play by GAME seat S, take up the foot or finish, then pass the turn."
|
||||
(let ((stage (card-games-get game :stage)))
|
||||
(when (and (= (aref stage s) 0) (null (card-games-rummy--hand game s)))
|
||||
;; hand exhausted: pick up the foot
|
||||
(card-games-hf--take-foot game s))
|
||||
(if (and (= (aref stage s) 1) (null (card-games-rummy--hand game s))
|
||||
(card-games-hf--can-go-out-p game (card-games-hf--team game s)))
|
||||
(card-games-hf--score-round game s)
|
||||
(card-games-put game :turn (mod (1+ s) (card-games-get game :nplayers)))
|
||||
(card-games-put game :step 'draw))))
|
||||
|
||||
(defun card-games-hf--can-go-out-p (game team)
|
||||
"Return non-nil when GAME TEAM owns at least two complete books."
|
||||
(>= (cl-count-if #'card-games-hf--book-complete-p (card-games-hf--books game team)) 2))
|
||||
|
||||
(defun card-games-hf--discard (game s card)
|
||||
"Discard CARD from GAME seat S and end the play portion of the turn."
|
||||
(card-games-rummy--set-hand game s (card-games-rummy--remove1 card (card-games-rummy--hand game s)))
|
||||
(card-games-put game :discard (cons card (card-games-get game :discard)))
|
||||
(card-games-hf--advance game s))
|
||||
|
||||
(cl-defmethod card-games-hf--score-round ((game card-games-handfoot-game) outseat)
|
||||
"Score GAME's round (OUTSEAT went out, or nil if the stock ran dry)."
|
||||
(let* ((nt (card-games-get game :nteams)) (scores (card-games-get game :scores)))
|
||||
(dotimes (team nt)
|
||||
(let ((pts 0))
|
||||
(dolist (bk (card-games-hf--books game team))
|
||||
(dolist (c bk) (setq pts (+ pts (card-games-hf-value c))))
|
||||
(when (card-games-hf--book-complete-p bk)
|
||||
(setq pts (+ pts (if (card-games-hf--book-clean-p bk) 500 300)))))
|
||||
(when (and outseat (= (card-games-hf--team game outseat) team))
|
||||
(setq pts (+ pts 100))) ; going-out bonus
|
||||
(let ((k (length (aref (card-games-get game :redthrees) team))))
|
||||
(setq pts (+ pts (* k (if (>= k 4) 200 100))))) ; red threes
|
||||
;; subtract cards left in members' hands and feet
|
||||
(dotimes (s (card-games-get game :nplayers))
|
||||
(when (= (card-games-hf--team game s) team)
|
||||
(dolist (c (card-games-rummy--hand game s)) (setq pts (- pts (card-games-hf-value c))))
|
||||
(when (= (aref (card-games-get game :stage) s) 0)
|
||||
(dolist (c (aref (card-games-get game :feet) s))
|
||||
(setq pts (- pts (card-games-hf-value c)))))))
|
||||
(aset scores team (+ (aref scores team) pts))))
|
||||
(let ((win nil) (best most-negative-fixnum))
|
||||
(dotimes (team nt)
|
||||
(when (and (>= (aref scores team) card-games-handfoot-target)
|
||||
(> (aref scores team) best))
|
||||
(setq win team best (aref scores team))))
|
||||
(card-games-put game :phase (if win 'game-over 'round-over))
|
||||
(card-games-put game :winner (or win (and outseat (card-games-hf--team game outseat))))
|
||||
(card-games-put game :reveal t)
|
||||
(card-games-put game :message
|
||||
(concat
|
||||
(if outseat (format "%s goes out! " (aref card-games-handfoot--names outseat))
|
||||
"Stock exhausted. ")
|
||||
(if win (format "Team %d wins the game! (n: new game)" win)
|
||||
(format "Round over. Scores: %s. (n: next round)"
|
||||
(card-games-hf--scores-string game))))))))
|
||||
|
||||
(defun card-games-hf--scores-string (game)
|
||||
"Return a compact per-team score line for GAME."
|
||||
(let ((scores (card-games-get game :scores)) (parts '()))
|
||||
(dotimes (team (card-games-get game :nteams))
|
||||
(push (format "Team %d %d" team (aref scores team)) parts))
|
||||
(mapconcat #'identity (nreverse parts) " · ")))
|
||||
|
||||
;;;; AI
|
||||
|
||||
(defun card-games-hf--ai-extend (game s)
|
||||
"Extend and add books for GAME seat S once the team is down."
|
||||
;; lay off naturals onto existing incomplete team books
|
||||
(let ((again t))
|
||||
(while again
|
||||
(setq again nil)
|
||||
(let ((card (cl-find-if
|
||||
(lambda (c)
|
||||
(and (not (card-games-hf--wild-p c)) (not (card-games-hf--three-p c))
|
||||
(cl-find-if
|
||||
(lambda (bk) (and (not (card-games-hf--book-complete-p bk))
|
||||
(equal (card-games-hf--book-rank bk) (cdr c))))
|
||||
(card-games-hf--books game (card-games-hf--team game s)))))
|
||||
(card-games-rummy--hand game s))))
|
||||
(when card (card-games-hf--layoff game s card) (setq again t)))))
|
||||
;; start new books from ranks with >=3 naturals in hand
|
||||
(let ((again t))
|
||||
(while again
|
||||
(setq again nil)
|
||||
(let* ((hand (card-games-rummy--hand game s))
|
||||
(byrank (make-hash-table :test 'eql)) (target nil))
|
||||
(dolist (c hand)
|
||||
(unless (or (card-games-hf--wild-p c) (card-games-hf--three-p c))
|
||||
(push c (gethash (cdr c) byrank))))
|
||||
(maphash (lambda (_r cs) (when (and (not target) (>= (length cs) 3))
|
||||
(setq target cs)))
|
||||
byrank)
|
||||
(when target
|
||||
(card-games-hf--meld game s (cl-subseq target 0 (min 7 (length target))))
|
||||
(setq again t)))))
|
||||
;; push a nearly-complete book to seven with a spare wild
|
||||
(let ((again t))
|
||||
(while again
|
||||
(setq again nil)
|
||||
(let ((wild (cl-find-if #'card-games-hf--wild-p (card-games-rummy--hand game s)))
|
||||
(team (card-games-hf--team game s)))
|
||||
(when wild
|
||||
(let ((bk (cl-find-if
|
||||
(lambda (b)
|
||||
(and (not (card-games-hf--book-complete-p b))
|
||||
(>= (length b) 5)
|
||||
(> (cl-count-if-not #'card-games-hf--wild-p b)
|
||||
(cl-count-if #'card-games-hf--wild-p b))
|
||||
(< (cl-count-if #'card-games-hf--wild-p b) 3)))
|
||||
(card-games-hf--books game team))))
|
||||
(when bk
|
||||
(card-games-rummy--set-hand game s (card-games-rummy--remove1 wild (card-games-rummy--hand game s)))
|
||||
(setcar (memq bk (card-games-hf--books game team))
|
||||
(card-games-rummy-sort-hand (cons wild bk)))
|
||||
(setq again t))))))))
|
||||
|
||||
(defun card-games-hf--ai-discard-card (game s)
|
||||
"Return the card GAME seat S should discard."
|
||||
(let ((hand (card-games-rummy--hand game s)))
|
||||
(or (cl-find-if #'card-games-hf--three-p hand)
|
||||
;; a high singleton, else the first card
|
||||
(let ((byrank (make-hash-table :test 'eql)) (best (car hand)) (bestv -1))
|
||||
(dolist (c hand) (unless (card-games-hf--wild-p c)
|
||||
(push c (gethash (cdr c) byrank))))
|
||||
(maphash (lambda (_r cs)
|
||||
(when (= (length cs) 1)
|
||||
(let ((v (card-games-hf-value (car cs))))
|
||||
(when (> v bestv) (setq best (car cs) bestv v)))))
|
||||
byrank)
|
||||
best))))
|
||||
|
||||
(cl-defmethod card-games-hf--ai-turn ((game card-games-handfoot-game) s)
|
||||
"Play GAME seat S's whole turn."
|
||||
(let ((got (or (and (> (length (card-games-get game :stock)) 30)
|
||||
(card-games-hf--pickup-eligible game s)
|
||||
(card-games-hf--pickup game s))
|
||||
(card-games-hf--draw2 game s))))
|
||||
(if (not got)
|
||||
(card-games-hf--score-round game nil)
|
||||
(card-games-hf--ai-meld game s)
|
||||
(when (eq (card-games-get game :phase) 'play)
|
||||
;; if the hand emptied through melding, pick up the foot and meld again
|
||||
(when (and (= (aref (card-games-get game :stage) s) 0) (null (card-games-rummy--hand game s)))
|
||||
(card-games-hf--take-foot game s)
|
||||
(card-games-hf--ai-meld game s))
|
||||
(when (eq (card-games-get game :phase) 'play)
|
||||
(if (card-games-rummy--hand game s)
|
||||
(card-games-hf--discard game s (card-games-hf--ai-discard-card game s))
|
||||
(card-games-hf--advance game s)))))))
|
||||
|
||||
(defun card-games-hf--run (game)
|
||||
"Advance GAME's AI seats until your turn or the round ends."
|
||||
(while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0))
|
||||
(card-games-hf--ai-turn game (card-games-get game :turn))))
|
||||
|
||||
;;;; UI
|
||||
|
||||
(defvar-local card-games-hf--game nil "The Hand & Foot game in the current buffer.")
|
||||
|
||||
(defun card-games-hf--svg (game)
|
||||
"Return an SVG board for the Hand & Foot GAME."
|
||||
(let* ((scores (card-games-get game :scores)) (infos '()) (melds '()))
|
||||
(dotimes (team (card-games-get game :nteams))
|
||||
(push (format "Team %d (score %d)%s%s" team (aref scores team)
|
||||
(if (card-games-hf--down-p game team) " down"
|
||||
(format " needs %d" (card-games-hf--min-for-round game)))
|
||||
(let ((k (length (aref (card-games-get game :redthrees) team))))
|
||||
(if (> k 0) (format " red3:%d" k) "")))
|
||||
infos)
|
||||
(dolist (bk (card-games-hf--books game team))
|
||||
(push (cons (format "T%d%s" team
|
||||
(if (card-games-hf--book-complete-p bk)
|
||||
(if (card-games-hf--book-clean-p bk) " clean" " dirty") ""))
|
||||
bk)
|
||||
melds)))
|
||||
(dotimes (s (card-games-get game :nplayers))
|
||||
(unless (= s 0)
|
||||
(push (format "%s: %d in hand%s" (aref card-games-handfoot--names s)
|
||||
(length (card-games-rummy--hand game s))
|
||||
(if (= (aref (card-games-get game :stage) s) 1) " (on foot)" ""))
|
||||
infos)))
|
||||
(card-games-rummy--board-svg
|
||||
:title (format "Hand & Foot target %d round %d (min %d)"
|
||||
card-games-handfoot-target (1+ (or (card-games-get game :round) 0))
|
||||
(card-games-hf--min-for-round game))
|
||||
:infos (nreverse infos) :melds (nreverse melds)
|
||||
:discard (card-games-rummy--top game) :stock (length (card-games-get game :stock))
|
||||
:hand (card-games-rummy--hand game 0) :cursor (card-games-get game :cursor)
|
||||
:marks (card-games-get game :marks) :message (card-games-get game :message))))
|
||||
|
||||
(cl-defmethod card-games-render ((game card-games-handfoot-game))
|
||||
"Return a depiction of the Hand & Foot GAME: SVG board if graphical, else text."
|
||||
(if (and card-games-rummy-svg-cards (display-graphic-p))
|
||||
(card-games-hf--svg game)
|
||||
(card-games-hf--render-text game)))
|
||||
|
||||
(defun card-games-hf--render-text (game)
|
||||
"Return a plain-text depiction of the Hand & Foot GAME."
|
||||
(let* ((out '()) (scores (card-games-get game :scores))
|
||||
(hand (card-games-rummy--hand game 0)) (cursor (card-games-get game :cursor)))
|
||||
(push (format " Hand & Foot target %d round %d (go-down minimum %d)\n\n"
|
||||
card-games-handfoot-target (1+ (or (card-games-get game :round) 0))
|
||||
(card-games-hf--min-for-round game)) out)
|
||||
(dotimes (team (card-games-get game :nteams))
|
||||
(push (format " Team %d (score %d)%s%s:\n" team (aref scores team)
|
||||
(if (card-games-hf--down-p game team) " down"
|
||||
(format " needs %d to go down" (card-games-hf--min-for-round game)))
|
||||
(let ((k (length (aref (card-games-get game :redthrees) team))))
|
||||
(if (> k 0) (format " red3:%d" k) ""))) out)
|
||||
(let ((bks (card-games-hf--books game team)))
|
||||
(if bks
|
||||
(dolist (bk bks)
|
||||
(push (format " %s%s\n"
|
||||
(mapconcat #'card-games-rummy-card-string bk " ")
|
||||
(cond ((card-games-hf--book-complete-p bk)
|
||||
(if (card-games-hf--book-clean-p bk) " [clean pile]" " [dirty pile]"))
|
||||
(t "")))
|
||||
out))
|
||||
(push " (no books yet)\n" out))))
|
||||
(push "\n" out)
|
||||
(dotimes (s (card-games-get game :nplayers))
|
||||
(unless (= s 0)
|
||||
(push (format " %-6s %d in hand%s\n" (aref card-games-handfoot--names s)
|
||||
(length (card-games-rummy--hand game s))
|
||||
(if (= (aref (card-games-get game :stage) s) 1) " (on foot)" ""))
|
||||
out)))
|
||||
(push (format "\n Discard: %s (pile %d) Stock: %d\n\n"
|
||||
(let ((cs (card-games-rummy-card-string (card-games-rummy--top game))) (tp (card-games-rummy--top game)))
|
||||
(if (and tp (not (card-games-rummy-joker-p tp)) (card-games-red-suit-p (car tp)))
|
||||
(propertize cs 'face 'card-games-red-suit) cs))
|
||||
(length (card-games-get game :discard))
|
||||
(length (card-games-get game :stock)))
|
||||
out)
|
||||
(push (format " Your %s:\n " (if (= (aref (card-games-get game :stage) 0) 1) "foot" "hand")) out)
|
||||
(push (card-games-rummy--render-cards hand cursor (card-games-get game :marks) nil 'hand) out)
|
||||
(push (format "\n\n %s\n" (card-games-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod card-games-render-apply ((g card-games-handfoot-game) action)
|
||||
"Apply a click ACTION on the hand to GAME G."
|
||||
(pcase action
|
||||
(`(hand . ,i) (card-games-put g :cursor i))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun card-games-hf--redisplay ()
|
||||
"Redraw the Hand & Foot buffer."
|
||||
(let ((game card-games-hf--game) (inhibit-read-only t))
|
||||
(setq card-games-current-game game card-games-redisplay-function #'card-games-hf--redisplay)
|
||||
(setq-local mode-line-process
|
||||
(format " [%s]" (or (card-games-get game :step) (card-games-get game :phase))))
|
||||
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
|
||||
|
||||
(defun card-games-hf--clamp (g)
|
||||
"Keep G's cursor in range and drop stale marked cards."
|
||||
(let ((n (length (card-games-rummy--hand g 0))))
|
||||
(card-games-put g :cursor (if (> n 0) (min (card-games-get g :cursor) (1- n)) 0))
|
||||
(card-games-put g :marks (cl-remove-if (lambda (i) (>= i n)) (card-games-get g :marks)))))
|
||||
|
||||
(defun card-games-hf--my-turn-p (g)
|
||||
"Return non-nil when it is your turn in G."
|
||||
(and (eq (card-games-get g :phase) 'play) (= (card-games-get g :turn) 0)))
|
||||
|
||||
(defun card-games-hf-left ()
|
||||
"Move the hand cursor left."
|
||||
(interactive)
|
||||
(let* ((g card-games-hf--game) (n (length (card-games-rummy--hand g 0))))
|
||||
(when (> n 0) (card-games-put g :cursor (mod (1- (card-games-get g :cursor)) n)))
|
||||
(card-games-hf--redisplay)))
|
||||
|
||||
(defun card-games-hf-right ()
|
||||
"Move the hand cursor right."
|
||||
(interactive)
|
||||
(let* ((g card-games-hf--game) (n (length (card-games-rummy--hand g 0))))
|
||||
(when (> n 0) (card-games-put g :cursor (mod (1+ (card-games-get g :cursor)) n)))
|
||||
(card-games-hf--redisplay)))
|
||||
|
||||
(defun card-games-hf-mark ()
|
||||
"Toggle a mark on the card under the cursor."
|
||||
(interactive)
|
||||
(let* ((g card-games-hf--game) (i (card-games-get g :cursor)) (marks (card-games-get g :marks)))
|
||||
(card-games-put g :marks (if (memq i marks) (delq i marks) (cons i marks)))
|
||||
(card-games-hf--redisplay)))
|
||||
|
||||
(defun card-games-hf--marked (g)
|
||||
"Return the marked cards in G's hand."
|
||||
(let ((hand (card-games-rummy--hand g 0)))
|
||||
(mapcar (lambda (i) (nth i hand)) (sort (copy-sequence (card-games-get g :marks)) #'<))))
|
||||
|
||||
(defun card-games-hf-meld ()
|
||||
"Meld the marked cards.
|
||||
Until your team is down you must mark a complete initial meld -- one or
|
||||
more valid books totalling at least the round minimum -- and lay it in one
|
||||
action. After that, mark single books as usual."
|
||||
(interactive)
|
||||
(let* ((g card-games-hf--game) (cards (card-games-hf--marked g)) (team (card-games-hf--team g 0)))
|
||||
(cond
|
||||
((not (card-games-hf--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((eq (card-games-get g :step) 'draw) (card-games-put g :message "Draw first (s)."))
|
||||
((not (card-games-hf--down-p g team))
|
||||
(if (card-games-hf--initial-meld g 0 cards)
|
||||
(progn
|
||||
(card-games-put g :marks nil) (card-games-hf--clamp g)
|
||||
(when (and (= (aref (card-games-get g :stage) 0) 0) (null (card-games-rummy--hand g 0)))
|
||||
(card-games-hf--take-foot g 0) (card-games-hf--clamp g))
|
||||
(card-games-put g :message
|
||||
(format "You're down! (met the %d minimum.) Meld more, lay off, or discard."
|
||||
(card-games-hf--min-for-round g))))
|
||||
(card-games-put g :message
|
||||
(format "Initial meld must be valid books totalling >= %d; mark them all, then m."
|
||||
(card-games-hf--min-for-round g)))))
|
||||
((not (card-games-hf--book-valid-p cards))
|
||||
(card-games-put g :message "Not a legal book: 3+ of a rank, 2+ natural, wilds <= naturals."))
|
||||
((card-games-hf--meld g 0 cards)
|
||||
(card-games-put g :marks nil) (card-games-hf--clamp g)
|
||||
(if (and (= (aref (card-games-get g :stage) 0) 0) (null (card-games-rummy--hand g 0)))
|
||||
(progn (card-games-hf--take-foot g 0) (card-games-hf--clamp g)
|
||||
(card-games-put g :message "Hand cleared -- foot picked up! Keep melding or discard (RET)."))
|
||||
(unless (and (= (aref (card-games-get g :stage) 0) 1) (null (card-games-rummy--hand g 0)))
|
||||
(card-games-put g :message "Booked. Meld more, lay off (l), or discard (RET)."))))
|
||||
(t (card-games-put g :message "Could not meld those cards.")))
|
||||
(card-games-hf--redisplay)))
|
||||
|
||||
(defun card-games-hf-layoff ()
|
||||
"Lay the cursor card (or marked cards) off onto a team book."
|
||||
(interactive)
|
||||
(let* ((g card-games-hf--game) (marks (card-games-hf--marked g)))
|
||||
(cond
|
||||
((not (card-games-hf--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((eq (card-games-get g :step) 'draw) (card-games-put g :message "Draw first (s)."))
|
||||
(t (let ((cards (or marks (list (nth (card-games-get g :cursor) (card-games-rummy--hand g 0)))))
|
||||
(any nil))
|
||||
(dolist (c cards) (when (and c (card-games-hf--layoff g 0 c)) (setq any t)))
|
||||
(card-games-put g :marks nil) (card-games-hf--clamp g)
|
||||
(card-games-put g :message (if any "Laid off." "That card fits none of your books.")))))
|
||||
(card-games-hf--redisplay)))
|
||||
|
||||
(defun card-games-hf-draw ()
|
||||
"Draw two cards from the stock."
|
||||
(interactive)
|
||||
(let ((g card-games-hf--game))
|
||||
(cond
|
||||
((not (card-games-hf--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((not (eq (card-games-get g :step) 'draw)) (card-games-put g :message "You already drew."))
|
||||
((card-games-hf--draw2 g 0)
|
||||
(card-games-hf--collect-red-threes g 0)
|
||||
(card-games-put g :step 'play) (card-games-hf--clamp g)
|
||||
(card-games-put g :message "Meld (m), lay off (l), then discard (RET)."))
|
||||
(t (card-games-hf--score-round g nil)))
|
||||
(card-games-hf--redisplay)))
|
||||
|
||||
(defun card-games-hf-pickup ()
|
||||
"Pick up the discard pile by melding its top card (Hand & Foot)."
|
||||
(interactive)
|
||||
(let ((g card-games-hf--game))
|
||||
(cond
|
||||
((not (card-games-hf--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((not (eq (card-games-get g :step) 'draw)) (card-games-put g :message "You already drew."))
|
||||
((not (card-games-hf--pickup-eligible g 0))
|
||||
(card-games-put g :message
|
||||
"Can't pick up: you need two natural cards matching the top discard."))
|
||||
(t (let ((top (card-games-hf--pickup g 0)))
|
||||
(card-games-put g :step 'play) (card-games-hf--clamp g)
|
||||
(card-games-put g :message
|
||||
(format "Picked up the pile, melding %s. Meld more, lay off, or discard."
|
||||
(card-games-rummy-card-string top))))))
|
||||
(card-games-hf--redisplay)))
|
||||
|
||||
(defun card-games-hf-discard ()
|
||||
"Discard the cursor card and end your turn."
|
||||
(interactive)
|
||||
(let* ((g card-games-hf--game) (card (nth (card-games-get g :cursor) (card-games-rummy--hand g 0))))
|
||||
(cond
|
||||
((not (card-games-hf--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((eq (card-games-get g :step) 'draw) (card-games-put g :message "Draw first (s)."))
|
||||
((null card) (card-games-put g :message "No card selected."))
|
||||
(t (card-games-hf--discard g 0 card)
|
||||
(card-games-put g :marks nil)
|
||||
(when (memq (card-games-get g :phase) '(play))
|
||||
(card-games-put g :message "You discarded.")
|
||||
(card-games-hf--run g))))
|
||||
(card-games-hf--redisplay)))
|
||||
|
||||
(defun card-games-hf-new ()
|
||||
"Deal a fresh round, or a new game when one is over."
|
||||
(interactive)
|
||||
(let ((g card-games-hf--game))
|
||||
(when (eq (card-games-get g :phase) 'game-over)
|
||||
(card-games-put g :scores (make-vector (card-games-get g :nteams) 0))
|
||||
(card-games-put g :round -1))
|
||||
(card-games-put g :reveal nil)
|
||||
(card-games-hf--deal g)
|
||||
(card-games-hf--run g)
|
||||
(card-games-hf--redisplay)))
|
||||
|
||||
(defun card-games-hf-redraw () "Redraw the board." (interactive) (card-games-hf--redisplay))
|
||||
|
||||
(defun card-games-hf-help ()
|
||||
"Describe the Hand & Foot controls."
|
||||
(interactive)
|
||||
(message "Arrows: choose SPC: mark m: meld l: lay off s: draw 2 p: pick up pile RET: discard n: new"))
|
||||
|
||||
(defvar card-games-handfoot-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'card-games-card-click)
|
||||
(define-key map "+" #'card-games-card-zoom-in)
|
||||
(define-key map "=" #'card-games-card-zoom-in)
|
||||
(define-key map "-" #'card-games-card-zoom-out)
|
||||
(define-key map "0" #'card-games-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'card-games-hf-left)
|
||||
(define-key map (kbd "<right>") #'card-games-hf-right)
|
||||
(define-key map (kbd "SPC") #'card-games-hf-mark)
|
||||
(define-key map "m" #'card-games-hf-meld)
|
||||
(define-key map "l" #'card-games-hf-layoff)
|
||||
(define-key map "s" #'card-games-hf-draw)
|
||||
(define-key map "p" #'card-games-hf-pickup)
|
||||
(define-key map (kbd "RET") #'card-games-hf-discard)
|
||||
(define-key map "n" #'card-games-hf-new)
|
||||
(define-key map "g" #'card-games-hf-redraw)
|
||||
(define-key map "?" #'card-games-hf-help)
|
||||
(define-key map "q" #'card-games-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `card-games-handfoot-mode'.")
|
||||
|
||||
(define-derived-mode card-games-handfoot-mode special-mode "Hand&Foot"
|
||||
"Major mode for Hand & Foot."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type card-games-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-handfoot ()
|
||||
"Play Hand & Foot, partnering North against two AI opponents."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Hand & Foot*")))
|
||||
(with-current-buffer buf
|
||||
(card-games-handfoot-mode)
|
||||
(setq card-games-hf--game (card-games-handfoot-game))
|
||||
(card-games-put card-games-hf--game :nplayers 4)
|
||||
(card-games-put card-games-hf--game :nteams 2)
|
||||
(card-games-put card-games-hf--game :scores (make-vector 2 0))
|
||||
(card-games-hf--deal card-games-hf--game)
|
||||
(card-games-hf--run card-games-hf--game)
|
||||
(card-games-hf--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;###autoload
|
||||
(defalias 'card-games-hand-and-foot #'card-games-handfoot)
|
||||
|
||||
(provide 'card-games-handfoot)
|
||||
;;; card-games-handfoot.el ends here
|
||||
611
card-games-match.el
Normal file
611
card-games-match.el
Normal file
|
|
@ -0,0 +1,611 @@
|
|||
;;; card-games-match.el --- Go Fish and Old Maid -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Two children's classics that turn on matching ranks rather than melding.
|
||||
;;
|
||||
;; `card-games-go-fish' -- Go Fish. On your turn ask another player for a rank
|
||||
;; you already hold; collect all four of a rank to lay down a book.
|
||||
;; Whoever lays down the most books wins.
|
||||
;; `card-games-old-maid' -- Old Maid. One Queen is removed, so one stays
|
||||
;; unpaired. Discard pairs, then draw blind from your neighbour; do
|
||||
;; not be the one left holding the odd Queen.
|
||||
;;
|
||||
;; You are the first player; the rest are computer opponents. Cards use
|
||||
;; the package cons (SUIT . RANK), RANK 0 (Ace) .. 12 (King).
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-rummy)
|
||||
|
||||
;;;; Go Fish
|
||||
|
||||
(defcustom card-games-go-fish-players 3
|
||||
"Number of players in Go Fish, including you (2-5)."
|
||||
:type '(choice (const 2) (const 3) (const 4) (const 5)) :group 'card-games)
|
||||
|
||||
(defclass card-games-go-fish-game (card-games-game)
|
||||
((vname :initform "Go Fish"))
|
||||
"A game of Go Fish.")
|
||||
|
||||
(defsubst card-games-gf--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
|
||||
(defsubst card-games-gf--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
|
||||
|
||||
(defun card-games-gf--books (game s) "Return seat S's laid-down books in GAME." (aref (card-games-get game :books) s))
|
||||
|
||||
(defun card-games-gf--rank-count (hand rank)
|
||||
"Return how many cards of RANK are in HAND."
|
||||
(cl-count rank hand :key #'cdr))
|
||||
|
||||
(defun card-games-gf--check-books (game s)
|
||||
"Lay down any completed four-of-a-kind books from GAME seat S's hand."
|
||||
(dotimes (r 13)
|
||||
(when (>= (card-games-gf--rank-count (card-games-gf--hand game s) r) 4)
|
||||
(card-games-gf--set-hand game s (cl-remove r (card-games-gf--hand game s) :key #'cdr))
|
||||
(aset (card-games-get game :books) s (1+ (aref (card-games-get game :books) s))))))
|
||||
|
||||
(cl-defmethod card-games-gf--deal ((game card-games-go-fish-game))
|
||||
"Deal a fresh Go Fish game into GAME."
|
||||
(let* ((n (max 2 (min 5 card-games-go-fish-players)))
|
||||
(deck (card-games-rummy-deck)) (per (if (<= n 3) 7 5))
|
||||
(hands (make-vector n nil)))
|
||||
(dotimes (s n) (aset hands s (cl-loop repeat per collect (pop deck))))
|
||||
(card-games-put game :hands hands)
|
||||
(card-games-put game :books (make-vector n 0))
|
||||
(card-games-put game :nplayers n)
|
||||
(card-games-put game :stock deck)
|
||||
(card-games-put game :turn 0)
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :cursor 0)
|
||||
(dotimes (s n)
|
||||
(card-games-gf--set-hand game s (card-games-rummy-sort-hand (card-games-gf--hand game s)))
|
||||
(card-games-gf--check-books game s))
|
||||
(card-games-put game :message "Pick a card, then press 1-4 to ask that player for its rank.")
|
||||
game))
|
||||
|
||||
(defun card-games-gf--draw (game s)
|
||||
"Draw one stock card into GAME seat S's hand. Return it, or nil if empty."
|
||||
(let ((stock (card-games-get game :stock)))
|
||||
(when stock
|
||||
(card-games-gf--set-hand game s (card-games-rummy-sort-hand (cons (car stock) (card-games-gf--hand game s))))
|
||||
(card-games-put game :stock (cdr stock))
|
||||
(car stock))))
|
||||
|
||||
(defun card-games-gf--total-books (game)
|
||||
"Return the total number of books laid down in GAME."
|
||||
(let ((sum 0)) (dotimes (s (card-games-get game :nplayers))
|
||||
(setq sum (+ sum (card-games-gf--books game s))))
|
||||
sum))
|
||||
|
||||
(defun card-games-gf--maybe-over (game)
|
||||
"End GAME when all thirteen books are made."
|
||||
(when (>= (card-games-gf--total-books game) 13)
|
||||
(let ((best 0))
|
||||
(dotimes (s (card-games-get game :nplayers))
|
||||
(when (> (card-games-gf--books game s) (card-games-gf--books game best)) (setq best s)))
|
||||
(card-games-put game :phase 'game-over)
|
||||
(card-games-put game :winner best)
|
||||
(card-games-put game :message
|
||||
(format "Game over. %s wins with %d books! (n: new game)"
|
||||
(card-games-gf--who best) (card-games-gf--books game best))))))
|
||||
|
||||
(defun card-games-gf--who (s) "Return the display name of seat S." (if (= s 0) "You" (format "Player %d" s)))
|
||||
|
||||
(cl-defmethod card-games-gf--ask ((game card-games-go-fish-game) asker target rank)
|
||||
"In GAME, ASKER asks TARGET for RANK; return non-nil for another turn."
|
||||
(let* ((got (cl-remove-if-not (lambda (c) (= (cdr c) rank)) (card-games-gf--hand game target)))
|
||||
(keep nil))
|
||||
(if got
|
||||
(progn
|
||||
(card-games-gf--set-hand game target (cl-remove rank (card-games-gf--hand game target) :key #'cdr))
|
||||
(card-games-gf--set-hand game asker
|
||||
(card-games-rummy-sort-hand (append got (card-games-gf--hand game asker))))
|
||||
(card-games-put game :message
|
||||
(format "%s took %d %s%s from %s."
|
||||
(card-games-gf--who asker) (length got)
|
||||
(aref card-games-rummy-ranks rank) (if (> (length got) 1) "s" "")
|
||||
(card-games-gf--who target)))
|
||||
(setq keep t))
|
||||
;; go fish
|
||||
(let ((drawn (card-games-gf--draw game asker)))
|
||||
(card-games-put game :message
|
||||
(format "%s asked %s for %ss -- go fish!%s"
|
||||
(card-games-gf--who asker) (card-games-gf--who target) (aref card-games-rummy-ranks rank)
|
||||
(cond ((null drawn) " (stock empty)")
|
||||
((= (cdr drawn) rank) " Fished it -- go again!")
|
||||
(t ""))))
|
||||
(when (and drawn (= (cdr drawn) rank)) (setq keep t))))
|
||||
(card-games-gf--check-books game asker)
|
||||
;; refill an empty hand from the stock if possible
|
||||
(when (and (null (card-games-gf--hand game asker)) (card-games-get game :stock))
|
||||
(card-games-gf--draw game asker))
|
||||
(card-games-gf--maybe-over game)
|
||||
(when (and (eq (card-games-get game :phase) 'play) (not keep))
|
||||
(card-games-put game :turn (card-games-gf--next game asker)))
|
||||
keep))
|
||||
|
||||
(defun card-games-gf--next (game s)
|
||||
"Return the next GAME seat after S that still has cards (or stock to draw)."
|
||||
(let ((n (card-games-get game :nplayers)) (i (mod (1+ s) (card-games-get game :nplayers))) (tries 0))
|
||||
(while (and (< tries n) (null (card-games-gf--hand game i)) (null (card-games-get game :stock)))
|
||||
(setq i (mod (1+ i) n) tries (1+ tries)))
|
||||
i))
|
||||
|
||||
(defun card-games-gf--start-turn (game s)
|
||||
"Ready GAME seat S to act: draw up if empty; pass if it cannot ask.
|
||||
Return non-nil when S can ask."
|
||||
(when (and (null (card-games-gf--hand game s)) (card-games-get game :stock))
|
||||
(card-games-gf--draw game s))
|
||||
(card-games-gf--maybe-over game)
|
||||
(cond ((not (eq (card-games-get game :phase) 'play)) nil)
|
||||
((card-games-gf--hand game s) t)
|
||||
(t (card-games-put game :turn (card-games-gf--next game s)) nil)))
|
||||
|
||||
(cl-defmethod card-games-gf--ai-turn ((game card-games-go-fish-game) s)
|
||||
"Take GAME seat S's whole AI turn (it may keep asking)."
|
||||
(when (card-games-gf--start-turn game s)
|
||||
(let ((guard 0))
|
||||
(while (and (= (card-games-get game :turn) s) (eq (card-games-get game :phase) 'play)
|
||||
(card-games-gf--hand game s) (< guard 40))
|
||||
(setq guard (1+ guard))
|
||||
(let* ((hand (card-games-gf--hand game s))
|
||||
(counts (make-vector 13 0)) (rank (cdr (car hand))))
|
||||
(dolist (c hand) (aset counts (cdr c) (1+ (aref counts (cdr c)))))
|
||||
(dotimes (r 13) (when (> (aref counts r) (aref counts rank)) (setq rank r)))
|
||||
(let* ((others (cl-loop for o below (card-games-get game :nplayers)
|
||||
unless (= o s) when (card-games-gf--hand game o) collect o))
|
||||
(target (and others (nth (random (length others)) others))))
|
||||
(if target (card-games-gf--ask game s target rank)
|
||||
(card-games-put game :turn (card-games-gf--next game s)))))))))
|
||||
|
||||
(defun card-games-gf--run (game)
|
||||
"Advance GAME's AI seats until your turn or the game ends."
|
||||
(let ((guard 0))
|
||||
(while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0) (< guard 1000))
|
||||
(setq guard (1+ guard))
|
||||
(card-games-gf--ai-turn game (card-games-get game :turn))))
|
||||
(when (and (eq (card-games-get game :phase) 'play) (= (card-games-get game :turn) 0))
|
||||
(unless (card-games-gf--start-turn game 0)
|
||||
(when (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0))
|
||||
(card-games-gf--run game)))))
|
||||
|
||||
;;;; Go Fish UI
|
||||
|
||||
(defvar-local card-games-gf--game nil "The Go Fish game in the current buffer.")
|
||||
|
||||
(cl-defmethod card-games-render ((game card-games-go-fish-game))
|
||||
"Return a propertized depiction of the Go Fish GAME."
|
||||
(let* ((out '()) (hand (card-games-gf--hand game 0)) (cursor (card-games-get game :cursor)))
|
||||
(push " Go Fish\n\n" out)
|
||||
(dotimes (s (card-games-get game :nplayers))
|
||||
(unless (= s 0)
|
||||
(push (format " Player %d: %d cards books %d\n"
|
||||
s (length (card-games-gf--hand game s)) (card-games-gf--books game s)) out)))
|
||||
(push (format "\n Stock: %d Your books: %d\n\n"
|
||||
(length (card-games-get game :stock)) (card-games-gf--books game 0)) out)
|
||||
(push " Your hand:\n " out)
|
||||
(push (card-games-rummy--render-cards hand cursor nil nil 'hand) out)
|
||||
(push (format "\n\n %s\n" (card-games-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod card-games-render-apply ((g card-games-go-fish-game) action)
|
||||
"Apply a click ACTION on the hand to GAME G."
|
||||
(pcase action
|
||||
(`(hand . ,i) (card-games-put g :cursor i))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun card-games-gf--hand-ranks (game)
|
||||
"Return the distinct ranks in your GAME hand, low to high (Ace..King)."
|
||||
(let ((seen (make-vector 13 nil)) (out '()))
|
||||
(dolist (c (card-games-gf--hand game 0)) (aset seen (cdr c) t))
|
||||
(dotimes (r 13) (when (aref seen r) (push r out)))
|
||||
(nreverse out)))
|
||||
|
||||
(defun card-games-gf--pick-rank (button)
|
||||
"Select the rank stored on BUTTON, ready to ask a player for it.
|
||||
Moves the hand cursor to a card of that rank so the existing
|
||||
1-4 player keys ask for it."
|
||||
(let* ((g card-games-gf--game) (rank (button-get button 'card-games-gf-rank))
|
||||
(i (cl-position rank (card-games-gf--hand g 0) :key #'cdr)))
|
||||
(when i (card-games-put g :cursor i))
|
||||
(card-games-put g :message
|
||||
(format "Ask which player for %s? Press 1-%d."
|
||||
(aref card-games-rummy-ranks rank) (1- (card-games-get g :nplayers))))
|
||||
(card-games-gf--redisplay)))
|
||||
|
||||
(defun card-games-gf--insert-rank-picker (game)
|
||||
"Insert clickable rank buttons for the ranks in your GAME hand.
|
||||
Each rank is a large, easy target, so you pick what to ask for by rank
|
||||
instead of hunting for one overlapped card in a big hand."
|
||||
(let* ((ranks (card-games-gf--hand-ranks game))
|
||||
(cur (nth (card-games-get game :cursor) (card-games-gf--hand game 0)))
|
||||
(cur-rank (and cur (cdr cur))))
|
||||
(when ranks
|
||||
(insert "\n Ask for: ")
|
||||
(dolist (r ranks)
|
||||
(insert-text-button
|
||||
(format " %s " (aref card-games-rummy-ranks r))
|
||||
'face (if (eql r cur-rank) 'card-games-hint 'link)
|
||||
'mouse-face 'highlight 'follow-link t
|
||||
'help-echo (format "Ask a player for %ss" (aref card-games-rummy-ranks r))
|
||||
'card-games-gf-rank r
|
||||
'action #'card-games-gf--pick-rank)
|
||||
(insert " "))
|
||||
(insert "\n"))))
|
||||
|
||||
(defun card-games-gf--redisplay ()
|
||||
"Redraw the current Go Fish buffer."
|
||||
(let ((game card-games-gf--game) (inhibit-read-only t))
|
||||
(setq card-games-current-game game card-games-redisplay-function #'card-games-gf--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))
|
||||
(erase-buffer)
|
||||
(insert (card-games-render game))
|
||||
(card-games-gf--insert-rank-picker game)
|
||||
(card-games-insert-legend "click a rank (or arrows) · 1-4 ask that player · n new · q menu · ? help")
|
||||
(goto-char (point-min))))
|
||||
|
||||
(defun card-games-gf-left ()
|
||||
"Move the hand cursor left."
|
||||
(interactive)
|
||||
(let* ((g card-games-gf--game) (n (length (card-games-gf--hand g 0))))
|
||||
(when (> n 0) (card-games-put g :cursor (mod (1- (card-games-get g :cursor)) n)))
|
||||
(card-games-gf--redisplay)))
|
||||
|
||||
(defun card-games-gf-right ()
|
||||
"Move the hand cursor right."
|
||||
(interactive)
|
||||
(let* ((g card-games-gf--game) (n (length (card-games-gf--hand g 0))))
|
||||
(when (> n 0) (card-games-put g :cursor (mod (1+ (card-games-get g :cursor)) n)))
|
||||
(card-games-gf--redisplay)))
|
||||
|
||||
(defun card-games-gf-ask ()
|
||||
"Ask the player whose number you pressed for the cursor card's rank."
|
||||
(interactive)
|
||||
(let* ((g card-games-gf--game)
|
||||
(target (- last-command-event ?0))
|
||||
(card (nth (card-games-get g :cursor) (card-games-gf--hand g 0))))
|
||||
(cond
|
||||
((not (eq (card-games-get g :phase) 'play)) (card-games-put g :message "Press n for a new game."))
|
||||
((/= (card-games-get g :turn) 0) (card-games-put g :message "Not your turn."))
|
||||
((null card) (card-games-put g :message "Pick a card first."))
|
||||
((or (< target 1) (>= target (card-games-get g :nplayers)))
|
||||
(card-games-put g :message "No such player to ask."))
|
||||
((null (card-games-gf--hand g target)) (card-games-put g :message "That player has no cards."))
|
||||
(t (card-games-gf--ask g 0 target (cdr card))
|
||||
(card-games-put g :cursor 0)
|
||||
(unless (= (card-games-get g :turn) 0) (card-games-gf--run g))))
|
||||
(card-games-gf--redisplay)))
|
||||
|
||||
(defun card-games-gf-new () "Deal a new Go Fish game." (interactive)
|
||||
(card-games-gf--deal card-games-gf--game) (card-games-gf--redisplay))
|
||||
(defun card-games-gf-redraw () "Redraw." (interactive) (card-games-gf--redisplay))
|
||||
(defun card-games-gf-help () "Describe the controls." (interactive)
|
||||
(message
|
||||
"Click a rank (or arrows) to choose 1-4: ask that player n: new q: menu"))
|
||||
|
||||
(defvar card-games-go-fish-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'card-games-card-click)
|
||||
(define-key map "+" #'card-games-card-zoom-in)
|
||||
(define-key map "=" #'card-games-card-zoom-in)
|
||||
(define-key map "-" #'card-games-card-zoom-out)
|
||||
(define-key map "0" #'card-games-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'card-games-gf-left)
|
||||
(define-key map (kbd "<right>") #'card-games-gf-right)
|
||||
(dolist (k '("1" "2" "3" "4")) (define-key map k #'card-games-gf-ask))
|
||||
(define-key map "n" #'card-games-gf-new)
|
||||
(define-key map "g" #'card-games-gf-redraw)
|
||||
(define-key map "?" #'card-games-gf-help)
|
||||
(define-key map "q" #'card-games-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `card-games-go-fish-mode'.")
|
||||
|
||||
(define-derived-mode card-games-go-fish-mode special-mode "GoFish"
|
||||
"Major mode for Go Fish."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type card-games-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-go-fish ()
|
||||
"Play Go Fish against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Go Fish*")))
|
||||
(with-current-buffer buf
|
||||
(card-games-go-fish-mode)
|
||||
(setq card-games-gf--game (card-games-go-fish-game))
|
||||
(card-games-gf--deal card-games-gf--game)
|
||||
(card-games-gf--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
|
||||
;;;; Old Maid
|
||||
|
||||
(defcustom card-games-old-maid-players 3
|
||||
"Number of players in Old Maid, including you (2-5)."
|
||||
:type '(choice (const 2) (const 3) (const 4) (const 5)) :group 'card-games)
|
||||
|
||||
(defclass card-games-old-maid-game (card-games-game)
|
||||
((vname :initform "Old Maid"))
|
||||
"A game of Old Maid.")
|
||||
|
||||
(defsubst card-games-om--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
|
||||
(defsubst card-games-om--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
|
||||
|
||||
(defun card-games-om--discard-pairs (hand)
|
||||
"Return HAND with every matched pair of ranks removed."
|
||||
(let ((out '()) (byrank (make-hash-table :test 'eql)))
|
||||
(dolist (c hand) (push c (gethash (cdr c) byrank)))
|
||||
(maphash (lambda (_r cs)
|
||||
(when (cl-oddp (length cs)) (push (car cs) out)))
|
||||
byrank)
|
||||
(card-games-rummy-sort-hand out)))
|
||||
|
||||
(cl-defmethod card-games-om--deal ((game card-games-old-maid-game))
|
||||
"Deal a fresh Old Maid game into GAME (one Queen removed)."
|
||||
(let* ((n (max 2 (min 5 card-games-old-maid-players)))
|
||||
(deck (cl-remove (cons 0 11) (card-games-rummy-deck) :test #'equal :count 1))
|
||||
(hands (make-vector n nil)) (i 0))
|
||||
(dolist (c deck)
|
||||
(aset hands i (cons c (aref hands i)))
|
||||
(setq i (mod (1+ i) n)))
|
||||
(dotimes (s n) (aset hands s (card-games-om--discard-pairs (aref hands s))))
|
||||
(card-games-put game :hands hands)
|
||||
(card-games-put game :nplayers n)
|
||||
(card-games-put game :turn 0)
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :pick 0)
|
||||
(card-games-put game :message "Draw a card from the next player: arrows pick, RET draws.")
|
||||
(card-games-om--skip-empty game)
|
||||
game))
|
||||
|
||||
(defun card-games-om--active (game)
|
||||
"Return GAME's seats still holding cards."
|
||||
(cl-loop for s below (card-games-get game :nplayers)
|
||||
when (card-games-om--hand game s) collect s))
|
||||
|
||||
(defun card-games-om--target (game s)
|
||||
"Return the next active GAME seat after S to draw from."
|
||||
(let ((n (card-games-get game :nplayers)) (i (mod (1+ s) (card-games-get game :nplayers))) (tries 0))
|
||||
(while (and (< tries n) (or (= i s) (null (card-games-om--hand game i))))
|
||||
(setq i (mod (1+ i) n) tries (1+ tries)))
|
||||
(and (card-games-om--hand game i) i)))
|
||||
|
||||
(defun card-games-om--skip-empty (game)
|
||||
"Advance GAME's turn past any seat that has run out of cards."
|
||||
(let ((n (card-games-get game :nplayers)) (tries 0))
|
||||
(while (and (< tries n) (null (card-games-om--hand game (card-games-get game :turn))))
|
||||
(card-games-put game :turn (mod (1+ (card-games-get game :turn)) n))
|
||||
(setq tries (1+ tries)))))
|
||||
|
||||
(defun card-games-om--total (game)
|
||||
"Return the total cards remaining in GAME."
|
||||
(let ((sum 0)) (dotimes (s (card-games-get game :nplayers))
|
||||
(setq sum (+ sum (length (card-games-om--hand game s)))))
|
||||
sum))
|
||||
|
||||
(cl-defmethod card-games-om--draw ((game card-games-old-maid-game) drawer idx)
|
||||
"In GAME, DRAWER takes card IDX from the next hand, then discards a pair."
|
||||
(let ((target (card-games-om--target game drawer)))
|
||||
(when target
|
||||
(let* ((thand (card-games-om--hand game target))
|
||||
(card (nth (min idx (1- (length thand))) thand)))
|
||||
(card-games-om--set-hand game target (cl-remove card thand :test #'equal :count 1))
|
||||
(card-games-om--set-hand game drawer
|
||||
(card-games-om--discard-pairs (cons card (card-games-om--hand game drawer))))
|
||||
(card-games-put game :message
|
||||
(format "%s drew from %s."
|
||||
(if (= drawer 0) "You" (format "Player %d" drawer))
|
||||
(if (= target 0) "you" (format "Player %d" target))))))
|
||||
(if (<= (card-games-om--total game) 1)
|
||||
(card-games-om--finish game)
|
||||
(card-games-put game :turn (mod (1+ drawer) (card-games-get game :nplayers)))
|
||||
(card-games-put game :pick 0)
|
||||
(card-games-om--skip-empty game))))
|
||||
|
||||
(cl-defmethod card-games-om--finish ((game card-games-old-maid-game))
|
||||
"End GAME; whoever has the last card is the Old Maid."
|
||||
(let ((loser (car (card-games-om--active game))))
|
||||
(card-games-put game :phase 'game-over)
|
||||
(card-games-put game :winner loser)
|
||||
(card-games-put game :message
|
||||
(if loser
|
||||
(format "%s is left holding the Old Maid! (n: new game)"
|
||||
(if (= loser 0) "You are" (format "Player %d is" loser)))
|
||||
"All paired off -- a draw! (n: new game)"))))
|
||||
|
||||
(defun card-games-om--ai-turn (game s)
|
||||
"Take GAME seat S's AI turn: draw a random card from the next hand."
|
||||
(let ((target (card-games-om--target game s)))
|
||||
(if (null target) (card-games-om--finish game)
|
||||
(card-games-om--draw game s (random (length (card-games-om--hand game target)))))))
|
||||
|
||||
(defun card-games-om--run (game)
|
||||
"Advance GAME's AI seats until your turn or the game ends."
|
||||
(let ((guard 0))
|
||||
(while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0) (< guard 500))
|
||||
(setq guard (1+ guard))
|
||||
(card-games-om--ai-turn game (card-games-get game :turn)))))
|
||||
|
||||
;;;; Old Maid UI
|
||||
|
||||
(defvar-local card-games-om--game nil "The Old Maid game in the current buffer.")
|
||||
|
||||
(defun card-games-om--svg (game)
|
||||
"Return an SVG board for the Old Maid GAME."
|
||||
(let* ((w card-games-svg-card-width) (h card-games-svg-card-height) (gap card-games-svg-card-gap) (pad 16)
|
||||
(hand (card-games-om--hand game 0)) (n (length hand))
|
||||
(target (card-games-om--target game 0)) (pick (or (card-games-get game :pick) 0))
|
||||
(yourp (and target (eq (card-games-get game :phase) 'play) (= (card-games-get game :turn) 0)))
|
||||
(np (card-games-get game :nplayers))
|
||||
(overlap (cond ((> n 11) (- w 24)) ((> n 8) 20) (t 0)))
|
||||
(step (max 14 (- (+ w gap) overlap)))
|
||||
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
|
||||
(bstep 20)
|
||||
(tn (and target (length (card-games-om--hand game target))))
|
||||
(y-title 6) (y-info 26)
|
||||
(y-target (+ y-info (* (1- np) 16) 18))
|
||||
(y-hand (+ y-target h 42))
|
||||
(targetw (if (and yourp tn (> tn 0)) (+ (* (1- tn) bstep) w) 0))
|
||||
(height (+ y-hand h 30))
|
||||
(width (max (+ fanw (* 2 pad)) (+ targetw (* 2 pad)) 560))
|
||||
(svg (svg-create width height))
|
||||
(lc (card-games-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels ((txt (str x y &optional sz bold)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family card-games-svg-font-family (and bold '(:font-weight "bold")))))
|
||||
(txt "Old Maid" pad (+ y-title 12) 13 t)
|
||||
(let ((yy (+ y-info 4)))
|
||||
(dotimes (s np)
|
||||
(unless (= s 0)
|
||||
(txt (format "Player %d: %d cards%s" s (length (card-games-om--hand game s))
|
||||
(if (eql s target) " <- draw from here" ""))
|
||||
pad yy 12)
|
||||
(setq yy (+ yy 16)))))
|
||||
(when (and yourp tn (> tn 0))
|
||||
(txt (format "Pick a card from Player %d:" target) pad (- y-target 6) 11)
|
||||
(let ((x pad))
|
||||
(dotimes (i tn)
|
||||
(card-games-svg-card svg x y-target :down t :highlight (= i pick))
|
||||
(push (cons (list x y-target (if (= i (1- tn)) w bstep) h) (cons 'pick i))
|
||||
regions)
|
||||
(setq x (+ x bstep)))))
|
||||
(txt "Your hand" pad (- y-hand 6) 11)
|
||||
(let ((x (max pad (- (/ width 2) (/ fanw 2)))))
|
||||
(dolist (c hand)
|
||||
(let ((sp (card-games-rummy--card-spec c)))
|
||||
(card-games-svg-card svg x y-hand :rank (car sp) :suit (cdr sp)))
|
||||
(setq x (+ x step))))
|
||||
(txt (or (card-games-get game :message) "") pad (- height 8) 12))
|
||||
(propertize "*" 'display (card-games-svg-image svg (card-games-scale)) 'card-games-regions (nreverse regions))))
|
||||
|
||||
(cl-defmethod card-games-render-apply ((g card-games-old-maid-game) action)
|
||||
"Apply click ACTION on G: pick that card from the target and draw it."
|
||||
(pcase action
|
||||
(`(pick . ,i) (card-games-put g :pick i) (card-games-om-draw))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(cl-defmethod card-games-render ((game card-games-old-maid-game))
|
||||
"Return a depiction of the Old Maid GAME: SVG board if graphical, else text."
|
||||
(if (and card-games-rummy-svg-cards (display-graphic-p))
|
||||
(card-games-om--svg game)
|
||||
(card-games-om--render-text game)))
|
||||
|
||||
(defun card-games-om--render-text (game)
|
||||
"Return a plain-text depiction of the Old Maid GAME."
|
||||
(let* ((out '()) (target (card-games-om--target game 0)))
|
||||
(push " Old Maid\n\n" out)
|
||||
(dotimes (s (card-games-get game :nplayers))
|
||||
(unless (= s 0)
|
||||
(push (format " Player %d: %d cards%s\n" s (length (card-games-om--hand game s))
|
||||
(if (eql s target) " <- you draw from here" "")) out)))
|
||||
(when (and target (eq (card-games-get game :phase) 'play) (= (card-games-get game :turn) 0))
|
||||
(push (format "\n Player %d's cards (pick one to draw):\n " target) out)
|
||||
(let ((np (length (card-games-om--hand game target))) (pk (card-games-get game :pick)))
|
||||
(dotimes (i np)
|
||||
(push (propertize " ##" 'face (if (= i pk) 'card-games-cursor 'card-games-gap)) out))))
|
||||
(push "\n\n Your hand:\n " out)
|
||||
(push (card-games-rummy--render-cards (card-games-om--hand game 0) -1 nil) out)
|
||||
(push (format "\n\n %s\n" (card-games-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(defun card-games-om--redisplay ()
|
||||
"Redraw the current Old Maid buffer."
|
||||
(let ((game card-games-om--game) (inhibit-read-only t))
|
||||
(setq card-games-current-game game card-games-redisplay-function #'card-games-om--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))
|
||||
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
|
||||
|
||||
(defun card-games-om-left ()
|
||||
"Move the pick cursor left over the target's cards."
|
||||
(interactive)
|
||||
(let* ((g card-games-om--game) (target (card-games-om--target g 0))
|
||||
(np (and target (length (card-games-om--hand g target)))))
|
||||
(when (and np (> np 0)) (card-games-put g :pick (mod (1- (card-games-get g :pick)) np)))
|
||||
(card-games-om--redisplay)))
|
||||
|
||||
(defun card-games-om-right ()
|
||||
"Move the pick cursor right over the target's cards."
|
||||
(interactive)
|
||||
(let* ((g card-games-om--game) (target (card-games-om--target g 0))
|
||||
(np (and target (length (card-games-om--hand g target)))))
|
||||
(when (and np (> np 0)) (card-games-put g :pick (mod (1+ (card-games-get g :pick)) np)))
|
||||
(card-games-om--redisplay)))
|
||||
|
||||
(defun card-games-om-draw ()
|
||||
"Draw the selected card from the next player."
|
||||
(interactive)
|
||||
(let ((g card-games-om--game))
|
||||
(cond
|
||||
((not (eq (card-games-get g :phase) 'play)) (card-games-put g :message "Press n for a new game."))
|
||||
((/= (card-games-get g :turn) 0) (card-games-put g :message "Not your turn."))
|
||||
(t (card-games-om--draw g 0 (card-games-get g :pick))
|
||||
(unless (= (card-games-get g :turn) 0) (card-games-om--run g))))
|
||||
(card-games-om--redisplay)))
|
||||
|
||||
(defun card-games-om-new () "Deal a new Old Maid game." (interactive)
|
||||
(card-games-om--deal card-games-om--game) (card-games-om--redisplay))
|
||||
(defun card-games-om-redraw () "Redraw." (interactive) (card-games-om--redisplay))
|
||||
(defun card-games-om-help () "Describe the controls." (interactive)
|
||||
(message "Arrows: pick a card from the next player RET: draw it n: new g: redraw"))
|
||||
|
||||
(defvar card-games-old-maid-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'card-games-card-click)
|
||||
(define-key map "+" #'card-games-card-zoom-in)
|
||||
(define-key map "=" #'card-games-card-zoom-in)
|
||||
(define-key map "-" #'card-games-card-zoom-out)
|
||||
(define-key map "0" #'card-games-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'card-games-om-left)
|
||||
(define-key map (kbd "<right>") #'card-games-om-right)
|
||||
(define-key map (kbd "RET") #'card-games-om-draw)
|
||||
(define-key map "n" #'card-games-om-new)
|
||||
(define-key map "g" #'card-games-om-redraw)
|
||||
(define-key map "?" #'card-games-om-help)
|
||||
(define-key map "q" #'card-games-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `card-games-old-maid-mode'.")
|
||||
|
||||
(define-derived-mode card-games-old-maid-mode special-mode "OldMaid"
|
||||
"Major mode for Old Maid."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type card-games-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-old-maid ()
|
||||
"Play Old Maid against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Old Maid*")))
|
||||
(with-current-buffer buf
|
||||
(card-games-old-maid-mode)
|
||||
(setq card-games-om--game (card-games-old-maid-game))
|
||||
(card-games-om--deal card-games-om--game)
|
||||
(card-games-om--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
(provide 'card-games-match)
|
||||
;;; card-games-match.el ends here
|
||||
352
card-games-net.el
Normal file
352
card-games-net.el
Normal file
|
|
@ -0,0 +1,352 @@
|
|||
;;; card-games-net.el --- Networked multiplayer for card games -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Host-authoritative networking for the card games. One Emacs is the
|
||||
;; HOST: it owns the canonical game and listens for players. Other
|
||||
;; Emacsen CONNECT as clients, send move "intents", and receive the new
|
||||
;; game state to redraw. Because the games are turn-based there is
|
||||
;; nothing to merge, so this is a simple authoritative server rather
|
||||
;; than a CRDT; crdt.el is kept in reserve for any future free-form
|
||||
;; shared state.
|
||||
;;
|
||||
;; Transport is line-delimited s-expressions over `make-network-process'
|
||||
;; (plain TCP), so it works wherever Emacs has TCP -- including an
|
||||
;; Android client joining a desktop host. A message is a plist with a
|
||||
;; `:type' key:
|
||||
;;
|
||||
;; client -> host: (:type hello :name NAME)
|
||||
;; (:type move :move MOVE)
|
||||
;; host -> client: (:type welcome :seat N)
|
||||
;; (:type state :state SEXP)
|
||||
;;
|
||||
;; A game plugs in by defining methods on `card-games-net-apply-move' (host
|
||||
;; side) and, if its state is not just the env plist, on
|
||||
;; `card-games-net-game-state' / `card-games-net-set-game-state'. Clients add a
|
||||
;; redraw function to `card-games-net-state-functions'.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'card-games-core)
|
||||
|
||||
(defgroup card-games-net nil
|
||||
"Networked play for card games."
|
||||
:group 'card-games
|
||||
:prefix "card-games-net-")
|
||||
|
||||
(defcustom card-games-net-port 7500
|
||||
"Default TCP port used to host or join a game."
|
||||
:type 'integer :group 'card-games-net)
|
||||
|
||||
(defcustom card-games-net-host-address "127.0.0.1"
|
||||
"Address the host's listening socket binds when hosting a game.
|
||||
The default, \"127.0.0.1\", accepts connections only from this
|
||||
machine; remote players reach it through a tunnel they were
|
||||
deliberately given (for example ssh port forwarding), which also
|
||||
encrypts the traffic in transit.
|
||||
|
||||
Setting this to \"0.0.0.0\" listens on every network interface, which
|
||||
means anyone able to reach this machine's port can take a seat: there
|
||||
is no password and no encryption on the wire. That can be a
|
||||
reasonable choice on a trusted LAN, but it is a choice -- make it
|
||||
deliberately."
|
||||
:type '(choice (const :tag "This machine only (recommended)" "127.0.0.1")
|
||||
(const :tag "Every interface (anyone who can reach you)" "0.0.0.0")
|
||||
(string :tag "A specific interface address"))
|
||||
:group 'card-games-net)
|
||||
|
||||
(defcustom card-games-net-max-line 65536
|
||||
"Longest unterminated line accepted from a connection, in bytes.
|
||||
Messages in this protocol are short; 64 KiB is generous. A connection
|
||||
whose pending (newline-less) data exceeds this is closed, so one peer
|
||||
cannot grow the line buffer until memory runs out."
|
||||
:type 'integer :group 'card-games-net)
|
||||
|
||||
(defcustom card-games-net-max-connections 8
|
||||
"Most simultaneous client connections a host will accept.
|
||||
A table seats four, so the default leaves headroom without letting the
|
||||
client list grow unboundedly. Connections beyond the limit are closed
|
||||
as they arrive."
|
||||
:type 'integer :group 'card-games-net)
|
||||
|
||||
(defvar card-games-net-state-functions nil
|
||||
"Abnormal hook run on a client after the game state is updated.
|
||||
Each function is called with the client's game object.")
|
||||
|
||||
(defvar card-games-net-connect-functions nil
|
||||
"Abnormal hook run on the host when a client connects.
|
||||
Each function is called with (HOST SEAT): the `card-games-net-host' struct and
|
||||
the seat number just assigned to the new connection.")
|
||||
|
||||
;;;; Game integration points
|
||||
|
||||
(cl-defgeneric card-games-net-apply-move (game seat move)
|
||||
"Apply MOVE made by SEAT to GAME on the host.
|
||||
Return non-nil when the move was accepted (and state should broadcast).")
|
||||
|
||||
(cl-defgeneric card-games-net-game-state (game &optional seat)
|
||||
"Return a `read'able representation of GAME's shared state for SEAT.
|
||||
SEAT is the recipient's seat number, letting a game hide other players'
|
||||
private information; nil requests the full host view.")
|
||||
|
||||
(cl-defmethod card-games-net-game-state ((game card-games-game) &optional _seat)
|
||||
"Default: return GAME's env plist (no per-seat filtering)."
|
||||
(oref game env))
|
||||
|
||||
(cl-defgeneric card-games-net-set-game-state (game state)
|
||||
"Replace GAME's shared state with STATE on a client.")
|
||||
|
||||
(cl-defmethod card-games-net-set-game-state ((game card-games-game) state)
|
||||
"Default: install STATE as GAME's env plist."
|
||||
(oset game env state))
|
||||
|
||||
;;;; Wire protocol
|
||||
|
||||
(defun card-games-net--send (proc msg)
|
||||
"Send MSG (a sexp) to PROC as one newline-terminated line."
|
||||
(when (process-live-p proc)
|
||||
(let ((print-length nil) (print-level nil))
|
||||
(process-send-string proc (concat (prin1-to-string msg) "\n")))))
|
||||
|
||||
(defun card-games-net--scrub (x)
|
||||
"Return X with text properties removed from every string inside it.
|
||||
Walks conses and vectors, tolerating shared and circular structure.
|
||||
Everything arriving over the network passes through this: text
|
||||
properties can rebind keys or carry expressions evaluated during
|
||||
redisplay, and there is never a reason to honour a remote peer's."
|
||||
(let ((seen (make-hash-table :test 'eq)))
|
||||
(cl-labels ((walk (v)
|
||||
(cond
|
||||
((stringp v) (substring-no-properties v))
|
||||
((consp v)
|
||||
(or (gethash v seen)
|
||||
(let ((cell (cons nil nil)))
|
||||
(puthash v cell seen)
|
||||
(setcar cell (walk (car v)))
|
||||
(setcdr cell (walk (cdr v)))
|
||||
cell)))
|
||||
((vectorp v)
|
||||
(or (gethash v seen)
|
||||
(let ((copy (make-vector (length v) nil)))
|
||||
(puthash v copy seen)
|
||||
(dotimes (i (length v))
|
||||
(aset copy i (walk (aref v i))))
|
||||
copy)))
|
||||
(t v))))
|
||||
(walk x))))
|
||||
|
||||
(defconst card-games-net-max-nodes 20000
|
||||
"Upper bound on the number of nodes accepted in one wire message.")
|
||||
|
||||
(defun card-games-net--valid-p (msg types)
|
||||
"Return non-nil when MSG is a well-shaped protocol message.
|
||||
TYPES is the list of message-type symbols accepted from this peer.
|
||||
MSG must be a proper plist whose `:type' is in TYPES, built only from
|
||||
conses, vectors, strings, numbers and symbols, with no shared or
|
||||
circular structure and at most `card-games-net-max-nodes' nodes. Accept what
|
||||
is recognised rather than trying to spot what is bad: parsed text can
|
||||
carry self-references that hang code walking them, and objects that
|
||||
impersonate internal record types."
|
||||
(let ((seen (make-hash-table :test 'eq))
|
||||
(nodes 0))
|
||||
(cl-labels ((clean-p (v)
|
||||
(cond
|
||||
((> (cl-incf nodes) card-games-net-max-nodes) nil)
|
||||
((consp v)
|
||||
(and (not (gethash v seen))
|
||||
(progn (puthash v t seen)
|
||||
(and (clean-p (car v)) (clean-p (cdr v))))))
|
||||
((vectorp v)
|
||||
(and (not (gethash v seen))
|
||||
(progn (puthash v t seen)
|
||||
(cl-every #'clean-p v))))
|
||||
((or (stringp v) (numberp v) (symbolp v)) t)
|
||||
(t nil))))
|
||||
(and (consp msg)
|
||||
(clean-p msg) ; safe before plist-get: no cycles past here
|
||||
(null (cdr (last msg))) ; a proper list
|
||||
(cl-evenp (length msg)) ; of key/value pairs
|
||||
(memq (plist-get msg :type) types)))))
|
||||
|
||||
(defun card-games-net--filter (handler types)
|
||||
"Return a process filter dispatching each complete line to HANDLER.
|
||||
HANDLER is called with (PROC MSG) for each line that parses into a
|
||||
well-shaped message (`card-games-net--valid-p') whose type is in TYPES;
|
||||
strings inside MSG have their text properties stripped first, by
|
||||
`card-games-net--scrub'. Anything else is dropped where it lands."
|
||||
(lambda (proc string)
|
||||
(let ((buf (concat (or (process-get proc 'card-games-net-buf) "") string))
|
||||
(start 0) nl)
|
||||
(while (setq nl (cl-search "\n" buf :start2 start))
|
||||
(let ((line (substring buf start nl)))
|
||||
(setq start (1+ nl))
|
||||
(unless (string-empty-p line)
|
||||
(condition-case err
|
||||
(let ((msg (car (read-from-string line))))
|
||||
(if (card-games-net--valid-p msg types)
|
||||
(funcall handler proc (card-games-net--scrub msg))
|
||||
(message "card-games-net: dropped malformed message")))
|
||||
(error (message "card-games-net: bad message: %S" err))))))
|
||||
(let ((rest (substring buf start)))
|
||||
(if (> (length rest) card-games-net-max-line)
|
||||
(progn
|
||||
(process-put proc 'card-games-net-buf nil)
|
||||
(message "card-games-net: dropping %s (line over %d bytes)"
|
||||
(process-name proc) card-games-net-max-line)
|
||||
(delete-process proc))
|
||||
(process-put proc 'card-games-net-buf rest))))))
|
||||
|
||||
;;;; Host
|
||||
|
||||
(cl-defstruct (card-games-net-host (:constructor card-games-net--host-make))
|
||||
server game (clients nil) (next-seat 0))
|
||||
|
||||
(defvar card-games-net--host nil
|
||||
"The running `card-games-net-host', or nil when not hosting.")
|
||||
|
||||
(defun card-games-net-hosting-p ()
|
||||
"Return non-nil when this Emacs is hosting a game."
|
||||
(and card-games-net--host (process-live-p (card-games-net-host-server card-games-net--host))))
|
||||
|
||||
(defun card-games-net-host-start (game &optional port)
|
||||
"Begin hosting GAME on PORT (default `card-games-net-port').
|
||||
Return the server process. The socket binds
|
||||
`card-games-net-host-address' -- by default, this machine only."
|
||||
(let* ((port (or port card-games-net-port))
|
||||
(server (make-network-process
|
||||
:name "card-games-host" :server t :service port
|
||||
:host card-games-net-host-address :family 'ipv4 :coding 'utf-8
|
||||
:log #'card-games-net--host-accept)))
|
||||
(setq card-games-net--host (card-games-net--host-make :server server :game game))
|
||||
server))
|
||||
|
||||
(defun card-games-net-host-stop ()
|
||||
"Stop hosting and close all client connections."
|
||||
(when card-games-net--host
|
||||
(dolist (c (card-games-net-host-clients card-games-net--host))
|
||||
(when (process-live-p c) (delete-process c)))
|
||||
(when (process-live-p (card-games-net-host-server card-games-net--host))
|
||||
(delete-process (card-games-net-host-server card-games-net--host)))
|
||||
(setq card-games-net--host nil)))
|
||||
|
||||
(defun card-games-net--host-sentinel (proc _event)
|
||||
"Reap PROC from the client list when its connection has ended.
|
||||
Without this, departed players stay listed forever and the host keeps
|
||||
sending to them. Seat numbers are deliberately not reused: a stale
|
||||
seat must not be inherited by a stranger mid-game."
|
||||
(unless (process-live-p proc)
|
||||
(when card-games-net--host
|
||||
(setf (card-games-net-host-clients card-games-net--host)
|
||||
(delq proc (card-games-net-host-clients card-games-net--host))))))
|
||||
|
||||
(defun card-games-net--host-accept (_server connection _message)
|
||||
"Set up an accepted CONNECTION: assign a seat and send the current state.
|
||||
A connection arriving past `card-games-net-max-connections' is closed instead."
|
||||
(if (>= (length (cl-remove-if-not #'process-live-p
|
||||
(card-games-net-host-clients card-games-net--host)))
|
||||
card-games-net-max-connections)
|
||||
(progn
|
||||
(message "card-games-net: refusing connection (table is at %d)"
|
||||
card-games-net-max-connections)
|
||||
(delete-process connection))
|
||||
(let ((seat (card-games-net-host-next-seat card-games-net--host)))
|
||||
(setf (card-games-net-host-next-seat card-games-net--host) (1+ seat))
|
||||
(push connection (card-games-net-host-clients card-games-net--host))
|
||||
(process-put connection 'card-games-net-seat seat)
|
||||
(set-process-coding-system connection 'utf-8 'utf-8)
|
||||
(set-process-sentinel connection #'card-games-net--host-sentinel)
|
||||
(set-process-filter connection
|
||||
(card-games-net--filter #'card-games-net--host-handle '(hello move)))
|
||||
(card-games-net--send connection (list :type 'welcome :seat seat))
|
||||
(card-games-net--send connection
|
||||
(list :type 'state
|
||||
:state (card-games-net-game-state (card-games-net-host-game card-games-net--host) seat)))
|
||||
(run-hook-with-args 'card-games-net-connect-functions card-games-net--host seat))))
|
||||
|
||||
(defun card-games-net--host-handle (proc msg)
|
||||
"Handle one message MSG from a client PROC on the host."
|
||||
(pcase (plist-get msg :type)
|
||||
('hello (process-put proc 'card-games-net-name (plist-get msg :name)))
|
||||
('move
|
||||
(let ((seat (process-get proc 'card-games-net-seat))
|
||||
(game (card-games-net-host-game card-games-net--host)))
|
||||
(when (card-games-net-apply-move game seat (plist-get msg :move))
|
||||
(card-games-net-host-broadcast))))))
|
||||
|
||||
(defun card-games-net-host-broadcast ()
|
||||
"Send each connected client the game state filtered for its seat."
|
||||
(when card-games-net--host
|
||||
(let ((game (card-games-net-host-game card-games-net--host)))
|
||||
(dolist (c (card-games-net-host-clients card-games-net--host))
|
||||
(card-games-net--send c (list :type 'state
|
||||
:state (card-games-net-game-state
|
||||
game (process-get c 'card-games-net-seat))))))))
|
||||
|
||||
;;;; Client
|
||||
|
||||
(cl-defstruct (card-games-net-client (:constructor card-games-net--client-make))
|
||||
proc game (seat nil))
|
||||
|
||||
(defvar card-games-net--client nil
|
||||
"The active `card-games-net-client', or nil when not connected.")
|
||||
|
||||
(defun card-games-net-connected-p ()
|
||||
"Return non-nil when connected to a host as a client."
|
||||
(and card-games-net--client (process-live-p (card-games-net-client-proc card-games-net--client))))
|
||||
|
||||
(defun card-games-net-connect (host port name game)
|
||||
"Connect to HOST on PORT as NAME, syncing into the local GAME.
|
||||
Return the new `card-games-net-client'."
|
||||
(let ((proc (make-network-process
|
||||
:name "card-games-client" :host host :service port
|
||||
:family 'ipv4 :coding 'utf-8)))
|
||||
(setq card-games-net--client (card-games-net--client-make :proc proc :game game))
|
||||
(set-process-coding-system proc 'utf-8 'utf-8)
|
||||
(set-process-filter proc
|
||||
(card-games-net--filter #'card-games-net--client-handle
|
||||
'(welcome state full)))
|
||||
(card-games-net--send proc (list :type 'hello :name name))
|
||||
card-games-net--client))
|
||||
|
||||
(defun card-games-net-disconnect ()
|
||||
"Disconnect from the host."
|
||||
(when (and card-games-net--client (process-live-p (card-games-net-client-proc card-games-net--client)))
|
||||
(delete-process (card-games-net-client-proc card-games-net--client)))
|
||||
(setq card-games-net--client nil))
|
||||
|
||||
(defun card-games-net--client-handle (_proc msg)
|
||||
"Handle one message MSG from the host on a client."
|
||||
(pcase (plist-get msg :type)
|
||||
('welcome (setf (card-games-net-client-seat card-games-net--client) (plist-get msg :seat)))
|
||||
('state
|
||||
(let ((game (card-games-net-client-game card-games-net--client)))
|
||||
(card-games-net-set-game-state game (plist-get msg :state))
|
||||
(run-hook-with-args 'card-games-net-state-functions game)))))
|
||||
|
||||
(defun card-games-net-send-move (move)
|
||||
"Send MOVE to the host from this client."
|
||||
(card-games-net--send (card-games-net-client-proc card-games-net--client) (list :type 'move :move move)))
|
||||
|
||||
(provide 'card-games-net)
|
||||
;;; card-games-net.el ends here
|
||||
456
card-games-patience.el
Normal file
456
card-games-patience.el
Normal file
|
|
@ -0,0 +1,456 @@
|
|||
;;; card-games-patience.el --- Pile solitaires (Golf, TriPeaks, Pyramid) -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Three "pile" solitaires that clear a fixed layout of cards rather than
|
||||
;; building tableau columns:
|
||||
;;
|
||||
;; `card-games-golf' -- move an exposed card to the waste when it is one rank
|
||||
;; above or below the waste's top card; deal when stuck.
|
||||
;; `card-games-tripeaks' -- the same, on three overlapping peaks, with Ace-King
|
||||
;; wrapping so long chains are possible.
|
||||
;; `card-games-pyramid' -- remove pairs of exposed cards whose ranks sum to 13
|
||||
;; (Kings go alone); deal from the stock to help.
|
||||
;;
|
||||
;; A board is a vector of card slots; each slot lists the slots that cover
|
||||
;; it, and a slot is "exposed" (playable) once all its coverers are gone.
|
||||
;; Cards are the package-standard cons (SUIT . RANK) with RANK 0 Ace .. 12
|
||||
;; King; a rank's value for the sum-of-13 rule is RANK + 1.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-svg)
|
||||
|
||||
(defconst card-games-pat-ranks
|
||||
["A" "2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K"]
|
||||
"Rank labels indexed 0 (Ace) .. 12 (King).")
|
||||
|
||||
(defun card-games-pat-card-string (card)
|
||||
"Return a short string for CARD, or a dot for an empty slot."
|
||||
(if (null card) "·"
|
||||
(concat (aref card-games-pat-ranks (cdr card)) (card-games-suit-glyph (car card)))))
|
||||
|
||||
(defsubst card-games-pat-red-p (card) "Return non-nil when CARD is red." (and card (card-games-red-suit-p (car card))))
|
||||
|
||||
(defun card-games-pat--deck () "Return a fresh shuffled 52-card deck." (card-games-shuffle (cl-loop for s below 4 append
|
||||
(cl-loop for r below 13 collect (cons s r)))))
|
||||
|
||||
;;;; Classes
|
||||
|
||||
(defclass card-games-patience-game (card-games-game)
|
||||
((mode :initform 'build :documentation "Play mode: build (waste) or sum13.")
|
||||
(wrap :initform nil :documentation "Whether Ace-King wrap in build mode.")
|
||||
(vname :initform "Patience"))
|
||||
"Abstract base for the pile solitaires."
|
||||
:abstract t)
|
||||
|
||||
(defclass card-games-golf-game (card-games-patience-game)
|
||||
((mode :initform 'build) (wrap :initform nil) (vname :initform "Golf")))
|
||||
(defclass card-games-tripeaks-game (card-games-patience-game)
|
||||
((mode :initform 'build) (wrap :initform t) (vname :initform "TriPeaks")))
|
||||
(defclass card-games-pyramid-game (card-games-patience-game)
|
||||
((mode :initform 'sum13) (vname :initform "Pyramid")))
|
||||
|
||||
;;;; Layouts -- return (CARDS-VECTOR COVER-VECTOR ROWS), ROWS for display.
|
||||
|
||||
(cl-defgeneric card-games-pat--layout (game deck)
|
||||
"Build GAME's board from DECK; return (CARDS COVER ROWS STOCK WASTE).")
|
||||
|
||||
(cl-defmethod card-games-pat--layout ((_ card-games-golf-game) deck)
|
||||
"Lay out DECK as a Golf board."
|
||||
(let ((cards (make-vector 35 nil)) (cover (make-vector 35 nil)) (rows nil))
|
||||
(dotimes (c 7) (dotimes (r 5)
|
||||
(let ((i (+ (* c 5) r)))
|
||||
(aset cards i (pop deck))
|
||||
(when (< r 4) (aset cover i (list (+ i 1)))))))
|
||||
(dotimes (r 5) (push (cl-loop for c below 7 collect (+ (* c 5) r)) rows))
|
||||
(let ((waste (list (pop deck))))
|
||||
(list cards cover (nreverse rows) deck waste))))
|
||||
|
||||
(cl-defmethod card-games-pat--layout ((_ card-games-tripeaks-game) deck)
|
||||
"Lay out DECK as a TriPeaks board."
|
||||
(let ((cards (make-vector 28 nil))
|
||||
(cover (vector '(3 4) '(5 6) '(7 8)
|
||||
'(9 10) '(10 11) '(12 13) '(13 14) '(15 16) '(16 17)
|
||||
'(18 19) '(19 20) '(20 21) '(21 22) '(22 23) '(23 24)
|
||||
'(24 25) '(25 26) '(26 27)
|
||||
nil nil nil nil nil nil nil nil nil nil))
|
||||
(rows (list '(0 1 2) '(3 4 5 6 7 8)
|
||||
'(9 10 11 12 13 14 15 16 17)
|
||||
'(18 19 20 21 22 23 24 25 26 27))))
|
||||
(dotimes (i 28) (aset cards i (pop deck)))
|
||||
(let ((waste (list (pop deck))))
|
||||
(list cards cover rows deck waste))))
|
||||
|
||||
(cl-defmethod card-games-pat--layout ((_ card-games-pyramid-game) deck)
|
||||
"Lay out DECK as a Pyramid board."
|
||||
(let ((cards (make-vector 28 nil)) (cover (make-vector 28 nil)) (rows nil))
|
||||
(dotimes (r 7)
|
||||
(let ((start (/ (* r (1+ r)) 2)) (row nil))
|
||||
(dotimes (i (1+ r))
|
||||
(let ((idx (+ start i)))
|
||||
(aset cards idx (pop deck))
|
||||
(push idx row)
|
||||
(when (< r 6)
|
||||
(let ((below (/ (* (1+ r) (+ r 2)) 2)))
|
||||
(aset cover idx (list (+ below i) (+ below i 1)))))))
|
||||
(push (nreverse row) rows)))
|
||||
(list cards cover (nreverse rows) deck nil)))
|
||||
|
||||
;;;; Engine
|
||||
|
||||
(cl-defmethod card-games-pat--deal ((game card-games-patience-game))
|
||||
"Deal a fresh board into GAME."
|
||||
(random t)
|
||||
(cl-destructuring-bind (cards cover rows stock waste) (card-games-pat--layout game (card-games-pat--deck))
|
||||
(card-games-put game :cards cards)
|
||||
(card-games-put game :cover cover)
|
||||
(card-games-put game :rows rows)
|
||||
(card-games-put game :stock stock)
|
||||
(card-games-put game :waste waste)
|
||||
(card-games-put game :marks nil)
|
||||
(card-games-put game :cursor 0)
|
||||
(card-games-put game :moves 0)
|
||||
(card-games-put game :history nil)
|
||||
(card-games-put game :message
|
||||
(if (eq (oref game mode) 'sum13)
|
||||
"Remove pairs summing to 13; Kings go alone. RET marks, stock deals."
|
||||
"Move a card one rank from the waste top. RET plays; stock deals."))
|
||||
game))
|
||||
|
||||
(defun card-games-pat--exposed-p (game i)
|
||||
"Return non-nil when GAME board slot I is present and uncovered."
|
||||
(let ((cards (card-games-get game :cards)))
|
||||
(and (aref cards i)
|
||||
(cl-every (lambda (j) (null (aref cards j))) (aref (card-games-get game :cover) i)))))
|
||||
|
||||
(defun card-games-pat--exposed (game)
|
||||
"Return GAME's list of exposed board slot indices."
|
||||
(cl-loop for i below (length (card-games-get game :cards))
|
||||
when (card-games-pat--exposed-p game i) collect i))
|
||||
|
||||
(defun card-games-pat--spots (game)
|
||||
"Return the ordered spots the cursor can visit in GAME."
|
||||
(append (mapcar (lambda (i) (cons 'slot i)) (card-games-pat--exposed game))
|
||||
'((waste . 0) (stock . 0))))
|
||||
|
||||
(defun card-games-pat--waste-top (game) "Return the top card of GAME's waste pile." (car (last (card-games-get game :waste))))
|
||||
|
||||
(defun card-games-pat--board-empty-p (game)
|
||||
"Return non-nil when every GAME board slot has been cleared."
|
||||
(cl-every #'null (append (card-games-get game :cards) nil)))
|
||||
|
||||
(cl-defmethod card-games-won-p ((game card-games-patience-game))
|
||||
"Return non-nil when GAME's board has been cleared."
|
||||
(card-games-pat--board-empty-p game))
|
||||
|
||||
(defun card-games-pat--adjacent (a b wrap)
|
||||
"Return non-nil when ranks A and B differ by one, or (with WRAP) Ace-King."
|
||||
(let ((d (abs (- a b)))) (or (= d 1) (and wrap (= d 12)))))
|
||||
|
||||
(defun card-games-pat--snapshot (game)
|
||||
"Record an undo snapshot of GAME."
|
||||
(card-games-put game :history
|
||||
(cons (list (copy-sequence (card-games-get game :cards))
|
||||
(copy-sequence (card-games-get game :stock))
|
||||
(copy-sequence (card-games-get game :waste))
|
||||
(card-games-get game :moves))
|
||||
(card-games-get game :history))))
|
||||
|
||||
(defun card-games-pat--restore (game)
|
||||
"Undo the last move of GAME, if any."
|
||||
(let ((h (card-games-get game :history)))
|
||||
(when h
|
||||
(cl-destructuring-bind (cards stock waste moves) (car h)
|
||||
(card-games-put game :cards cards) (card-games-put game :stock stock)
|
||||
(card-games-put game :waste waste) (card-games-put game :moves moves))
|
||||
(card-games-put game :history (cdr h))
|
||||
(card-games-put game :marks nil)
|
||||
t)))
|
||||
|
||||
(defun card-games-pat--deal-stock (game)
|
||||
"Turn one of GAME's stock cards to the waste."
|
||||
(let ((stock (card-games-get game :stock)))
|
||||
(if (null stock)
|
||||
(card-games-put game :message "The stock is empty.")
|
||||
(card-games-pat--snapshot game)
|
||||
(card-games-put game :waste (append (card-games-get game :waste) (last stock 1)))
|
||||
(card-games-put game :stock (butlast stock 1))
|
||||
(card-games-put game :marks nil)
|
||||
(card-games-put game :message "Dealt a card."))))
|
||||
|
||||
(defun card-games-pat--value (card) "Sum-of-13 value of CARD." (1+ (cdr card)))
|
||||
|
||||
(defun card-games-pat--remove-slot (game i)
|
||||
"Clear GAME board slot I."
|
||||
(aset (card-games-get game :cards) i nil))
|
||||
|
||||
;;;; Interaction
|
||||
|
||||
(defvar-local card-games-pat--game nil "The pile-solitaire game in the current buffer.")
|
||||
|
||||
(defun card-games-pat--cur-spot (game)
|
||||
"Return the spot the cursor is on in GAME."
|
||||
(let ((spots (card-games-pat--spots game)))
|
||||
(nth (min (card-games-get game :cursor) (1- (length spots))) spots)))
|
||||
|
||||
(defun card-games-pat-act ()
|
||||
"Play the spot under the cursor (build move, sum-13 mark, or deal)."
|
||||
(interactive)
|
||||
(let* ((game card-games-pat--game) (spot (card-games-pat--cur-spot game)))
|
||||
(pcase (car spot)
|
||||
('stock (card-games-pat--deal-stock game))
|
||||
('waste (when (eq (oref game mode) 'sum13) (card-games-pat--toggle-mark game (cons 'waste 0))))
|
||||
('slot
|
||||
(let* ((i (cdr spot)) (card (aref (card-games-get game :cards) i)))
|
||||
(if (eq (oref game mode) 'build)
|
||||
(let ((top (card-games-pat--waste-top game)))
|
||||
(if (and top (card-games-pat--adjacent (cdr card) (cdr top) (oref game wrap)))
|
||||
(progn (card-games-pat--snapshot game)
|
||||
(card-games-put game :waste (append (card-games-get game :waste) (list card)))
|
||||
(card-games-pat--remove-slot game i)
|
||||
(card-games-put game :moves (1+ (card-games-get game :moves)))
|
||||
(card-games-put game :message "Played."))
|
||||
(card-games-put game :message "That card is not adjacent to the waste top.")))
|
||||
;; sum13
|
||||
(if (= 13 (card-games-pat--value card))
|
||||
(progn (card-games-pat--snapshot game) (card-games-pat--remove-slot game i)
|
||||
(card-games-put game :moves (1+ (card-games-get game :moves)))
|
||||
(card-games-put game :marks nil)
|
||||
(card-games-put game :message "King removed."))
|
||||
(card-games-pat--toggle-mark game (cons 'slot i)))))))
|
||||
(card-games-pat--after game)))
|
||||
|
||||
(defun card-games-pat--mark-value (game m)
|
||||
"Return the card value of GAME mark M (a slot or the waste)."
|
||||
(pcase (car m)
|
||||
('slot (card-games-pat--value (aref (card-games-get game :cards) (cdr m))))
|
||||
('waste (let ((w (card-games-pat--waste-top game))) (and w (card-games-pat--value w))))))
|
||||
|
||||
(defun card-games-pat--toggle-mark (game m)
|
||||
"Toggle GAME mark M; when two marked slots sum to 13, remove both."
|
||||
(if (member m (card-games-get game :marks))
|
||||
(card-games-put game :marks (remove m (card-games-get game :marks)))
|
||||
(card-games-put game :marks (cons m (card-games-get game :marks))))
|
||||
(let ((marks (card-games-get game :marks)))
|
||||
(when (= 2 (length marks))
|
||||
(if (= 13 (+ (card-games-pat--mark-value game (nth 0 marks))
|
||||
(card-games-pat--mark-value game (nth 1 marks))))
|
||||
(progn (card-games-pat--snapshot game)
|
||||
(dolist (mm marks)
|
||||
(pcase (car mm)
|
||||
('slot (card-games-pat--remove-slot game (cdr mm)))
|
||||
('waste (card-games-put game :waste (butlast (card-games-get game :waste) 1)))))
|
||||
(card-games-put game :moves (1+ (card-games-get game :moves)))
|
||||
(card-games-put game :marks nil)
|
||||
(card-games-put game :message "Pair removed."))
|
||||
(card-games-put game :marks nil)
|
||||
(card-games-put game :message "Those do not sum to 13.")))))
|
||||
|
||||
(defun card-games-pat--after (game)
|
||||
"Redisplay GAME and announce a win."
|
||||
(card-games-pat--redisplay)
|
||||
(when (card-games-won-p game)
|
||||
(card-games-put game :message "Board cleared -- you won! Press n for a new game.")
|
||||
(card-games-pat--redisplay)
|
||||
(message "Solved!")))
|
||||
|
||||
(defun card-games-pat--move (delta)
|
||||
"Move the cursor by DELTA spots."
|
||||
(let* ((game card-games-pat--game) (n (length (card-games-pat--spots game))))
|
||||
(card-games-put game :cursor (mod (+ (card-games-get game :cursor) delta) n))
|
||||
(card-games-pat--redisplay)))
|
||||
|
||||
(defun card-games-pat-left () "Cursor left." (interactive) (card-games-pat--move -1))
|
||||
(defun card-games-pat-right () "Cursor right." (interactive) (card-games-pat--move 1))
|
||||
(defun card-games-pat-undo () "Undo." (interactive)
|
||||
(let ((game card-games-pat--game))
|
||||
(card-games-put game :message (if (card-games-pat--restore game) "Undid a move." "Nothing to undo."))
|
||||
(card-games-pat--redisplay)))
|
||||
(defun card-games-pat-new () "New deal." (interactive)
|
||||
(card-games-pat--deal card-games-pat--game) (card-games-pat--redisplay))
|
||||
(defun card-games-pat-redraw () "Redraw." (interactive) (card-games-pat--redisplay))
|
||||
(defun card-games-pat-help () "Controls." (interactive)
|
||||
(message "Arrows or click: move/play RET: play/mark/deal u: undo +/-: size n: new"))
|
||||
|
||||
;;;; Rendering
|
||||
|
||||
(defun card-games-pat--render-card (card &optional exposed marked cursor)
|
||||
"Return CARD's display text, flagged by EXPOSED, MARKED, and CURSOR."
|
||||
(let ((s (card-games-pat-card-string card)) (faces nil))
|
||||
(when (card-games-pat-red-p card) (push 'card-games-red-suit faces))
|
||||
(when (and card (not exposed)) (push 'card-games-gap faces))
|
||||
(when marked (push 'card-games-hint faces))
|
||||
(when cursor (push 'card-games-cursor faces))
|
||||
(propertize (format "%4s" s) 'face (or faces 'default))))
|
||||
|
||||
(defcustom card-games-pat-svg-cards t
|
||||
"When non-nil, draw the patience board as SVG on a graphical display."
|
||||
:type 'boolean :group 'card-games)
|
||||
|
||||
(defun card-games-pat--spec (card)
|
||||
"Return the card-games-svg display spec (RANK-STRING . SUIT) for CARD, or nil."
|
||||
(and card (cons (aref card-games-pat-ranks (cdr card)) (car card))))
|
||||
|
||||
(defun card-games-pat--svg (game)
|
||||
"Return a propertized, clickable one-image SVG board for patience GAME.
|
||||
Exposed slots, the waste, and the stock each carry a click region (the
|
||||
matching spot); a card-size slider sits below."
|
||||
(let* ((w card-games-svg-card-width) (h card-games-svg-card-height) (pad 12) (gap card-games-svg-card-gap)
|
||||
(rowstep 30) (rows (card-games-get game :rows)) (cur (card-games-pat--cur-spot game))
|
||||
(marks (card-games-get game :marks)) (lc (card-games-color 'shadow :foreground "gray40"))
|
||||
(maxlen (apply #'max 1 (mapcar #'length rows))) (nrows (length rows))
|
||||
(sh (card-games-svg-slider-height))
|
||||
(width (+ (* 2 pad) (max (* maxlen (+ w gap)) (card-games-svg-slider-width))))
|
||||
(boardh (+ (* (1- nrows) rowstep) h)) (bottom-y (+ pad boardh 26))
|
||||
(slider-y (+ bottom-y h 10))
|
||||
(height (+ slider-y sh pad)) (svg (svg-create width height))
|
||||
(r 0) (regions '()))
|
||||
(dolist (row rows)
|
||||
(let* ((len (length row)) (x0 (/ (- width (* len (+ w gap))) 2))
|
||||
(y (+ pad (* r rowstep))) (c 0))
|
||||
(dolist (i row)
|
||||
(let* ((card (aref (card-games-get game :cards) i)) (x (+ x0 (* c (+ w gap)))))
|
||||
(when card
|
||||
(card-games-svg-card svg x y :rank (car (card-games-pat--spec card))
|
||||
:suit (cdr (card-games-pat--spec card))
|
||||
:highlight (equal cur (cons 'slot i))
|
||||
:hint (and (member (cons 'slot i) marks) t))
|
||||
(when (card-games-pat--exposed-p game i)
|
||||
(push (cons (list x y w h) (cons 'slot i)) regions))))
|
||||
(setq c (1+ c))))
|
||||
(setq r (1+ r)))
|
||||
(svg-text svg "Waste" :x pad :y (- bottom-y 3) :font-size 11 :fill lc
|
||||
:font-family card-games-svg-font-family)
|
||||
(let ((wt (card-games-pat--waste-top game)))
|
||||
(if wt (card-games-svg-card svg pad bottom-y :rank (car (card-games-pat--spec wt))
|
||||
:suit (cdr (card-games-pat--spec wt))
|
||||
:highlight (equal cur '(waste . 0))
|
||||
:hint (and (member '(waste . 0) marks) t))
|
||||
(card-games-svg-card svg pad bottom-y :gap t :highlight (equal cur '(waste . 0)))))
|
||||
(push (cons (list pad bottom-y w h) (cons 'waste 0)) regions)
|
||||
(svg-text svg (format "Stock(%d)" (length (card-games-get game :stock)))
|
||||
:x (+ pad w gap) :y (- bottom-y 3) :font-size 11 :fill lc
|
||||
:font-family card-games-svg-font-family)
|
||||
(if (card-games-get game :stock)
|
||||
(card-games-svg-card svg (+ pad w gap) bottom-y :down t :highlight (equal cur '(stock . 0)))
|
||||
(card-games-svg-card svg (+ pad w gap) bottom-y :gap t :highlight (equal cur '(stock . 0))))
|
||||
(push (cons (list (+ pad w gap) bottom-y w h) (cons 'stock 0)) regions)
|
||||
(setq regions (append (nreverse regions)
|
||||
(card-games-svg-slider-draw svg pad slider-y card-games-card-scale)))
|
||||
(propertize "*" 'display (card-games-svg-image svg (card-games-scale)) 'card-games-regions regions)))
|
||||
|
||||
(cl-defmethod card-games-render-apply ((g card-games-patience-game) action)
|
||||
"Apply a click ACTION (a board spot) to GAME G: select that spot and play."
|
||||
(pcase action
|
||||
((or `(slot . ,_) `(waste . ,_) `(stock . ,_))
|
||||
(let ((idx (cl-position action (card-games-pat--spots g) :test #'equal)))
|
||||
(when idx (card-games-put g :cursor idx) (card-games-pat-act))))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(cl-defmethod card-games-render ((game card-games-patience-game))
|
||||
"Return a propertized depiction of GAME (SVG on a graphical display)."
|
||||
(if (and card-games-pat-svg-cards (display-graphic-p))
|
||||
(card-games-pat--svg game)
|
||||
(card-games-pat--render-text game)))
|
||||
|
||||
(defun card-games-pat--render-text (game)
|
||||
"Return a plain-text depiction of patience GAME."
|
||||
(let* ((cur (card-games-pat--cur-spot game)) (marks (card-games-get game :marks)) (out (list)))
|
||||
(push (format " %s Moves: %d\n\n" (oref game vname) (card-games-get game :moves)) out)
|
||||
(dolist (row (card-games-get game :rows))
|
||||
(push " " out)
|
||||
(dolist (i row)
|
||||
(let* ((card (aref (card-games-get game :cards) i))
|
||||
(exp (card-games-pat--exposed-p game i))
|
||||
(mk (member (cons 'slot i) marks))
|
||||
(cz (equal cur (cons 'slot i))))
|
||||
(push (if card (card-games-pat--render-card card exp mk cz) " ") out)))
|
||||
(push "\n" out))
|
||||
(push (format "\n Waste: %s Stock: %d\n"
|
||||
(let ((w (card-games-pat--waste-top game)))
|
||||
(card-games-pat--render-card w t (member '(waste . 0) marks)
|
||||
(equal cur '(waste . 0))))
|
||||
(length (card-games-get game :stock)))
|
||||
out)
|
||||
(push (format " %s\n" (if (equal cur '(stock . 0))
|
||||
(propertize "[stock]" 'face 'card-games-cursor) "")) out)
|
||||
(push (format "\n %s\n" (card-games-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(defun card-games-pat--redisplay ()
|
||||
"Redraw the current patience-game buffer."
|
||||
(let ((game card-games-pat--game) (inhibit-read-only t))
|
||||
(setq card-games-current-game game card-games-redisplay-function #'card-games-pat--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (if (card-games-won-p game) "solved" "playing")))
|
||||
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
|
||||
|
||||
;;;; Mode and commands
|
||||
|
||||
(defvar card-games-pat-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'card-games-card-click)
|
||||
(define-key map "+" #'card-games-card-zoom-in)
|
||||
(define-key map "=" #'card-games-card-zoom-in)
|
||||
(define-key map "-" #'card-games-card-zoom-out)
|
||||
(define-key map "0" #'card-games-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'card-games-pat-left)
|
||||
(define-key map (kbd "<right>") #'card-games-pat-right)
|
||||
(define-key map (kbd "<up>") #'card-games-pat-left)
|
||||
(define-key map (kbd "<down>") #'card-games-pat-right)
|
||||
(define-key map (kbd "RET") #'card-games-pat-act)
|
||||
(define-key map (kbd "SPC") #'card-games-pat-act)
|
||||
(define-key map "u" #'card-games-pat-undo)
|
||||
(define-key map "n" #'card-games-pat-new)
|
||||
(define-key map "g" #'card-games-pat-redraw)
|
||||
(define-key map "?" #'card-games-pat-help)
|
||||
(define-key map "q" #'card-games-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `card-games-pat-mode'.")
|
||||
|
||||
(define-derived-mode card-games-pat-mode special-mode "Patience"
|
||||
"Major mode for the pile solitaires."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type card-games-cursor-type))
|
||||
|
||||
(defun card-games-pat--play (class)
|
||||
"Start a patience game of CLASS."
|
||||
(let* ((game (card-games-pat--deal (make-instance class)))
|
||||
(buf (get-buffer-create (format "*%s*" (oref game vname)))))
|
||||
(with-current-buffer buf
|
||||
(card-games-pat-mode) (setq card-games-pat--game game) (card-games-pat--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-golf () "Play Golf solitaire." (interactive) (card-games-pat--play 'card-games-golf-game))
|
||||
;;;###autoload
|
||||
(defun card-games-tripeaks () "Play TriPeaks solitaire." (interactive) (card-games-pat--play 'card-games-tripeaks-game))
|
||||
;;;###autoload
|
||||
(defun card-games-pyramid () "Play Pyramid solitaire." (interactive) (card-games-pat--play 'card-games-pyramid-game))
|
||||
|
||||
(provide 'card-games-patience)
|
||||
;;; card-games-patience.el ends here
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
;;; card-games-pkg.el --- Package metadata -*- no-byte-compile: t; -*-
|
||||
(define-package "card-games" "1.0.91"
|
||||
"Play card games in Emacs (console UNICODE and graphical SVG)."
|
||||
"Play card games (console UNICODE and graphical SVG)."
|
||||
'((emacs "26.1"))
|
||||
:keywords '("games")
|
||||
:url "https://code.bru.st/corwin/card-game.el"
|
||||
|
|
|
|||
430
card-games-president.el
Normal file
430
card-games-president.el
Normal file
|
|
@ -0,0 +1,430 @@
|
|||
;;; card-games-president.el --- President (Scum), a climbing card game -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; President (also Scum, Asshole, Daihinmin): a climbing/shedding game.
|
||||
;; The leader plays one to four cards of a single rank; each player in turn
|
||||
;; must beat it with the same number of a higher rank or pass. Once all but
|
||||
;; one have passed, the pile clears and the last player to play leads again.
|
||||
;; The first player out is President, the last is Scum; on the next deal the
|
||||
;; Scum hands the President their two best cards and gets two junk cards back.
|
||||
;;
|
||||
;; You are the South player (seat 0); the rest are simple AI. Card power
|
||||
;; runs 3 (low) .. K, A, then the Two (highest). Cards are the package
|
||||
;; cons (SUIT . RANK) with RANK 0 (the Two) .. 12 (the Ace).
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-svg)
|
||||
|
||||
(defconst card-games-pres-ranks
|
||||
["2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K" "A"]
|
||||
"Rank labels indexed 0 (Two) .. 12 (Ace).")
|
||||
|
||||
(defconst card-games-pres-titles ["President" "Vice-President" "Citizen"
|
||||
"Vice-Scum" "Scum"]
|
||||
"Finishing titles from first out to last.")
|
||||
|
||||
(defcustom card-games-president-players 4
|
||||
"Number of players in President, including you (3-6)."
|
||||
:type 'integer :group 'card-games)
|
||||
|
||||
(defun card-games-pres--power (rank)
|
||||
"Return the climbing power of RANK; the Two (RANK 0) is highest."
|
||||
(if (= rank 0) 13 rank))
|
||||
|
||||
(defun card-games-pres-card-string (card)
|
||||
"Return the display string for CARD (a middot for nil)."
|
||||
(if (null card) "·"
|
||||
(concat (aref card-games-pres-ranks (cdr card)) (card-games-suit-glyph (car card)))))
|
||||
|
||||
(defsubst card-games-pres-red-p (card) "Return non-nil when CARD is red." (and card (card-games-red-suit-p (car card))))
|
||||
|
||||
(defun card-games-pres--deck ()
|
||||
"Return a fresh shuffled 52-card deck."
|
||||
(card-games-shuffle (cl-loop for s below 4 append
|
||||
(cl-loop for r below 13 collect (cons s r)))))
|
||||
|
||||
(defun card-games-pres--sort (cards)
|
||||
"Sort CARDS by climbing power then suit."
|
||||
(sort (copy-sequence cards)
|
||||
(lambda (a b) (if (= (card-games-pres--power (cdr a)) (card-games-pres--power (cdr b)))
|
||||
(< (car a) (car b))
|
||||
(< (card-games-pres--power (cdr a)) (card-games-pres--power (cdr b)))))))
|
||||
|
||||
(defclass card-games-president-game (card-games-game)
|
||||
((vname :initform "President"))
|
||||
"A game of President (Scum).")
|
||||
|
||||
(defsubst card-games-pres--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
|
||||
(defsubst card-games-pres--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
|
||||
(defsubst card-games-pres--name (_game s)
|
||||
"Return the display name of seat S."
|
||||
(if (= s 0) "You" (format "Player %d" s)))
|
||||
|
||||
;;;; Dealing and the inter-game exchange
|
||||
|
||||
(cl-defmethod card-games-pres--deal ((game card-games-president-game))
|
||||
"Deal a new round into GAME (3-6 players)."
|
||||
(let* ((n (max 3 (min 6 card-games-president-players)))
|
||||
(deck (card-games-pres--deck))
|
||||
(hands (make-vector n nil))
|
||||
(s 0))
|
||||
(while deck
|
||||
(push (pop deck) (aref hands (mod s n)))
|
||||
(cl-incf s))
|
||||
(dotimes (i n) (aset hands i (card-games-pres--sort (aref hands i))))
|
||||
(card-games-put game :hands hands)
|
||||
(card-games-put game :nplayers n)
|
||||
(card-games-pres--exchange game) ; carry out roles from the last deal
|
||||
(card-games-put game :count 0)
|
||||
(card-games-put game :top -1)
|
||||
(card-games-put game :passed (make-vector n nil))
|
||||
(card-games-put game :out nil)
|
||||
(card-games-put game :last-player nil)
|
||||
(card-games-put game :turn 0)
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :cursor 0)
|
||||
(unless (card-games-get game :games) (card-games-put game :games 0))
|
||||
(card-games-put game :message
|
||||
"Lead any rank; others beat it with a higher one or pass. p passes.")
|
||||
game))
|
||||
|
||||
(defun card-games-pres--best (hand k) "The K highest-power cards of HAND." (last (card-games-pres--sort hand) k))
|
||||
(defun card-games-pres--worst (hand k) "The K lowest-power cards of HAND." (cl-subseq (card-games-pres--sort hand) 0 k))
|
||||
|
||||
(cl-defmethod card-games-pres--exchange ((game card-games-president-game))
|
||||
"Trade GAME cards by rank from the previous deal's finishing order, if any."
|
||||
(let ((order (card-games-get game :order)) (n (card-games-get game :nplayers)))
|
||||
(when (and order (= (length order) n) (>= n 4))
|
||||
(let* ((prez (nth 0 order)) (scum (nth (1- n) order))
|
||||
(vp (nth 1 order)) (vice (nth (- n 2) order)))
|
||||
(card-games-pres--give game scum prez 2) ; scum's 2 best -> president
|
||||
(card-games-pres--give game prez scum 2 t) ; president's 2 worst -> scum
|
||||
(card-games-pres--give game vice vp 1)
|
||||
(card-games-pres--give game vp vice 1 t)))))
|
||||
|
||||
(defun card-games-pres--give (game from to k &optional worst)
|
||||
"Move K cards (best, or WORST) from GAME seat FROM to seat TO."
|
||||
(let* ((cards (if worst (card-games-pres--worst (card-games-pres--hand game from) k)
|
||||
(card-games-pres--best (card-games-pres--hand game from) k))))
|
||||
(card-games-pres--set-hand game from
|
||||
(cl-set-difference (card-games-pres--hand game from) cards :test #'equal))
|
||||
(card-games-pres--set-hand game to
|
||||
(card-games-pres--sort (append (card-games-pres--hand game to) cards)))))
|
||||
|
||||
;;;; Move logic
|
||||
|
||||
(defun card-games-pres--rank-counts (game s)
|
||||
"Return an alist (RANK . COUNT) for GAME seat S's hand."
|
||||
(let ((tbl nil))
|
||||
(dolist (c (card-games-pres--hand game s))
|
||||
(setf (alist-get (cdr c) tbl 0) (1+ (alist-get (cdr c) tbl 0))))
|
||||
tbl))
|
||||
|
||||
(defun card-games-pres--legal-ranks (game s)
|
||||
"Return the ranks GAME seat S may legally play now."
|
||||
(let ((cnt (card-games-get game :count)) (top (card-games-get game :top)))
|
||||
(cl-loop for (r . c) in (card-games-pres--rank-counts game s)
|
||||
when (if (= cnt 0) t (and (>= c cnt) (> (card-games-pres--power r) top)))
|
||||
collect r)))
|
||||
|
||||
(defun card-games-pres--remove-n (hand rank n)
|
||||
"Remove N cards of RANK from HAND."
|
||||
(let ((out nil) (left n))
|
||||
(dolist (c hand) (if (and (> left 0) (= (cdr c) rank))
|
||||
(cl-decf left) (push c out)))
|
||||
(nreverse out)))
|
||||
|
||||
(defun card-games-pres--in-game (game)
|
||||
"Return GAME seats that still hold cards."
|
||||
(cl-loop for s below (card-games-get game :nplayers)
|
||||
unless (memq s (card-games-get game :out)) collect s))
|
||||
|
||||
(defun card-games-pres--round-active (game)
|
||||
"Return GAME seats that can still act on the current pile."
|
||||
(cl-loop for s below (card-games-get game :nplayers)
|
||||
unless (or (memq s (card-games-get game :out)) (aref (card-games-get game :passed) s))
|
||||
collect s))
|
||||
|
||||
(defun card-games-pres--next (game from)
|
||||
"Return the next GAME seat after FROM still in the round."
|
||||
(let ((n (card-games-get game :nplayers)) (s from) (res nil))
|
||||
(dotimes (_ n)
|
||||
(setq s (mod (1+ s) n))
|
||||
(when (and (not res)
|
||||
(not (memq s (card-games-get game :out)))
|
||||
(not (aref (card-games-get game :passed) s)))
|
||||
(setq res s)))
|
||||
(or res from)))
|
||||
|
||||
(defun card-games-pres--clear (game)
|
||||
"Clear GAME's pile; the last player to play leads, else the next active seat."
|
||||
(card-games-put game :count 0) (card-games-put game :top -1)
|
||||
(card-games-put game :passed (make-vector (card-games-get game :nplayers) nil))
|
||||
(let ((last (card-games-get game :last-player)))
|
||||
(card-games-put game :turn (if (and last (not (memq last (card-games-get game :out)))) last
|
||||
(card-games-pres--next game (or last 0)))))
|
||||
(card-games-put game :message "Pile cleared."))
|
||||
|
||||
(defun card-games-pres--check-finish (game)
|
||||
"End GAME when only one player still has cards (the Scum)."
|
||||
(let ((in (card-games-pres--in-game game)))
|
||||
(when (<= (length in) 1)
|
||||
(when in (card-games-put game :out (append (card-games-get game :out) in)))
|
||||
(card-games-put game :order (card-games-get game :out))
|
||||
(card-games-put game :games (1+ (or (card-games-get game :games) 0)))
|
||||
(card-games-put game :phase 'game-over)
|
||||
(card-games-put game :message (card-games-pres--result game))
|
||||
t)))
|
||||
|
||||
(defun card-games-pres--advance (game)
|
||||
"Decide GAME's next turn or clear the pile after a move."
|
||||
(unless (card-games-pres--check-finish game)
|
||||
(let* ((active (card-games-pres--round-active game))
|
||||
(last (card-games-get game :last-player))
|
||||
(others (and last (cl-remove last active))))
|
||||
(if (and (> (card-games-get game :count) 0) (null others))
|
||||
(card-games-pres--clear game)
|
||||
(card-games-put game :turn (card-games-pres--next game (card-games-get game :turn)))))))
|
||||
|
||||
(defun card-games-pres--play (game seat rank n)
|
||||
"Have GAME seat SEAT play N cards of RANK."
|
||||
(card-games-pres--set-hand game seat (card-games-pres--remove-n (card-games-pres--hand game seat) rank n))
|
||||
(card-games-put game :count n) (card-games-put game :top (card-games-pres--power rank))
|
||||
(card-games-put game :last-player seat)
|
||||
(when (null (card-games-pres--hand game seat))
|
||||
(card-games-put game :out (append (card-games-get game :out) (list seat))))
|
||||
(card-games-put game :message (format "%s plays %d × %s" (card-games-pres--name game seat)
|
||||
n (aref card-games-pres-ranks rank)))
|
||||
(card-games-pres--advance game))
|
||||
|
||||
(defun card-games-pres--pass (game seat)
|
||||
"Have GAME seat SEAT pass on the current pile."
|
||||
(aset (card-games-get game :passed) seat t)
|
||||
(card-games-put game :message (format "%s passes." (card-games-pres--name game seat)))
|
||||
(card-games-pres--advance game))
|
||||
|
||||
(defun card-games-pres--ai-move (game seat)
|
||||
"Make GAME seat SEAT's move: lead low, beat low, or pass."
|
||||
(let* ((cnt (card-games-get game :count)) (top (card-games-get game :top))
|
||||
(counts (card-games-pres--rank-counts game seat)))
|
||||
(if (= cnt 0)
|
||||
(let ((r (caar (cl-sort counts #'< :key (lambda (x) (card-games-pres--power (car x)))))))
|
||||
(card-games-pres--play game seat r 1))
|
||||
(let ((cand (cl-loop for (r . c) in counts
|
||||
when (and (>= c cnt) (> (card-games-pres--power r) top)) collect r)))
|
||||
(if cand
|
||||
(card-games-pres--play game seat
|
||||
(car (cl-sort cand #'< :key #'card-games-pres--power)) cnt)
|
||||
(card-games-pres--pass game seat))))))
|
||||
|
||||
(defun card-games-pres--result (game)
|
||||
"Return a finishing summary string for GAME."
|
||||
(let* ((order (card-games-get game :order)) (n (length order)) (parts nil))
|
||||
(dotimes (i n)
|
||||
(let ((title (cond ((= i 0) "President") ((= i (1- n)) "Scum")
|
||||
((= i 1) "Vice-President") ((= i (- n 2)) "Vice-Scum")
|
||||
(t "Citizen"))))
|
||||
(push (format "%s: %s" title (card-games-pres--name game (nth i order))) parts)))
|
||||
(concat "Game over -- " (mapconcat #'identity (nreverse parts) ", ")
|
||||
". Press n for the next deal.")))
|
||||
|
||||
;;;; UI
|
||||
|
||||
(defvar-local card-games-pres--game nil "The President game in the current buffer.")
|
||||
|
||||
(defun card-games-pres--run (game)
|
||||
"Advance GAME's AI seats until the human's turn or the game ends."
|
||||
(while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0))
|
||||
(card-games-pres--ai-move game (card-games-get game :turn))))
|
||||
|
||||
(defun card-games-pres--hand-ranks (game)
|
||||
"Return the distinct ranks in GAME seat 0's hand, ordered by power."
|
||||
(let ((rs (delete-dups (mapcar #'cdr (card-games-pres--hand game 0)))))
|
||||
(cl-sort rs #'< :key #'card-games-pres--power)))
|
||||
|
||||
(defun card-games-pres-act (&optional count)
|
||||
"Play the selected rank. With prefix COUNT, lead that many of it."
|
||||
(interactive "P")
|
||||
(let* ((game card-games-pres--game)
|
||||
(ranks (card-games-pres--hand-ranks game)))
|
||||
(cond
|
||||
((not (eq (card-games-get game :phase) 'play)) (card-games-put game :message "Press n for a new deal."))
|
||||
((/= (card-games-get game :turn) 0) (card-games-put game :message "Not your turn."))
|
||||
((null ranks) (card-games-put game :message "You are out."))
|
||||
(t (let* ((rank (nth (min (card-games-get game :cursor) (1- (length ranks))) ranks))
|
||||
(have (cl-count rank (mapcar #'cdr (card-games-pres--hand game 0))))
|
||||
(need (card-games-get game :count)))
|
||||
(if (= need 0)
|
||||
(let ((n (min have (max 1 (prefix-numeric-value (or count 1))))))
|
||||
(card-games-pres--play game 0 rank n)
|
||||
(card-games-put game :cursor 0)
|
||||
(card-games-pres--run game))
|
||||
(if (and (>= have need) (> (card-games-pres--power rank) (card-games-get game :top)))
|
||||
(progn (card-games-pres--play game 0 rank need)
|
||||
(card-games-put game :cursor 0)
|
||||
(card-games-pres--run game))
|
||||
(card-games-put game :message
|
||||
(format "Need %d of a rank higher than the pile." need)))))))
|
||||
(card-games-pres--redisplay)))
|
||||
|
||||
(defun card-games-pres-pass ()
|
||||
"Pass for the current pile."
|
||||
(interactive)
|
||||
(let ((game card-games-pres--game))
|
||||
(cond
|
||||
((/= (card-games-get game :turn) 0) (card-games-put game :message "Not your turn."))
|
||||
((= (card-games-get game :count) 0) (card-games-put game :message "You lead -- you must play."))
|
||||
(t (card-games-pres--pass game 0) (card-games-pres--run game)))
|
||||
(card-games-pres--redisplay)))
|
||||
|
||||
(defun card-games-pres-left () "Cursor left." (interactive)
|
||||
(let* ((g card-games-pres--game) (n (length (card-games-pres--hand-ranks g))))
|
||||
(when (> n 0) (card-games-put g :cursor (mod (1- (card-games-get g :cursor)) n))) (card-games-pres--redisplay)))
|
||||
(defun card-games-pres-right () "Cursor right." (interactive)
|
||||
(let* ((g card-games-pres--game) (n (length (card-games-pres--hand-ranks g))))
|
||||
(when (> n 0) (card-games-put g :cursor (mod (1+ (card-games-get g :cursor)) n))) (card-games-pres--redisplay)))
|
||||
(defun card-games-pres-new () "New deal." (interactive)
|
||||
(card-games-pres--deal card-games-pres--game) (card-games-pres--run card-games-pres--game) (card-games-pres--redisplay))
|
||||
(defun card-games-pres-redraw () "Redraw." (interactive) (card-games-pres--redisplay))
|
||||
(defun card-games-pres-help () "Controls." (interactive)
|
||||
(message "Arrows or click: choose/play RET: play (C-u N to lead N) p: pass +/-: size n: new"))
|
||||
|
||||
(defcustom card-games-pres-svg-cards t
|
||||
"When non-nil, draw the hand as SVG on a graphical display."
|
||||
:type 'boolean :group 'card-games)
|
||||
|
||||
(defun card-games-pres--svg (game)
|
||||
"Return a propertized, clickable SVG row of GAME's hand: one card per rank.
|
||||
Each rank maps to a (hand . INDEX) region and a card-size slider sits below."
|
||||
(let* ((w card-games-svg-card-width) (h card-games-svg-card-height) (pad 10)
|
||||
(gap (+ card-games-svg-card-gap 8)) (ranks (card-games-pres--hand-ranks game))
|
||||
(cur (card-games-get game :cursor)) (hand (card-games-pres--hand game 0))
|
||||
(n (length ranks)) (lc (card-games-color 'shadow :foreground "gray40"))
|
||||
(sh (card-games-svg-slider-height)) (slider-y (+ pad h 22))
|
||||
(width (+ (* 2 pad) (max (+ w gap) (* n (+ w gap)) (card-games-svg-slider-width))))
|
||||
(height (+ slider-y sh pad)) (svg (svg-create width height))
|
||||
(x pad) (i 0) (regions '()))
|
||||
(dolist (r ranks)
|
||||
(let* ((cnt (cl-count r (mapcar #'cdr hand)))
|
||||
(suit (car (cl-find r hand :key #'cdr))))
|
||||
(card-games-svg-card svg x pad :rank (aref card-games-pres-ranks r) :suit suit
|
||||
:highlight (= i cur))
|
||||
(svg-text svg (format "x%d" cnt) :x (+ x 3) :y (+ pad h 15)
|
||||
:font-size 13 :fill lc :font-family card-games-svg-font-family)
|
||||
(push (cons (list x pad w h) (cons 'hand i)) regions))
|
||||
(setq x (+ x w gap) i (1+ i)))
|
||||
(setq regions (append (nreverse regions)
|
||||
(card-games-svg-slider-draw svg pad slider-y card-games-card-scale)))
|
||||
(propertize "*" 'display (card-games-svg-image svg (card-games-scale)) 'card-games-regions regions)))
|
||||
|
||||
(cl-defmethod card-games-render ((game card-games-president-game))
|
||||
"Return a propertized string depicting GAME for a text display."
|
||||
(let* ((out (list)) (ranks (card-games-pres--hand-ranks game))
|
||||
(cur (card-games-get game :cursor)))
|
||||
(push (format " President\n\n") out)
|
||||
(dotimes (s (card-games-get game :nplayers))
|
||||
(unless (= s 0)
|
||||
(push (format " Player %d: %d cards%s\n" s (length (card-games-pres--hand game s))
|
||||
(if (memq s (card-games-get game :out)) " (out)" "")) out)))
|
||||
(push (format "\n Pile: %s\n\n"
|
||||
(if (> (card-games-get game :count) 0)
|
||||
(format "%d × power-%d (last: %s)"
|
||||
(card-games-get game :count) (card-games-get game :top)
|
||||
(card-games-pres--name game (card-games-get game :last-player)))
|
||||
"empty -- your lead"))
|
||||
out)
|
||||
(push " Your hand (by rank):\n " out)
|
||||
(if (and card-games-pres-svg-cards (display-graphic-p))
|
||||
(push (card-games-pres--svg game) out)
|
||||
(let ((i 0))
|
||||
(dolist (r ranks)
|
||||
(let* ((cnt (cl-count r (mapcar #'cdr (card-games-pres--hand game 0))))
|
||||
(str (format "%s×%d" (aref card-games-pres-ranks r) cnt))
|
||||
(faces nil))
|
||||
(when (= i cur) (push 'card-games-cursor faces))
|
||||
(push (propertize (format "%6s" str) 'face (or faces 'default)) out))
|
||||
(cl-incf i))))
|
||||
(push (format "\n\n %s\n" (card-games-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod card-games-render-apply ((g card-games-president-game) action)
|
||||
"Apply a click ACTION on the rank row to GAME G (a click also plays)."
|
||||
(pcase action
|
||||
(`(hand . ,i)
|
||||
(card-games-put g :cursor i)
|
||||
(when (and (eq (card-games-get g :phase) 'play) (= (card-games-get g :turn) 0))
|
||||
(card-games-pres-act)))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun card-games-pres--redisplay ()
|
||||
"Redraw the current President buffer."
|
||||
(let ((game card-games-pres--game) (inhibit-read-only t))
|
||||
(setq card-games-current-game game card-games-redisplay-function #'card-games-pres--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))
|
||||
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
|
||||
|
||||
(defvar card-games-pres-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'card-games-card-click)
|
||||
(define-key map "+" #'card-games-card-zoom-in)
|
||||
(define-key map "=" #'card-games-card-zoom-in)
|
||||
(define-key map "-" #'card-games-card-zoom-out)
|
||||
(define-key map "0" #'card-games-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'card-games-pres-left)
|
||||
(define-key map (kbd "<right>") #'card-games-pres-right)
|
||||
(define-key map (kbd "RET") #'card-games-pres-act)
|
||||
(define-key map (kbd "SPC") #'card-games-pres-act)
|
||||
(define-key map "p" #'card-games-pres-pass)
|
||||
(define-key map "n" #'card-games-pres-new)
|
||||
(define-key map "g" #'card-games-pres-redraw)
|
||||
(define-key map "?" #'card-games-pres-help)
|
||||
(define-key map "q" #'card-games-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `card-games-pres-mode'.")
|
||||
|
||||
(define-derived-mode card-games-pres-mode special-mode "President"
|
||||
"Major mode for President."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type card-games-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-president ()
|
||||
"Play President (Scum) against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*President*")))
|
||||
(with-current-buffer buf
|
||||
(card-games-pres-mode)
|
||||
(setq card-games-pres--game (card-games-president-game))
|
||||
(card-games-pres--deal card-games-pres--game)
|
||||
(card-games-pres--run card-games-pres--game)
|
||||
(card-games-pres--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
(provide 'card-games-president)
|
||||
;;; card-games-president.el ends here
|
||||
|
|
@ -1,11 +1,10 @@
|
|||
;;; cg-render.el --- Renderer "skins" for card games -*- lexical-binding: t; -*-
|
||||
;;; card-games-render.el --- Renderer "skins" for card games -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
|
|
@ -24,103 +23,103 @@
|
|||
|
||||
;;; Commentary:
|
||||
|
||||
;; Concrete display treatments ("skins") built on the `cg-renderer'
|
||||
;; protocol from cg-core. Each treatment is a small EIEIO class that
|
||||
;; Concrete display treatments ("skins") built on the `card-games-renderer'
|
||||
;; protocol from card-games-core. Each treatment is a small EIEIO class that
|
||||
;; registers itself by name:
|
||||
;;
|
||||
;; text plain UNICODE text (works in a terminal and on Android)
|
||||
;; svg SVG cards on a graphical display
|
||||
;; svg-fill a full-window SVG table that grows with the window
|
||||
;;
|
||||
;; A game draws itself by calling `cg-render-game', which selects the
|
||||
;; A game draws itself by calling `card-games-render-game', which selects the
|
||||
;; game's current renderer (falling back to a default treatment chosen
|
||||
;; for the display) and dispatches `cg-renderer-draw'. The actual,
|
||||
;; for the display) and dispatches `card-games-renderer-draw'. The actual,
|
||||
;; game-specific drawing is supplied as methods specialised on a
|
||||
;; (TREATMENT GAME) pair in the individual game files.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cg-core)
|
||||
(require 'card-games-core)
|
||||
|
||||
(defgroup cg-render nil
|
||||
(defgroup card-games-render nil
|
||||
"Display treatments (\"skins\") for card games."
|
||||
:group 'card-games
|
||||
:prefix "cg-render-")
|
||||
:prefix "card-games-render-")
|
||||
|
||||
(defclass cg-text-renderer (cg-renderer)
|
||||
(defclass card-games-text-renderer (card-games-renderer)
|
||||
((name :initform 'text))
|
||||
"Plain UNICODE text treatment.")
|
||||
|
||||
(defclass cg-svg-renderer (cg-renderer)
|
||||
(defclass card-games-svg-renderer (card-games-renderer)
|
||||
((name :initform 'svg))
|
||||
"SVG cards on a graphical display.")
|
||||
|
||||
(defclass cg-svg-fill-renderer (cg-svg-renderer)
|
||||
(defclass card-games-svg-fill-renderer (card-games-svg-renderer)
|
||||
((name :initform 'svg-fill))
|
||||
"Full-window SVG table that grows to fill the window.")
|
||||
|
||||
(cg-register-renderer 'text 'cg-text-renderer)
|
||||
(cg-register-renderer 'svg 'cg-svg-renderer)
|
||||
(cg-register-renderer 'svg-fill 'cg-svg-fill-renderer)
|
||||
(card-games-register-renderer 'text 'card-games-text-renderer)
|
||||
(card-games-register-renderer 'svg 'card-games-svg-renderer)
|
||||
(card-games-register-renderer 'svg-fill 'card-games-svg-fill-renderer)
|
||||
|
||||
(defcustom cg-render-default-treatment 'auto
|
||||
(defcustom card-games-render-default-treatment 'auto
|
||||
"Default display treatment for games.
|
||||
The value `auto' chooses `svg' on a graphical display and `text'
|
||||
otherwise. It may instead name a treatment registered in
|
||||
`cg-renderers', such as `text', `svg', or `svg-fill'."
|
||||
`card-games-renderers', such as `text', `svg', or `svg-fill'."
|
||||
:type '(choice (const :tag "Automatic (svg if graphical, else text)" auto)
|
||||
(const text) (const svg) (const svg-fill)
|
||||
(symbol :tag "Other registered treatment"))
|
||||
:group 'cg-render)
|
||||
:group 'card-games-render)
|
||||
|
||||
(defun cg-render-resolve-treatment (&optional name)
|
||||
(defun card-games-render-resolve-treatment (&optional name)
|
||||
"Return a concrete treatment name, resolving `auto' and NAME for this display.
|
||||
NAME defaults to `cg-render-default-treatment'."
|
||||
(let ((n (or name cg-render-default-treatment)))
|
||||
NAME defaults to `card-games-render-default-treatment'."
|
||||
(let ((n (or name card-games-render-default-treatment)))
|
||||
(if (eq n 'auto)
|
||||
(if (display-graphic-p) 'svg 'text)
|
||||
n)))
|
||||
|
||||
(defun cg-render-game (game)
|
||||
(defun card-games-render-game (game)
|
||||
"Draw GAME with its current renderer, creating a default one if needed.
|
||||
The default treatment comes from `cg-render-resolve-treatment'."
|
||||
The default treatment comes from `card-games-render-resolve-treatment'."
|
||||
(let ((r (or (oref game renderer)
|
||||
(let ((new (cg-make-renderer (cg-render-resolve-treatment))))
|
||||
(let ((new (card-games-make-renderer (card-games-render-resolve-treatment))))
|
||||
(oset game renderer new)
|
||||
new))))
|
||||
(cg-renderer-draw r game)))
|
||||
(card-games-renderer-draw r game)))
|
||||
|
||||
(defun cg-render-set-treatment (game name)
|
||||
(defun card-games-render-set-treatment (game name)
|
||||
"Switch GAME to the treatment NAME and return its new renderer."
|
||||
(oset game renderer (cg-make-renderer name)))
|
||||
(oset game renderer (card-games-make-renderer name)))
|
||||
|
||||
(cl-defgeneric cg-render-text (game)
|
||||
(cl-defgeneric card-games-render-text (game)
|
||||
"Return the plain-text display string for GAME.
|
||||
The default falls back to the game's `cg-render' method."
|
||||
(cg-render game))
|
||||
The default falls back to the game's `card-games-render' method."
|
||||
(card-games-render game))
|
||||
|
||||
(cl-defgeneric cg-render-svg (game)
|
||||
(cl-defgeneric card-games-render-svg (game)
|
||||
"Return (DISPLAY-STRING . REGIONS) for GAME's SVG treatment.
|
||||
The default falls back to the `cg-render' string with no click regions."
|
||||
(cons (cg-render game) nil))
|
||||
The default falls back to the `card-games-render' string with no click regions."
|
||||
(cons (card-games-render game) nil))
|
||||
|
||||
(cl-defmethod cg-renderer-draw ((r cg-text-renderer) (game cg-game))
|
||||
(cl-defmethod card-games-renderer-draw ((r card-games-text-renderer) (game card-games-game))
|
||||
"Draw GAME as plain text on renderer R, clearing any click regions."
|
||||
(oset r regions nil)
|
||||
(insert (cg-render-text game)))
|
||||
(insert (card-games-render-text game)))
|
||||
|
||||
(cl-defmethod cg-renderer-draw ((r cg-svg-renderer) (game cg-game))
|
||||
(cl-defmethod card-games-renderer-draw ((r card-games-svg-renderer) (game card-games-game))
|
||||
"Draw GAME as SVG and record its click regions on R."
|
||||
(let ((res (cg-render-svg game)))
|
||||
(let ((res (card-games-render-svg game)))
|
||||
(oset r regions (cdr res))
|
||||
(insert (car res))))
|
||||
|
||||
(cl-defmethod cg-renderer-hit ((r cg-svg-renderer) (game cg-game) position)
|
||||
(cl-defmethod card-games-renderer-hit ((r card-games-svg-renderer) (game card-games-game) position)
|
||||
"Map POSITION to a GAME action via R regions from the last draw."
|
||||
(ignore game)
|
||||
(let ((xy (posn-object-x-y position)) (sc (cg-scale)))
|
||||
(and xy (cg-regions-hit (oref r regions)
|
||||
(let ((xy (posn-object-x-y position)) (sc (card-games-scale)))
|
||||
(and xy (card-games-regions-hit (oref r regions)
|
||||
(round (/ (car xy) sc)) (round (/ (cdr xy) sc))))))
|
||||
|
||||
(provide 'cg-render)
|
||||
;;; cg-render.el ends here
|
||||
(provide 'card-games-render)
|
||||
;;; card-games-render.el ends here
|
||||
666
card-games-rum500.el
Normal file
666
card-games-rum500.el
Normal file
|
|
@ -0,0 +1,666 @@
|
|||
;;; card-games-rum500.el --- Basic Rummy and Rummy 500 -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Two table-meld rummy games sharing one engine, built on the meld
|
||||
;; finder in card-games-rummy.el.
|
||||
;;
|
||||
;; In a table-meld game you draw a card, lay melds face-up on the table,
|
||||
;; lay single cards off onto melds already there, and end your turn by
|
||||
;; discarding. Empty your hand to go out.
|
||||
;;
|
||||
;; `card-games-rummy-basic' -- plain Rummy: the first player to meld their whole
|
||||
;; hand wins the deal and scores the cards left in the others' hands.
|
||||
;; `card-games-rum500' -- Rummy 500: you score the cards you lay down and lose
|
||||
;; the cards left in your hand; first past 500 wins. In Rummy 500 you
|
||||
;; may take a card from anywhere in the discard pile (T): you take that
|
||||
;; card and everything above it, and the chosen card is melded at once.
|
||||
;;
|
||||
;; You are the South player (seat 0); the rest are simple AI. To meld,
|
||||
;; mark cards with SPC and press m; to lay a card off, put the cursor on
|
||||
;; it and press l.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-rummy)
|
||||
|
||||
(defclass card-games-tablemeld-game (card-games-rummy-game)
|
||||
((nplayers :initarg :nplayers :initform 2)
|
||||
(hand-size :initarg :hand-size :initform 10)
|
||||
(ace-15 :initarg :ace-15 :initform nil)
|
||||
(ace-high :initarg :ace-high :initform nil)
|
||||
(target :initarg :target :initform 100)
|
||||
(score-style :initarg :score-style :initform 'go-out)
|
||||
(deep-pickup :initarg :deep-pickup :initform nil))
|
||||
"Abstract base for table-meld rummy games (Basic Rummy, Rummy 500)."
|
||||
:abstract t)
|
||||
|
||||
;;;; Engine
|
||||
|
||||
(cl-defmethod card-games-tm--deal ((game card-games-tablemeld-game))
|
||||
"Deal a fresh hand into GAME."
|
||||
(let* ((n (oref game nplayers))
|
||||
(deck (card-games-rummy-deck))
|
||||
(per (oref game hand-size))
|
||||
(hands (make-vector n nil)))
|
||||
(dotimes (s n)
|
||||
(aset hands s (card-games-rummy-sort-hand (cl-loop repeat per collect (pop deck)))))
|
||||
(card-games-put game :hands hands)
|
||||
(card-games-put game :nplayers n)
|
||||
(card-games-put game :discard (list (pop deck)))
|
||||
(card-games-put game :stock deck)
|
||||
(card-games-put game :table nil)
|
||||
(card-games-put game :laid (make-vector n 0))
|
||||
(card-games-put game :turn 0)
|
||||
(card-games-put game :step 'draw)
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :cursor 0)
|
||||
(card-games-put game :marks nil)
|
||||
(unless (card-games-get game :scores) (card-games-put game :scores (make-vector n 0)))
|
||||
(card-games-put game :message "Your turn: s draws from stock, t takes the discard.")
|
||||
game))
|
||||
|
||||
(defun card-games-tm--ace-high (game) "Return non-nil when GAME plays the Ace high." (oref game ace-high))
|
||||
(defun card-games-tm--ace-15 (game) "Return non-nil when GAME scores the Ace as 15." (oref game ace-15))
|
||||
(defun card-games-tm--deep-pickup (game) "Return non-nil when GAME's deep discard pickups are enabled." (oref game deep-pickup))
|
||||
|
||||
(defun card-games-tm--draw (game s)
|
||||
"Move one of GAME's stock cards to seat S's hand; return it or nil if empty."
|
||||
(let ((stock (card-games-get game :stock)))
|
||||
(when stock
|
||||
(let ((c (pop stock)))
|
||||
(card-games-put game :stock stock)
|
||||
(card-games-rummy--set-hand game s (card-games-rummy-sort-hand
|
||||
(cons c (card-games-rummy--hand game s))))
|
||||
c))))
|
||||
|
||||
(defun card-games-tm--take-top (game s)
|
||||
"Move GAME's discard top to seat S's hand and return it."
|
||||
(let ((c (card-games-rummy--top game)))
|
||||
(when c
|
||||
(card-games-put game :discard (cdr (card-games-get game :discard)))
|
||||
(card-games-rummy--set-hand game s (card-games-rummy-sort-hand
|
||||
(cons c (card-games-rummy--hand game s))))
|
||||
c)))
|
||||
|
||||
(defun card-games-tm--meld-value (game cards)
|
||||
"Return the total point value of CARDS for GAME's scoring."
|
||||
(apply #'+ (mapcar (lambda (c) (card-games-rummy-value c (card-games-tm--ace-15 game))) cards)))
|
||||
|
||||
(cl-defmethod card-games-tm--meld ((game card-games-tablemeld-game) s cards)
|
||||
"Have GAME seat S meld CARDS onto the table. Return non-nil on success."
|
||||
(when (card-games-rummy-meld-p cards :min 3 :ace-high (card-games-tm--ace-high game)
|
||||
:distinct-suits t)
|
||||
(dolist (c cards) (card-games-rummy--set-hand game s (remove c (card-games-rummy--hand game s))))
|
||||
(card-games-put game :table (append (card-games-get game :table)
|
||||
(list (cons s (copy-sequence cards)))))
|
||||
(let ((laid (card-games-get game :laid)))
|
||||
(aset laid s (+ (aref laid s) (card-games-tm--meld-value game cards))))
|
||||
t))
|
||||
|
||||
(cl-defmethod card-games-tm--layoff ((game card-games-tablemeld-game) s card)
|
||||
"Have GAME seat S lay CARD off onto a matching meld; non-nil on success."
|
||||
(let ((rec (cl-find-if
|
||||
(lambda (r) (card-games-rummy-meld-p (cons card (cdr r)) :min 3
|
||||
:ace-high (card-games-tm--ace-high game)))
|
||||
(card-games-get game :table))))
|
||||
(when rec
|
||||
(card-games-rummy--set-hand game s (remove card (card-games-rummy--hand game s)))
|
||||
(setcdr rec (card-games-rummy-sort-hand (cons card (cdr rec))))
|
||||
(let ((laid (card-games-get game :laid)))
|
||||
(aset laid s (+ (aref laid s) (card-games-rummy-value card (card-games-tm--ace-15 game)))))
|
||||
t)))
|
||||
|
||||
(cl-defmethod card-games-tm--score-hand ((game card-games-tablemeld-game) outseat)
|
||||
"Score GAME's hand ended by OUTSEAT (or nil for a washed-out hand)."
|
||||
(let* ((n (card-games-get game :nplayers)) (scores (card-games-get game :scores))
|
||||
(style (oref game score-style)))
|
||||
(cond
|
||||
((eq style 'go-out)
|
||||
(when outseat
|
||||
(let ((sum 0))
|
||||
(dotimes (s n)
|
||||
(unless (= s outseat)
|
||||
(dolist (c (card-games-rummy--hand game s))
|
||||
(setq sum (+ sum (card-games-rummy-value c))))))
|
||||
(aset scores outseat (+ (aref scores outseat) sum)))))
|
||||
((eq style 'meld-points)
|
||||
(let ((laid (card-games-get game :laid)))
|
||||
(dotimes (s n)
|
||||
(let ((rem (apply #'+ (mapcar (lambda (c)
|
||||
(card-games-rummy-value c (card-games-tm--ace-15 game)))
|
||||
(card-games-rummy--hand game s)))))
|
||||
(aset scores s (+ (aref scores s) (- (aref laid s) rem))))))))
|
||||
;; decide if the game is over
|
||||
(let ((win nil) (best most-negative-fixnum))
|
||||
(dotimes (s n)
|
||||
(when (and (>= (aref scores s) (oref game target))
|
||||
(> (aref scores s) best))
|
||||
(setq win s best (aref scores s))))
|
||||
(card-games-put game :phase (if win 'game-over 'hand-over))
|
||||
(card-games-put game :winner (or win outseat))
|
||||
(card-games-put game :reveal t)
|
||||
(card-games-put game :message
|
||||
(if win
|
||||
(format "%s wins the game with %d! (n: new game)"
|
||||
(card-games-tm--who win) (aref scores win))
|
||||
(concat (if outseat (format "%s goes out. " (card-games-tm--who outseat))
|
||||
"Stock exhausted. ")
|
||||
(format "Scores: %s. (n: next hand)"
|
||||
(card-games-tm--scores-string game))))))))
|
||||
|
||||
(defun card-games-tm--who (s) "Return the display name of seat S." (if (= s 0) "You" (format "Player %d" s)))
|
||||
|
||||
(defun card-games-tm--scores-string (game)
|
||||
"Return a compact \"You N · P1 N ...\" score line for GAME."
|
||||
(let ((scores (card-games-get game :scores)) (parts '()))
|
||||
(dotimes (s (card-games-get game :nplayers))
|
||||
(push (format "%s %d" (if (= s 0) "You" (format "P%d" s)) (aref scores s))
|
||||
parts))
|
||||
(mapconcat #'identity (nreverse parts) " · ")))
|
||||
|
||||
(cl-defmethod card-games-tm--end-turn ((game card-games-tablemeld-game) s)
|
||||
"Finish GAME seat S's turn: go out if the hand is empty, else advance."
|
||||
(if (null (card-games-rummy--hand game s))
|
||||
(card-games-tm--score-hand game s)
|
||||
(card-games-put game :turn (mod (1+ s) (card-games-get game :nplayers)))
|
||||
(card-games-put game :step 'draw)))
|
||||
|
||||
(cl-defmethod card-games-tm--discard ((game card-games-tablemeld-game) s card)
|
||||
"Discard CARD from GAME seat S and finish the turn."
|
||||
(card-games-rummy--set-hand game s (remove card (card-games-rummy--hand game s)))
|
||||
(card-games-put game :discard (cons card (card-games-get game :discard)))
|
||||
(card-games-tm--end-turn game s))
|
||||
|
||||
;;;; AI
|
||||
|
||||
(defun card-games-tm--ai-melds (game s)
|
||||
"Lay down every meld GAME seat S can, keeping a card back to discard.
|
||||
Return non-nil if any meld was laid."
|
||||
(let ((did nil) (again t))
|
||||
(while again
|
||||
(setq again nil)
|
||||
(let* ((hand (card-games-rummy--hand game s))
|
||||
(p (card-games-rummy-best-partition hand :ace-high (card-games-tm--ace-high game)
|
||||
:ace-15 (card-games-tm--ace-15 game)))
|
||||
(melds (plist-get p :melds))
|
||||
;; keep one card to discard: skip a meld if it would empty the hand
|
||||
(melded (apply #'+ (mapcar #'length melds))))
|
||||
(when (and melds (= melded (length hand)))
|
||||
(setq melds (cdr (sort melds (lambda (a b) (< (length a) (length b)))))))
|
||||
(when melds
|
||||
(card-games-tm--meld game s (car melds))
|
||||
(setq did t again t))))
|
||||
did))
|
||||
|
||||
(defun card-games-tm--ai-layoffs (game s)
|
||||
"Lay off every fitting card from GAME seat S, keeping a card to discard."
|
||||
(let ((again t))
|
||||
(while again
|
||||
(setq again nil)
|
||||
(when (> (length (card-games-rummy--hand game s)) 1)
|
||||
(let ((card (cl-find-if
|
||||
(lambda (c)
|
||||
(cl-find-if
|
||||
(lambda (r) (card-games-rummy-meld-p (cons c (cdr r)) :min 3
|
||||
:ace-high (card-games-tm--ace-high game)))
|
||||
(card-games-get game :table)))
|
||||
(card-games-rummy--hand game s))))
|
||||
(when card (card-games-tm--layoff game s card) (setq again t)))))))
|
||||
|
||||
(defun card-games-tm--ai-discard-card (game s)
|
||||
"Return the best card for GAME seat S to discard (highest deadwood)."
|
||||
(let* ((hand (card-games-rummy--hand game s))
|
||||
(p (card-games-rummy-best-partition hand :ace-high (card-games-tm--ace-high game)
|
||||
:ace-15 (card-games-tm--ace-15 game)))
|
||||
(dead (or (plist-get p :deadwood) hand))
|
||||
(best (car dead)) (bestv -1))
|
||||
(dolist (c dead best)
|
||||
(let ((v (card-games-rummy-value c (card-games-tm--ace-15 game))))
|
||||
(when (> v bestv) (setq best c bestv v))))))
|
||||
|
||||
(defun card-games-tm--meld-for-target (game cards target)
|
||||
"Return a minimal valid GAME meld (card list) with TARGET drawn from CARDS.
|
||||
Return nil when TARGET cannot join a set or run with the other CARDS."
|
||||
(let* ((ace-high (card-games-tm--ace-high game))
|
||||
(pool (cons target cards))
|
||||
(cands (card-games-rummy--candidate-melds pool :ace-high ace-high))
|
||||
(vec (vconcat pool))
|
||||
(withtgt (cl-remove-if-not (lambda (m) (memq 0 m)) cands)))
|
||||
(when withtgt
|
||||
(setq withtgt (sort withtgt (lambda (a b) (< (length a) (length b)))))
|
||||
(mapcar (lambda (i) (aref vec i)) (car withtgt)))))
|
||||
|
||||
(defun card-games-tm--take-deep (game s depth)
|
||||
"Have GAME seat S take the card at DEPTH in the discard, plus all above.
|
||||
The chosen card is melded or laid off at once, as Rummy 500 requires; the
|
||||
rest enter the hand. Return a status string, or nil when the move is not
|
||||
legal (the chosen card cannot be used immediately)."
|
||||
(let* ((pile (card-games-get game :discard)) (n (length pile)))
|
||||
(when (and (card-games-tm--deep-pickup game) (>= depth 0) (< depth n))
|
||||
(let* ((target (nth depth pile))
|
||||
(above (cl-subseq pile 0 depth))
|
||||
(avail (append (card-games-rummy--hand game s) above))
|
||||
(lay (cl-find-if
|
||||
(lambda (r)
|
||||
(card-games-rummy-meld-p (cons target (cdr r)) :min 3
|
||||
:ace-high (card-games-tm--ace-high game)))
|
||||
(card-games-get game :table)))
|
||||
(meld (unless lay (card-games-tm--meld-for-target game avail target))))
|
||||
(when (or lay meld)
|
||||
(let ((taken (cl-subseq pile 0 (1+ depth))))
|
||||
(card-games-put game :discard (nthcdr (1+ depth) pile))
|
||||
(dolist (c taken)
|
||||
(card-games-rummy--set-hand game s (card-games-rummy-sort-hand
|
||||
(cons c (card-games-rummy--hand game s))))))
|
||||
(if lay (card-games-tm--layoff game s target) (card-games-tm--meld game s meld))
|
||||
(format "Took %d card%s and used %s."
|
||||
(1+ depth) (if (= depth 0) "" "s")
|
||||
(card-games-rummy-card-string target)))))))
|
||||
|
||||
(defun card-games-tm--ai-deep-pickup (game s)
|
||||
"Try a worthwhile below-the-top discard pickup for GAME seat S.
|
||||
Return non-nil when one was taken."
|
||||
(when (card-games-tm--deep-pickup game)
|
||||
(let* ((pile (card-games-get game :discard)) (n (length pile))
|
||||
(limit (min n 7)) (hand (card-games-rummy--hand game s)) (chosen nil))
|
||||
(cl-loop for d from 1 below limit
|
||||
for target = (nth d pile)
|
||||
for above = (cl-subseq pile 0 d)
|
||||
when (card-games-tm--meld-for-target game (append hand above) target)
|
||||
do (setq chosen d) (cl-return))
|
||||
(when chosen (card-games-tm--take-deep game s chosen)))))
|
||||
|
||||
(cl-defmethod card-games-tm--ai-turn ((game card-games-tablemeld-game) s)
|
||||
"Play GAME seat S's whole turn."
|
||||
(let* ((deep (card-games-tm--ai-deep-pickup game s))
|
||||
(drew (if deep t
|
||||
(let* ((hand (card-games-rummy--hand game s))
|
||||
(up (card-games-rummy--top game))
|
||||
(cur (card-games-rummy-deadwood hand (card-games-tm--ace-high game)
|
||||
(card-games-tm--ace-15 game)))
|
||||
(with (and up (card-games-rummy-deadwood
|
||||
(cons up hand)
|
||||
(card-games-tm--ace-high game) (card-games-tm--ace-15 game)))))
|
||||
(if (and up with (< with cur))
|
||||
(card-games-tm--take-top game s)
|
||||
(card-games-tm--draw game s))))))
|
||||
(if (not drew)
|
||||
(card-games-tm--score-hand game nil)
|
||||
(card-games-tm--ai-melds game s)
|
||||
(card-games-tm--ai-layoffs game s)
|
||||
(when (eq (card-games-get game :phase) 'play)
|
||||
(if (null (card-games-rummy--hand game s))
|
||||
(card-games-tm--end-turn game s) ; melded out, no discard needed
|
||||
(card-games-tm--discard game s (card-games-tm--ai-discard-card game s)))))))
|
||||
|
||||
(defun card-games-tm--run (game)
|
||||
"Advance GAME's AI seats until the human's turn or the hand ends."
|
||||
(while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0))
|
||||
(card-games-tm--ai-turn game (card-games-get game :turn))))
|
||||
|
||||
;;;; UI
|
||||
|
||||
(defvar-local card-games-tm--game nil "The table-meld game in the current buffer.")
|
||||
|
||||
(defun card-games-tm--discard-string (game)
|
||||
"Return the discard-pile display line for GAME.
|
||||
Deep-pickup games show the whole pile with depth indices (0 = top)."
|
||||
(cl-flet ((paint (c)
|
||||
(let ((cs (card-games-rummy-card-string c)))
|
||||
(if (and c (not (card-games-rummy-joker-p c)) (card-games-red-suit-p (car c)))
|
||||
(propertize cs 'face 'card-games-red-suit) cs))))
|
||||
(let ((pile (card-games-get game :discard)))
|
||||
(if (and (card-games-tm--deep-pickup game) (cdr pile))
|
||||
(concat "Discard (0=top): "
|
||||
(let ((i -1))
|
||||
(mapconcat
|
||||
(lambda (c) (setq i (1+ i)) (format "%d:%s" i (paint c)))
|
||||
(cl-subseq pile 0 (min (length pile) 12)) " ")))
|
||||
(concat "Discard: " (paint (card-games-rummy--top game)))))))
|
||||
|
||||
(defun card-games-tm--layoff-hint (game)
|
||||
"Return a predicate marking cards that can be laid off in GAME now."
|
||||
(lambda (c)
|
||||
(cl-find-if (lambda (r) (card-games-rummy-meld-p (cons c (cdr r)) :min 3
|
||||
:ace-high (card-games-tm--ace-high game)))
|
||||
(card-games-get game :table))))
|
||||
|
||||
(defun card-games-tm--svg (game)
|
||||
"Return an SVG board for the table-meld GAME."
|
||||
(let* ((scores (card-games-get game :scores)) (laid (card-games-get game :laid))
|
||||
(meldp (oref game score-style)))
|
||||
(card-games-rummy--board-svg
|
||||
:title (format "%s (target %d)" (oref game vname) (oref game target))
|
||||
:infos (let (out)
|
||||
(dotimes (s (card-games-get game :nplayers))
|
||||
(unless (= s 0)
|
||||
(push (format "Player %d: %d cards score %d%s"
|
||||
s (length (card-games-rummy--hand game s)) (aref scores s)
|
||||
(if (eq meldp 'meld-points)
|
||||
(format " laid %d" (aref laid s)) ""))
|
||||
out)))
|
||||
(nreverse out))
|
||||
:melds (mapcar (lambda (rec)
|
||||
(cons (if (= (car rec) 0) "you" (format "P%d" (car rec)))
|
||||
(cdr rec)))
|
||||
(card-games-get game :table))
|
||||
:discard (card-games-rummy--top game) :stock (length (card-games-get game :stock))
|
||||
:hand (card-games-rummy--hand game 0) :cursor (card-games-get game :cursor)
|
||||
:marks (card-games-get game :marks) :hint-fn (card-games-tm--layoff-hint game)
|
||||
:message (card-games-get game :message))))
|
||||
|
||||
(cl-defmethod card-games-render ((game card-games-tablemeld-game))
|
||||
"Return a depiction of the table-meld GAME: SVG board if graphical, else text."
|
||||
(if (and card-games-rummy-svg-cards (display-graphic-p))
|
||||
(card-games-tm--svg game)
|
||||
(card-games-tm--render-text game)))
|
||||
|
||||
(defun card-games-tm--render-text (game)
|
||||
"Return a plain-text depiction of the table-meld GAME."
|
||||
(let* ((out '()) (scores (card-games-get game :scores))
|
||||
(laid (card-games-get game :laid)) (meldp (oref game score-style))
|
||||
(hand (card-games-rummy--hand game 0)) (cursor (card-games-get game :cursor)))
|
||||
(push (format " %s target %d\n\n" (oref game vname) (oref game target)) out)
|
||||
(dotimes (s (card-games-get game :nplayers))
|
||||
(unless (= s 0)
|
||||
(push (format " Player %d: %d cards score %d%s\n"
|
||||
s (length (card-games-rummy--hand game s)) (aref scores s)
|
||||
(if (eq meldp 'meld-points)
|
||||
(format " (laid %d)" (aref laid s)) ""))
|
||||
out)))
|
||||
(push "\n Table:\n" out)
|
||||
(if (card-games-get game :table)
|
||||
(dolist (rec (card-games-get game :table))
|
||||
(push (format " [%s] %s\n" (if (= (car rec) 0) "you" (format "P%d" (car rec)))
|
||||
(mapconcat #'card-games-rummy-card-string (cdr rec) " "))
|
||||
out))
|
||||
(push " (empty)\n" out))
|
||||
(push (format "\n %s Stock: %d\n\n"
|
||||
(card-games-tm--discard-string game)
|
||||
(length (card-games-get game :stock)))
|
||||
out)
|
||||
(push (format " Your hand%s:\n "
|
||||
(if (eq meldp 'meld-points) (format " (laid %d, score %d)"
|
||||
(aref laid 0) (aref scores 0))
|
||||
(format " (score %d)" (aref scores 0))))
|
||||
out)
|
||||
(push (card-games-rummy--render-cards hand cursor (card-games-get game :marks)
|
||||
(card-games-tm--layoff-hint game) 'hand)
|
||||
out)
|
||||
(push (format "\n\n %s\n" (card-games-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod card-games-render-apply ((g card-games-tablemeld-game) action)
|
||||
"Apply a click ACTION on the hand to GAME G."
|
||||
(pcase action
|
||||
(`(hand . ,i) (card-games-put g :cursor i))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun card-games-tm--redisplay ()
|
||||
"Redraw the table-meld buffer."
|
||||
(let ((game card-games-tm--game) (inhibit-read-only t))
|
||||
(setq card-games-current-game game card-games-redisplay-function #'card-games-tm--redisplay)
|
||||
(setq-local mode-line-process
|
||||
(format " [%s]" (or (card-games-get game :step) (card-games-get game :phase))))
|
||||
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
|
||||
|
||||
(defun card-games-tm--clamp-cursor (g)
|
||||
"Keep G's cursor within the hand and drop stale marked cards."
|
||||
(let ((n (length (card-games-rummy--hand g 0))))
|
||||
(card-games-put g :cursor (if (> n 0) (min (card-games-get g :cursor) (1- n)) 0))
|
||||
(card-games-put g :marks (cl-remove-if (lambda (i) (>= i n)) (card-games-get g :marks)))))
|
||||
|
||||
(defun card-games-tm--my-turn-p (g)
|
||||
"Return non-nil when it is your turn in G."
|
||||
(and (eq (card-games-get g :phase) 'play) (= (card-games-get g :turn) 0)))
|
||||
|
||||
(defun card-games-tm-left ()
|
||||
"Move the hand cursor left."
|
||||
(interactive)
|
||||
(let* ((g card-games-tm--game) (n (length (card-games-rummy--hand g 0))))
|
||||
(when (> n 0) (card-games-put g :cursor (mod (1- (card-games-get g :cursor)) n)))
|
||||
(card-games-tm--redisplay)))
|
||||
|
||||
(defun card-games-tm-right ()
|
||||
"Move the hand cursor right."
|
||||
(interactive)
|
||||
(let* ((g card-games-tm--game) (n (length (card-games-rummy--hand g 0))))
|
||||
(when (> n 0) (card-games-put g :cursor (mod (1+ (card-games-get g :cursor)) n)))
|
||||
(card-games-tm--redisplay)))
|
||||
|
||||
(defun card-games-tm-mark ()
|
||||
"Toggle a mark on the card under the cursor (for melding)."
|
||||
(interactive)
|
||||
(let* ((g card-games-tm--game) (i (card-games-get g :cursor)) (marks (card-games-get g :marks)))
|
||||
(card-games-put g :marks (if (memq i marks) (delq i marks) (cons i marks)))
|
||||
(card-games-tm--redisplay)))
|
||||
|
||||
(defun card-games-tm--marked-cards (g)
|
||||
"Return the cards currently marked in G's hand."
|
||||
(let ((hand (card-games-rummy--hand g 0)))
|
||||
(mapcar (lambda (i) (nth i hand)) (sort (copy-sequence (card-games-get g :marks)) #'<))))
|
||||
|
||||
(defun card-games-tm-meld ()
|
||||
"Meld the marked cards onto the table."
|
||||
(interactive)
|
||||
(let* ((g card-games-tm--game) (cards (card-games-tm--marked-cards g)))
|
||||
(cond
|
||||
((not (card-games-tm--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((eq (card-games-get g :step) 'draw) (card-games-put g :message "Draw first (s or t)."))
|
||||
((< (length cards) 3) (card-games-put g :message "Mark at least three cards (SPC), then m."))
|
||||
((card-games-tm--meld g 0 cards)
|
||||
(card-games-put g :marks nil) (card-games-tm--clamp-cursor g)
|
||||
(card-games-put g :message "Melded. Lay off with l, meld more, or discard (RET)."))
|
||||
(t (card-games-put g :message "Those cards are not a valid set or run.")))
|
||||
(card-games-tm--redisplay)))
|
||||
|
||||
(defun card-games-tm-layoff ()
|
||||
"Lay the cursor card (or marked cards) off onto a table meld."
|
||||
(interactive)
|
||||
(let* ((g card-games-tm--game) (marks (card-games-tm--marked-cards g)))
|
||||
(cond
|
||||
((not (card-games-tm--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((eq (card-games-get g :step) 'draw) (card-games-put g :message "Draw first (s or t)."))
|
||||
(t (let ((cards (or marks (list (nth (card-games-get g :cursor) (card-games-rummy--hand g 0)))))
|
||||
(any nil))
|
||||
(dolist (c cards) (when (and c (card-games-tm--layoff g 0 c)) (setq any t)))
|
||||
(card-games-put g :marks nil) (card-games-tm--clamp-cursor g)
|
||||
(card-games-put g :message (if any "Laid off." "That card fits no meld on the table.")))))
|
||||
(card-games-tm--redisplay)))
|
||||
|
||||
(defun card-games-tm-draw-stock ()
|
||||
"Draw the top stock card."
|
||||
(interactive)
|
||||
(let ((g card-games-tm--game))
|
||||
(cond
|
||||
((not (card-games-tm--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((not (eq (card-games-get g :step) 'draw)) (card-games-put g :message "You already drew."))
|
||||
((card-games-tm--draw g 0)
|
||||
(card-games-put g :step 'play) (card-games-tm--clamp-cursor g)
|
||||
(card-games-put g :message "Meld (m), lay off (l), then discard (RET)."))
|
||||
(t (card-games-tm--score-hand g nil)))
|
||||
(card-games-tm--redisplay)))
|
||||
|
||||
(defun card-games-tm-take ()
|
||||
"Take the discard top into your hand."
|
||||
(interactive)
|
||||
(let ((g card-games-tm--game))
|
||||
(cond
|
||||
((not (card-games-tm--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((not (eq (card-games-get g :step) 'draw)) (card-games-put g :message "You already drew."))
|
||||
((null (card-games-rummy--top g)) (card-games-put g :message "The discard pile is empty."))
|
||||
(t (let ((c (card-games-tm--take-top g 0)))
|
||||
(card-games-put g :step 'play) (card-games-tm--clamp-cursor g)
|
||||
(card-games-put g :message (format "Took %s. Meld (m), lay off (l), discard (RET)."
|
||||
(card-games-rummy-card-string c))))))
|
||||
(card-games-tm--redisplay)))
|
||||
|
||||
(defun card-games-tm-take-deep ()
|
||||
"Take a card from below the top of the discard pile (Rummy 500).
|
||||
You take that card and every card lying on top of it; the chosen card is
|
||||
melded or laid off at once, the rest go into your hand."
|
||||
(interactive)
|
||||
(let* ((g card-games-tm--game) (pile (card-games-get g :discard)) (n (length pile)))
|
||||
(cond
|
||||
((not (card-games-tm--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((not (card-games-tm--deep-pickup g))
|
||||
(card-games-put g :message "This game lets you take only the top discard (t)."))
|
||||
((not (eq (card-games-get g :step) 'draw)) (card-games-put g :message "You already drew."))
|
||||
((< n 1) (card-games-put g :message "The discard pile is empty."))
|
||||
(t (let ((depth (read-number
|
||||
(format "Take how deep? 0=top .. %d (you must meld that card): "
|
||||
(1- n)) 0)))
|
||||
(if (and (integerp depth) (>= depth 0) (< depth n))
|
||||
(let ((desc (card-games-tm--take-deep g 0 depth)))
|
||||
(if desc
|
||||
(progn (card-games-put g :step 'play) (card-games-tm--clamp-cursor g)
|
||||
(card-games-put g :message
|
||||
(concat desc " Meld, lay off, or discard (RET).")))
|
||||
(card-games-put g :message
|
||||
"You can't use that card right now -- choose another.")))
|
||||
(card-games-put g :message "No card at that depth.")))))
|
||||
(card-games-tm--redisplay)))
|
||||
|
||||
(defun card-games-tm-discard ()
|
||||
"Discard the cursor card and end your turn."
|
||||
(interactive)
|
||||
(let* ((g card-games-tm--game) (card (nth (card-games-get g :cursor) (card-games-rummy--hand g 0))))
|
||||
(cond
|
||||
((not (card-games-tm--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((eq (card-games-get g :step) 'draw) (card-games-put g :message "Draw first (s or t)."))
|
||||
((null card) (card-games-put g :message "No card selected."))
|
||||
(t (card-games-tm--discard g 0 card)
|
||||
(card-games-put g :marks nil)
|
||||
(when (eq (card-games-get g :phase) 'play)
|
||||
(card-games-put g :message "You discarded.")
|
||||
(card-games-tm--run g))))
|
||||
(card-games-tm--redisplay)))
|
||||
|
||||
(defun card-games-tm-new ()
|
||||
"Deal a fresh hand, or a new game when one is over."
|
||||
(interactive)
|
||||
(let ((g card-games-tm--game))
|
||||
(when (eq (card-games-get g :phase) 'game-over)
|
||||
(card-games-put g :scores (make-vector (oref g nplayers) 0)))
|
||||
(card-games-put g :reveal nil)
|
||||
(card-games-tm--deal g)
|
||||
(card-games-tm--run g)
|
||||
(card-games-tm--redisplay)))
|
||||
|
||||
(defun card-games-tm-redraw () "Redraw the board." (interactive) (card-games-tm--redisplay))
|
||||
|
||||
(defun card-games-tm-help ()
|
||||
"Describe the table-meld controls."
|
||||
(interactive)
|
||||
(message "Arrows: choose SPC: mark m: meld l: lay off s: draw t: take T: deep take RET: discard n: new"))
|
||||
|
||||
(defvar card-games-tm-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'card-games-card-click)
|
||||
(define-key map "+" #'card-games-card-zoom-in)
|
||||
(define-key map "=" #'card-games-card-zoom-in)
|
||||
(define-key map "-" #'card-games-card-zoom-out)
|
||||
(define-key map "0" #'card-games-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'card-games-tm-left)
|
||||
(define-key map (kbd "<right>") #'card-games-tm-right)
|
||||
(define-key map (kbd "SPC") #'card-games-tm-mark)
|
||||
(define-key map "m" #'card-games-tm-meld)
|
||||
(define-key map "l" #'card-games-tm-layoff)
|
||||
(define-key map "s" #'card-games-tm-draw-stock)
|
||||
(define-key map "t" #'card-games-tm-take)
|
||||
(define-key map "T" #'card-games-tm-take-deep)
|
||||
(define-key map (kbd "RET") #'card-games-tm-discard)
|
||||
(define-key map "n" #'card-games-tm-new)
|
||||
(define-key map "g" #'card-games-tm-redraw)
|
||||
(define-key map "?" #'card-games-tm-help)
|
||||
(define-key map "q" #'card-games-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `card-games-tm-mode'.")
|
||||
|
||||
(define-derived-mode card-games-tm-mode special-mode "Rummy"
|
||||
"Major mode for the table-meld rummy games."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type card-games-cursor-type))
|
||||
|
||||
(defun card-games-tm--start (game buffer-name)
|
||||
"Start GAME in a buffer named BUFFER-NAME."
|
||||
(let ((buf (get-buffer-create buffer-name)))
|
||||
(with-current-buffer buf
|
||||
(card-games-tm-mode)
|
||||
(setq card-games-tm--game game)
|
||||
(card-games-tm--deal game)
|
||||
(card-games-tm--run game)
|
||||
(card-games-tm--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;; The two games
|
||||
|
||||
(defcustom card-games-rummy-basic-players 2
|
||||
"Number of players in Basic Rummy, including you (2-4)."
|
||||
:type '(choice (const 2) (const 3) (const 4)) :group 'card-games)
|
||||
|
||||
(defclass card-games-rummy-basic-game (card-games-tablemeld-game)
|
||||
((vname :initform "Rummy")
|
||||
(score-style :initform 'go-out)
|
||||
(target :initform 100))
|
||||
"A game of plain Rummy.")
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-rummy-basic ()
|
||||
"Play Basic Rummy against the computer."
|
||||
(interactive)
|
||||
(let ((n (max 2 (min 4 card-games-rummy-basic-players))))
|
||||
(card-games-tm--start (card-games-rummy-basic-game :nplayers n :hand-size (if (= n 2) 10 7))
|
||||
"*Rummy*")))
|
||||
|
||||
(defcustom card-games-rum500-players 3
|
||||
"Number of players in Rummy 500, including you (2-4)."
|
||||
:type '(choice (const 2) (const 3) (const 4)) :group 'card-games)
|
||||
|
||||
(defclass card-games-rum500-game (card-games-tablemeld-game)
|
||||
((vname :initform "Rummy 500")
|
||||
(score-style :initform 'meld-points)
|
||||
(ace-15 :initform t)
|
||||
(ace-high :initform t)
|
||||
(deep-pickup :initform t)
|
||||
(target :initform 500))
|
||||
"A game of Rummy 500.")
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-rum500 ()
|
||||
"Play Rummy 500 against the computer."
|
||||
(interactive)
|
||||
(let ((n (max 2 (min 4 card-games-rum500-players))))
|
||||
(card-games-tm--start (card-games-rum500-game :nplayers n :hand-size (if (= n 2) 13 7))
|
||||
"*Rummy 500*")))
|
||||
|
||||
;;;###autoload
|
||||
(defalias 'card-games-rummy-500 #'card-games-rum500)
|
||||
|
||||
(provide 'card-games-rum500)
|
||||
;;; card-games-rum500.el ends here
|
||||
786
card-games-rummy.el
Normal file
786
card-games-rummy.el
Normal file
|
|
@ -0,0 +1,786 @@
|
|||
;;; card-games-rummy.el --- Rummy meld engine and Gin Rummy -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; The shared meld engine for the rummy family, plus Gin Rummy.
|
||||
;;
|
||||
;; A "meld" is a list of cards that is either a *set* (three or four cards
|
||||
;; of the same rank) or a *run* (three or more cards of the same suit in
|
||||
;; consecutive rank). The engine validates melds, enumerates the melds
|
||||
;; latent in a hand, and -- the hard part -- finds the layout that leaves
|
||||
;; the least deadwood, which drives both knock detection and the AI.
|
||||
;;
|
||||
;; Cards use the package-standard cons (SUIT . RANK) with SUIT 0 spades,
|
||||
;; 1 clubs, 2 diamonds, 3 hearts, and RANK 0 (Ace) .. 12 (King). A joker,
|
||||
;; used only by Hand & Foot, is the cons (joker . 0).
|
||||
;;
|
||||
;; Gin Rummy: a two-handed game of ten-card hands. Draw from the stock or
|
||||
;; take the discard, then discard one card. Knock when your deadwood is
|
||||
;; ten or less, or go gin with none; your opponent then lays off onto your
|
||||
;; melds. First to 100 points wins. This file also provides the abstract
|
||||
;; `card-games-rummy-game' base and the rendering helpers reused by the other
|
||||
;; rummy games (card-games-rum500.el, card-games-handfoot.el).
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-svg)
|
||||
|
||||
(defconst card-games-rummy-ranks
|
||||
["A" "2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K"]
|
||||
"Rank labels indexed 0 (Ace) .. 12 (King).")
|
||||
|
||||
(defface card-games-rummy-mark '((t :background "steelblue" :foreground "white"))
|
||||
"Face for a card the player has marked toward a meld."
|
||||
:group 'card-games)
|
||||
|
||||
(defun card-games-rummy-card-string (card)
|
||||
"Return a short label for CARD, or a dot for nil."
|
||||
(cond ((null card) "·")
|
||||
((eq (car card) 'joker) (card-games-suit-glyph 'joker))
|
||||
(t (concat (aref card-games-rummy-ranks (cdr card)) (card-games-suit-glyph (car card))))))
|
||||
|
||||
(defun card-games-rummy-joker-p (card)
|
||||
"Return non-nil when CARD is a joker."
|
||||
(and card (eq (car card) 'joker)))
|
||||
|
||||
(defun card-games-rummy-value (card &optional ace-15)
|
||||
"Return the point value of CARD.
|
||||
Faces and tens are 10, an Ace is 1 (or 15 when ACE-15 is non-nil), and
|
||||
other cards their pip value. A joker is worth 0 here; games that use
|
||||
jokers value them separately."
|
||||
(cond ((or (null card) (card-games-rummy-joker-p card)) 0)
|
||||
(t (let ((r (cdr card)))
|
||||
(cond ((= r 0) (if ace-15 15 1))
|
||||
((<= r 8) (1+ r))
|
||||
(t 10))))))
|
||||
|
||||
|
||||
;;;; Meld predicates
|
||||
|
||||
(defun card-games-rummy--consec-p (ranks)
|
||||
"Return non-nil when sorted RANKS rise by exactly one with no repeats."
|
||||
(let ((ok t) (prev nil))
|
||||
(dolist (r ranks ok)
|
||||
(when (and prev (/= r (1+ prev))) (setq ok nil))
|
||||
(setq prev r))))
|
||||
|
||||
(cl-defun card-games-rummy-set-p (cards &key (min 3) distinct-suits)
|
||||
"Return non-nil when CARDS form a set (>= MIN cards of one rank).
|
||||
With DISTINCT-SUITS, every suit must differ (a single-deck rule)."
|
||||
(and (>= (length cards) min)
|
||||
(not (cl-some #'card-games-rummy-joker-p cards))
|
||||
(let ((r (cdr (car cards))))
|
||||
(cl-every (lambda (c) (= (cdr c) r)) cards))
|
||||
(or (not distinct-suits)
|
||||
(let ((suits (mapcar #'car cards)))
|
||||
(= (length suits)
|
||||
(length (delete-dups (copy-sequence suits))))))))
|
||||
|
||||
(cl-defun card-games-rummy-run-p (cards &key (min 3) ace-high)
|
||||
"Return non-nil when CARDS form a run (>= MIN cards, one suit, in sequence).
|
||||
With ACE-HIGH, an Ace may sit above the King (Q-K-A)."
|
||||
(and (>= (length cards) min)
|
||||
(not (cl-some #'card-games-rummy-joker-p cards))
|
||||
(let ((suit (car (car cards)))
|
||||
(ranks (sort (mapcar #'cdr cards) #'<)))
|
||||
(and (cl-every (lambda (c) (= (car c) suit)) cards)
|
||||
(= (length ranks) (length (delete-dups (copy-sequence ranks))))
|
||||
(or (card-games-rummy--consec-p ranks)
|
||||
(and ace-high (eql (car ranks) 0)
|
||||
(card-games-rummy--consec-p (sort (cons 13 (cdr ranks)) #'<))))))))
|
||||
|
||||
(cl-defun card-games-rummy-meld-p (cards &key (min 3) ace-high distinct-suits)
|
||||
"Return non-nil when CARDS form a valid set or run.
|
||||
MIN, ACE-HIGH and DISTINCT-SUITS are passed through to the predicates."
|
||||
(or (card-games-rummy-set-p cards :min min :distinct-suits distinct-suits)
|
||||
(card-games-rummy-run-p cards :min min :ace-high ace-high)))
|
||||
|
||||
|
||||
;;;; Candidate melds and best partition
|
||||
|
||||
(defun card-games-rummy--combinations (lst k)
|
||||
"Return all combinations of LST taken K at a time, each as a list."
|
||||
(cond ((= k 0) (list nil))
|
||||
((null lst) nil)
|
||||
(t (append
|
||||
(mapcar (lambda (c) (cons (car lst) c))
|
||||
(card-games-rummy--combinations (cdr lst) (1- k)))
|
||||
(card-games-rummy--combinations (cdr lst) k)))))
|
||||
|
||||
(defun card-games-rummy--runs-in (pairs)
|
||||
"Return an index-list for each run (length >= 3) within PAIRS.
|
||||
PAIRS is a list of (RANK . INDEX) sorted ascending by RANK."
|
||||
(let ((res '()) (vec (vconcat pairs)))
|
||||
(let ((n (length vec)))
|
||||
(dotimes (i n)
|
||||
(let ((idxs (list (cdr (aref vec i))))
|
||||
(last (car (aref vec i)))
|
||||
(j (1+ i)))
|
||||
(while (and (< j n) (= (car (aref vec j)) (1+ last)))
|
||||
(setq last (car (aref vec j)))
|
||||
(setq idxs (cons (cdr (aref vec j)) idxs))
|
||||
(when (>= (length idxs) 3)
|
||||
(push (reverse idxs) res))
|
||||
(setq j (1+ j))))))
|
||||
res))
|
||||
|
||||
(cl-defun card-games-rummy--candidate-melds (cards &key ace-high)
|
||||
"Return candidate melds for CARDS as a list of index-lists.
|
||||
Each index-list refers to positions in CARDS. With ACE-HIGH, high runs
|
||||
ending in an Ace are also generated."
|
||||
(let* ((vec (vconcat cards)) (n (length vec)) (melds '()))
|
||||
;; sets, grouped by rank
|
||||
(let ((byrank (make-hash-table :test 'eql)))
|
||||
(dotimes (i n)
|
||||
(let ((c (aref vec i)))
|
||||
(unless (card-games-rummy-joker-p c)
|
||||
(push i (gethash (cdr c) byrank)))))
|
||||
(maphash
|
||||
(lambda (_r idxs)
|
||||
(when (>= (length idxs) 3)
|
||||
(dolist (k '(3 4))
|
||||
(dolist (combo (card-games-rummy--combinations idxs k))
|
||||
(when (card-games-rummy-set-p (mapcar (lambda (i) (aref vec i)) combo)
|
||||
:distinct-suits t)
|
||||
(push (sort (copy-sequence combo) #'<) melds))))))
|
||||
byrank))
|
||||
;; runs, grouped by suit
|
||||
(let ((bysuit (make-hash-table :test 'eql)))
|
||||
(dotimes (i n)
|
||||
(let ((c (aref vec i)))
|
||||
(unless (card-games-rummy-joker-p c)
|
||||
(push (cons (cdr c) i) (gethash (car c) bysuit)))))
|
||||
(maphash
|
||||
(lambda (_s pairs)
|
||||
(let ((sorted (sort (copy-sequence pairs)
|
||||
(lambda (a b) (< (car a) (car b))))))
|
||||
(dolist (m (card-games-rummy--runs-in sorted)) (push (sort m #'<) melds)))
|
||||
(when (and ace-high (assq 0 pairs))
|
||||
(let* ((hi (mapcar (lambda (p) (if (= (car p) 0) (cons 13 (cdr p)) p))
|
||||
pairs))
|
||||
(sh (sort hi (lambda (a b) (< (car a) (car b))))))
|
||||
(dolist (m (card-games-rummy--runs-in sh)) (push (sort m #'<) melds)))))
|
||||
bysuit))
|
||||
(delete-dups melds)))
|
||||
|
||||
(cl-defun card-games-rummy-best-partition (cards &key ace-high ace-15)
|
||||
"Return the lowest-deadwood layout of CARDS.
|
||||
The result is a plist (:melds MELDS :deadwood CARDS :count N) where MELDS
|
||||
is a list of card-lists, DEADWOOD the unmelded cards and N their value
|
||||
sum. ACE-HIGH allows Q-K-A runs; ACE-15 scores Aces at 15."
|
||||
(let* ((vec (vconcat cards)) (n (length vec))
|
||||
(cand (card-games-rummy--candidate-melds cards :ace-high ace-high))
|
||||
(mmasks (mapcar (lambda (m)
|
||||
(let ((b 0)) (dolist (i m) (setq b (logior b (ash 1 i))))
|
||||
b))
|
||||
cand))
|
||||
(memo (make-hash-table :test 'eql))
|
||||
(full (1- (ash 1 n))))
|
||||
(cl-labels
|
||||
((cval (i) (card-games-rummy-value (aref vec i) ace-15))
|
||||
(lowbit (avail)
|
||||
(let ((i 0)) (while (zerop (logand avail (ash 1 i))) (setq i (1+ i))) i))
|
||||
(solve (avail)
|
||||
(if (zerop avail) (cons 0 '())
|
||||
(or (gethash avail memo)
|
||||
(let* ((i (lowbit avail))
|
||||
(ibit (ash 1 i))
|
||||
(sub0 (solve (logxor avail ibit)))
|
||||
(best (cons (+ (cval i) (car sub0)) (cdr sub0))))
|
||||
(dolist (mask mmasks)
|
||||
(when (and (/= 0 (logand mask ibit))
|
||||
(= mask (logand mask avail)))
|
||||
(let ((sub (solve (logand avail (lognot mask)))))
|
||||
(when (< (car sub) (car best))
|
||||
(setq best (cons (car sub) (cons mask (cdr sub))))))))
|
||||
(puthash avail best memo)
|
||||
best)))))
|
||||
(let* ((res (solve full)) (maskmelds (cdr res)) (used 0))
|
||||
(dolist (m maskmelds) (setq used (logior used m)))
|
||||
(list :melds
|
||||
(mapcar (lambda (mask)
|
||||
(let ((cl '()))
|
||||
(dotimes (i n)
|
||||
(when (/= 0 (logand mask (ash 1 i)))
|
||||
(push (aref vec i) cl)))
|
||||
(nreverse cl)))
|
||||
maskmelds)
|
||||
:deadwood
|
||||
(let ((dl '()))
|
||||
(dotimes (i n)
|
||||
(when (= 0 (logand used (ash 1 i))) (push (aref vec i) dl)))
|
||||
(nreverse dl))
|
||||
:count (car res))))))
|
||||
|
||||
(defun card-games-rummy-deadwood (cards &optional ace-high ace-15)
|
||||
"Return the minimum deadwood value of CARDS.
|
||||
ACE-HIGH and ACE-15 are passed to `card-games-rummy-best-partition'."
|
||||
(plist-get (card-games-rummy-best-partition cards :ace-high ace-high :ace-15 ace-15)
|
||||
:count))
|
||||
|
||||
(defun card-games-rummy-layoff-p (card melds &optional ace-high)
|
||||
"Return the first meld in MELDS that CARD can extend, or nil.
|
||||
ACE-HIGH allows extending a run with a high Ace."
|
||||
(cl-find-if (lambda (m)
|
||||
(card-games-rummy-meld-p (cons card m) :min 3 :ace-high ace-high))
|
||||
melds))
|
||||
|
||||
|
||||
;;;; Shared deck and base game
|
||||
|
||||
(defun card-games-rummy-deck (&optional ndecks jokers)
|
||||
"Return a shuffled deck of NDECKS standard packs plus JOKERS jokers each.
|
||||
NDECKS defaults to 1 and JOKERS to 0."
|
||||
(random t)
|
||||
(let ((cards '()))
|
||||
(dotimes (_ (or ndecks 1))
|
||||
(dotimes (s 4) (dotimes (r 13) (push (cons s r) cards)))
|
||||
(dotimes (_ (or jokers 0)) (push (cons 'joker 0) cards)))
|
||||
(card-games-shuffle cards)))
|
||||
|
||||
(defclass card-games-rummy-game (card-games-game) ()
|
||||
"Abstract base for rummy-style draw-and-discard games."
|
||||
:abstract t)
|
||||
|
||||
(defsubst card-games-rummy--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
|
||||
(defsubst card-games-rummy--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
|
||||
(defsubst card-games-rummy--top (game) "Return the top card of GAME's discard pile." (car (card-games-get game :discard)))
|
||||
|
||||
(defun card-games-rummy-sort-hand (cards)
|
||||
"Return CARDS sorted by suit then rank for display, jokers last."
|
||||
(sort (copy-sequence cards)
|
||||
(lambda (a b)
|
||||
(let ((sa (if (card-games-rummy-joker-p a) 99 (car a)))
|
||||
(sb (if (card-games-rummy-joker-p b) 99 (car b))))
|
||||
(if (= sa sb) (< (cdr a) (cdr b)) (< sa sb))))))
|
||||
|
||||
(defcustom card-games-rummy-svg-cards t
|
||||
"When non-nil, draw cards as SVG images on a graphical display.
|
||||
Set to nil to force the plain-text card row everywhere."
|
||||
:type 'boolean :group 'card-games)
|
||||
|
||||
(defun card-games-rummy--card-spec (card)
|
||||
"Return the card-games-svg display spec (RANK-STRING . SUIT) for CARD."
|
||||
(if (card-games-rummy-joker-p card) (cons "" 'joker)
|
||||
(cons (aref card-games-rummy-ranks (cdr card)) (car card))))
|
||||
|
||||
(defun card-games-rummy--svg-row (cards cursor marks hint-fn &optional region-tag)
|
||||
"Return a one-image SVG row for CARDS (clickable + sliderful when REGION-TAG).
|
||||
CURSOR is the highlighted index and MARKS the selected ones; HINT-FN is an
|
||||
optional predicate marking playable cards."
|
||||
(let ((hints (when hint-fn
|
||||
(let ((hs '()) (i 0))
|
||||
(dolist (c cards) (when (funcall hint-fn c) (push i hs))
|
||||
(setq i (1+ i)))
|
||||
hs))))
|
||||
(card-games-svg-hand-image (mapcar #'card-games-rummy--card-spec cards)
|
||||
:cursor (and (integerp cursor) (>= cursor 0) cursor)
|
||||
:marks marks :hints hints
|
||||
:overlap (if (> (length cards) 11)
|
||||
(max 0 (- card-games-svg-card-width 24)) 0)
|
||||
:region-tag region-tag)))
|
||||
|
||||
(defun card-games-rummy--render-cards (cards cursor marks &optional hint-fn region-tag)
|
||||
"Return a propertized row of CARDS.
|
||||
CURSOR is the highlighted index, MARKS a list of marked indices, and
|
||||
HINT-FN an optional predicate marking playable cards. When REGION-TAG is
|
||||
non-nil the SVG row is clickable (each card mapped to (REGION-TAG . INDEX))
|
||||
and carries a card-size slider. Draws SVG cards on a graphical display
|
||||
\(see `card-games-rummy-svg-cards'), else a plain-text row."
|
||||
(if (and card-games-rummy-svg-cards (display-graphic-p))
|
||||
(card-games-rummy--svg-row cards cursor marks hint-fn region-tag)
|
||||
(let ((i 0) (out '()))
|
||||
(dolist (c cards)
|
||||
(let ((cs (card-games-rummy-card-string c)) (faces nil))
|
||||
(when (and (not (card-games-rummy-joker-p c)) (card-games-red-suit-p (car c)))
|
||||
(push 'card-games-red-suit faces))
|
||||
(when (and hint-fn (funcall hint-fn c)) (push 'card-games-hint faces))
|
||||
(when (memq i marks) (push 'card-games-rummy-mark faces))
|
||||
(when (eql i cursor) (push 'card-games-cursor faces))
|
||||
(push (propertize (format "%4s" cs) 'face (or faces 'default)) out))
|
||||
(setq i (1+ i)))
|
||||
(apply #'concat (nreverse out)))))
|
||||
|
||||
(defun card-games-rummy--board-svg (&rest args)
|
||||
"Draw a rummy-style board; return a propertized display string.
|
||||
Keyword ARGS: :title :infos :melds :discard :stock :hand :cursor :marks
|
||||
:hint-fn :message. :melds is a list of (LABEL . CARDS), or the symbol
|
||||
`none' to hide the table area. The hand carries (hand . INDEX) regions."
|
||||
(let* ((title (or (plist-get args :title) ""))
|
||||
(infos (plist-get args :infos))
|
||||
(raw-melds (plist-get args :melds))
|
||||
(show-table (not (eq raw-melds 'none)))
|
||||
(melds (and show-table raw-melds))
|
||||
(raw-discard (plist-get args :discard))
|
||||
(show-discard (not (eq raw-discard 'none)))
|
||||
(discard (and show-discard raw-discard))
|
||||
(stock (or (plist-get args :stock) 0))
|
||||
(stock-label (or (plist-get args :stock-label) "Stock"))
|
||||
(hand (plist-get args :hand))
|
||||
(cursor (or (plist-get args :cursor) 0))
|
||||
(marks (plist-get args :marks))
|
||||
(hint-fn (plist-get args :hint-fn))
|
||||
(msg (or (plist-get args :message) ""))
|
||||
(w card-games-svg-card-width) (h card-games-svg-card-height) (gap card-games-svg-card-gap)
|
||||
(pad 16) (label-w 46)
|
||||
(n (length hand))
|
||||
(overlap (cond ((> n 11) (- w 24)) ((> n 8) 20) (t 0)))
|
||||
(step (max 14 (- (+ w gap) overlap)))
|
||||
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
|
||||
(mstep (max 16 (round (* w 0.5))))
|
||||
(n-info (length infos))
|
||||
(y-title 6) (y-info 26)
|
||||
(y-sd (+ y-info (* n-info 16) 8))
|
||||
(meld-rowh (+ h 8))
|
||||
(y-melds (+ y-sd h 26))
|
||||
(melds-area (if show-table (+ (* (max 1 (length melds)) meld-rowh) 16) 6))
|
||||
(y-hand (+ y-melds melds-area))
|
||||
(height (+ y-hand h 30))
|
||||
(meld-maxw (if melds
|
||||
(apply #'max 0
|
||||
(mapcar (lambda (m)
|
||||
(+ label-w
|
||||
(let ((k (length (cdr m))))
|
||||
(if (> k 0) (+ (* (1- k) mstep) w) w))))
|
||||
melds))
|
||||
0))
|
||||
(width (max (+ fanw (* 2 pad)) (+ meld-maxw (* 2 pad)) 640))
|
||||
(svg (svg-create width height))
|
||||
(lc (card-games-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels ((txt (str x y &optional sz bold)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family card-games-svg-font-family
|
||||
(and bold '(:font-weight "bold"))))
|
||||
(drow (specs x y stp)
|
||||
(let ((xx x))
|
||||
(dolist (sp specs)
|
||||
(if sp (card-games-svg-card svg xx y :rank (car sp) :suit (cdr sp))
|
||||
(card-games-svg-card svg xx y :gap t))
|
||||
(setq xx (+ xx stp))))))
|
||||
(txt title pad (+ y-title 12) 13 t)
|
||||
(let ((yy (+ y-info 4)))
|
||||
(dolist (line infos) (txt line pad yy 12) (setq yy (+ yy 16))))
|
||||
(card-games-svg-card svg pad y-sd :down (> stock 0) :gap (= stock 0))
|
||||
(txt (format "%s %d" stock-label stock) pad (+ y-sd h 13) 11)
|
||||
(when show-discard
|
||||
(let ((dx (+ pad w gap 24)))
|
||||
(if discard
|
||||
(let ((sp (card-games-rummy--card-spec discard)))
|
||||
(card-games-svg-card svg dx y-sd :rank (car sp) :suit (cdr sp)))
|
||||
(card-games-svg-card svg dx y-sd :gap t))
|
||||
(txt "Discard" dx (+ y-sd h 13) 11)))
|
||||
(when show-table
|
||||
(txt "Table" pad (- y-melds 4) 11)
|
||||
(if (null melds)
|
||||
(txt "(no melds yet)" (+ pad label-w) (+ y-melds (round (* h 0.5))) 11)
|
||||
(let ((yy y-melds))
|
||||
(dolist (m melds)
|
||||
(txt (car m) pad (+ yy (round (* h 0.55))) 11)
|
||||
(drow (mapcar #'card-games-rummy--card-spec (cdr m)) (+ pad label-w) yy mstep)
|
||||
(setq yy (+ yy meld-rowh))))))
|
||||
(txt "Your hand" pad (- y-hand 6) 11)
|
||||
(let ((x (max pad (- (/ width 2) (/ fanw 2)))) (i 0))
|
||||
(dolist (c hand)
|
||||
(let ((sp (card-games-rummy--card-spec c))
|
||||
(curp (= i cursor))
|
||||
(markp (and marks (memq i marks)))
|
||||
(hintp (and hint-fn (funcall hint-fn c))))
|
||||
(card-games-svg-card svg x y-hand :rank (car sp) :suit (cdr sp)
|
||||
:highlight curp :hint hintp)
|
||||
(when markp
|
||||
(svg-rectangle svg (- x 3) (- y-hand 3) (+ w 6) (+ h 6)
|
||||
:rx 8 :fill "none" :stroke "#4a90d9" :stroke-width 3))
|
||||
(push (cons (list x y-hand (if (= i (1- n)) w step) h) (cons 'hand i)) regions))
|
||||
(setq x (+ x step) i (1+ i))))
|
||||
(txt msg pad (- height 8) 12))
|
||||
(propertize "*" 'display (card-games-svg-image svg (card-games-scale))
|
||||
'card-games-regions (nreverse regions))))
|
||||
|
||||
(defun card-games-rummy--melds-string (melds)
|
||||
"Return a one-line depiction of MELDS (a list of card-lists)."
|
||||
(mapconcat (lambda (m) (mapconcat #'card-games-rummy-card-string m " "))
|
||||
melds " | "))
|
||||
|
||||
|
||||
;;;; Gin Rummy
|
||||
|
||||
(defcustom card-games-gin-target 100
|
||||
"Points needed to win a game of Gin Rummy."
|
||||
:type 'integer :group 'card-games)
|
||||
|
||||
(defclass card-games-gin-game (card-games-rummy-game)
|
||||
((vname :initform "Gin Rummy"))
|
||||
"A two-handed game of Gin Rummy.")
|
||||
|
||||
(cl-defmethod card-games-gin--deal ((game card-games-gin-game))
|
||||
"Deal a fresh Gin hand into GAME."
|
||||
(let ((deck (card-games-rummy-deck)) (hands (make-vector 2 nil)))
|
||||
(dotimes (s 2)
|
||||
(aset hands s (card-games-rummy-sort-hand (cl-loop repeat 10 collect (pop deck)))))
|
||||
(card-games-put game :hands hands)
|
||||
(card-games-put game :discard (list (pop deck)))
|
||||
(card-games-put game :stock deck)
|
||||
(card-games-put game :turn 0)
|
||||
(card-games-put game :step 'draw)
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :cursor 0)
|
||||
(unless (card-games-get game :scores) (card-games-put game :scores (make-vector 2 0)))
|
||||
(card-games-put game :message
|
||||
"Your turn: s draws from stock, t takes the discard.")
|
||||
game))
|
||||
|
||||
(defun card-games-gin--deadwood (cards) "Return the deadwood value of CARDS." (card-games-rummy-deadwood cards))
|
||||
|
||||
(defun card-games-gin--draw (game s)
|
||||
"Move one of GAME's stock cards to seat S's hand; return it or nil if empty."
|
||||
(let ((stock (card-games-get game :stock)))
|
||||
(when stock
|
||||
(let ((c (pop stock)))
|
||||
(card-games-put game :stock stock)
|
||||
(card-games-rummy--set-hand game s (cons c (card-games-rummy--hand game s)))
|
||||
c))))
|
||||
|
||||
(defun card-games-gin--take (game s)
|
||||
"Move GAME's discard top to seat S's hand and return it."
|
||||
(let ((c (card-games-rummy--top game)))
|
||||
(card-games-put game :discard (cdr (card-games-get game :discard)))
|
||||
(card-games-rummy--set-hand game s (cons c (card-games-rummy--hand game s)))
|
||||
c))
|
||||
|
||||
(defun card-games-gin--discard (game s card)
|
||||
"Discard CARD from GAME seat S's hand onto the pile."
|
||||
(card-games-rummy--set-hand game s (card-games-rummy-sort-hand
|
||||
(remove card (card-games-rummy--hand game s))))
|
||||
(card-games-put game :discard (cons card (card-games-get game :discard))))
|
||||
|
||||
(defun card-games-gin--ai-best-discard (game s)
|
||||
"Return the card GAME seat S should discard to minimise its deadwood."
|
||||
(let ((hand (card-games-rummy--hand game s)) (best nil) (bestv most-positive-fixnum))
|
||||
(dolist (c hand best)
|
||||
(let ((d (card-games-gin--deadwood (remove c hand))))
|
||||
(when (or (< d bestv)
|
||||
(and (= d bestv) best
|
||||
(> (card-games-rummy-value c) (card-games-rummy-value best))))
|
||||
(setq best c bestv d))))))
|
||||
|
||||
(cl-defmethod card-games-gin--ai-turn ((game card-games-gin-game) s)
|
||||
"Play GAME seat S's whole turn, then hand control back."
|
||||
(let* ((hand (card-games-rummy--hand game s))
|
||||
(cur (card-games-gin--deadwood hand))
|
||||
(up (card-games-rummy--top game))
|
||||
(with (and up (card-games-gin--deadwood (cons up hand))))
|
||||
;; take the discard only when it strictly helps
|
||||
(drew (if (and up with (< with cur))
|
||||
(card-games-gin--take game s)
|
||||
(card-games-gin--draw game s))))
|
||||
(if (not drew)
|
||||
(card-games-gin--exhaust game) ; stock exhausted: wash the hand
|
||||
(let ((card (card-games-gin--ai-best-discard game s)))
|
||||
(card-games-gin--discard game s card)
|
||||
(let ((dw (card-games-gin--deadwood (card-games-rummy--hand game s))))
|
||||
(if (<= dw 10)
|
||||
(card-games-gin--knock game s)
|
||||
(card-games-put game :turn 0)
|
||||
(card-games-put game :step 'draw)
|
||||
(card-games-put game :message
|
||||
(format "Opponent discarded %s. s draws, t takes."
|
||||
(card-games-rummy-card-string card)))))))))
|
||||
|
||||
(cl-defmethod card-games-gin--knock ((game card-games-gin-game) knocker)
|
||||
"Resolve GAME's hand when KNOCKER knocks; score and end the hand."
|
||||
(let* ((kpart (card-games-rummy-best-partition (card-games-rummy--hand game knocker)))
|
||||
(kmelds (plist-get kpart :melds))
|
||||
(kdw (plist-get kpart :count))
|
||||
(opp (- 1 knocker))
|
||||
(opart (card-games-rummy-best-partition (card-games-rummy--hand game opp)))
|
||||
(odead (plist-get opart :deadwood))
|
||||
(gin (= kdw 0)))
|
||||
;; opponent lays off onto the knocker's melds (not allowed on gin)
|
||||
(unless gin
|
||||
(let (remaining)
|
||||
(dolist (c odead)
|
||||
(let ((m (card-games-rummy-layoff-p c kmelds)))
|
||||
(if m (setcdr (last m) (list c)) ; extend that meld in place
|
||||
(push c remaining))))
|
||||
(setq odead (nreverse remaining))))
|
||||
(let* ((odw (apply #'+ (mapcar #'card-games-rummy-value odead)))
|
||||
(scores (card-games-get game :scores))
|
||||
(winner knocker) (pts 0) (note ""))
|
||||
(cond
|
||||
(gin (setq pts (+ 25 odw) note "Gin!"))
|
||||
((< kdw odw) (setq pts (- odw kdw) note "Knock."))
|
||||
(t ;; undercut: defender wins
|
||||
(setq winner opp pts (+ 25 (- kdw odw)) note "Undercut!")))
|
||||
(aset scores winner (+ (aref scores winner) pts))
|
||||
(card-games-put game :phase 'hand-over)
|
||||
(card-games-put game :reveal t)
|
||||
(card-games-put game :winner winner)
|
||||
(card-games-put game :message
|
||||
(format "%s %s scores %d. %s (n: next hand)"
|
||||
note
|
||||
(if (= winner 0) "You" "Opponent") pts
|
||||
(if (>= (aref scores winner) card-games-gin-target)
|
||||
(progn (card-games-put game :phase 'game-over)
|
||||
(format "%s wins the game!"
|
||||
(if (= winner 0) "You" "Opponent")))
|
||||
(format "Score %d-%d."
|
||||
(aref scores 0) (aref scores 1))))))))
|
||||
|
||||
(cl-defmethod card-games-gin--exhaust ((game card-games-gin-game))
|
||||
"End a GAME hand washed out because the stock ran dry."
|
||||
(card-games-put game :phase 'hand-over)
|
||||
(card-games-put game :reveal t)
|
||||
(card-games-put game :message "Stock exhausted -- the hand is a wash. n: next hand."))
|
||||
|
||||
;;;; Gin UI
|
||||
|
||||
(defvar-local card-games-gin--game nil "The Gin Rummy game in the current buffer.")
|
||||
|
||||
(defun card-games-gin--svg (game)
|
||||
"Return an SVG board for the Gin GAME."
|
||||
(let* ((scores (card-games-get game :scores)) (reveal (card-games-get game :reveal))
|
||||
(hand (card-games-rummy--hand game 0)) (infos '()))
|
||||
(push (format "Opponent: %d cards score %d"
|
||||
(length (card-games-rummy--hand game 1)) (aref scores 1)) infos)
|
||||
(when reveal
|
||||
(let ((pp (card-games-rummy-best-partition (card-games-rummy--hand game 1))))
|
||||
(push (format " melds %s deadwood %s (%d)"
|
||||
(card-games-rummy--melds-string (plist-get pp :melds))
|
||||
(mapconcat #'card-games-rummy-card-string (plist-get pp :deadwood) " ")
|
||||
(plist-get pp :count))
|
||||
infos)))
|
||||
(push (format "You: deadwood %d score %d"
|
||||
(card-games-gin--deadwood hand) (aref scores 0)) infos)
|
||||
(card-games-rummy--board-svg
|
||||
:title (format "Gin Rummy (first to %d)" card-games-gin-target)
|
||||
:infos (nreverse infos) :melds 'none
|
||||
:discard (card-games-rummy--top game) :stock (length (card-games-get game :stock))
|
||||
:hand hand :cursor (card-games-get game :cursor)
|
||||
:message (card-games-get game :message))))
|
||||
|
||||
(cl-defmethod card-games-render ((game card-games-gin-game))
|
||||
"Return a depiction of the Gin GAME: SVG board if graphical, else text."
|
||||
(if (and card-games-rummy-svg-cards (display-graphic-p))
|
||||
(card-games-gin--svg game)
|
||||
(card-games-gin--render-text game)))
|
||||
|
||||
(defun card-games-gin--render-text (game)
|
||||
"Return a plain-text depiction of the Gin GAME."
|
||||
(let* ((out '()) (scores (card-games-get game :scores))
|
||||
(reveal (card-games-get game :reveal))
|
||||
(hand (card-games-rummy--hand game 0)) (cursor (card-games-get game :cursor)))
|
||||
(push (format " Gin Rummy first to %d\n\n" card-games-gin-target) out)
|
||||
(push (format " Opponent: %d cards score %d\n"
|
||||
(length (card-games-rummy--hand game 1)) (aref scores 1)) out)
|
||||
(when reveal
|
||||
(let ((p (card-games-rummy-best-partition (card-games-rummy--hand game 1))))
|
||||
(push (format " melds: %s\n deadwood: %s (%d)\n"
|
||||
(card-games-rummy--melds-string (plist-get p :melds))
|
||||
(mapconcat #'card-games-rummy-card-string (plist-get p :deadwood) " ")
|
||||
(plist-get p :count))
|
||||
out)))
|
||||
(push (format "\n Discard: %s Stock: %d\n\n"
|
||||
(let ((cs (card-games-rummy-card-string (card-games-rummy--top game))))
|
||||
(if (and (card-games-rummy--top game) (card-games-red-suit-p (car (card-games-rummy--top game))))
|
||||
(propertize cs 'face 'card-games-red-suit) cs))
|
||||
(length (card-games-get game :stock)))
|
||||
out)
|
||||
(push (format " Your hand (deadwood %d, score %d):\n "
|
||||
(card-games-gin--deadwood hand) (aref scores 0)) out)
|
||||
(push (card-games-rummy--render-cards hand cursor nil nil 'hand) out)
|
||||
(when reveal
|
||||
(let ((p (card-games-rummy-best-partition hand)))
|
||||
(push (format "\n melds: %s\n deadwood: %s"
|
||||
(card-games-rummy--melds-string (plist-get p :melds))
|
||||
(mapconcat #'card-games-rummy-card-string (plist-get p :deadwood) " "))
|
||||
out)))
|
||||
(push (format "\n\n %s\n" (card-games-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod card-games-render-apply ((g card-games-gin-game) action)
|
||||
"Apply a click ACTION on the hand to GAME G."
|
||||
(pcase action
|
||||
(`(hand . ,i) (card-games-put g :cursor i))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun card-games-gin--redisplay ()
|
||||
"Redraw the Gin Rummy buffer."
|
||||
(let ((game card-games-gin--game) (inhibit-read-only t))
|
||||
(setq card-games-current-game game card-games-redisplay-function #'card-games-gin--redisplay)
|
||||
(setq-local mode-line-process
|
||||
(format " [%s]" (or (card-games-get game :step) (card-games-get game :phase))))
|
||||
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
|
||||
|
||||
(defun card-games-gin--cursor-card ()
|
||||
"Return the card under the cursor in your hand."
|
||||
(nth (card-games-get card-games-gin--game :cursor) (card-games-rummy--hand card-games-gin--game 0)))
|
||||
|
||||
(defun card-games-gin-left ()
|
||||
"Move the hand cursor left."
|
||||
(interactive)
|
||||
(let* ((g card-games-gin--game) (n (length (card-games-rummy--hand g 0))))
|
||||
(when (> n 0) (card-games-put g :cursor (mod (1- (card-games-get g :cursor)) n)))
|
||||
(card-games-gin--redisplay)))
|
||||
|
||||
(defun card-games-gin-right ()
|
||||
"Move the hand cursor right."
|
||||
(interactive)
|
||||
(let* ((g card-games-gin--game) (n (length (card-games-rummy--hand g 0))))
|
||||
(when (> n 0) (card-games-put g :cursor (mod (1+ (card-games-get g :cursor)) n)))
|
||||
(card-games-gin--redisplay)))
|
||||
|
||||
(defun card-games-gin--my-turn-p (g)
|
||||
"Return non-nil when it is your turn to act in G."
|
||||
(and (eq (card-games-get g :phase) 'play) (= (card-games-get g :turn) 0)))
|
||||
|
||||
(defun card-games-gin-draw-stock ()
|
||||
"Draw the top stock card into your hand."
|
||||
(interactive)
|
||||
(let ((g card-games-gin--game))
|
||||
(cond
|
||||
((not (card-games-gin--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((not (eq (card-games-get g :step) 'draw)) (card-games-put g :message "Discard first (RET)."))
|
||||
((card-games-gin--draw g 0)
|
||||
(card-games-put g :step 'discard)
|
||||
(card-games-put g :cursor 0)
|
||||
(card-games-put g :message "Choose a card and discard with RET, or knock with k."))
|
||||
(t (card-games-gin--exhaust g)))
|
||||
(card-games-gin--redisplay)))
|
||||
|
||||
(defun card-games-gin-take-discard ()
|
||||
"Take the discard top into your hand."
|
||||
(interactive)
|
||||
(let ((g card-games-gin--game))
|
||||
(cond
|
||||
((not (card-games-gin--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((not (eq (card-games-get g :step) 'draw)) (card-games-put g :message "Discard first (RET)."))
|
||||
((null (card-games-rummy--top g)) (card-games-put g :message "The discard pile is empty."))
|
||||
(t (let ((c (card-games-gin--take g 0)))
|
||||
(card-games-put g :step 'discard)
|
||||
(card-games-put g :cursor 0)
|
||||
(card-games-put g :message
|
||||
(format "Took %s. Discard with RET, or knock with k."
|
||||
(card-games-rummy-card-string c))))))
|
||||
(card-games-gin--redisplay)))
|
||||
|
||||
(defun card-games-gin--after-discard (g)
|
||||
"Hand control to the opponent after you discard in G."
|
||||
(card-games-put g :turn 1)
|
||||
(card-games-put g :step 'draw)
|
||||
(card-games-gin--ai-turn g 1)
|
||||
(card-games-gin--redisplay))
|
||||
|
||||
(defun card-games-gin-discard ()
|
||||
"Discard the selected card and end your turn."
|
||||
(interactive)
|
||||
(let* ((g card-games-gin--game) (card (card-games-gin--cursor-card)))
|
||||
(cond
|
||||
((not (card-games-gin--my-turn-p g)) (card-games-put g :message "Not your turn.")
|
||||
(card-games-gin--redisplay))
|
||||
((not (eq (card-games-get g :step) 'discard))
|
||||
(card-games-put g :message "Draw first (s or t).") (card-games-gin--redisplay))
|
||||
((null card) (card-games-put g :message "No card selected.") (card-games-gin--redisplay))
|
||||
(t (card-games-gin--discard g 0 card)
|
||||
(card-games-put g :message (format "You discarded %s." (card-games-rummy-card-string card)))
|
||||
(card-games-gin--after-discard g)))))
|
||||
|
||||
(defun card-games-gin-knock ()
|
||||
"Knock, discarding the selected card, if your deadwood is low enough."
|
||||
(interactive)
|
||||
(let* ((g card-games-gin--game) (card (card-games-gin--cursor-card)))
|
||||
(cond
|
||||
((not (card-games-gin--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((not (eq (card-games-get g :step) 'discard))
|
||||
(card-games-put g :message "Draw first (s or t)."))
|
||||
((null card) (card-games-put g :message "No card selected."))
|
||||
(t (let ((dw (card-games-gin--deadwood (remove card (card-games-rummy--hand g 0)))))
|
||||
(if (> dw 10)
|
||||
(card-games-put g :message
|
||||
(format "Can't knock: that leaves %d deadwood (need <= 10)." dw))
|
||||
(card-games-gin--discard g 0 card)
|
||||
(card-games-gin--knock g 0)))))
|
||||
(card-games-gin--redisplay)))
|
||||
|
||||
(defun card-games-gin-new ()
|
||||
"Deal a fresh hand (or a new game when one is over)."
|
||||
(interactive)
|
||||
(let ((g card-games-gin--game))
|
||||
(when (eq (card-games-get g :phase) 'game-over) (card-games-put g :scores (make-vector 2 0)))
|
||||
(card-games-put g :reveal nil)
|
||||
(card-games-gin--deal g)
|
||||
(card-games-gin--redisplay)))
|
||||
|
||||
(defun card-games-gin-redraw () "Redraw the board." (interactive) (card-games-gin--redisplay))
|
||||
|
||||
(defun card-games-gin-help ()
|
||||
"Describe the Gin Rummy controls."
|
||||
(interactive)
|
||||
(message "Arrows: choose s: draw stock t: take discard RET: discard k: knock n: new g: redraw"))
|
||||
|
||||
(defvar card-games-gin-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'card-games-card-click)
|
||||
(define-key map "+" #'card-games-card-zoom-in)
|
||||
(define-key map "=" #'card-games-card-zoom-in)
|
||||
(define-key map "-" #'card-games-card-zoom-out)
|
||||
(define-key map "0" #'card-games-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'card-games-gin-left)
|
||||
(define-key map (kbd "<right>") #'card-games-gin-right)
|
||||
(define-key map "s" #'card-games-gin-draw-stock)
|
||||
(define-key map "t" #'card-games-gin-take-discard)
|
||||
(define-key map (kbd "RET") #'card-games-gin-discard)
|
||||
(define-key map "k" #'card-games-gin-knock)
|
||||
(define-key map "n" #'card-games-gin-new)
|
||||
(define-key map "g" #'card-games-gin-redraw)
|
||||
(define-key map "?" #'card-games-gin-help)
|
||||
(define-key map "q" #'card-games-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `card-games-gin-mode'.")
|
||||
|
||||
(define-derived-mode card-games-gin-mode special-mode "Gin"
|
||||
"Major mode for Gin Rummy."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type card-games-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-gin ()
|
||||
"Play Gin Rummy against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Gin Rummy*")))
|
||||
(with-current-buffer buf
|
||||
(card-games-gin-mode)
|
||||
(setq card-games-gin--game (card-games-gin-game))
|
||||
(card-games-gin--deal card-games-gin--game)
|
||||
(card-games-gin--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;###autoload
|
||||
(defalias 'card-games-gin-rummy #'card-games-gin)
|
||||
|
||||
(provide 'card-games-rummy)
|
||||
;;; card-games-rummy.el ends here
|
||||
440
card-games-scopa.el
Normal file
440
card-games-scopa.el
Normal file
|
|
@ -0,0 +1,440 @@
|
|||
;;; card-games-scopa.el --- Scopa and Casino, capturing games -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Two capturing ("fishing") games on a shared engine. You play a card
|
||||
;; from your hand to capture cards from the table: either a single card of
|
||||
;; equal value or a combination that sums to it. Clear the whole table
|
||||
;; for a sweep.
|
||||
;;
|
||||
;; `card-games-scopa' -- Scopa. The Italian classic on a 40-card deck; score
|
||||
;; for cards, coins (diamonds), the sette bello (seven of diamonds),
|
||||
;; primiera, and each sweep ("scopa"). Game to 11.
|
||||
;; `card-games-casino' -- Casino. The English cousin on the full deck; score for
|
||||
;; cards, spades, big casino (ten of diamonds), little casino (two of
|
||||
;; spades), each ace, and each sweep. Game to 21.
|
||||
;;
|
||||
;; You are the first player against the computer. Captures are resolved
|
||||
;; automatically (a single equal card if there is one, otherwise the
|
||||
;; combination taking the most cards). This Casino omits builds and
|
||||
;; multiple captures from a single card. Cards use the package cons
|
||||
;; (SUIT . RANK), RANK 0 (Ace) .. 12 (King); suit 2 is diamonds.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-rummy)
|
||||
|
||||
(defclass card-games-fish-game (card-games-game)
|
||||
((nplayers :initarg :nplayers :initform 2)
|
||||
(hand-size :initarg :hand-size :initform 3)
|
||||
(target :initarg :target :initform 11))
|
||||
"Abstract base for the capturing games Scopa and Casino."
|
||||
:abstract t)
|
||||
|
||||
(cl-defgeneric card-games-fish--value (game card)
|
||||
"Return CARD's capture value in GAME, or nil if it captures only by rank.")
|
||||
(cl-defgeneric card-games-fish--deck (game)
|
||||
"Return a fresh shuffled deck for GAME.")
|
||||
(cl-defgeneric card-games-fish--face-pair-p (game card)
|
||||
"Return non-nil when CARD in GAME captures only equal-rank cards (no sums).")
|
||||
(cl-defmethod card-games-fish--face-pair-p ((_game card-games-fish-game) _card) "Base fishing games capture rank pairs only, never sums." nil)
|
||||
(cl-defgeneric card-games-fish--score-round (game)
|
||||
"Add this round's points to GAME's running scores.")
|
||||
|
||||
(defsubst card-games-fish--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
|
||||
(defsubst card-games-fish--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
|
||||
(defsubst card-games-fish--captured (game s) "Return the cards seat S has captured in GAME." (aref (card-games-get game :captured) s))
|
||||
|
||||
(defun card-games-fish--who (s) "Return the display name of seat S." (if (= s 0) "You" "Computer"))
|
||||
|
||||
;;;; Capture search
|
||||
|
||||
(defun card-games-fish--best-subset (cards target valfn)
|
||||
"Return the largest subset of CARDS whose values (via VALFN) sum to TARGET.
|
||||
Only subsets of two or more cards are considered. Return nil if none."
|
||||
(let ((best nil) (vec (vconcat cards)) (n (length cards)))
|
||||
(dotimes (mask (ash 1 n))
|
||||
(let ((sum 0) (sub '()) (cnt 0))
|
||||
(dotimes (i n)
|
||||
(when (/= 0 (logand mask (ash 1 i)))
|
||||
(let ((v (funcall valfn (aref vec i))))
|
||||
(when v (setq sum (+ sum v) sub (cons (aref vec i) sub) cnt (1+ cnt))))))
|
||||
(when (and (>= cnt 2) (= sum target) (> cnt (length best)))
|
||||
(setq best sub))))
|
||||
best))
|
||||
|
||||
(defun card-games-fish--capture (game card)
|
||||
"Return the table cards CARD would capture in GAME, or nil."
|
||||
(let ((table (card-games-get game :table)))
|
||||
(if (card-games-fish--face-pair-p game card)
|
||||
(let ((same (cl-remove-if-not (lambda (c) (= (cdr c) (cdr card))) table)))
|
||||
(and same (list (car same))))
|
||||
(let ((v (card-games-fish--value game card)))
|
||||
(and v (let ((single (cl-find-if (lambda (c) (eql (card-games-fish--value game c) v))
|
||||
table)))
|
||||
(if single (list single)
|
||||
(card-games-fish--best-subset table v
|
||||
(lambda (c) (card-games-fish--value game c))))))))))
|
||||
|
||||
;;;; Flow
|
||||
|
||||
(cl-defmethod card-games-fish--deal-round ((game card-games-fish-game))
|
||||
"Start a fresh round of GAME: shuffle, deal the table and first hands."
|
||||
(let* ((n (oref game nplayers)) (deck (card-games-fish--deck game))
|
||||
(hands (make-vector n nil)) (table '()))
|
||||
(dotimes (_ 4) (push (pop deck) table))
|
||||
(dotimes (s n)
|
||||
(aset hands s (card-games-rummy-sort-hand (cl-loop repeat (oref game hand-size)
|
||||
collect (pop deck)))))
|
||||
(card-games-put game :hands hands)
|
||||
(card-games-put game :table table)
|
||||
(card-games-put game :deck deck)
|
||||
(card-games-put game :captured (make-vector n nil))
|
||||
(card-games-put game :sweeps (make-vector n 0))
|
||||
(card-games-put game :nplayers n)
|
||||
(card-games-put game :turn 0)
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :cursor 0)
|
||||
(card-games-put game :last-capturer nil)
|
||||
(unless (card-games-get game :scores) (card-games-put game :scores (make-vector n 0)))
|
||||
(card-games-put game :message "Play a card to capture by value, or trail it on the table.")
|
||||
game))
|
||||
|
||||
(defun card-games-fish--refill (game)
|
||||
"Deal GAME fresh hands from the deck when every hand is empty."
|
||||
(when (and (cl-every #'null (append (card-games-get game :hands) nil)) (card-games-get game :deck))
|
||||
(let ((deck (card-games-get game :deck)))
|
||||
(dotimes (s (card-games-get game :nplayers))
|
||||
(card-games-fish--set-hand game s
|
||||
(card-games-rummy-sort-hand
|
||||
(cl-loop repeat (oref game hand-size)
|
||||
while deck collect (pop deck)))))
|
||||
(card-games-put game :deck deck))))
|
||||
|
||||
(defun card-games-fish--round-over-p (game)
|
||||
"Return non-nil when GAME's deck and every hand are empty."
|
||||
(and (null (card-games-get game :deck))
|
||||
(cl-every #'null (append (card-games-get game :hands) nil))))
|
||||
|
||||
(cl-defmethod card-games-fish--play ((game card-games-fish-game) s card)
|
||||
"Have seat S play CARD in GAME: capture if possible, else trail it."
|
||||
(card-games-fish--set-hand game s (cl-remove card (card-games-fish--hand game s) :test #'equal :count 1))
|
||||
(let ((cap (card-games-fish--capture game card)))
|
||||
(if cap
|
||||
(progn
|
||||
(dolist (c cap)
|
||||
(card-games-put game :table (cl-remove c (card-games-get game :table) :test #'equal :count 1)))
|
||||
(aset (card-games-get game :captured) s (append (cons card cap) (card-games-fish--captured game s)))
|
||||
(card-games-put game :last-capturer s)
|
||||
(when (and (null (card-games-get game :table)) (not (card-games-fish--round-over-p game)))
|
||||
(aset (card-games-get game :sweeps) s (1+ (aref (card-games-get game :sweeps) s))))
|
||||
(card-games-put game :message
|
||||
(format "%s captured %d card%s with %s.%s" (card-games-fish--who s)
|
||||
(length cap) (if (> (length cap) 1) "s" "")
|
||||
(card-games-rummy-card-string card)
|
||||
(if (null (card-games-get game :table)) " Sweep!" ""))))
|
||||
(card-games-put game :table (cons card (card-games-get game :table)))
|
||||
(card-games-put game :message (format "%s trailed %s." (card-games-fish--who s)
|
||||
(card-games-rummy-card-string card))))
|
||||
(card-games-put game :turn (mod (1+ s) (card-games-get game :nplayers)))
|
||||
(card-games-fish--refill game)
|
||||
(when (card-games-fish--round-over-p game) (card-games-fish--finish-round game))))
|
||||
|
||||
(cl-defmethod card-games-fish--finish-round ((game card-games-fish-game))
|
||||
"Award GAME's leftover table cards to the last capturer and score the round."
|
||||
(when (and (card-games-get game :table) (card-games-get game :last-capturer))
|
||||
(let ((s (card-games-get game :last-capturer)))
|
||||
(aset (card-games-get game :captured) s
|
||||
(append (card-games-get game :table) (card-games-fish--captured game s)))
|
||||
(card-games-put game :table nil)))
|
||||
(card-games-fish--score-round game)
|
||||
(let ((win nil) (n (card-games-get game :nplayers)) (best most-negative-fixnum))
|
||||
(dotimes (s n)
|
||||
(when (and (>= (aref (card-games-get game :scores) s) (oref game target))
|
||||
(> (aref (card-games-get game :scores) s) best))
|
||||
(setq win s best (aref (card-games-get game :scores) s))))
|
||||
(card-games-put game :phase (if win 'game-over 'round-over))
|
||||
(card-games-put game :winner win)
|
||||
(card-games-put game :message
|
||||
(format "Round over. Scores: You %d, Computer %d. %s"
|
||||
(aref (card-games-get game :scores) 0) (aref (card-games-get game :scores) 1)
|
||||
(if win (format "%s wins! (n: new game)" (card-games-fish--who win))
|
||||
"(n: next round)")))))
|
||||
|
||||
(defun card-games-fish--award-most (game suit-pred pts)
|
||||
"Give PTS to whoever captured more of GAME's cards satisfying SUIT-PRED."
|
||||
(let ((c0 (cl-count-if suit-pred (card-games-fish--captured game 0)))
|
||||
(c1 (cl-count-if suit-pred (card-games-fish--captured game 1))))
|
||||
(cond ((> c0 c1) (aset (card-games-get game :scores) 0 (+ (aref (card-games-get game :scores) 0) pts)))
|
||||
((> c1 c0) (aset (card-games-get game :scores) 1 (+ (aref (card-games-get game :scores) 1) pts))))))
|
||||
|
||||
(cl-defmethod card-games-fish--ai-play ((game card-games-fish-game) s)
|
||||
"Have GAME AI seat S capture the most it can, else trail its lowest card."
|
||||
(let ((hand (card-games-fish--hand game s)) (best nil) (bestn -1) (sweep nil))
|
||||
(dolist (c hand)
|
||||
(let* ((cap (card-games-fish--capture game c))
|
||||
(nn (length cap))
|
||||
(sw (and cap (= nn (length (card-games-get game :table))))))
|
||||
(when (or (and sw (not sweep))
|
||||
(and (eq (and sw t) (and sweep t)) (> nn bestn)))
|
||||
(setq best c bestn nn sweep sw))))
|
||||
(unless best ; nothing captures: trail the lowest-value card
|
||||
(setq best (car (sort (copy-sequence hand)
|
||||
(lambda (a b) (< (or (card-games-fish--value game a) 99)
|
||||
(or (card-games-fish--value game b) 99)))))))
|
||||
(card-games-fish--play game s best)))
|
||||
|
||||
(defun card-games-fish--run (game)
|
||||
"Advance GAME's AI seats until your turn or the round ends."
|
||||
(let ((guard 0))
|
||||
(while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0) (< guard 200))
|
||||
(setq guard (1+ guard))
|
||||
(card-games-fish--ai-play game (card-games-get game :turn)))))
|
||||
|
||||
;;;; UI
|
||||
|
||||
(defvar-local card-games-fish--game nil "The fishing game in the current buffer.")
|
||||
|
||||
(defun card-games-fish--svg (game)
|
||||
"Return an SVG board for the fishing GAME."
|
||||
(card-games-rummy--board-svg
|
||||
:title (format "%s (to %d)" (oref game vname) (oref game target))
|
||||
:infos (list (format "Computer: %d cards captured %d (score %d)"
|
||||
(length (card-games-fish--hand game 1)) (length (card-games-fish--captured game 1))
|
||||
(aref (card-games-get game :scores) 1))
|
||||
(format "Your captured: %d (score %d)"
|
||||
(length (card-games-fish--captured game 0)) (aref (card-games-get game :scores) 0)))
|
||||
:stock-label "Deck" :stock (length (card-games-get game :deck)) :discard 'none
|
||||
:melds (list (cons "Table" (card-games-rummy-sort-hand (card-games-get game :table))))
|
||||
:hand (card-games-fish--hand game 0) :cursor (card-games-get game :cursor)
|
||||
:message (card-games-get game :message)))
|
||||
|
||||
(cl-defmethod card-games-render ((game card-games-fish-game))
|
||||
"Return a depiction of the fishing GAME: SVG board if graphical, else text."
|
||||
(if (and card-games-rummy-svg-cards (display-graphic-p))
|
||||
(card-games-fish--svg game)
|
||||
(card-games-fish--render-text game)))
|
||||
|
||||
(defun card-games-fish--render-text (game)
|
||||
"Return a plain-text depiction of the fishing GAME."
|
||||
(let* ((out '()) (cursor (card-games-get game :cursor)))
|
||||
(push (format " %s to %d\n\n" (oref game vname) (oref game target)) out)
|
||||
(push (format " Computer: %d cards captured %d (score %d)\n"
|
||||
(length (card-games-fish--hand game 1)) (length (card-games-fish--captured game 1))
|
||||
(aref (card-games-get game :scores) 1)) out)
|
||||
(push (format " Deck: %d Your captured: %d (score %d)\n\n"
|
||||
(length (card-games-get game :deck)) (length (card-games-fish--captured game 0))
|
||||
(aref (card-games-get game :scores) 0)) out)
|
||||
(push " Table:\n " out)
|
||||
(push (if (card-games-get game :table)
|
||||
(card-games-rummy--render-cards (card-games-rummy-sort-hand (card-games-get game :table)) -1 nil)
|
||||
"(empty)")
|
||||
out)
|
||||
(push "\n\n Your hand:\n " out)
|
||||
(push (card-games-rummy--render-cards (card-games-fish--hand game 0) cursor nil nil 'hand) out)
|
||||
(push (format "\n\n %s\n" (card-games-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod card-games-render-apply ((g card-games-fish-game) action)
|
||||
"Apply a click ACTION on the hand to GAME G."
|
||||
(pcase action
|
||||
(`(hand . ,i) (card-games-put g :cursor i)
|
||||
(card-games-fish-play))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun card-games-fish--redisplay ()
|
||||
"Redraw the current fishing-family game buffer."
|
||||
(let ((game card-games-fish--game) (inhibit-read-only t))
|
||||
(setq card-games-current-game game card-games-redisplay-function #'card-games-fish--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))
|
||||
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
|
||||
|
||||
(defun card-games-fish-left ()
|
||||
"Move the hand cursor left."
|
||||
(interactive)
|
||||
(let* ((g card-games-fish--game) (n (length (card-games-fish--hand g 0))))
|
||||
(when (> n 0) (card-games-put g :cursor (mod (1- (card-games-get g :cursor)) n)))
|
||||
(card-games-fish--redisplay)))
|
||||
|
||||
(defun card-games-fish-right ()
|
||||
"Move the hand cursor right."
|
||||
(interactive)
|
||||
(let* ((g card-games-fish--game) (n (length (card-games-fish--hand g 0))))
|
||||
(when (> n 0) (card-games-put g :cursor (mod (1+ (card-games-get g :cursor)) n)))
|
||||
(card-games-fish--redisplay)))
|
||||
|
||||
(defun card-games-fish-play ()
|
||||
"Play the card under the cursor."
|
||||
(interactive)
|
||||
(let* ((g card-games-fish--game) (card (nth (card-games-get g :cursor) (card-games-fish--hand g 0))))
|
||||
(cond
|
||||
((not (eq (card-games-get g :phase) 'play)) (card-games-put g :message "Press n to continue."))
|
||||
((/= (card-games-get g :turn) 0) (card-games-put g :message "Not your turn."))
|
||||
((null card) (card-games-put g :message "No card selected."))
|
||||
(t (card-games-fish--play g 0 card)
|
||||
(card-games-put g :cursor 0)
|
||||
(when (eq (card-games-get g :phase) 'play) (card-games-fish--run g))))
|
||||
(card-games-fish--redisplay)))
|
||||
|
||||
(defun card-games-fish-new ()
|
||||
"Start the next round, or a new game when one is over."
|
||||
(interactive)
|
||||
(let ((g card-games-fish--game))
|
||||
(when (eq (card-games-get g :phase) 'game-over)
|
||||
(card-games-put g :scores (make-vector (oref g nplayers) 0)))
|
||||
(card-games-fish--deal-round g)
|
||||
(card-games-fish--run g)
|
||||
(card-games-fish--redisplay)))
|
||||
|
||||
(defun card-games-fish-redraw () "Redraw." (interactive) (card-games-fish--redisplay))
|
||||
(defun card-games-fish-help () "Describe the controls." (interactive)
|
||||
(message "Arrows: choose RET: play the card n: next round / new game g: redraw"))
|
||||
|
||||
(defvar card-games-fish-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'card-games-card-click)
|
||||
(define-key map "+" #'card-games-card-zoom-in)
|
||||
(define-key map "=" #'card-games-card-zoom-in)
|
||||
(define-key map "-" #'card-games-card-zoom-out)
|
||||
(define-key map "0" #'card-games-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'card-games-fish-left)
|
||||
(define-key map (kbd "<right>") #'card-games-fish-right)
|
||||
(define-key map (kbd "RET") #'card-games-fish-play)
|
||||
(define-key map "n" #'card-games-fish-new)
|
||||
(define-key map "g" #'card-games-fish-redraw)
|
||||
(define-key map "?" #'card-games-fish-help)
|
||||
(define-key map "q" #'card-games-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `card-games-fish-mode'.")
|
||||
|
||||
(define-derived-mode card-games-fish-mode special-mode "Fish"
|
||||
"Major mode for the capturing games Scopa and Casino."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type card-games-cursor-type))
|
||||
|
||||
(defun card-games-fish--start (game buffer-name)
|
||||
"Start GAME in a buffer named BUFFER-NAME."
|
||||
(let ((buf (get-buffer-create buffer-name)))
|
||||
(with-current-buffer buf
|
||||
(card-games-fish-mode)
|
||||
(setq card-games-fish--game game)
|
||||
(card-games-fish--deal-round game)
|
||||
(card-games-fish--run game)
|
||||
(card-games-fish--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;; Scopa
|
||||
|
||||
(defclass card-games-scopa-game (card-games-fish-game)
|
||||
((vname :initform "Scopa") (hand-size :initform 3) (target :initform 11))
|
||||
"A game of Scopa.")
|
||||
|
||||
(cl-defmethod card-games-fish--value ((_game card-games-scopa-game) card)
|
||||
"Return CARD's Scopa value (Ace 1 .. 7, Jack 8, Queen 9, King 10)."
|
||||
(let ((r (cdr card)))
|
||||
(cond ((<= r 6) (1+ r)) ((= r 10) 8) ((= r 11) 9) ((= r 12) 10))))
|
||||
|
||||
(cl-defmethod card-games-fish--deck ((_game card-games-scopa-game))
|
||||
"Return a shuffled 40-card Scopa deck (no eights, nines, or tens)."
|
||||
(random t)
|
||||
(card-games-shuffle (cl-loop for s below 4 append
|
||||
(cl-loop for r below 13
|
||||
unless (memq r '(7 8 9)) collect (cons s r)))))
|
||||
|
||||
(defun card-games-scopa--prime (card)
|
||||
"Return the primiera prime value of CARD."
|
||||
(pcase (cdr card)
|
||||
(6 21) (5 18) (0 16) (4 15) (3 14) (2 13) (1 12) (_ 10)))
|
||||
|
||||
(cl-defmethod card-games-fish--score-round ((game card-games-scopa-game))
|
||||
"Score a Scopa round for GAME: cards, coins, sette bello, primiera, sweeps."
|
||||
(let ((scores (card-games-get game :scores)))
|
||||
(card-games-fish--award-most game (lambda (_c) t) 1) ; most cards
|
||||
(card-games-fish--award-most game (lambda (c) (= (car c) 2)) 1) ; most coins (diamonds)
|
||||
;; sette bello: 7 of diamonds
|
||||
(dotimes (s 2)
|
||||
(when (cl-find '(2 . 6) (card-games-fish--captured game s) :test #'equal)
|
||||
(aset scores s (1+ (aref scores s)))))
|
||||
;; primiera: best prime total across suits
|
||||
(let ((p (vector 0 0)))
|
||||
(dotimes (s 2)
|
||||
(let ((bysuit (make-vector 4 0)))
|
||||
(dolist (c (card-games-fish--captured game s))
|
||||
(aset bysuit (car c) (max (aref bysuit (car c)) (card-games-scopa--prime c))))
|
||||
(aset p s (apply #'+ (append bysuit nil)))))
|
||||
(cond ((> (aref p 0) (aref p 1)) (aset scores 0 (1+ (aref scores 0))))
|
||||
((> (aref p 1) (aref p 0)) (aset scores 1 (1+ (aref scores 1))))))
|
||||
;; sweeps
|
||||
(dotimes (s 2) (aset scores s (+ (aref scores s) (aref (card-games-get game :sweeps) s))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-scopa ()
|
||||
"Play Scopa against the computer."
|
||||
(interactive)
|
||||
(card-games-fish--start (card-games-scopa-game) "*Scopa*"))
|
||||
|
||||
;;;; Casino
|
||||
|
||||
(defclass card-games-casino-game (card-games-fish-game)
|
||||
((vname :initform "Casino") (hand-size :initform 4) (target :initform 21))
|
||||
"A game of Casino.")
|
||||
|
||||
(cl-defmethod card-games-fish--value ((_game card-games-casino-game) card)
|
||||
"Return CARD's Casino value (Ace 1, pips 2-10, faces nil)."
|
||||
(let ((r (cdr card)))
|
||||
(cond ((= r 0) 1) ((<= r 9) (1+ r)) (t nil))))
|
||||
|
||||
(cl-defmethod card-games-fish--face-pair-p ((_game card-games-casino-game) card)
|
||||
"Return non-nil when CARD is a face card (captures only by matching rank)."
|
||||
(>= (cdr card) 10))
|
||||
|
||||
(cl-defmethod card-games-fish--deck ((_game card-games-casino-game))
|
||||
"Return a shuffled 52-card deck for Casino."
|
||||
(card-games-rummy-deck))
|
||||
|
||||
(cl-defmethod card-games-fish--score-round ((game card-games-casino-game))
|
||||
"Score a Casino round for GAME: cards, spades, casinos, aces, sweeps."
|
||||
(let ((scores (card-games-get game :scores)))
|
||||
(card-games-fish--award-most game (lambda (_c) t) 3) ; most cards
|
||||
(card-games-fish--award-most game (lambda (c) (= (car c) 0)) 1) ; most spades
|
||||
(dotimes (s 2)
|
||||
(let ((caps (card-games-fish--captured game s)))
|
||||
(when (cl-find '(2 . 9) caps :test #'equal) ; big casino 10D
|
||||
(aset scores s (+ (aref scores s) 2)))
|
||||
(when (cl-find '(0 . 1) caps :test #'equal) ; little casino 2S
|
||||
(aset scores s (+ (aref scores s) 1)))
|
||||
(aset scores s (+ (aref scores s) (cl-count 0 caps :key #'cdr))) ; aces
|
||||
(aset scores s (+ (aref scores s) (aref (card-games-get game :sweeps) s)))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-casino ()
|
||||
"Play Casino against the computer."
|
||||
(interactive)
|
||||
(card-games-fish--start (card-games-casino-game) "*Casino*"))
|
||||
|
||||
(provide 'card-games-scopa)
|
||||
;;; card-games-scopa.el ends here
|
||||
1026
card-games-solitaire.el
Normal file
1026
card-games-solitaire.el
Normal file
File diff suppressed because it is too large
Load diff
508
card-games-spite.el
Normal file
508
card-games-spite.el
Normal file
|
|
@ -0,0 +1,508 @@
|
|||
;;; card-games-spite.el --- Spite and Malice, a competitive patience -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Spite & Malice (also called Cat & Mouse): a race between you and the
|
||||
;; computer to empty a face-down goal pile. Play cards onto up to four
|
||||
;; shared centre piles, which build up from Ace to Queen regardless of
|
||||
;; suit; a pile that reaches a Queen is cleared away. Kings are wild and
|
||||
;; stand for whatever rank a pile needs next.
|
||||
;;
|
||||
;; On your turn, draw your hand up to five, then play from the top of your
|
||||
;; goal pile, your hand, or the tops of your four discard piles. Playing
|
||||
;; your goal card is how you win, so take every chance to. End your turn
|
||||
;; by discarding one card to a discard pile.
|
||||
;;
|
||||
;; Targets are chosen automatically (the first centre pile a card fits).
|
||||
;; Cards use the package cons (SUIT . RANK), RANK 0 (Ace) .. 12 (King);
|
||||
;; the build order runs Ace(0) up to Queen(11), and the King(12) is wild.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-rummy)
|
||||
|
||||
(defcustom card-games-spite-goal-size 20
|
||||
"Number of cards in each player's goal pile."
|
||||
:type 'integer :group 'card-games)
|
||||
|
||||
(defclass card-games-spite-game (card-games-game)
|
||||
((vname :initform "Spite & Malice"))
|
||||
"A game of Spite & Malice.")
|
||||
|
||||
(defun card-games-spite--wild-p (card) "Return non-nil when CARD (a King) is wild."
|
||||
(= (cdr card) 12))
|
||||
|
||||
(defun card-games-spite--nat (card) "Return CARD's natural build rank, or nil if wild."
|
||||
(if (card-games-spite--wild-p card) nil (cdr card)))
|
||||
|
||||
(defun card-games-spite--deck ()
|
||||
"Return two shuffled standard decks (104 cards)."
|
||||
(random t)
|
||||
(card-games-shuffle (cl-loop repeat 2 append
|
||||
(cl-loop for s below 4 append
|
||||
(cl-loop for r below 13 collect (cons s r))))))
|
||||
|
||||
;;;; Accessors
|
||||
|
||||
(defsubst card-games-spite--goal (game s) "Return seat S's goal pile in GAME." (aref (card-games-get game :goal) s))
|
||||
(defsubst card-games-spite--set-goal (game s v) "Set seat S's goal pile in GAME to V." (aset (card-games-get game :goal) s v))
|
||||
(defsubst card-games-spite--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hand) s))
|
||||
(defsubst card-games-spite--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hand) s v))
|
||||
(defsubst card-games-spite--disc (game s) "Return seat S's discard piles in GAME." (aref (card-games-get game :disc) s)) ; vector of 4 lists
|
||||
|
||||
(defun card-games-spite--who (s) "Return the display name of seat S." (if (= s 0) "You" "Computer"))
|
||||
|
||||
(cl-defmethod card-games-spite--deal ((game card-games-spite-game))
|
||||
"Deal a fresh Spite & Malice game into GAME."
|
||||
(let ((deck (card-games-spite--deck)) (goal (make-vector 2 nil))
|
||||
(hand (make-vector 2 nil)) (disc (vector nil nil)))
|
||||
(dotimes (s 2)
|
||||
(aset goal s (cl-loop repeat card-games-spite-goal-size collect (pop deck)))
|
||||
(aset hand s (card-games-rummy-sort-hand (cl-loop repeat 5 collect (pop deck))))
|
||||
(aset disc s (make-vector 4 nil)))
|
||||
(card-games-put game :goal goal)
|
||||
(card-games-put game :hand hand)
|
||||
(card-games-put game :disc disc)
|
||||
(card-games-put game :center (make-vector 4 nil)) ; each nil or (TOPRANK . CARDS)
|
||||
(card-games-put game :muck nil)
|
||||
(card-games-put game :stock deck)
|
||||
(card-games-put game :turn 0)
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :cursor 0)
|
||||
(card-games-put game :message "Your turn. RET plays a hand card; G plays your goal card.")
|
||||
game))
|
||||
|
||||
;;;; Stock and centre piles
|
||||
|
||||
(defun card-games-spite--draw-stock (game)
|
||||
"Pop one card from GAME's stock, recycling the muck when it is empty."
|
||||
(when (and (null (card-games-get game :stock)) (card-games-get game :muck))
|
||||
(card-games-put game :stock (card-games-shuffle (card-games-get game :muck)))
|
||||
(card-games-put game :muck nil))
|
||||
(let ((stock (card-games-get game :stock)))
|
||||
(when stock (card-games-put game :stock (cdr stock)) (car stock))))
|
||||
|
||||
(defun card-games-spite--refill (game s)
|
||||
"Draw GAME seat S's hand back up to five cards."
|
||||
(while (and (< (length (card-games-spite--hand game s)) 5) (or (card-games-get game :stock)
|
||||
(card-games-get game :muck)))
|
||||
(let ((c (card-games-spite--draw-stock game)))
|
||||
(when c (card-games-spite--set-hand game s (card-games-rummy-sort-hand
|
||||
(cons c (card-games-spite--hand game s))))))))
|
||||
|
||||
(defun card-games-spite--needed (game i)
|
||||
"Return the rank GAME centre pile I needs next (0 for an empty slot)."
|
||||
(let ((p (aref (card-games-get game :center) i)))
|
||||
(if p (1+ (car p)) 0)))
|
||||
|
||||
(defun card-games-spite--legal-center (game card)
|
||||
"Return the index of the first GAME centre pile CARD may be played on, or nil."
|
||||
(let ((found nil))
|
||||
(dotimes (i 4)
|
||||
(let ((need (card-games-spite--needed game i)))
|
||||
(when (and (null found) (<= need 11)
|
||||
(or (card-games-spite--wild-p card) (eql (card-games-spite--nat card) need)))
|
||||
(setq found i))))
|
||||
found))
|
||||
|
||||
(defun card-games-spite--put-center (game card i)
|
||||
"Place CARD on GAME centre pile I; clear the pile if it reaches a Queen."
|
||||
(let* ((need (card-games-spite--needed game i))
|
||||
(p (aref (card-games-get game :center) i))
|
||||
(cards (cons card (and p (cdr p)))))
|
||||
(if (= need 11) ; completed Ace..Queen
|
||||
(progn (card-games-put game :muck (append cards (card-games-get game :muck)))
|
||||
(aset (card-games-get game :center) i nil))
|
||||
(aset (card-games-get game :center) i (cons need cards)))))
|
||||
|
||||
;;;; Plays
|
||||
|
||||
(defun card-games-spite--play-hand (game s card i)
|
||||
"Have GAME seat S play hand CARD onto centre pile I."
|
||||
(card-games-spite--set-hand game s (cl-remove card (card-games-spite--hand game s) :test #'equal :count 1))
|
||||
(card-games-spite--put-center game card i)
|
||||
(when (null (card-games-spite--hand game s)) (card-games-spite--refill game s)))
|
||||
|
||||
(defun card-games-spite--play-goal (game s i)
|
||||
"Have GAME seat S play the top of their goal pile onto centre pile I."
|
||||
(let ((card (car (card-games-spite--goal game s))))
|
||||
(card-games-spite--set-goal game s (cdr (card-games-spite--goal game s)))
|
||||
(card-games-spite--put-center game card i)
|
||||
(when (null (card-games-spite--goal game s))
|
||||
(card-games-put game :phase 'game-over) (card-games-put game :winner s))))
|
||||
|
||||
(defun card-games-spite--play-disc (game s d i)
|
||||
"Have GAME seat S play the top of discard pile D onto centre pile I."
|
||||
(let* ((pile (aref (card-games-spite--disc game s) d)) (card (car pile)))
|
||||
(aset (card-games-spite--disc game s) d (cdr pile))
|
||||
(card-games-spite--put-center game card i)))
|
||||
|
||||
(defun card-games-spite--discard (game s card d)
|
||||
"Have GAME seat S discard CARD from hand onto pile D, ending the turn."
|
||||
(card-games-spite--set-hand game s (cl-remove card (card-games-spite--hand game s) :test #'equal :count 1))
|
||||
(aset (card-games-spite--disc game s) d (cons card (aref (card-games-spite--disc game s) d)))
|
||||
(card-games-put game :turn (- 1 s)))
|
||||
|
||||
;;;; AI
|
||||
|
||||
(defun card-games-spite--ai-one (game s)
|
||||
"Make one beneficial play for GAME seat S; return non-nil if one was made."
|
||||
(let ((goal (car (card-games-spite--goal game s))) (done nil))
|
||||
(cond
|
||||
;; 1. advance the goal card (a wild goal card plays anywhere)
|
||||
((and goal (card-games-spite--legal-center game goal))
|
||||
(card-games-spite--play-goal game s (card-games-spite--legal-center game goal)) (setq done t))
|
||||
;; 2. a non-wild hand card that fits
|
||||
((cl-find-if (lambda (c) (and (not (card-games-spite--wild-p c))
|
||||
(card-games-spite--legal-center game c)))
|
||||
(card-games-spite--hand game s))
|
||||
(let ((card (cl-find-if (lambda (c) (and (not (card-games-spite--wild-p c))
|
||||
(card-games-spite--legal-center game c)))
|
||||
(card-games-spite--hand game s))))
|
||||
(card-games-spite--play-hand game s card (card-games-spite--legal-center game card))
|
||||
(setq done t)))
|
||||
(t
|
||||
;; 3. a non-wild discard top that fits
|
||||
(catch 'hit
|
||||
(dotimes (d 4)
|
||||
(let ((top (car (aref (card-games-spite--disc game s) d))))
|
||||
(when (and top (not (card-games-spite--wild-p top)) (card-games-spite--legal-center game top))
|
||||
(card-games-spite--play-disc game s d (card-games-spite--legal-center game top))
|
||||
(setq done t) (throw 'hit t))))
|
||||
;; 4. use a wild King: bridge to the goal card if possible, else
|
||||
;; advance the most-built pile to keep cards flowing
|
||||
(let ((king (cl-find-if #'card-games-spite--wild-p (card-games-spite--hand game s))))
|
||||
(when king
|
||||
(let* ((gr (and goal (card-games-spite--nat goal))) (target nil))
|
||||
(when gr
|
||||
(dotimes (i 4)
|
||||
(let ((need (card-games-spite--needed game i)))
|
||||
(when (and (null target) (<= need 11) (= need (1- gr)))
|
||||
(setq target i)))))
|
||||
(unless target
|
||||
(let ((bestneed -1))
|
||||
(dotimes (i 4)
|
||||
(let ((need (card-games-spite--needed game i)))
|
||||
(when (and (<= need 11) (> need bestneed))
|
||||
(setq bestneed need target i))))))
|
||||
(when target
|
||||
(card-games-spite--play-hand game s king target) (setq done t))))))))
|
||||
done))
|
||||
|
||||
(defun card-games-spite--ai-turn (game s)
|
||||
"Take GAME seat S's whole AI turn: play what helps, then discard."
|
||||
(card-games-spite--refill game s)
|
||||
(let ((guard 0))
|
||||
(while (and (eq (card-games-get game :phase) 'play) (< guard 300)
|
||||
(card-games-spite--ai-one game s))
|
||||
(setq guard (1+ guard))))
|
||||
(when (eq (card-games-get game :phase) 'play)
|
||||
(let ((hand (card-games-spite--hand game s)))
|
||||
(if (null hand)
|
||||
(card-games-put game :turn (- 1 s)) ; played out, nothing to discard
|
||||
;; discard the highest non-wild card; keep Kings (wild)
|
||||
(let* ((nonk (cl-remove-if #'card-games-spite--wild-p hand))
|
||||
(card (car (sort (copy-sequence (or nonk hand))
|
||||
(lambda (a b) (> (cdr a) (cdr b))))))
|
||||
(d (card-games-spite--ai-disc-pile game s card)))
|
||||
(card-games-spite--discard game s card d))))))
|
||||
|
||||
(defun card-games-spite--ai-disc-pile (game s card)
|
||||
"Choose GAME seat S's discard pile for CARD (empty, else topped just above)."
|
||||
(let ((disc (card-games-spite--disc game s)) (empty nil) (best nil) (bestv 99))
|
||||
(dotimes (d 4)
|
||||
(let ((top (car (aref disc d))))
|
||||
(cond ((null top) (unless empty (setq empty d)))
|
||||
((and (not (card-games-spite--wild-p top)) (>= (cdr top) (cdr card))
|
||||
(< (- (cdr top) (cdr card)) bestv))
|
||||
(setq best d bestv (- (cdr top) (cdr card)))))))
|
||||
(or best empty 0)))
|
||||
|
||||
(defun card-games-spite--run (game)
|
||||
"Let the computer (seat 1) act in GAME until your turn or the game ends."
|
||||
(let ((guard 0))
|
||||
(while (and (eq (card-games-get game :phase) 'play) (= (card-games-get game :turn) 1) (< guard 200))
|
||||
(setq guard (1+ guard))
|
||||
(card-games-spite--ai-turn game 1))))
|
||||
|
||||
;;;; UI
|
||||
|
||||
(defvar-local card-games-spite--game nil "The Spite & Malice game in the current buffer.")
|
||||
|
||||
(defun card-games-spite--center-string (game)
|
||||
"Return a one-line depiction of GAME's centre piles."
|
||||
(let ((parts '()))
|
||||
(dotimes (i 4)
|
||||
(let ((p (aref (card-games-get game :center) i)))
|
||||
(push (if p (format "[%s->%s]" (length (cdr p))
|
||||
(aref card-games-rummy-ranks (car p)))
|
||||
"[ -- ]")
|
||||
parts)))
|
||||
(mapconcat #'identity (nreverse parts) " ")))
|
||||
|
||||
(defun card-games-spite--disc-string (game s)
|
||||
"Return a depiction of GAME seat S's four discard-pile tops."
|
||||
(let ((parts '()))
|
||||
(dotimes (d 4)
|
||||
(let ((top (car (aref (card-games-spite--disc game s) d))))
|
||||
(push (format "%d:%s" (1+ d) (if top (card-games-rummy-card-string top) "--")) parts)))
|
||||
(mapconcat #'identity (nreverse parts) " ")))
|
||||
|
||||
(defun card-games-spite--board-svg (game)
|
||||
"Return an SVG board for the Spite & Malice GAME."
|
||||
(let* ((w card-games-svg-card-width) (h card-games-svg-card-height) (gap card-games-svg-card-gap) (pad 16)
|
||||
(hand (card-games-spite--hand game 0)) (n (length hand))
|
||||
(cursor (card-games-get game :cursor)) (center (card-games-get game :center))
|
||||
(overlap (cond ((> n 11) (- w 24)) ((> n 8) 20) (t 0)))
|
||||
(step (max 14 (- (+ w gap) overlap)))
|
||||
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
|
||||
(colstep (+ w 14))
|
||||
(y-title 6) (y-opp 26)
|
||||
(y-center (+ y-opp 16))
|
||||
(y-sm (+ y-center h 16))
|
||||
(y-ylabel (+ y-sm 12))
|
||||
(y-yours (+ y-ylabel 6))
|
||||
(y-hand (+ y-yours h 42))
|
||||
(height (+ y-hand h 30))
|
||||
(width (max (+ fanw (* 2 pad)) (+ (* 5 colstep) (* 2 pad)) 620))
|
||||
(svg (svg-create width height))
|
||||
(lc (card-games-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels ((txt (str x y &optional sz bold)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family card-games-svg-font-family (and bold '(:font-weight "bold"))))
|
||||
(pilecard (spec x y)
|
||||
(if spec (card-games-svg-card svg x y :rank (car spec) :suit (cdr spec))
|
||||
(card-games-svg-card svg x y :gap t))))
|
||||
(txt (format "Spite & Malice (goal %d)" card-games-spite-goal-size) pad (+ y-title 12) 13 t)
|
||||
(txt (format "Computer: goal %d left hand %d discards %s"
|
||||
(length (card-games-spite--goal game 1)) (length (card-games-spite--hand game 1))
|
||||
(card-games-spite--disc-string game 1))
|
||||
pad (+ y-opp 4) 12)
|
||||
(txt "Centre (build A..Q; King is wild)" pad (- y-center 4) 11)
|
||||
(dotimes (i 4)
|
||||
(let* ((x (+ pad (* i colstep))) (pp (aref center i))
|
||||
(spec (and pp (cons (aref card-games-rummy-ranks (car pp)) (car (cadr pp))))))
|
||||
(pilecard spec x y-center)))
|
||||
(txt (format "Stock %d Muck %d"
|
||||
(length (card-games-get game :stock)) (length (card-games-get game :muck)))
|
||||
pad y-sm 11)
|
||||
(let* ((gtop (car (card-games-spite--goal game 0)))
|
||||
(gspec (and gtop (card-games-rummy--card-spec gtop))))
|
||||
(txt (format "Your goal (%d left)" (length (card-games-spite--goal game 0)))
|
||||
pad y-ylabel 11)
|
||||
(txt "Discards" (+ pad colstep) y-ylabel 11)
|
||||
(pilecard gspec pad y-yours)
|
||||
(dotimes (d 4)
|
||||
(let* ((x (+ pad colstep (* d colstep)))
|
||||
(dtop (car (aref (card-games-spite--disc game 0) d)))
|
||||
(dspec (and dtop (card-games-rummy--card-spec dtop))))
|
||||
(pilecard dspec x y-yours))))
|
||||
(txt "Your hand" pad (- y-hand 6) 11)
|
||||
(let ((x (max pad (- (/ width 2) (/ fanw 2)))) (i 0))
|
||||
(dolist (c hand)
|
||||
(let ((sp (card-games-rummy--card-spec c)) (curp (= i cursor)))
|
||||
(card-games-svg-card svg x y-hand :rank (car sp) :suit (cdr sp) :highlight curp)
|
||||
(push (cons (list x y-hand (if (= i (1- n)) w step) h) (cons 'hand i)) regions))
|
||||
(setq x (+ x step) i (1+ i))))
|
||||
(txt (or (card-games-get game :message) "") pad (- height 8) 12))
|
||||
(propertize "*" 'display (card-games-svg-image svg (card-games-scale)) 'card-games-regions (nreverse regions))))
|
||||
|
||||
(cl-defmethod card-games-render ((game card-games-spite-game))
|
||||
"Return a depiction of the GAME: an SVG board if graphical, else text."
|
||||
(if (and card-games-rummy-svg-cards (display-graphic-p))
|
||||
(card-games-spite--board-svg game)
|
||||
(card-games-spite--render-text game)))
|
||||
|
||||
(defun card-games-spite--render-text (game)
|
||||
"Return a plain-text depiction of the Spite & Malice GAME."
|
||||
(let* ((out '()) (cursor (card-games-get game :cursor)))
|
||||
(push " Spite & Malice\n\n" out)
|
||||
(push (format " Computer goal: %d left hand: %d discards: %s\n\n"
|
||||
(length (card-games-spite--goal game 1)) (length (card-games-spite--hand game 1))
|
||||
(card-games-spite--disc-string game 1))
|
||||
out)
|
||||
(push (format " Centre: %s\n" (card-games-spite--center-string game)) out)
|
||||
(push (format " Stock: %d Muck: %d\n\n"
|
||||
(length (card-games-get game :stock)) (length (card-games-get game :muck))) out)
|
||||
(push (format " Your goal: %s (%d left)\n"
|
||||
(let ((g (car (card-games-spite--goal game 0))))
|
||||
(if g (card-games-rummy-card-string g) "--"))
|
||||
(length (card-games-spite--goal game 0)))
|
||||
out)
|
||||
(push (format " Your discards: %s\n\n" (card-games-spite--disc-string game 0)) out)
|
||||
(push " Your hand:\n " out)
|
||||
(push (card-games-rummy--render-cards (card-games-spite--hand game 0) cursor nil nil 'hand) out)
|
||||
(push (format "\n\n %s\n" (card-games-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod card-games-render-apply ((g card-games-spite-game) action)
|
||||
"Apply a click ACTION on the hand to GAME G."
|
||||
(pcase action
|
||||
(`(hand . ,i) (card-games-put g :cursor i)
|
||||
(card-games-spite-play))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun card-games-spite--redisplay ()
|
||||
"Redraw the current Spite & Malice buffer."
|
||||
(let ((game card-games-spite--game) (inhibit-read-only t))
|
||||
(setq card-games-current-game game card-games-redisplay-function #'card-games-spite--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))
|
||||
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
|
||||
|
||||
(defun card-games-spite--my-turn-p (g)
|
||||
"Return non-nil when it is your turn to play in G."
|
||||
(and (eq (card-games-get g :phase) 'play) (= (card-games-get g :turn) 0)))
|
||||
|
||||
(defun card-games-spite-left ()
|
||||
"Move the hand cursor left."
|
||||
(interactive)
|
||||
(let* ((g card-games-spite--game) (n (length (card-games-spite--hand g 0))))
|
||||
(when (> n 0) (card-games-put g :cursor (mod (1- (card-games-get g :cursor)) n)))
|
||||
(card-games-spite--redisplay)))
|
||||
|
||||
(defun card-games-spite-right ()
|
||||
"Move the hand cursor right."
|
||||
(interactive)
|
||||
(let* ((g card-games-spite--game) (n (length (card-games-spite--hand g 0))))
|
||||
(when (> n 0) (card-games-put g :cursor (mod (1+ (card-games-get g :cursor)) n)))
|
||||
(card-games-spite--redisplay)))
|
||||
|
||||
(defun card-games-spite--ensure-hand (g)
|
||||
"Draw your hand in G up to five at the start of your turn."
|
||||
(card-games-spite--refill g 0))
|
||||
|
||||
(defun card-games-spite-play ()
|
||||
"Play the cursor hand card onto the first centre pile it fits."
|
||||
(interactive)
|
||||
(let* ((g card-games-spite--game) (card (nth (card-games-get g :cursor) (card-games-spite--hand g 0))))
|
||||
(cond
|
||||
((not (card-games-spite--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((null card) (card-games-put g :message "No card selected."))
|
||||
(t (let ((i (card-games-spite--legal-center g card)))
|
||||
(if (null i) (card-games-put g :message "That card fits no centre pile.")
|
||||
(card-games-spite--play-hand g 0 card i)
|
||||
(card-games-put g :cursor 0)
|
||||
(card-games-put g :message "Played. Keep going, or d to discard and end turn.")))))
|
||||
(card-games-spite--redisplay)))
|
||||
|
||||
(defun card-games-spite-goal ()
|
||||
"Play your goal-pile top onto the first centre pile it fits."
|
||||
(interactive)
|
||||
(let* ((g card-games-spite--game) (card (car (card-games-spite--goal g 0))))
|
||||
(cond
|
||||
((not (card-games-spite--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((null card) (card-games-put g :message "Your goal pile is empty."))
|
||||
(t (let ((i (card-games-spite--legal-center g card)))
|
||||
(if (null i) (card-games-put g :message "Your goal card fits no centre pile.")
|
||||
(card-games-spite--play-goal g 0 i)
|
||||
(if (eq (card-games-get g :phase) 'game-over)
|
||||
(card-games-put g :message "You emptied your goal -- you win! (n: new game)")
|
||||
(card-games-put g :message "Goal card played!"))))))
|
||||
(card-games-spite--redisplay)))
|
||||
|
||||
(defun card-games-spite-play-disc ()
|
||||
"Play the top of the discard pile whose number you pressed."
|
||||
(interactive)
|
||||
(let* ((g card-games-spite--game) (d (- last-command-event ?1))
|
||||
(top (and (>= d 0) (< d 4) (car (aref (card-games-spite--disc g 0) d)))))
|
||||
(cond
|
||||
((not (card-games-spite--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((null top) (card-games-put g :message "That discard pile is empty."))
|
||||
(t (let ((i (card-games-spite--legal-center g top)))
|
||||
(if (null i) (card-games-put g :message "That card fits no centre pile.")
|
||||
(card-games-spite--play-disc g 0 d i)
|
||||
(card-games-put g :message "Played from a discard pile.")))))
|
||||
(card-games-spite--redisplay)))
|
||||
|
||||
(defun card-games-spite-discard ()
|
||||
"Discard the cursor card to a discard pile and end your turn."
|
||||
(interactive)
|
||||
(let* ((g card-games-spite--game) (card (nth (card-games-get g :cursor) (card-games-spite--hand g 0))))
|
||||
(cond
|
||||
((not (card-games-spite--my-turn-p g)) (card-games-put g :message "Not your turn."))
|
||||
((null card) (card-games-put g :message "No card to discard."))
|
||||
(t (card-games-spite--discard g 0 card (card-games-spite--ai-disc-pile g 0 card))
|
||||
(card-games-put g :cursor 0)
|
||||
(card-games-spite--run g)
|
||||
(when (eq (card-games-get g :phase) 'play)
|
||||
(card-games-spite--ensure-hand g)
|
||||
(card-games-put g :message "Your turn."))))
|
||||
(card-games-spite--redisplay)))
|
||||
|
||||
(defun card-games-spite-new ()
|
||||
"Deal a fresh game."
|
||||
(interactive)
|
||||
(card-games-spite--deal card-games-spite--game)
|
||||
(card-games-spite--redisplay))
|
||||
|
||||
(defun card-games-spite-redraw () "Redraw." (interactive) (card-games-spite--redisplay))
|
||||
(defun card-games-spite-help () "Describe the controls." (interactive)
|
||||
(message "Arrows: choose RET: play hand card G: play goal 1-4: play discard top d: discard/end n: new"))
|
||||
|
||||
(defvar card-games-spite-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'card-games-card-click)
|
||||
(define-key map "+" #'card-games-card-zoom-in)
|
||||
(define-key map "=" #'card-games-card-zoom-in)
|
||||
(define-key map "-" #'card-games-card-zoom-out)
|
||||
(define-key map "0" #'card-games-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'card-games-spite-left)
|
||||
(define-key map (kbd "<right>") #'card-games-spite-right)
|
||||
(define-key map (kbd "RET") #'card-games-spite-play)
|
||||
(define-key map "G" #'card-games-spite-goal)
|
||||
(dolist (k '("1" "2" "3" "4")) (define-key map k #'card-games-spite-play-disc))
|
||||
(define-key map "d" #'card-games-spite-discard)
|
||||
(define-key map "n" #'card-games-spite-new)
|
||||
(define-key map "g" #'card-games-spite-redraw)
|
||||
(define-key map "?" #'card-games-spite-help)
|
||||
(define-key map "q" #'card-games-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `card-games-spite-mode'.")
|
||||
|
||||
(define-derived-mode card-games-spite-mode special-mode "Spite"
|
||||
"Major mode for Spite & Malice."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type card-games-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-spite ()
|
||||
"Play Spite & Malice against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Spite & Malice*")))
|
||||
(with-current-buffer buf
|
||||
(card-games-spite-mode)
|
||||
(setq card-games-spite--game (card-games-spite-game))
|
||||
(card-games-spite--deal card-games-spite--game)
|
||||
(card-games-spite--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;###autoload
|
||||
(defalias 'card-games-cat-and-mouse #'card-games-spite)
|
||||
|
||||
(provide 'card-games-spite)
|
||||
;;; card-games-spite.el ends here
|
||||
|
|
@ -1,11 +1,10 @@
|
|||
;;; cg-svg.el --- SVG card drawing for card games -*- lexical-binding: t; -*-
|
||||
;;; card-games-svg.el --- SVG card drawing for card games -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
|
|
@ -44,142 +43,142 @@
|
|||
;; `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
|
||||
;; `card-games-svg-cards-svg' lays specs out in a row; `card-games-svg-grid-svg' lays
|
||||
;; rows out as a grid. Both return an svg object; wrap with
|
||||
;; `cg-svg-image' to insert or `cg-svg-to-string' to serialize.
|
||||
;; `card-games-svg-image' to insert or `card-games-svg-to-string' to serialize.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'svg)
|
||||
(require 'cg-core)
|
||||
(require 'card-games-core)
|
||||
|
||||
(defgroup cg-svg nil
|
||||
(defgroup card-games-svg nil
|
||||
"SVG rendering for card games."
|
||||
:group 'card-games
|
||||
:prefix "cg-svg-")
|
||||
:prefix "card-games-svg-")
|
||||
|
||||
(defcustom cg-svg-card-width 56
|
||||
(defcustom card-games-svg-card-width 56
|
||||
"Card width in pixels."
|
||||
:type 'integer :group 'cg-svg)
|
||||
:type 'integer :group 'card-games-svg)
|
||||
|
||||
(defcustom cg-svg-card-height 80
|
||||
(defcustom card-games-svg-card-height 80
|
||||
"Card height in pixels."
|
||||
:type 'integer :group 'cg-svg)
|
||||
:type 'integer :group 'card-games-svg)
|
||||
|
||||
(defcustom cg-svg-card-gap 8
|
||||
(defcustom card-games-svg-card-gap 8
|
||||
"Pixels between adjacent cards."
|
||||
:type 'integer :group 'cg-svg)
|
||||
:type 'integer :group 'card-games-svg)
|
||||
|
||||
(defcustom cg-svg-card-shadow t
|
||||
(defcustom card-games-svg-card-shadow t
|
||||
"When non-nil, draw a soft drop shadow under each card."
|
||||
:type 'boolean :group 'cg-svg)
|
||||
:type 'boolean :group 'card-games-svg)
|
||||
|
||||
(defcustom cg-svg-font-family "Helvetica, Arial, sans-serif"
|
||||
(defcustom card-games-svg-font-family "Helvetica, Arial, sans-serif"
|
||||
"Font family used for ranks, pips and indices."
|
||||
:type 'string :group 'cg-svg)
|
||||
:type 'string :group 'card-games-svg)
|
||||
|
||||
(defcustom cg-svg-theme-colors t
|
||||
(defcustom card-games-svg-theme-colors t
|
||||
"Derive the card back and move-hint ring from the active theme.
|
||||
When non-nil, those colours are taken from the active Emacs theme, with
|
||||
the colour variables below as fallbacks. The cursor/selection ring is
|
||||
not themed this way -- see `cg-svg--highlight' -- so it never picks up a
|
||||
not themed this way -- see `card-games-svg--highlight' -- so it never picks up a
|
||||
theme's `region' colour."
|
||||
:type 'boolean :group 'cg-svg)
|
||||
:type 'boolean :group 'card-games-svg)
|
||||
|
||||
(defcustom cg-svg-card-back 'random
|
||||
(defcustom card-games-svg-card-back 'random
|
||||
"Pattern drawn on a face-down card back.
|
||||
The `emacs', `emacs-classic', `gnu' and `splash' backs stamp the card with
|
||||
a logo that ships with Emacs. `random' picks one of the concrete backs
|
||||
for the session (reshuffle with `cg-svg-shuffle-card-back')."
|
||||
for the session (reshuffle with `card-games-svg-shuffle-card-back')."
|
||||
:type '(choice (const dots) (const rings) (const solid)
|
||||
(const lattice) (const waves) (const diamond)
|
||||
(const emacs) (const emacs-classic) (const gnu) (const splash)
|
||||
(const random))
|
||||
:group 'cg-svg)
|
||||
:group 'card-games-svg)
|
||||
|
||||
(defconst cg-svg--card-backs
|
||||
(defconst card-games-svg--card-backs
|
||||
'(dots rings solid lattice waves diamond emacs emacs-classic gnu splash)
|
||||
"Concrete card backs that `random' chooses among.")
|
||||
|
||||
(defvar cg-svg--random-back nil
|
||||
(defvar card-games-svg--random-back nil
|
||||
"The concrete back currently chosen for the `random' setting.")
|
||||
|
||||
(defun cg-svg--roll-back ()
|
||||
(defun card-games-svg--roll-back ()
|
||||
"Choose a fresh concrete back for `random' and return it."
|
||||
(setq cg-svg--random-back
|
||||
(nth (random (length cg-svg--card-backs)) cg-svg--card-backs)))
|
||||
(setq card-games-svg--random-back
|
||||
(nth (random (length card-games-svg--card-backs)) card-games-svg--card-backs)))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-svg-shuffle-card-back ()
|
||||
"Pick a new random card back (used when `cg-svg-card-back' is `random')."
|
||||
(defun card-games-svg-shuffle-card-back ()
|
||||
"Pick a new random card back (used when `card-games-svg-card-back' is `random')."
|
||||
(interactive)
|
||||
(cg-svg--roll-back)
|
||||
(card-games-svg--roll-back)
|
||||
(when (called-interactively-p 'interactive)
|
||||
(message "Card back: %s" cg-svg--random-back)))
|
||||
(message "Card back: %s" card-games-svg--random-back)))
|
||||
|
||||
(defun cg-svg--effective-back ()
|
||||
(defun card-games-svg--effective-back ()
|
||||
"Return the concrete back to draw, resolving `random'."
|
||||
(if (eq cg-svg-card-back 'random)
|
||||
(or cg-svg--random-back (cg-svg--roll-back))
|
||||
cg-svg-card-back))
|
||||
(if (eq card-games-svg-card-back 'random)
|
||||
(or card-games-svg--random-back (card-games-svg--roll-back))
|
||||
card-games-svg-card-back))
|
||||
|
||||
(defun cg-svg--back-logo-name (back)
|
||||
"Map a logo card-back BACK to a `cg-svg--logo-files' key."
|
||||
(defun card-games-svg--back-logo-name (back)
|
||||
"Map a logo card-back BACK to a `card-games-svg--logo-files' key."
|
||||
(pcase back ('emacs 'modern) ('emacs-classic 'classic)
|
||||
('gnu 'gnu) ('splash 'splash)))
|
||||
|
||||
(defcustom cg-svg-four-color nil
|
||||
(defcustom card-games-svg-four-color nil
|
||||
"Use a four-colour deck when non-nil.
|
||||
Clubs are drawn green and diamonds blue-purple; spades stay black and
|
||||
hearts red."
|
||||
:type 'boolean :group 'cg-svg)
|
||||
:type 'boolean :group 'card-games-svg)
|
||||
|
||||
(defconst cg-svg-corner-radius 6
|
||||
(defconst card-games-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.")
|
||||
(defvar card-games-svg-red-color "#c0392b" "Colour for red suits.")
|
||||
(defvar card-games-svg-black-color "#2c3e50" "Colour for black suits.")
|
||||
(defvar card-games-svg-club-color "#166534" "Clubs colour in a four-colour deck.")
|
||||
(defvar card-games-svg-diamond-color "#3b3fb0" "Diamonds colour in a four-colour deck.")
|
||||
(defvar card-games-svg-joker-color "#8e44ad" "Colour for the Joker.")
|
||||
(defvar card-games-svg-face-color "#fdfdfb" "Card face fill.")
|
||||
(defvar card-games-svg-court-color "#f6f2e8" "Court-card inner panel fill.")
|
||||
(defvar card-games-svg-border-color "#566573" "Card border colour.")
|
||||
(defvar card-games-svg-back-color "#27496d" "Card back fill.")
|
||||
(defvar card-games-svg-back-trim "#9fb3cf" "Card back inner trim/dots.")
|
||||
(defvar card-games-svg-highlight-color "#f1c40f" "Cursor/selection highlight.")
|
||||
(defvar card-games-svg-gap-color "#cbd5e1" "Empty-slot outline colour.")
|
||||
|
||||
(defun cg-svg--highlight ()
|
||||
(defun card-games-svg--highlight ()
|
||||
"Resolve the cursor/selection ring colour.
|
||||
Always the configured `cg-svg-highlight-color' (a calm gold by
|
||||
Always the configured `card-games-svg-highlight-color' (a calm gold by
|
||||
default). This is deliberately not taken from the theme's `region'
|
||||
face: on many themes that face is a saturated colour, and a fat ring
|
||||
in it reads as an alarming frame flashing around the whole board on
|
||||
each redraw. Customize `cg-svg-highlight-color' to change it."
|
||||
cg-svg-highlight-color)
|
||||
each redraw. Customize `card-games-svg-highlight-color' to change it."
|
||||
card-games-svg-highlight-color)
|
||||
|
||||
(defun cg-svg--back-fill ()
|
||||
(defun card-games-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))
|
||||
(if card-games-svg-theme-colors
|
||||
(card-games-color 'mode-line :background card-games-svg-back-color)
|
||||
card-games-svg-back-color))
|
||||
|
||||
(defun cg-svg--court-fill (suit)
|
||||
(defun card-games-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")
|
||||
((card-games-red-suit-p suit) "#fbeceb")
|
||||
(t "#eef2f6")))
|
||||
|
||||
(defvar cg-svg-hint-color "#27ae60" "Colour ringing a valid move target.")
|
||||
(defvar card-games-svg-hint-color "#7cf59a" "Colour ringing a valid move target.")
|
||||
|
||||
(defun cg-svg--hint ()
|
||||
(defun card-games-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))
|
||||
(if card-games-svg-theme-colors
|
||||
(card-games-color 'success :foreground card-games-svg-hint-color)
|
||||
card-games-svg-hint-color))
|
||||
|
||||
(defconst cg-svg--pip-layout
|
||||
(defconst card-games-svg--pip-layout
|
||||
'((1 (0.5 . 0.50))
|
||||
(2 (0.5 . 0.16) (0.5 . 0.84))
|
||||
(3 (0.5 . 0.16) (0.5 . 0.50) (0.5 . 0.84))
|
||||
|
|
@ -198,31 +197,31 @@ each redraw. Customize `cg-svg-highlight-color' to change it."
|
|||
"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)
|
||||
(defun card-games-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)))
|
||||
(cond ((eq suit 'joker) card-games-svg-joker-color)
|
||||
(card-games-svg-four-color
|
||||
(pcase suit (0 card-games-svg-black-color) (1 card-games-svg-club-color)
|
||||
(2 card-games-svg-diamond-color) (3 card-games-svg-red-color)
|
||||
(_ card-games-svg-black-color)))
|
||||
((card-games-red-suit-p suit) card-games-svg-red-color)
|
||||
(t card-games-svg-black-color)))
|
||||
|
||||
(defun cg-svg--suit-glyph (suit)
|
||||
(defun card-games-svg--suit-glyph (suit)
|
||||
"Return the glyph for SUIT (0-3 or the symbol `joker').
|
||||
Defers to `cg-suit-glyph', so it honours `cg-symbols'."
|
||||
(cg-suit-glyph suit))
|
||||
Defers to `card-games-suit-glyph', so it honours `card-games-symbols'."
|
||||
(card-games-suit-glyph suit))
|
||||
|
||||
(defun cg-svg--text (svg str x y size color &optional bold transform)
|
||||
(defun card-games-svg--text (svg str x y size color &optional bold transform)
|
||||
"Add centred text STR to SVG at X, Y with SIZE, COLOR, BOLD, TRANSFORM."
|
||||
(let ((args (list :x (round x) :y (round y) :font-size (round size)
|
||||
:fill color :text-anchor "middle"
|
||||
:font-family cg-svg-font-family)))
|
||||
:font-family card-games-svg-font-family)))
|
||||
(when bold (setq args (append args (list :font-weight "bold"))))
|
||||
(when transform (setq args (append args (list :transform transform))))
|
||||
(apply #'svg-text svg str args)))
|
||||
|
||||
(defun cg-svg--index (svg x y w h rank glyph color flip)
|
||||
(defun card-games-svg--index (svg x y w h rank glyph color flip)
|
||||
"Draw a stacked RANK/GLYPH index in COLOR on SVG.
|
||||
X, Y and W, H give the card's top-left corner and size. The index sits
|
||||
top-left normally, and bottom-right and upside-down when FLIP is non-nil."
|
||||
|
|
@ -235,31 +234,31 @@ top-left normally, and bottom-right and upside-down when FLIP is non-nil."
|
|||
(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)))
|
||||
(card-games-svg--text svg rank ix ry rs color t tr))
|
||||
(card-games-svg--text svg glyph ix gy gs color nil tr)))
|
||||
|
||||
(defun cg-svg--pip (svg px py size glyph color flip)
|
||||
(defun card-games-svg--pip (svg px py size glyph color flip)
|
||||
"Draw a single pip GLYPH of SIZE in COLOR centred at PX, PY on SVG."
|
||||
(cg-svg--text svg glyph px (+ py (* size 0.36)) size color nil
|
||||
(card-games-svg--text svg glyph px (+ py (* size 0.36)) size color nil
|
||||
(and flip (format "rotate(180 %d %d)" (round px) (round py)))))
|
||||
|
||||
(defun cg-svg--draw-pips (svg x y w h n glyph color)
|
||||
(defun card-games-svg--draw-pips (svg x y w h n glyph color)
|
||||
"Lay out N pips of GLYPH in COLOR within the card at X, Y (W by H) on SVG."
|
||||
(let* ((mx (* w 0.24)) (my (* h 0.14))
|
||||
(iw (- w (* 2 mx))) (ih (- h (* 2 my)))
|
||||
(ps (max 9 (round (* h 0.155))))
|
||||
(layout (cdr (assq n cg-svg--pip-layout))))
|
||||
(layout (cdr (assq n card-games-svg--pip-layout))))
|
||||
(dolist (pos layout)
|
||||
(cg-svg--pip svg (+ x mx (* (car pos) iw)) (+ y my (* (cdr pos) ih))
|
||||
(card-games-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)
|
||||
(defun card-games-svg--draw-ace (svg x y w h glyph color)
|
||||
"Draw a single large central pip (an ace) of GLYPH in COLOR on SVG.
|
||||
X, Y and W, H give the card's top-left corner and size."
|
||||
(cg-svg--pip svg (+ x (/ w 2.0)) (+ y (/ h 2.0)) (round (* h 0.42))
|
||||
(card-games-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)
|
||||
(defun card-games-svg--draw-court (svg x y w h rank glyph color suit)
|
||||
"Draw a framed court card (RANK letter + GLYPH) of SUIT in COLOR on SVG.
|
||||
X, Y and W, H give the card's top-left corner and size. The inner panel
|
||||
has a quarter-circle scallop cut into each corner; the scallop radius is
|
||||
|
|
@ -282,176 +281,191 @@ has a quarter-circle scallop cut into each corner; the scallop radius is
|
|||
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)
|
||||
(svg-node svg 'path :d d :fill (card-games-svg--court-fill suit)
|
||||
:stroke color :stroke-width 1)
|
||||
(cg-svg--text svg rank (+ x (/ w 2.0)) (+ y (* h 0.65)) (* h 0.282) color t)
|
||||
(cg-svg--text svg glyph (+ x (/ w 2.0)) (+ y (* h 0.82)) (* h 0.17) color)))
|
||||
(card-games-svg--text svg rank (+ x (/ w 2.0)) (+ y (* h 0.65)) (* h 0.282) color t)
|
||||
(card-games-svg--text svg glyph (+ x (/ w 2.0)) (+ y (* h 0.82)) (* h 0.17) color)))
|
||||
|
||||
(defun cg-svg--draw-joker (svg x y w h color)
|
||||
(defun card-games-svg--draw-joker (svg x y w h color)
|
||||
"Draw the joker face in COLOR on SVG.
|
||||
X, Y and W, H give the card's top-left corner and size."
|
||||
(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))
|
||||
(card-games-svg--text svg "★" (+ x (/ w 2.0)) (+ y (* h 0.52)) (* h 0.40) color)
|
||||
(card-games-svg--text svg "JOKER" (+ x (/ w 2.0)) (+ y (* h 0.74)) (* h 0.135) color t))
|
||||
|
||||
(defun cg-svg--back-dots (svg x y w h)
|
||||
"Draw the dotted-medallion back pattern."
|
||||
(defun card-games-svg--back-dots (svg x y w h)
|
||||
"Draw the dotted-medallion back pattern on SVG within X, Y, W, H."
|
||||
(let ((gy (+ y 10)))
|
||||
(while (< gy (- (+ y h) 8))
|
||||
(let ((gx (+ x 10)))
|
||||
(while (< gx (- (+ x w) 8))
|
||||
(svg-circle svg gx gy 1.1 :fill cg-svg-back-trim)
|
||||
(svg-circle svg gx gy 1.1 :fill card-games-svg-back-trim)
|
||||
(setq gx (+ gx 9))))
|
||||
(setq gy (+ gy 9)))))
|
||||
|
||||
(defun cg-svg--back-lattice (svg x y w h)
|
||||
"Draw a small-cross lattice back pattern."
|
||||
(defun card-games-svg--back-lattice (svg x y w h)
|
||||
"Draw a small-cross lattice back pattern on SVG within X, Y, W, H."
|
||||
(let ((gy (+ y 13)))
|
||||
(while (< gy (- (+ y h) 10))
|
||||
(let ((gx (+ x 13)))
|
||||
(while (< gx (- (+ x w) 10))
|
||||
(svg-line svg (- gx 2) (- gy 2) (+ gx 2) (+ gy 2)
|
||||
:stroke cg-svg-back-trim :stroke-width 1)
|
||||
:stroke card-games-svg-back-trim :stroke-width 1)
|
||||
(svg-line svg (- gx 2) (+ gy 2) (+ gx 2) (- gy 2)
|
||||
:stroke cg-svg-back-trim :stroke-width 1)
|
||||
:stroke card-games-svg-back-trim :stroke-width 1)
|
||||
(setq gx (+ gx 11))))
|
||||
(setq gy (+ gy 11)))))
|
||||
|
||||
(defun cg-svg--back-waves (svg x y w h)
|
||||
"Draw a staggered-dash (brickwork) back pattern."
|
||||
(defun card-games-svg--back-waves (svg x y w h)
|
||||
"Draw a staggered-dash (brickwork) back pattern on SVG within X, Y, W, H."
|
||||
(let ((gy (+ y 12)) (row 0))
|
||||
(while (< gy (- (+ y h) 9))
|
||||
(let ((gx (+ x (if (cl-evenp row) 9 15))))
|
||||
(while (< gx (- (+ x w) 9))
|
||||
(svg-line svg gx gy (+ gx 6) gy :stroke cg-svg-back-trim :stroke-width 1.4)
|
||||
(svg-line svg gx gy (+ gx 6) gy :stroke card-games-svg-back-trim :stroke-width 1.4)
|
||||
(setq gx (+ gx 12))))
|
||||
(setq gy (+ gy 8) row (1+ row)))))
|
||||
|
||||
(defun cg-svg--back-diamond (svg x y w h)
|
||||
"Draw concentric diamonds as the back pattern."
|
||||
(defun card-games-svg--back-diamond (svg x y w h)
|
||||
"Draw concentric diamonds as the back pattern on SVG within X, Y, W, H."
|
||||
(let ((cx (+ x (/ w 2.0))) (cy (+ y (/ h 2.0))))
|
||||
(dolist (f '(0.40 0.28 0.16))
|
||||
(let ((dw (* w f)) (dh (* h f)))
|
||||
(svg-polygon svg (list (cons cx (- cy dh)) (cons (+ cx dw) cy)
|
||||
(cons cx (+ cy dh)) (cons (- cx dw) cy))
|
||||
:fill "none" :stroke cg-svg-back-trim :stroke-width 1)))))
|
||||
:fill "none" :stroke card-games-svg-back-trim :stroke-width 1)))))
|
||||
|
||||
(defun cg-svg--back-logo (svg x y w h back)
|
||||
"Stamp the Emacs logo for BACK centred on the card, or dots if unavailable."
|
||||
(defun card-games-svg--back-logo (svg x y w h back)
|
||||
"Stamp the Emacs logo named BACK on SVG within X, Y, W, H.
|
||||
Fall back to dots when the logo image is unavailable."
|
||||
(let ((file (and (fboundp 'svg-embed)
|
||||
(cg-svg--logo-file (cg-svg--back-logo-name back)))))
|
||||
(card-games-svg--logo-file (card-games-svg--back-logo-name back)))))
|
||||
(if (null file)
|
||||
(cg-svg--back-dots svg x y w h)
|
||||
(card-games-svg--back-dots svg x y w h)
|
||||
(let ((size (round (* h 0.52))))
|
||||
(svg-embed svg file "image/png" nil
|
||||
:x (round (+ x (/ (- w size) 2.0)))
|
||||
:y (round (+ y (/ (- h size) 2.0)))
|
||||
:width size :height size)))))
|
||||
|
||||
(defun cg-svg--draw-back (svg x y w h r)
|
||||
(defun card-games-svg--draw-back (svg x y w h r)
|
||||
"Draw a face-down card back on SVG at X, Y (W by H, corner R).
|
||||
The pattern is controlled by `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)
|
||||
The pattern is controlled by `card-games-svg-card-back'."
|
||||
(svg-rectangle svg x y w h :rx r :ry r :fill (card-games-svg--back-fill)
|
||||
:stroke card-games-svg-border-color :stroke-width 1)
|
||||
(svg-rectangle svg (+ x 4) (+ y 4) (- w 8) (- h 8) :rx 4 :fill "none"
|
||||
:stroke cg-svg-back-trim :stroke-width 1)
|
||||
(let ((back (cg-svg--effective-back)))
|
||||
:stroke card-games-svg-back-trim :stroke-width 1)
|
||||
(let ((back (card-games-svg--effective-back)))
|
||||
(pcase back
|
||||
('solid nil)
|
||||
('rings
|
||||
(svg-rectangle svg (+ x 8) (+ y 8) (- w 16) (- h 16) :rx 5 :fill "none"
|
||||
:stroke cg-svg-back-trim :stroke-width 1)
|
||||
:stroke card-games-svg-back-trim :stroke-width 1)
|
||||
(svg-rectangle svg (+ x 12) (+ y 12) (- w 24) (- h 24) :rx 4 :fill "none"
|
||||
:stroke cg-svg-back-trim :stroke-width 1))
|
||||
('lattice (cg-svg--back-lattice svg x y w h))
|
||||
('waves (cg-svg--back-waves svg x y w h))
|
||||
('diamond (cg-svg--back-diamond svg x y w h))
|
||||
:stroke card-games-svg-back-trim :stroke-width 1))
|
||||
('lattice (card-games-svg--back-lattice svg x y w h))
|
||||
('waves (card-games-svg--back-waves svg x y w h))
|
||||
('diamond (card-games-svg--back-diamond svg x y w h))
|
||||
((or 'emacs 'emacs-classic 'gnu 'splash)
|
||||
(cg-svg--back-logo svg x y w h back))
|
||||
(_ (cg-svg--back-dots svg x y w h)))))
|
||||
(card-games-svg--back-logo svg x y w h back))
|
||||
(_ (card-games-svg--back-dots svg x y w h)))))
|
||||
|
||||
(defun cg-svg--draw-face (svg x y w h r rank suit)
|
||||
(defun card-games-svg--draw-face (svg x y w h r rank suit)
|
||||
"Draw a face-up card (RANK of SUIT) on SVG at X, Y (W by H, corner R)."
|
||||
(svg-rectangle svg x y w h :rx r :ry r :fill 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)
|
||||
(svg-rectangle svg x y w h :rx r :ry r :fill card-games-svg-face-color
|
||||
:stroke card-games-svg-border-color :stroke-width 1)
|
||||
(let ((color (card-games-svg--suit-color suit))
|
||||
(glyph (card-games-svg--suit-glyph suit)))
|
||||
(card-games-svg--index svg x y w h rank glyph color nil)
|
||||
(card-games-svg--index svg x y w h rank glyph color t)
|
||||
(cond
|
||||
((eq suit 'joker) (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))
|
||||
((eq suit 'joker) (card-games-svg--draw-joker svg x y w h color))
|
||||
((member rank '("J" "Q" "K")) (card-games-svg--draw-court svg x y w h rank glyph color suit))
|
||||
((equal rank "A") (card-games-svg--draw-ace svg x y w h glyph color))
|
||||
(t (let ((n (truncate (string-to-number (or rank "0")))))
|
||||
(if (and (>= n 1) (<= n 10))
|
||||
(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))
|
||||
(card-games-svg--draw-pips svg x y w h n glyph color)
|
||||
(card-games-svg--text svg glyph (+ x (/ w 2.0)) (+ y (* h 0.6))
|
||||
(* h 0.40) color)))))))
|
||||
|
||||
(cl-defun cg-svg-card (svg x y &key rank suit down gap highlight hint)
|
||||
(cl-defun card-games-svg-card (svg x y &key rank suit down gap highlight hint)
|
||||
"Draw one card onto SVG with its top-left corner at X, Y.
|
||||
With GAP draw an empty slot; with DOWN draw a face-down card;
|
||||
otherwise draw a face card labelled RANK of SUIT (0-3 or `joker').
|
||||
HIGHLIGHT draws a glowing cursor ring around the card."
|
||||
(let* ((w cg-svg-card-width)
|
||||
(h cg-svg-card-height)
|
||||
(r cg-svg-corner-radius))
|
||||
(when (and cg-svg-card-shadow (not gap))
|
||||
(let* ((w card-games-svg-card-width)
|
||||
(h card-games-svg-card-height)
|
||||
(r card-games-svg-corner-radius))
|
||||
(when (and card-games-svg-card-shadow (not gap))
|
||||
(svg-rectangle svg (+ x 2) (+ y 3) w h :rx r :ry r
|
||||
:fill "black" :fill-opacity 0.16))
|
||||
(cond
|
||||
(gap
|
||||
(svg-rectangle svg x y w h :rx r :ry r :fill "black" :fill-opacity 0.05
|
||||
:stroke cg-svg-gap-color :stroke-width 1.5
|
||||
:stroke card-games-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)))
|
||||
(down (card-games-svg--draw-back svg x y w h r))
|
||||
(t (card-games-svg--draw-face svg x y w h r rank suit)))
|
||||
(when hint
|
||||
;; Haloed dashed ring: a dark backing reads on the light card faces and
|
||||
;; the bright ring reads on the (green) felt -- one colour cannot do
|
||||
;; both. Dashed (vs the solid cursor ring) keeps it distinct by shape,
|
||||
;; not colour alone.
|
||||
(svg-rectangle svg (- x 3) (- y 3) (+ w 6) (+ h 6) :rx (+ r 2)
|
||||
:fill "none" :stroke "#101010" :stroke-opacity 0.55
|
||||
:stroke-width 4 :stroke-dasharray "3,3")
|
||||
(svg-rectangle svg (- x 2) (- y 2) (+ w 4) (+ h 4) :rx (+ r 1)
|
||||
:fill "none" :stroke (cg-svg--hint) :stroke-width 2
|
||||
:fill "none" :stroke (card-games-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)
|
||||
(let ((hl (card-games-svg--highlight)))
|
||||
;; Haloed ring so the cursor reads on both the near-white card faces
|
||||
;; (dark edges) and the dark felt (bright ring): no single colour
|
||||
;; meets 3:1 on both, so pair a bright ring with dark edges.
|
||||
(svg-rectangle svg (- x 5) (- y 5) (+ w 10) (+ h 10) :rx (+ r 4)
|
||||
:fill "none" :stroke "#101010" :stroke-opacity 0.6
|
||||
:stroke-width 6)
|
||||
(svg-rectangle svg (- x 3) (- y 3) (+ w 6) (+ h 6) :rx (+ r 2)
|
||||
:fill "none" :stroke hl :stroke-width 2.5)))))
|
||||
:fill "none" :stroke hl :stroke-width 3.5)
|
||||
(svg-rectangle svg (- x 1) (- y 1) (+ w 2) (+ h 2) :rx (+ r 1)
|
||||
:fill "none" :stroke "#101010" :stroke-opacity 0.55
|
||||
:stroke-width 1.5)))))
|
||||
|
||||
(defun cg-svg--draw-spec (svg x y spec highlight &optional hint)
|
||||
(defun card-games-svg--draw-spec (svg x y spec highlight &optional hint)
|
||||
"Draw SPEC onto SVG at X, Y, with HIGHLIGHT and optional HINT ring.
|
||||
SPEC is (RANK . SUIT), the symbol `down', or nil for a gap."
|
||||
(cond
|
||||
((null spec) (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)
|
||||
((null spec) (card-games-svg-card svg x y :gap t :highlight highlight :hint hint))
|
||||
((eq spec 'down) (card-games-svg-card svg x y :down t :highlight highlight :hint hint))
|
||||
(t (card-games-svg-card svg x y :rank (car spec) :suit (cdr spec)
|
||||
:highlight highlight :hint hint))))
|
||||
|
||||
(cl-defun cg-svg-cards-svg (specs &key highlight (pad 10) (overlap 0))
|
||||
(cl-defun card-games-svg-cards-svg (specs &key highlight (pad 10) (overlap 0))
|
||||
"Return an svg object drawing SPECS left to right.
|
||||
SPECS is a list of card specs (see Commentary). HIGHLIGHT is the
|
||||
index of a card to ring. OVERLAP fans cards by overlapping them by
|
||||
that many pixels. PAD is the margin around the row."
|
||||
(let* ((w cg-svg-card-width)
|
||||
(h cg-svg-card-height)
|
||||
(step (max 1 (- (+ w cg-svg-card-gap) overlap)))
|
||||
(let* ((w card-games-svg-card-width)
|
||||
(h card-games-svg-card-height)
|
||||
(step (max 1 (- (+ w card-games-svg-card-gap) overlap)))
|
||||
(n (length specs))
|
||||
(width (+ (* 2 pad) (if (> n 0) (+ (* (1- n) step) w) w)))
|
||||
(height (+ (* 2 pad) h))
|
||||
(svg (svg-create width height)))
|
||||
(let ((x pad) (i 0))
|
||||
(dolist (spec specs)
|
||||
(cg-svg--draw-spec svg x pad spec (and highlight (= i highlight)))
|
||||
(card-games-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))
|
||||
(cl-defun card-games-svg-grid-svg (rows &key cursor hints (pad 10))
|
||||
"Return an svg object drawing ROWS as a grid of cards.
|
||||
ROWS is a list of rows, each a list of card specs. CURSOR is (ROW . COL)
|
||||
to highlight, or nil. HINTS is a list of (ROW . COL) to ring as valid
|
||||
targets. PAD is the margin around the grid."
|
||||
(let* ((w cg-svg-card-width)
|
||||
(h cg-svg-card-height)
|
||||
(gx cg-svg-card-gap)
|
||||
(gy cg-svg-card-gap)
|
||||
(let* ((w card-games-svg-card-width)
|
||||
(h card-games-svg-card-height)
|
||||
(gx card-games-svg-card-gap)
|
||||
(gy card-games-svg-card-gap)
|
||||
(ncols (apply #'max 1 (mapcar #'length rows)))
|
||||
(nrows (max 1 (length rows)))
|
||||
(width (+ (* 2 pad) (* ncols w) (* (1- ncols) gx)))
|
||||
|
|
@ -462,107 +476,107 @@ targets. PAD is the margin around the grid."
|
|||
(let ((c 0)
|
||||
(y (+ pad (* r (+ h gy)))))
|
||||
(dolist (spec row)
|
||||
(cg-svg--draw-spec svg (+ pad (* c (+ w gx))) y spec
|
||||
(card-games-svg--draw-spec svg (+ pad (* c (+ w gx))) y spec
|
||||
(and cursor (= r (car cursor)) (= c (cdr cursor)))
|
||||
(and hints (member (cons r c) hints) t))
|
||||
(setq c (1+ c))))
|
||||
(setq r (1+ r)))
|
||||
svg))
|
||||
|
||||
(defun cg-svg-image (svg &optional scale)
|
||||
(defun card-games-svg-image (svg &optional scale)
|
||||
"Return an Emacs image for SVG, optionally enlarged by SCALE."
|
||||
(if (and scale (/= scale 1.0))
|
||||
(svg-image svg :scale scale)
|
||||
(svg-image svg)))
|
||||
|
||||
(defun cg-svg-to-string (svg)
|
||||
(defun card-games-svg-to-string (svg)
|
||||
"Return the serialized XML string for SVG."
|
||||
(with-temp-buffer
|
||||
(svg-print svg)
|
||||
(buffer-string)))
|
||||
|
||||
(cl-defun cg-svg-hand-svg (specs &key cursor hints marks (overlap 0) (pad 8))
|
||||
(cl-defun card-games-svg-hand-svg (specs &key cursor hints marks (overlap 0) (pad 8))
|
||||
"Return an svg drawing SPECS as a left-to-right hand.
|
||||
CURSOR is the index to ring as the cursor; HINTS and MARKS are lists of
|
||||
indices to ring as playable and as marked; OVERLAP fans the cards and
|
||||
PAD insets the row."
|
||||
(let* ((w cg-svg-card-width) (h cg-svg-card-height)
|
||||
(step (max 1 (- (+ w cg-svg-card-gap) overlap)))
|
||||
(let* ((w card-games-svg-card-width) (h card-games-svg-card-height)
|
||||
(step (max 1 (- (+ w card-games-svg-card-gap) overlap)))
|
||||
(n (length specs))
|
||||
(width (+ (* 2 pad) (if (> n 0) (+ (* (1- n) step) w) w)))
|
||||
(height (+ (* 2 pad) h))
|
||||
(svg (svg-create width height))
|
||||
(x pad) (i 0))
|
||||
(dolist (spec specs)
|
||||
(cg-svg--draw-spec svg x pad spec (eql i cursor) (and (memq i hints) t))
|
||||
(card-games-svg--draw-spec svg x pad spec (eql i cursor) (and (memq i hints) t))
|
||||
(when (memq i marks)
|
||||
(svg-rectangle svg (- x 3) (- pad 3) (+ w 6) (+ h 6)
|
||||
:rx 7 :fill "none" :stroke "#4a90d9" :stroke-width 3))
|
||||
(setq x (+ x step) i (1+ i)))
|
||||
svg))
|
||||
|
||||
(defcustom cg-svg-slider-stops '(0.6 0.8 1.0 1.25 1.5 1.8 2.2)
|
||||
(defcustom card-games-svg-slider-stops '(0.6 0.8 1.0 1.25 1.5 1.8 2.2)
|
||||
"Card-size slider stops, as scale multipliers."
|
||||
:type '(repeat number) :group 'card-games)
|
||||
|
||||
(defun cg-svg-slider-width ()
|
||||
(defun card-games-svg-slider-width ()
|
||||
"Return the pixel width of the card-size slider."
|
||||
(+ 36 (* (length cg-svg-slider-stops) 24) 8))
|
||||
(+ 36 (* (length card-games-svg-slider-stops) 24) 8))
|
||||
|
||||
(defun cg-svg-slider-height ()
|
||||
(defun card-games-svg-slider-height ()
|
||||
"Return the pixel height of the card-size slider."
|
||||
24)
|
||||
|
||||
(defun cg-svg-slider-draw (svg x y current)
|
||||
(defun card-games-svg-slider-draw (svg x y current)
|
||||
"Draw a card-size slider into SVG at X, Y knobbed at CURRENT.
|
||||
Return its click regions as a list of (RECT . (scale . VALUE))."
|
||||
(let* ((stops cg-svg-slider-stops) (segw 24) (regions '()) (i 0)
|
||||
(let* ((stops card-games-svg-slider-stops) (segw 24) (regions '()) (i 0)
|
||||
(cy (+ y 10)) (tx (+ x 36)))
|
||||
(svg-text svg "size" :x x :y (+ y 14) :font-size 9 :fill "gray55"
|
||||
:font-family cg-svg-font-family)
|
||||
:font-family card-games-svg-font-family)
|
||||
(svg-line svg tx cy (+ tx (* (length stops) segw)) cy
|
||||
:stroke "gray60" :stroke-width 2)
|
||||
(dolist (v stops)
|
||||
(let* ((px (+ tx (* i segw) (/ segw 2)))
|
||||
(near (< (abs (- v current)) 0.08)))
|
||||
(svg-circle svg px cy (if near 7 4)
|
||||
:fill (if near (cg-svg--highlight) "white")
|
||||
:fill (if near (card-games-svg--highlight) "white")
|
||||
:stroke "gray50" :stroke-width 1)
|
||||
(push (cons (list (+ tx (* i segw)) y segw 22) (cons 'scale v)) regions))
|
||||
(setq i (1+ i)))
|
||||
(nreverse regions)))
|
||||
|
||||
(cl-defun cg-svg-hand-image (specs &key cursor marks hints (overlap 0) region-tag)
|
||||
(cl-defun card-games-svg-hand-image (specs &key cursor marks hints (overlap 0) region-tag)
|
||||
"Return a propertized one-image string for a hand of card SPECS.
|
||||
CURSOR is the highlighted index; MARKS and HINTS are index lists and
|
||||
OVERLAP fans the cards. With REGION-TAG non-nil, the image carries a
|
||||
`cg-regions' click map (each card as (REGION-TAG . INDEX)) and a
|
||||
`card-games-regions' click map (each card as (REGION-TAG . INDEX)) and a
|
||||
card-size slider beneath the row."
|
||||
(if (not region-tag)
|
||||
(propertize "*" 'display
|
||||
(cg-svg-image (cg-svg-hand-svg specs :cursor cursor :hints hints
|
||||
(card-games-svg-image (card-games-svg-hand-svg specs :cursor cursor :hints hints
|
||||
:marks marks :overlap overlap)
|
||||
(cg-scale)))
|
||||
(let* ((w cg-svg-card-width) (h cg-svg-card-height) (pad 8)
|
||||
(step (max 1 (- (+ w cg-svg-card-gap) overlap)))
|
||||
(card-games-scale)))
|
||||
(let* ((w card-games-svg-card-width) (h card-games-svg-card-height) (pad 8)
|
||||
(step (max 1 (- (+ w card-games-svg-card-gap) overlap)))
|
||||
(n (length specs))
|
||||
(cardw (if (> n 0) (+ (* (1- n) step) w) w))
|
||||
(sh (cg-svg-slider-height))
|
||||
(width (+ (* 2 pad) (max cardw (cg-svg-slider-width))))
|
||||
(sh (card-games-svg-slider-height))
|
||||
(width (+ (* 2 pad) (max cardw (card-games-svg-slider-width))))
|
||||
(height (+ (* 2 pad) h 8 sh))
|
||||
(svg (svg-create width height)) (regions '()) (x pad) (i 0))
|
||||
(dolist (spec specs)
|
||||
(cg-svg--draw-spec svg x pad spec (eql i cursor) (and (memq i hints) t))
|
||||
(card-games-svg--draw-spec svg x pad spec (eql i cursor) (and (memq i hints) t))
|
||||
(when (memq i marks)
|
||||
(svg-rectangle svg (- x 3) (- pad 3) (+ w 6) (+ h 6)
|
||||
:rx 7 :fill "none" :stroke "#4a90d9" :stroke-width 3))
|
||||
(push (cons (list x pad w h) (cons region-tag i)) regions)
|
||||
(setq x (+ x step) i (1+ i)))
|
||||
(setq regions (append (nreverse regions)
|
||||
(cg-svg-slider-draw svg pad (+ pad h 8) cg-card-scale)))
|
||||
(propertize "*" 'display (cg-svg-image svg (cg-scale)) 'cg-regions regions))))
|
||||
(card-games-svg-slider-draw svg pad (+ pad h 8) card-games-card-scale)))
|
||||
(propertize "*" 'display (card-games-svg-image svg (card-games-scale)) 'card-games-regions regions))))
|
||||
|
||||
(defcustom cg-svg-emacs-logo 'modern
|
||||
(defcustom card-games-svg-emacs-logo 'modern
|
||||
"Which Emacs emblem to show in the full-window (svg-fill) games.
|
||||
The image choices embed a logo that ships with Emacs, falling back to the
|
||||
drawn emblem when the file is unavailable. `drawn' is a small built-in
|
||||
|
|
@ -573,9 +587,9 @@ emblem and `none' shows nothing."
|
|||
(const :tag "GNU Emacs splash" splash)
|
||||
(const :tag "Drawn emblem" drawn)
|
||||
(const :tag "None" none))
|
||||
:group 'cg-svg)
|
||||
:group 'card-games-svg)
|
||||
|
||||
(defconst cg-svg--logo-files
|
||||
(defconst card-games-svg--logo-files
|
||||
'((modern . ("images/icons/hicolor/48x48/apps/emacs.png"
|
||||
"images/icons/hicolor/128x128/apps/emacs.png"))
|
||||
(classic . ("images/icons/hicolor/48x48/apps/emacs23.png"
|
||||
|
|
@ -584,37 +598,39 @@ emblem and `none' shows nothing."
|
|||
(splash . ("images/splash.png")))
|
||||
"Map a logo name to candidate image files relative to `data-directory'.")
|
||||
|
||||
(defun cg-svg--logo-file (name)
|
||||
(defun card-games-svg--logo-file (name)
|
||||
"Return the first readable image file for logo NAME, or nil."
|
||||
(cl-loop for rel in (cdr (assq name cg-svg--logo-files))
|
||||
(cl-loop for rel in (cdr (assq name card-games-svg--logo-files))
|
||||
for f = (expand-file-name rel data-directory)
|
||||
when (file-readable-p f) return f))
|
||||
|
||||
(defun cg-svg--draw-logo-emblem (svg cx cy fs)
|
||||
"Draw the built-in purple GNU Emacs emblem centred at CX, CY, scaled FS."
|
||||
(svg-gradient svg "cg-logo" 'linear '((0 . "#8056c8") (100 . "#3f1f9e")))
|
||||
(svg-circle svg cx cy (round (* 26 fs)) :gradient "cg-logo"
|
||||
(defun card-games-svg--draw-logo-emblem (svg cx cy fs)
|
||||
"Draw the built-in purple GNU Emacs emblem on SVG.
|
||||
Centre it at CX, CY, scaled by FS."
|
||||
(svg-gradient svg "card-games-logo" 'linear '((0 . "#8056c8") (100 . "#3f1f9e")))
|
||||
(svg-circle svg cx cy (round (* 26 fs)) :gradient "card-games-logo"
|
||||
:stroke "#2a1370" :stroke-width 2)
|
||||
(cg-svg--text svg "e" cx (+ cy (round (* 10 fs))) (round (* 30 fs)) "#ffffff" t)
|
||||
(cg-svg--text svg "GNU Emacs" cx (+ cy (round (* 42 fs)))
|
||||
(card-games-svg--text svg "e" cx (+ cy (round (* 10 fs))) (round (* 30 fs)) "#ffffff" t)
|
||||
(card-games-svg--text svg "GNU Emacs" cx (+ cy (round (* 42 fs)))
|
||||
(max 10 (round (* 11 fs))) "#c7bbe6"))
|
||||
|
||||
(defun cg-svg-draw-logo (svg cx cy &optional fs)
|
||||
"Draw the configured Emacs emblem (`cg-svg-emacs-logo') centred at CX, CY.
|
||||
FS scales it. Embeds a real Emacs logo image when one is available, and
|
||||
otherwise draws the built-in emblem."
|
||||
(let ((fs (or fs 1.0)) (choice cg-svg-emacs-logo))
|
||||
(defun card-games-svg-draw-logo (svg cx cy &optional fs)
|
||||
"Draw the configured Emacs emblem on SVG, centred at CX, CY.
|
||||
The emblem is chosen by `card-games-svg-emacs-logo'; FS scales it. Embeds a
|
||||
real Emacs logo image when one is available, and otherwise draws the
|
||||
built-in emblem."
|
||||
(let ((fs (or fs 1.0)) (choice card-games-svg-emacs-logo))
|
||||
(pcase choice
|
||||
('none nil)
|
||||
('drawn (cg-svg--draw-logo-emblem svg cx cy fs))
|
||||
(_ (let ((file (and (fboundp 'svg-embed) (cg-svg--logo-file choice))))
|
||||
('drawn (card-games-svg--draw-logo-emblem svg cx cy fs))
|
||||
(_ (let ((file (and (fboundp 'svg-embed) (card-games-svg--logo-file choice))))
|
||||
(if (null file)
|
||||
(cg-svg--draw-logo-emblem svg cx cy fs)
|
||||
(card-games-svg--draw-logo-emblem svg cx cy fs)
|
||||
(let ((size (round (* 56 fs))))
|
||||
(svg-embed svg file "image/png" nil
|
||||
:x (round (- cx (/ size 2)))
|
||||
:y (round (- cy (/ size 2)))
|
||||
:width size :height size))))))))
|
||||
|
||||
(provide 'cg-svg)
|
||||
;;; cg-svg.el ends here
|
||||
(provide 'card-games-svg)
|
||||
;;; card-games-svg.el ends here
|
||||
522
card-games-trick-ext.el
Normal file
522
card-games-trick-ext.el
Normal file
|
|
@ -0,0 +1,522 @@
|
|||
;;; card-games-trick-ext.el --- Euchre, Pitch and Briscola -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Three more trick-taking games built on the engine in card-games-trick.el, each
|
||||
;; a four-handed game against three AI opponents (you are South).
|
||||
;;
|
||||
;; `card-games-euchre' -- Euchre. A 24-card deck, the Jack of trump (right
|
||||
;; bower) and its same-colour Jack (left bower) outranking everything;
|
||||
;; order up or call trump, then take three tricks. Partnership to 10.
|
||||
;; `card-games-pitch' -- Auction Pitch (All Fours). Bid for the privilege of
|
||||
;; pitching; the first card led sets trump. Score High, Low, Jack and
|
||||
;; Game. First to 7.
|
||||
;; `card-games-briscola' -- Briscola. A 40-card deck, a fixed trump turned from
|
||||
;; the deal, and no need to follow suit; capture the Aces and Threes.
|
||||
;; Partnership race to 61 of the 120 points.
|
||||
;;
|
||||
;; Cards use the package cons (SUIT . RANK), RANK 0 (Two) .. 12 (Ace) as
|
||||
;; in card-games-trick.el.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-trick)
|
||||
|
||||
;;;; Shared helpers
|
||||
|
||||
(defun card-games-tx--deck (ranks)
|
||||
"Return a shuffled deck holding only the RANKS (a list of rank indices)."
|
||||
(random t)
|
||||
(card-games-shuffle (cl-loop for s below 4 append
|
||||
(cl-loop for r in ranks collect (cons s r)))))
|
||||
|
||||
(defun card-games-tx--deal (game deck hs)
|
||||
"Deal HS cards each from DECK into GAME, in the card-games-trick layout."
|
||||
(let ((hands (make-vector 4 nil)) (last nil) (d deck))
|
||||
(dotimes (s 4)
|
||||
(let ((h nil))
|
||||
(dotimes (_ hs) (setq last (pop d)) (push last h))
|
||||
(aset hands s (card-games-trick--sort h))))
|
||||
(card-games-put game :hands hands)
|
||||
(card-games-put game :deck d)
|
||||
(card-games-put game :last-card last)
|
||||
(card-games-put game :trick nil)
|
||||
(card-games-put game :tricks (make-vector 4 0))
|
||||
(card-games-put game :taken (make-vector 4 nil))
|
||||
(card-games-put game :broken t)
|
||||
(card-games-put game :trick-no 0)
|
||||
game))
|
||||
|
||||
(defun card-games-tx--winner (plays trump powerfn ledfn)
|
||||
"Return the winning seat of PLAYS (a list of (SEAT . CARD), play order).
|
||||
TRUMP is the trump suit; POWERFN and LEDFN rank cards for this game."
|
||||
(let* ((led (funcall ledfn (cdr (car plays)) trump))
|
||||
(best (car plays))
|
||||
(bestp (funcall powerfn (cdr (car plays)) trump led)))
|
||||
(dolist (p (cdr plays))
|
||||
(let ((pp (funcall powerfn (cdr p) trump led)))
|
||||
(when (> pp bestp) (setq best p bestp pp))))
|
||||
(car best)))
|
||||
|
||||
(defun card-games-tx--ai (game seat powerfn ledfn valuefn)
|
||||
"Pick a card for GAME SEAT: win cheaply if leading, else shed the cheapest.
|
||||
POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
|
||||
(let* ((legal (card-games-trick--legal-moves game seat))
|
||||
(trick (card-games-get game :trick)) (trump (oref game trump)))
|
||||
(if (null trick)
|
||||
(car (sort (copy-sequence legal)
|
||||
(lambda (a b) (< (funcall valuefn a) (funcall valuefn b)))))
|
||||
(let* ((order (reverse trick))
|
||||
(led (funcall ledfn (cdr (car order)) trump))
|
||||
(winners '()) (losers '()))
|
||||
(dolist (c legal)
|
||||
(if (= seat (card-games-tx--winner (append order (list (cons seat c)))
|
||||
trump powerfn ledfn))
|
||||
(push c winners) (push c losers)))
|
||||
(if winners
|
||||
(car (sort winners (lambda (a b) (< (funcall powerfn a trump led)
|
||||
(funcall powerfn b trump led)))))
|
||||
(car (sort (or losers legal)
|
||||
(lambda (a b) (< (funcall valuefn a) (funcall valuefn b))))))))))
|
||||
|
||||
(defun card-games-tx--plain-led (card _trump) "Return CARD's suit (the plain led suit)." (car card))
|
||||
|
||||
|
||||
;;;; Briscola
|
||||
|
||||
(defconst card-games-briscola--ranks '(0 1 2 3 4 5 9 10 11 12)
|
||||
"Rank indices in a 40-card Briscola deck (no 8, 9, or 10).")
|
||||
|
||||
(defclass card-games-briscola-game (card-games-trick-game)
|
||||
((trump :initform nil) (target :initform 61) (hand-size :initform 10)
|
||||
(vname :initform "Briscola"))
|
||||
"Briscola: fixed trump, no follow, capture the points.")
|
||||
|
||||
(defun card-games-bris--power (card _trump _led)
|
||||
"Return CARD's rank power within its suit for Briscola."
|
||||
(- 10 (or (cl-position (cdr card) '(12 1 11 10 9 5 4 3 2 0)) 10)))
|
||||
|
||||
(defun card-games-bris--points (card)
|
||||
"Return CARD's Briscola point value."
|
||||
(pcase (cdr card) (12 11) (1 10) (11 4) (10 3) (9 2) (_ 0)))
|
||||
|
||||
(defun card-games-bris--win-power (card trump led)
|
||||
"Return CARD's Briscola power given TRUMP and LED (trump dominates)."
|
||||
(cond ((= (car card) trump) (+ 200 (card-games-bris--power card trump led)))
|
||||
((= (car card) led) (+ 100 (card-games-bris--power card trump led)))
|
||||
(t 0)))
|
||||
|
||||
(cl-defmethod card-games-trick--legal-p ((game card-games-briscola-game) seat card)
|
||||
"In GAME Briscola, SEAT may play any CARD (following suit is optional)."
|
||||
(and (member card (card-games-trick--hand game seat)) t))
|
||||
|
||||
(cl-defmethod card-games-trick--winner ((game card-games-briscola-game))
|
||||
"Return the winning seat of GAME's current Briscola trick."
|
||||
(card-games-tx--winner (reverse (card-games-get game :trick)) (oref game trump)
|
||||
#'card-games-bris--win-power #'card-games-tx--plain-led))
|
||||
|
||||
(cl-defmethod card-games-trick--ai-play ((game card-games-briscola-game) seat)
|
||||
"Return a card for AI SEAT in Briscola GAME."
|
||||
(card-games-tx--ai game seat #'card-games-bris--win-power #'card-games-tx--plain-led #'card-games-bris--points))
|
||||
|
||||
(cl-defmethod card-games-trick--begin-hand ((game card-games-briscola-game))
|
||||
"Begin a Briscola hand in GAME: deal and turn the trump."
|
||||
(card-games-tx--deal game (card-games-tx--deck card-games-briscola--ranks) 10)
|
||||
(card-games-put game :dealer (mod (1+ (or (card-games-get game :dealer) 3)) 4))
|
||||
(oset game trump (car (card-games-get game :last-card)))
|
||||
(card-games-put game :cursor 0)
|
||||
(let ((lead (mod (1+ (card-games-get game :dealer)) 4)))
|
||||
(card-games-put game :leader lead) (card-games-put game :turn lead))
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :message
|
||||
(format "Trump is %s. No need to follow suit."
|
||||
(card-games-suit-glyph (oref game trump))))
|
||||
(card-games-trick--run game))
|
||||
|
||||
(cl-defmethod card-games-trick--score-hand ((game card-games-briscola-game))
|
||||
"Score GAME's completed Briscola hand."
|
||||
(let ((scores (card-games-get game :scores)) (tp (make-vector 2 0)))
|
||||
(dotimes (s 4)
|
||||
(aset tp (card-games-trick--team s)
|
||||
(+ (aref tp (card-games-trick--team s))
|
||||
(apply #'+ (mapcar #'card-games-bris--points (aref (card-games-get game :taken) s))))))
|
||||
(dotimes (s 4) (aset scores s (+ (aref scores s) (aref tp (card-games-trick--team s)))))))
|
||||
|
||||
(cl-defmethod card-games-trick--game-over-p ((game card-games-briscola-game))
|
||||
"Return non-nil when GAME's Briscola game is over."
|
||||
(or (>= (aref (card-games-get game :scores) 0) (oref game target))
|
||||
(>= (aref (card-games-get game :scores) 1) (oref game target))))
|
||||
|
||||
(cl-defmethod card-games-trick--winner-seat ((game card-games-briscola-game))
|
||||
"Return the winning seat of GAME's Briscola game."
|
||||
(if (>= (aref (card-games-get game :scores) 0) (aref (card-games-get game :scores) 1)) 0 1))
|
||||
|
||||
(cl-defmethod card-games-trick--result-string ((game card-games-briscola-game))
|
||||
"Return GAME's Briscola game-over summary."
|
||||
(let ((w (card-games-trick--winner-seat game)))
|
||||
(format "%s win (%d points)" (if (= w 0) "You and North" "West and East")
|
||||
(aref (card-games-get game :scores) w))))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-briscola ()
|
||||
"Play Briscola against three AI opponents."
|
||||
(interactive)
|
||||
(card-games-trick--play-game 'card-games-briscola-game))
|
||||
|
||||
|
||||
;;;; Auction Pitch
|
||||
|
||||
(defclass card-games-pitch-game (card-games-trick-game)
|
||||
((trump :initform nil) (target :initform 7) (hand-size :initform 6)
|
||||
(vname :initform "Pitch"))
|
||||
"Auction Pitch: bid, pitch to set trump, score High/Low/Jack/Game.")
|
||||
|
||||
(defun card-games-pitch--pip (rank)
|
||||
"Return the Game-point pip value of RANK."
|
||||
(pcase rank (12 4) (11 3) (10 2) (9 1) (8 10) (_ 0)))
|
||||
|
||||
(defun card-games-pitch--power (card trump led)
|
||||
"Rank CARD for a Pitch trick under TRUMP given the LED suit."
|
||||
(cond ((and trump (= (car card) trump)) (+ 100 (cdr card)))
|
||||
((= (car card) led) (+ 50 (cdr card)))
|
||||
(t (cdr card))))
|
||||
|
||||
(cl-defmethod card-games-trick--legal-p ((game card-games-pitch-game) seat card)
|
||||
"In GAME Pitch, SEAT follows the led suit if able but may always trump CARD."
|
||||
(let ((hand (card-games-trick--hand game seat)) (trick (card-games-get game :trick))
|
||||
(trump (oref game trump)))
|
||||
(and (member card hand)
|
||||
(or (null trick)
|
||||
(let ((led (card-games-trick--led-suit game)))
|
||||
(cond ((= (car card) led) t)
|
||||
((and trump (= (car card) trump)) t)
|
||||
((cl-some (lambda (c) (= (car c) led)) hand) nil)
|
||||
(t t)))))))
|
||||
|
||||
(cl-defmethod card-games-trick--play ((game card-games-pitch-game) seat card)
|
||||
"In GAME, set trump from the pitcher's first lead (SEAT plays CARD), then play on."
|
||||
(when (and (null (oref game trump)) (null (card-games-get game :trick)))
|
||||
(oset game trump (car card))
|
||||
(card-games-put game :message
|
||||
(format "%s leads %s -- %s is trump."
|
||||
(aref card-games-trick-seat-names seat) (card-games-trick-card-string card)
|
||||
(card-games-suit-glyph (car card)))))
|
||||
(cl-call-next-method))
|
||||
|
||||
(cl-defmethod card-games-trick--ai-play ((game card-games-pitch-game) seat)
|
||||
"Return a card for AI SEAT in Pitch GAME."
|
||||
(if (and (null (oref game trump)) (= seat (card-games-get game :leader)))
|
||||
;; pitcher's opening lead: lead high from the strongest suit
|
||||
(let ((best nil) (bestv -1))
|
||||
(dotimes (s 4)
|
||||
(let ((v (card-games-pitch--suit-strength game seat s)))
|
||||
(when (> v bestv) (setq bestv v best s))))
|
||||
(car (sort (cl-remove-if-not (lambda (c) (= (car c) best))
|
||||
(card-games-trick--hand game seat))
|
||||
(lambda (a b) (> (cdr a) (cdr b))))))
|
||||
(card-games-tx--ai game seat #'card-games-pitch--power #'card-games-tx--plain-led
|
||||
(lambda (c) (card-games-pitch--pip (cdr c))))))
|
||||
|
||||
(defun card-games-pitch--suit-strength (game seat suit)
|
||||
"Estimate GAME SEAT's strength if SUIT were trump."
|
||||
(let ((v 0))
|
||||
(dolist (c (card-games-trick--hand game seat))
|
||||
(when (= (car c) suit)
|
||||
(setq v (+ v 2 (pcase (cdr c) (12 4) (11 3) (9 3) (_ 1))))))
|
||||
v))
|
||||
|
||||
(cl-defmethod card-games-trick--ai-bid ((game card-games-pitch-game) seat)
|
||||
"Return GAME SEAT's Pitch bid (0 to pass, else 2..4), only what is makeable."
|
||||
(let ((bid 0))
|
||||
(dotimes (s 4)
|
||||
(let* ((cards (cl-remove-if-not (lambda (c) (= (car c) s))
|
||||
(card-games-trick--hand game seat)))
|
||||
(n (length cards))
|
||||
(hasa (cl-find 12 cards :key #'cdr))
|
||||
(hask (cl-find 11 cards :key #'cdr))
|
||||
(hasj (cl-find 9 cards :key #'cdr))
|
||||
(b (cond ((and (>= n 4) hasa hasj) 4)
|
||||
((and (>= n 3) hasa (or hask hasj)) 3)
|
||||
((and (>= n 3) hasa) 2)
|
||||
((and (>= n 2) hasa hask) 2)
|
||||
(t 0))))
|
||||
(setq bid (max bid b))))
|
||||
bid))
|
||||
|
||||
(defun card-games-pitch--read-bid (game high)
|
||||
"Prompt you for a GAME Pitch bid that must beat HIGH (or 0 to pass)."
|
||||
(let ((sug (card-games-trick--ai-bid game 0)))
|
||||
(max 0 (min 4 (read-number
|
||||
(format "Your bid (0 pass, else %d-4) [suggest %d]: "
|
||||
(max 2 (1+ high)) sug)
|
||||
sug)))))
|
||||
|
||||
(cl-defmethod card-games-trick--begin-hand ((game card-games-pitch-game))
|
||||
"Begin a Pitch hand in GAME: deal and run the bidding."
|
||||
(card-games-tx--deal game (card-games-tx--deck (number-sequence 0 12)) 6)
|
||||
(oset game trump nil)
|
||||
(card-games-put game :dealer (mod (1+ (or (card-games-get game :dealer) 3)) 4))
|
||||
(card-games-put game :cursor 0)
|
||||
(let ((high 0) (bidder nil))
|
||||
(dotimes (k 4)
|
||||
(let* ((s (mod (+ (card-games-get game :dealer) 1 k) 4))
|
||||
(b (if (= s 0)
|
||||
(if noninteractive (card-games-trick--ai-bid game 0) (card-games-pitch--read-bid game high))
|
||||
(card-games-trick--ai-bid game s))))
|
||||
(when (and (>= b 2) (> b high)) (setq high b bidder s))))
|
||||
(unless bidder (setq bidder (card-games-get game :dealer) high 2)) ; stuck dealer pitches 2
|
||||
(card-games-put game :bidder bidder) (card-games-put game :bid high)
|
||||
(card-games-put game :leader bidder) (card-games-put game :turn bidder)
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :message
|
||||
(format "%s pitches (bid %d). Their first card sets trump."
|
||||
(aref card-games-trick-seat-names bidder) high))
|
||||
(card-games-trick--run game)))
|
||||
|
||||
(cl-defmethod card-games-trick--score-hand ((game card-games-pitch-game))
|
||||
"Score GAME's completed Pitch hand."
|
||||
(let* ((trump (oref game trump)) (scores (card-games-get game :scores))
|
||||
(earned (make-vector 4 0)) (game-pts (make-vector 4 0))
|
||||
(bidder (card-games-get game :bidder)) (bid (card-games-get game :bid))
|
||||
(hi nil) (hiseat nil) (lo nil) (loseat nil) (jackseat nil))
|
||||
(dotimes (s 4)
|
||||
(dolist (c (aref (card-games-get game :taken) s))
|
||||
(when (= (car c) trump)
|
||||
(when (or (null hi) (> (cdr c) hi)) (setq hi (cdr c) hiseat s))
|
||||
(when (or (null lo) (< (cdr c) lo)) (setq lo (cdr c) loseat s))
|
||||
(when (= (cdr c) 9) (setq jackseat s)))
|
||||
(aset game-pts s (+ (aref game-pts s) (card-games-pitch--pip (cdr c))))))
|
||||
(when hiseat (aset earned hiseat (1+ (aref earned hiseat))))
|
||||
(when loseat (aset earned loseat (1+ (aref earned loseat))))
|
||||
(when jackseat (aset earned jackseat (1+ (aref earned jackseat))))
|
||||
(let ((best -1) (bs nil) (tie nil))
|
||||
(dotimes (s 4)
|
||||
(cond ((> (aref game-pts s) best) (setq best (aref game-pts s) bs s tie nil))
|
||||
((= (aref game-pts s) best) (setq tie t))))
|
||||
(when (and bs (not tie) (> best 0)) (aset earned bs (1+ (aref earned bs)))))
|
||||
(dotimes (s 4)
|
||||
(if (= s bidder)
|
||||
(if (>= (aref earned s) bid)
|
||||
(aset scores s (+ (aref scores s) (aref earned s)))
|
||||
(aset scores s (- (aref scores s) bid)))
|
||||
(aset scores s (+ (aref scores s) (aref earned s)))))
|
||||
(card-games-put game :last-earned earned)))
|
||||
|
||||
(cl-defmethod card-games-trick--game-over-p ((game card-games-pitch-game))
|
||||
"Return non-nil when GAME's Pitch game is over."
|
||||
(cl-some (lambda (s) (>= s (oref game target))) (append (card-games-get game :scores) nil)))
|
||||
|
||||
(cl-defmethod card-games-trick--winner-seat ((game card-games-pitch-game))
|
||||
"Return the winning seat of GAME's Pitch game."
|
||||
(let ((best 0)) (dotimes (s 4)
|
||||
(when (> (aref (card-games-get game :scores) s)
|
||||
(aref (card-games-get game :scores) best)) (setq best s)))
|
||||
best))
|
||||
|
||||
(cl-defmethod card-games-trick--result-string ((game card-games-pitch-game))
|
||||
"Return GAME's Pitch game-over summary."
|
||||
(format "%s wins" (aref card-games-trick-seat-names (card-games-trick--winner-seat game))))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-pitch ()
|
||||
"Play Auction Pitch against three AI opponents."
|
||||
(interactive)
|
||||
(card-games-trick--play-game 'card-games-pitch-game))
|
||||
|
||||
|
||||
;;;; Euchre
|
||||
|
||||
(defclass card-games-euchre-game (card-games-trick-game)
|
||||
((trump :initform nil) (target :initform 10) (hand-size :initform 5)
|
||||
(vname :initform "Euchre"))
|
||||
"Euchre: 24 cards, bowers, order up or call trump, partnership to 10.")
|
||||
|
||||
(defun card-games-euchre--right-bower-p (card trump)
|
||||
"Return non-nil when CARD is the right bower for TRUMP."
|
||||
(and (= (cdr card) 9) (= (car card) trump)))
|
||||
|
||||
(defun card-games-euchre--left-bower-p (card trump)
|
||||
"Return non-nil when CARD is the left bower for TRUMP."
|
||||
(and (= (cdr card) 9) (= (car card) (card-games-sister-suit trump))))
|
||||
|
||||
(defun card-games-euchre--eff-suit (card trump)
|
||||
"Return CARD's effective suit (the left bower belongs to TRUMP)."
|
||||
(if (card-games-euchre--left-bower-p card trump) trump (car card)))
|
||||
|
||||
(defun card-games-euchre--power (card trump led)
|
||||
"Rank CARD for a Euchre trick under TRUMP given the effective LED suit."
|
||||
(cond ((card-games-euchre--right-bower-p card trump) 1000)
|
||||
((card-games-euchre--left-bower-p card trump) 999)
|
||||
((= (card-games-euchre--eff-suit card trump) trump) (+ 900 (cdr card)))
|
||||
((= (card-games-euchre--eff-suit card trump) led) (+ 100 (cdr card)))
|
||||
(t (cdr card))))
|
||||
|
||||
(defun card-games-euchre--eff-led (card trump) "Return CARD's effective led suit under TRUMP." (card-games-euchre--eff-suit card trump))
|
||||
|
||||
(cl-defmethod card-games-trick--legal-p ((game card-games-euchre-game) seat card)
|
||||
"In GAME Euchre, SEAT must follow the effective led suit with CARD if able."
|
||||
(let ((hand (card-games-trick--hand game seat)) (trick (card-games-get game :trick))
|
||||
(trump (oref game trump)))
|
||||
(and (member card hand)
|
||||
(or (null trick)
|
||||
(let ((led (card-games-euchre--eff-suit (cdr (card-games-trick--first-play game)) trump)))
|
||||
(if (cl-some (lambda (c) (= (card-games-euchre--eff-suit c trump) led)) hand)
|
||||
(= (card-games-euchre--eff-suit card trump) led)
|
||||
t))))))
|
||||
|
||||
(cl-defmethod card-games-trick--winner ((game card-games-euchre-game))
|
||||
"Return the winning seat of GAME's current Euchre trick."
|
||||
(card-games-tx--winner (reverse (card-games-get game :trick)) (oref game trump)
|
||||
#'card-games-euchre--power #'card-games-euchre--eff-led))
|
||||
|
||||
(cl-defmethod card-games-trick--ai-play ((game card-games-euchre-game) seat)
|
||||
"Return a card for AI SEAT in Euchre GAME."
|
||||
(card-games-tx--ai game seat #'card-games-euchre--power #'card-games-euchre--eff-led
|
||||
(lambda (c) (card-games-euchre--power c (oref game trump) -1))))
|
||||
|
||||
(defun card-games-euchre--strength (game seat suit)
|
||||
"Estimate GAME SEAT's trump strength if SUIT were trump."
|
||||
(let ((v 0))
|
||||
(dolist (c (card-games-trick--hand game seat))
|
||||
(cond ((card-games-euchre--right-bower-p c suit) (setq v (+ v 4)))
|
||||
((card-games-euchre--left-bower-p c suit) (setq v (+ v 3)))
|
||||
((= (card-games-euchre--eff-suit c suit) suit) (setq v (+ v 2)))
|
||||
((= (cdr c) 12) (setq v (+ v 1))))) ; off-ace
|
||||
v))
|
||||
|
||||
(defun card-games-euchre--ai-order (game seat upsuit)
|
||||
"Return non-nil if GAME SEAT orders up the UPSUIT."
|
||||
(>= (card-games-euchre--strength game seat upsuit) 6))
|
||||
|
||||
(defun card-games-euchre--ai-call (game seat upsuit)
|
||||
"Return a suit GAME SEAT names in round two after UPSUIT, or nil to pass."
|
||||
(let ((best nil) (bestv 0))
|
||||
(dotimes (s 4)
|
||||
(unless (= s upsuit)
|
||||
(let ((v (card-games-euchre--strength game seat s)))
|
||||
(when (> v bestv) (setq bestv v best s)))))
|
||||
(and (>= bestv 6) best)))
|
||||
|
||||
(defun card-games-euchre--best-suit (game seat upsuit)
|
||||
"Return GAME SEAT's strongest suit other than UPSUIT (for a stuck dealer)."
|
||||
(let ((best (mod (1+ upsuit) 4)) (bestv -1))
|
||||
(dotimes (s 4)
|
||||
(unless (= s upsuit)
|
||||
(let ((v (card-games-euchre--strength game seat s)))
|
||||
(when (> v bestv) (setq bestv v best s)))))
|
||||
best))
|
||||
|
||||
(defun card-games-euchre--dealer-pickup (game up)
|
||||
"In GAME, the dealer takes the UP card and discards their weakest."
|
||||
(let* ((d (card-games-get game :dealer)) (trump (car up))
|
||||
(hand (cons up (card-games-trick--hand game d)))
|
||||
(worst (car (sort (copy-sequence hand)
|
||||
(lambda (a b) (< (card-games-euchre--power a trump -1)
|
||||
(card-games-euchre--power b trump -1)))))))
|
||||
(card-games-trick--set-hand game d (card-games-trick--sort (remove worst hand)))))
|
||||
|
||||
(cl-defmethod card-games-trick--begin-hand ((game card-games-euchre-game))
|
||||
"Begin a Euchre hand in GAME: deal, turn up, run the bidding."
|
||||
(card-games-tx--deal game (card-games-tx--deck '(7 8 9 10 11 12)) 5)
|
||||
(oset game trump nil)
|
||||
(card-games-put game :dealer (mod (1+ (or (card-games-get game :dealer) 3)) 4))
|
||||
(card-games-put game :cursor 0)
|
||||
(let* ((up (car (card-games-get game :deck))) (upsuit (car up))
|
||||
(dealer (card-games-get game :dealer)) (maker nil) (chosen nil))
|
||||
(card-games-put game :up up)
|
||||
(cl-block bid
|
||||
(dotimes (k 4)
|
||||
(let ((s (mod (+ dealer 1 k) 4)))
|
||||
(when (if (= s 0)
|
||||
(if noninteractive (card-games-euchre--ai-order game 0 upsuit)
|
||||
(y-or-n-p (format "Order up %s as trump? " (card-games-suit-glyph upsuit))))
|
||||
(card-games-euchre--ai-order game s upsuit))
|
||||
(setq maker s chosen upsuit)
|
||||
(card-games-euchre--dealer-pickup game up)
|
||||
(cl-return-from bid))))
|
||||
(dotimes (k 4)
|
||||
(let* ((s (mod (+ dealer 1 k) 4))
|
||||
(suit (if (= s 0)
|
||||
(if noninteractive (card-games-euchre--ai-call game 0 upsuit)
|
||||
(card-games-euchre--human-call upsuit))
|
||||
(card-games-euchre--ai-call game s upsuit))))
|
||||
(when suit (setq maker s chosen suit) (cl-return-from bid)))))
|
||||
(unless chosen
|
||||
(setq maker dealer chosen (card-games-euchre--best-suit game dealer upsuit)))
|
||||
(oset game trump chosen)
|
||||
(card-games-put game :maker maker)
|
||||
(let ((lead (mod (1+ dealer) 4)))
|
||||
(card-games-put game :leader lead) (card-games-put game :turn lead))
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :message
|
||||
(format "%s makes %s trump." (aref card-games-trick-seat-names maker)
|
||||
(card-games-suit-glyph chosen)))
|
||||
(card-games-trick--run game)))
|
||||
|
||||
(defun card-games-euchre--human-call (upsuit)
|
||||
"Prompt you to name a trump suit other than UPSUIT, or pass."
|
||||
(let* ((choices (cl-loop for s below 4 unless (= s upsuit)
|
||||
collect (cons (aref card-games-suit-names s) s)))
|
||||
(pick (completing-read "Call trump (or RET to pass): "
|
||||
(mapcar #'car choices) nil t)))
|
||||
(cdr (assoc pick choices))))
|
||||
|
||||
(cl-defmethod card-games-trick--score-hand ((game card-games-euchre-game))
|
||||
"Score GAME's completed Euchre hand."
|
||||
(let* ((scores (card-games-get game :scores))
|
||||
(mteam (card-games-trick--team (card-games-get game :maker)))
|
||||
(mt (+ (aref (card-games-get game :tricks) mteam)
|
||||
(aref (card-games-get game :tricks) (+ mteam 2))))
|
||||
(oteam (- 1 mteam)))
|
||||
(cl-flet ((award (team n) (dolist (s (list team (+ team 2)))
|
||||
(aset scores s (+ (aref scores s) n)))))
|
||||
(cond ((>= mt 5) (award mteam 2))
|
||||
((>= mt 3) (award mteam 1))
|
||||
(t (award oteam 2))))))
|
||||
|
||||
(cl-defmethod card-games-trick--game-over-p ((game card-games-euchre-game))
|
||||
"Return non-nil when GAME's Euchre game is over."
|
||||
(or (>= (aref (card-games-get game :scores) 0) (oref game target))
|
||||
(>= (aref (card-games-get game :scores) 1) (oref game target))))
|
||||
|
||||
(cl-defmethod card-games-trick--winner-seat ((game card-games-euchre-game))
|
||||
"Return the winning seat of GAME's Euchre game."
|
||||
(if (>= (aref (card-games-get game :scores) 0) (aref (card-games-get game :scores) 1)) 0 1))
|
||||
|
||||
(cl-defmethod card-games-trick--result-string ((game card-games-euchre-game))
|
||||
"Return GAME's Euchre game-over summary."
|
||||
(let ((w (card-games-trick--winner-seat game)))
|
||||
(format "%s win" (if (= w 0) "You and North" "West and East"))))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-euchre ()
|
||||
"Play Euchre against three AI opponents."
|
||||
(interactive)
|
||||
(card-games-trick--play-game 'card-games-euchre-game))
|
||||
|
||||
(provide 'card-games-trick-ext)
|
||||
;;; card-games-trick-ext.el ends here
|
||||
960
card-games-trick.el
Normal file
960
card-games-trick.el
Normal file
|
|
@ -0,0 +1,960 @@
|
|||
;;; card-games-trick.el --- Four-hand trick-taking games (Hearts, Spades) -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; A small four-handed trick-taking engine and two games built on it:
|
||||
;;
|
||||
;; `card-games-hearts' -- the classic avoidance game; dodge every heart and the
|
||||
;; Queen of Spades, or take them all to "shoot the moon".
|
||||
;; `card-games-spades' -- partnership bidding; spades are always trump; make your
|
||||
;; side's combined bid, beware of bags, and dare a nil.
|
||||
;;
|
||||
;; You sit South (seat 0); the other three seats are played by simple but
|
||||
;; legal AI. Cards are the package-standard cons (SUIT . RANK) with SUIT
|
||||
;; 0 spades, 1 clubs, 2 diamonds, 3 hearts and RANK 0 (the Two) .. 12 (the
|
||||
;; Ace); within a suit the higher rank wins, with the trump suit beating
|
||||
;; every plain suit.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-svg)
|
||||
|
||||
;;;; Cards
|
||||
|
||||
(defconst card-games-trick-ranks
|
||||
["2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K" "A"]
|
||||
"Rank labels indexed 0 (Two) .. 12 (Ace).")
|
||||
|
||||
(defconst card-games-trick-seat-names ["South" "West" "North" "East"]
|
||||
"Seat names indexed 0..3, going clockwise from the human player.")
|
||||
|
||||
(defun card-games-trick-card-string (card)
|
||||
"Return a short string for CARD."
|
||||
(if (null card) "·"
|
||||
(concat (aref card-games-trick-ranks (cdr card)) (card-games-suit-glyph (car card)))))
|
||||
|
||||
(defsubst card-games-trick-red-p (card) "Return non-nil when CARD is red." (and card (card-games-red-suit-p (car card))))
|
||||
|
||||
(defun card-games-trick--full-deck ()
|
||||
"Return a fresh shuffled 52-card deck."
|
||||
(random t)
|
||||
(card-games-shuffle (cl-loop for s below 4 append
|
||||
(cl-loop for r below 13 collect (cons s r)))))
|
||||
|
||||
(defun card-games-trick--sort (cards)
|
||||
"Return CARDS sorted by suit then rank for display."
|
||||
(sort (copy-sequence cards)
|
||||
(lambda (a b) (if (= (car a) (car b)) (< (cdr a) (cdr b))
|
||||
(< (car a) (car b))))))
|
||||
|
||||
;;;; Classes
|
||||
|
||||
(defclass card-games-trick-game (card-games-game)
|
||||
((trump :initform nil :documentation "Trump suit index, or nil for none.")
|
||||
(restricted :initform 3 :documentation "Suit that cannot be led until broken.")
|
||||
(target :initform 100 :documentation "Score that ends the game.")
|
||||
(hand-size :initform 13 :documentation "Cards dealt to each seat per hand.")
|
||||
(vname :initform "Trick game"))
|
||||
"Abstract base for four-handed trick-taking games."
|
||||
:abstract t)
|
||||
|
||||
(defclass card-games-hearts-game (card-games-trick-game)
|
||||
((trump :initform nil) (restricted :initform 3) (target :initform 100)
|
||||
(vname :initform "Hearts"))
|
||||
"Hearts: no trump; avoid hearts and the Queen of Spades.")
|
||||
|
||||
(defclass card-games-spades-game (card-games-trick-game)
|
||||
((trump :initform 0) (restricted :initform 0) (target :initform 500)
|
||||
(vname :initform "Spades"))
|
||||
"Spades: spades are trump; partnership bidding to 500.")
|
||||
|
||||
;;;; Dealing
|
||||
|
||||
(cl-defmethod card-games-trick--deal ((game card-games-trick-game))
|
||||
"Deal a fresh hand into GAME."
|
||||
(let ((deck (card-games-trick--full-deck))
|
||||
(hands (make-vector 4 nil))
|
||||
(hs (oref game hand-size))
|
||||
(last nil))
|
||||
(dotimes (s 4)
|
||||
(let ((h nil))
|
||||
(dotimes (_ hs) (setq last (pop deck)) (push last h))
|
||||
(aset hands s (card-games-trick--sort h))))
|
||||
(card-games-put game :hands hands)
|
||||
(card-games-put game :deck deck)
|
||||
(card-games-put game :last-card last)
|
||||
(card-games-put game :trick nil)
|
||||
(card-games-put game :tricks (make-vector 4 0))
|
||||
(card-games-put game :taken (make-vector 4 nil))
|
||||
(card-games-put game :broken nil)
|
||||
(card-games-put game :trick-no 0)
|
||||
game))
|
||||
|
||||
(defsubst card-games-trick--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
|
||||
(defsubst card-games-trick--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
|
||||
(defsubst card-games-trick--partner (s) "Return seat S's partner seat." (mod (+ s 2) 4))
|
||||
(defsubst card-games-trick--team (s) "Return seat S's team index (0 or 1)." (mod s 2))
|
||||
|
||||
;;;; Trick mechanics
|
||||
|
||||
(defun card-games-trick--led-suit (game)
|
||||
"Return the suit led to GAME's current trick, or nil if none yet."
|
||||
(let ((tr (card-games-get game :trick)))
|
||||
(and tr (car (cdr (car (last tr))))))) ; first entry played
|
||||
|
||||
(defun card-games-trick--first-play (game)
|
||||
"Return the (SEAT . CARD) led to GAME's current trick, or nil."
|
||||
(car (last (card-games-get game :trick))))
|
||||
|
||||
(cl-defmethod card-games-trick--has-points-only-p ((_ card-games-trick-game) _hand) "By default no trick restricts play to point cards." nil)
|
||||
|
||||
(cl-defmethod card-games-trick--legal-p ((game card-games-trick-game) seat card)
|
||||
"Return non-nil when SEAT may legally play CARD in GAME now."
|
||||
(let* ((hand (card-games-trick--hand game seat))
|
||||
(trick (card-games-get game :trick))
|
||||
(restricted (oref game restricted))
|
||||
(broken (card-games-get game :broken)))
|
||||
(and (member card hand)
|
||||
(if trick
|
||||
;; following: must follow the led suit if able
|
||||
(let ((led (card-games-trick--led-suit game)))
|
||||
(if (cl-some (lambda (c) (= (car c) led)) hand)
|
||||
(= (car card) led)
|
||||
t))
|
||||
;; leading: cannot lead the restricted suit until broken,
|
||||
;; unless the hand holds nothing else
|
||||
(if (and (= (car card) restricted) (not broken))
|
||||
(cl-every (lambda (c) (= (car c) restricted)) hand)
|
||||
t)))))
|
||||
|
||||
(defun card-games-trick--legal-moves (game seat)
|
||||
"Return the cards SEAT may legally play in GAME now."
|
||||
(cl-remove-if-not (lambda (c) (card-games-trick--legal-p game seat c))
|
||||
(card-games-trick--hand game seat)))
|
||||
|
||||
(cl-defmethod card-games-trick--winner ((game card-games-trick-game))
|
||||
"Return the seat that wins GAME's now-complete current trick."
|
||||
(let* ((trick (reverse (card-games-get game :trick))) ; play order
|
||||
(led (car (cdr (car trick))))
|
||||
(trump (oref game trump))
|
||||
(best (car trick)))
|
||||
(dolist (play (cdr trick))
|
||||
(let ((bc (cdr best)) (pc (cdr play)))
|
||||
(cond
|
||||
((and trump (= (car pc) trump) (not (= (car bc) trump)))
|
||||
(setq best play))
|
||||
((and (= (car pc) (car bc)) (> (cdr pc) (cdr bc)))
|
||||
(setq best play))
|
||||
((and trump (not (= (car bc) trump)) (= (car pc) led)
|
||||
(> (cdr pc) (cdr bc)))
|
||||
(setq best play)))))
|
||||
(car best)))
|
||||
|
||||
(cl-defmethod card-games-trick--play ((game card-games-trick-game) seat card)
|
||||
"Have GAME SEAT play CARD, resolving the trick when it completes."
|
||||
(card-games-trick--set-hand game seat (remove card (card-games-trick--hand game seat)))
|
||||
(when (= (car card) (oref game restricted)) (card-games-put game :broken t))
|
||||
(card-games-put game :trick (cons (cons seat card) (card-games-get game :trick)))
|
||||
(if (= 4 (length (card-games-get game :trick)))
|
||||
(let* ((w (card-games-trick--winner game))
|
||||
(cards (mapcar #'cdr (card-games-get game :trick))))
|
||||
(aset (card-games-get game :tricks) w (1+ (aref (card-games-get game :tricks) w)))
|
||||
(aset (card-games-get game :taken) w (append cards (aref (card-games-get game :taken) w)))
|
||||
(card-games-put game :trick nil)
|
||||
(card-games-put game :trick-no (1+ (card-games-get game :trick-no)))
|
||||
(card-games-put game :leader w)
|
||||
(card-games-put game :turn w)
|
||||
w)
|
||||
(card-games-put game :turn (mod (1+ seat) 4))
|
||||
nil))
|
||||
|
||||
(defun card-games-trick--hand-over-p (game)
|
||||
"Return non-nil when all 13 tricks of GAME's hand have been played."
|
||||
(and (null (card-games-get game :trick))
|
||||
(cl-every #'null (append (card-games-get game :hands) nil))))
|
||||
|
||||
;;;; Hearts specifics
|
||||
|
||||
(defun card-games-hearts--card-points (card)
|
||||
"Return the penalty points for CARD in Hearts."
|
||||
(cond ((equal card '(0 . 10)) 13) ; Queen of Spades
|
||||
((= (car card) 3) 1) ; any heart
|
||||
(t 0)))
|
||||
|
||||
(cl-defmethod card-games-trick--legal-p ((game card-games-hearts-game) seat card)
|
||||
"In GAME, apply Hearts legality (SEAT/CARD), adding the first-trick rules."
|
||||
(and (cl-call-next-method)
|
||||
(let ((trick (card-games-get game :trick))
|
||||
(hand (card-games-trick--hand game seat))
|
||||
(first (= 0 (card-games-get game :trick-no))))
|
||||
(cond
|
||||
;; the very first card of the hand must be the Two of Clubs
|
||||
((and first (null trick))
|
||||
(equal card '(1 . 0)))
|
||||
;; no points on the first trick unless that is all one holds
|
||||
((and first trick (> (card-games-hearts--card-points card) 0))
|
||||
(cl-every (lambda (c) (> (card-games-hearts--card-points c) 0)) hand))
|
||||
(t t)))))
|
||||
|
||||
(cl-defmethod card-games-trick--leader-init ((game card-games-hearts-game))
|
||||
"In GAME Hearts, the holder of the Two of Clubs leads first."
|
||||
(let (seat)
|
||||
(dotimes (s 4)
|
||||
(when (member '(1 . 0) (card-games-trick--hand game s)) (setq seat s)))
|
||||
(card-games-put game :leader seat) (card-games-put game :turn seat)))
|
||||
|
||||
(cl-defmethod card-games-trick--leader-init ((game card-games-spades-game))
|
||||
"In GAME Spades, the player left of the dealer leads first."
|
||||
(let ((s (mod (1+ (or (card-games-get game :dealer) 3)) 4)))
|
||||
(card-games-put game :leader s) (card-games-put game :turn s)))
|
||||
|
||||
(cl-defmethod card-games-trick--score-hand ((game card-games-hearts-game))
|
||||
"Score GAME's finished Hearts hand into the cumulative scores."
|
||||
(let ((pts (make-vector 4 0)) (scores (card-games-get game :scores)))
|
||||
(dotimes (s 4)
|
||||
(aset pts s (apply #'+ (mapcar #'card-games-hearts--card-points
|
||||
(aref (card-games-get game :taken) s)))))
|
||||
;; shooting the moon
|
||||
(let ((moon (cl-position 26 (append pts nil))))
|
||||
(if moon
|
||||
(dotimes (s 4) (unless (= s moon)
|
||||
(aset scores s (+ (aref scores s) 26))))
|
||||
(dotimes (s 4) (aset scores s (+ (aref scores s) (aref pts s))))))
|
||||
(card-games-put game :last-points pts)))
|
||||
|
||||
(cl-defmethod card-games-trick--game-over-p ((game card-games-hearts-game))
|
||||
"In GAME, Hearts ends when any score reaches the target."
|
||||
(cl-some (lambda (s) (>= s (oref game target))) (append (card-games-get game :scores) nil)))
|
||||
|
||||
(cl-defmethod card-games-trick--winner-seat ((game card-games-hearts-game))
|
||||
"Return GAME's winning seat (lowest score) for a finished Hearts game."
|
||||
(let ((best 0))
|
||||
(dotimes (s 4) (when (< (aref (card-games-get game :scores) s)
|
||||
(aref (card-games-get game :scores) best))
|
||||
(setq best s)))
|
||||
best))
|
||||
|
||||
;;;; Spades specifics
|
||||
|
||||
(cl-defmethod card-games-trick--score-hand ((game card-games-spades-game))
|
||||
"Score GAME's finished Spades hand into the cumulative team scores."
|
||||
(let ((scores (card-games-get game :scores))
|
||||
(bags (card-games-get game :bags))
|
||||
(bids (card-games-get game :bids))
|
||||
(tricks (card-games-get game :tricks)))
|
||||
(dotimes (team 2)
|
||||
(let* ((a team) (b (+ team 2))
|
||||
(teambid 0) (teamtricks (+ (aref tricks a) (aref tricks b)))
|
||||
(delta 0))
|
||||
;; nil bids handled per player
|
||||
(dolist (s (list a b))
|
||||
(if (= (aref bids s) 0)
|
||||
(setq delta (+ delta (if (= (aref tricks s) 0) 100 -100)))
|
||||
(setq teambid (+ teambid (aref bids s)))))
|
||||
(if (>= teamtricks teambid)
|
||||
(let ((over (- teamtricks teambid)))
|
||||
;; overtricks beyond nil winners count as bags
|
||||
(setq delta (+ delta (* 10 teambid) over))
|
||||
(aset bags team (+ (aref bags team) over))
|
||||
(when (>= (aref bags team) 10)
|
||||
(setq delta (- delta 100))
|
||||
(aset bags team (- (aref bags team) 10))))
|
||||
(setq delta (- delta (* 10 teambid))))
|
||||
(aset scores a (+ (aref scores a) delta))
|
||||
(aset scores b (aref scores a))))
|
||||
(card-games-put game :scores scores)))
|
||||
|
||||
(cl-defmethod card-games-trick--game-over-p ((game card-games-spades-game))
|
||||
"In GAME, Spades ends when a team reaches the target (or falls badly behind)."
|
||||
(cl-some (lambda (s) (>= s (oref game target))) (append (card-games-get game :scores) nil)))
|
||||
|
||||
(cl-defmethod card-games-trick--winner-seat ((game card-games-spades-game))
|
||||
"Return a seat of GAME's winning team for a finished Spades game."
|
||||
(if (>= (aref (card-games-get game :scores) 0) (aref (card-games-get game :scores) 1)) 0 1))
|
||||
|
||||
;;;; AI
|
||||
|
||||
(cl-defmethod card-games-trick--ai-bid ((game card-games-spades-game) seat)
|
||||
"Return a simple trick estimate (bid) for GAME SEAT in Spades."
|
||||
(let ((hand (card-games-trick--hand game seat)) (bid 0))
|
||||
(dolist (c hand)
|
||||
(cond
|
||||
((= (cdr c) 12) (setq bid (1+ bid))) ; aces
|
||||
((and (= (cdr c) 11)) (setq bid (1+ bid))) ; kings
|
||||
((and (= (car c) 0) (>= (cdr c) 9)) (setq bid (1+ bid))))) ; high spades
|
||||
;; long spades add tricks
|
||||
(let ((nsp (cl-count-if (lambda (c) (= (car c) 0)) hand)))
|
||||
(when (> nsp 4) (setq bid (+ bid (- nsp 4)))))
|
||||
(max 1 (min 13 bid))))
|
||||
|
||||
(cl-defmethod card-games-trick--ai-play ((game card-games-hearts-game) seat)
|
||||
"Choose a legal Hearts card for GAME SEAT, avoiding points."
|
||||
(let* ((moves (card-games-trick--legal-moves game seat))
|
||||
(trick (card-games-get game :trick)))
|
||||
(or
|
||||
(if (null trick)
|
||||
;; leading: play a low non-point card
|
||||
(car (sort (copy-sequence moves)
|
||||
(lambda (a b) (< (+ (* 4 (card-games-hearts--card-points a)) (cdr a))
|
||||
(+ (* 4 (card-games-hearts--card-points b)) (cdr b))))))
|
||||
;; following: if we can duck under the current winner, play highest
|
||||
;; safe card; else dump the most dangerous card
|
||||
(let* ((led (card-games-trick--led-suit game))
|
||||
(winrank (apply #'max (cons -1 (mapcar (lambda (p) (if (= (car (cdr p)) led)
|
||||
(cdr (cdr p)) -1))
|
||||
trick))))
|
||||
(under (cl-remove-if-not (lambda (c) (and (= (car c) led)
|
||||
(< (cdr c) winrank)))
|
||||
moves)))
|
||||
(cond
|
||||
(under (car (last (card-games-trick--sort under)))) ; highest still safe
|
||||
((cl-some (lambda (c) (/= (car c) led)) moves) ; void: dump worst
|
||||
(car (sort (copy-sequence moves)
|
||||
(lambda (a b) (> (+ (* 4 (card-games-hearts--card-points a)) (cdr a))
|
||||
(+ (* 4 (card-games-hearts--card-points b)) (cdr b)))))))
|
||||
(t (car (sort (copy-sequence moves) ; must follow & take: lowest
|
||||
(lambda (a b) (< (cdr a) (cdr b)))))))))
|
||||
(car moves))))
|
||||
|
||||
(cl-defmethod card-games-trick--ai-play ((game card-games-spades-game) seat)
|
||||
"Choose a legal Spades card for GAME SEAT."
|
||||
(let* ((moves (card-games-trick--legal-moves game seat))
|
||||
(trick (card-games-get game :trick))
|
||||
(trump (oref game trump)))
|
||||
(or
|
||||
(if (null trick)
|
||||
;; lead a high non-spade if possible, else lowest
|
||||
(let ((non (cl-remove-if (lambda (c) (= (car c) trump)) moves)))
|
||||
(if non (car (last (card-games-trick--sort non)))
|
||||
(car (card-games-trick--sort moves))))
|
||||
(let* ((led (card-games-trick--led-suit game))
|
||||
(cur (card-games-get game :trick))
|
||||
;; current winning play
|
||||
(winner (card-games-trick--winner-of game cur))
|
||||
(partner-winning (and winner (= (card-games-trick--team winner)
|
||||
(card-games-trick--team seat)))))
|
||||
(if partner-winning
|
||||
(car (card-games-trick--sort moves)) ; let partner have it: play low
|
||||
;; try to win cheaply
|
||||
(let* ((followers (cl-remove-if-not (lambda (c) (= (car c) led)) moves)))
|
||||
(or (car (card-games-trick--sort followers))
|
||||
(car (card-games-trick--sort moves)))))))
|
||||
(car moves))))
|
||||
|
||||
(defun card-games-trick--winner-of (game trick)
|
||||
"Return the seat currently winning the partial TRICK of GAME."
|
||||
(when trick
|
||||
(let* ((order (reverse trick))
|
||||
(led (car (cdr (car order))))
|
||||
(trump (oref game trump))
|
||||
(best (car order)))
|
||||
(dolist (play (cdr order))
|
||||
(let ((bc (cdr best)) (pc (cdr play)))
|
||||
(cond
|
||||
((and trump (= (car pc) trump) (not (= (car bc) trump))) (setq best play))
|
||||
((and (= (car pc) (car bc)) (> (cdr pc) (cdr bc))) (setq best play))
|
||||
((and trump (not (= (car bc) trump)) (= (car pc) led)
|
||||
(> (cdr pc) (cdr bc))) (setq best play)))))
|
||||
(car best))))
|
||||
|
||||
;;;; Game driver (logic; UI layered on top)
|
||||
|
||||
(cl-defmethod card-games-trick--start-hand ((game card-games-trick-game))
|
||||
"Deal and prepare a new hand, leaving GAME ready for the first lead."
|
||||
(card-games-trick--deal game)
|
||||
(card-games-trick--leader-init game)
|
||||
game)
|
||||
|
||||
(defun card-games-trick--simulate-hand (game)
|
||||
"Play a whole GAME hand with AI for every seat (used by the test suite)."
|
||||
(while (not (card-games-trick--hand-over-p game))
|
||||
(let ((seat (card-games-get game :turn)))
|
||||
(card-games-trick--play game seat
|
||||
(if (eq card-games-ai-level 'easy)
|
||||
(let ((moves (card-games-trick--legal-moves game seat)))
|
||||
(nth (random (length moves)) moves))
|
||||
(card-games-trick--ai-play game seat)))))
|
||||
(card-games-trick--score-hand game))
|
||||
|
||||
;;;; New-game / hand lifecycle
|
||||
|
||||
(defvar-local card-games-trick--game nil "The trick-taking game in the current buffer.")
|
||||
|
||||
(defconst card-games-trick--pass-dirs [1 3 2 0]
|
||||
"Pass directions by hand: left, right, across, hold (then repeat).")
|
||||
|
||||
(defun card-games-trick--dir-name (dir)
|
||||
"Return a human label for pass direction DIR."
|
||||
(pcase dir (1 "left") (3 "right") (2 "across") (_ "hold")))
|
||||
|
||||
(cl-defgeneric card-games-trick--begin-hand (game)
|
||||
"Deal and set up a new hand of GAME, then run AI up to the human's turn.")
|
||||
|
||||
(cl-defmethod card-games-trick--begin-hand ((game card-games-hearts-game))
|
||||
"Begin a Hearts hand in GAME: deal and set the leader."
|
||||
(card-games-trick--deal game)
|
||||
(card-games-put game :hand-no (1+ (or (card-games-get game :hand-no) 0)))
|
||||
(card-games-put game :cursor 0) (card-games-put game :marks nil)
|
||||
(let ((dir (aref card-games-trick--pass-dirs (mod (1- (card-games-get game :hand-no)) 4))))
|
||||
(card-games-put game :pass-dir dir)
|
||||
(if (= dir 0)
|
||||
(progn (card-games-trick--leader-init game)
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :message "No passing this hand. Play begins.")
|
||||
(card-games-trick--run game))
|
||||
(card-games-put game :phase 'pass)
|
||||
(card-games-put game :message
|
||||
(format "Pass three cards %s. RET marks a card; p sends them."
|
||||
(card-games-trick--dir-name dir))))))
|
||||
|
||||
(cl-defmethod card-games-trick--begin-hand ((game card-games-spades-game))
|
||||
"Begin a Spades hand in GAME: deal and run the bidding."
|
||||
(card-games-trick--deal game)
|
||||
(card-games-put game :dealer (mod (1+ (or (card-games-get game :dealer) 3)) 4))
|
||||
(card-games-put game :cursor 0)
|
||||
(let ((bids (make-vector 4 0)))
|
||||
(dotimes (s 4) (unless (= s 0) (aset bids s (card-games-trick--ai-bid game s))))
|
||||
(aset bids 0 (if noninteractive (card-games-trick--ai-bid game 0)
|
||||
(let ((sug (card-games-trick--ai-bid game 0)))
|
||||
(max 0 (min 13 (read-number
|
||||
(format "Your bid (0 = nil) [suggest %d]: " sug)
|
||||
sug))))))
|
||||
(card-games-put game :bids bids))
|
||||
(card-games-trick--leader-init game)
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :message
|
||||
(format "You bid %d. Make your side's combined bid."
|
||||
(aref (card-games-get game :bids) 0)))
|
||||
(card-games-trick--run game))
|
||||
|
||||
(defun card-games-trick--new (game)
|
||||
"Initialise GAME for a fresh match and deal the first hand."
|
||||
(card-games-put game :scores (make-vector 4 0))
|
||||
(card-games-put game :bags (make-vector 2 0))
|
||||
(card-games-put game :dealer 3)
|
||||
(card-games-put game :hand-no 0)
|
||||
(card-games-put game :round 0)
|
||||
(card-games-trick--begin-hand game)
|
||||
game)
|
||||
|
||||
(defun card-games-trick--run (game)
|
||||
"Advance GAME's AI seats until the human's turn or the hand ends."
|
||||
(while (and (eq (card-games-get game :phase) 'play)
|
||||
(not (card-games-trick--hand-over-p game))
|
||||
(/= (card-games-get game :turn) 0))
|
||||
(let ((s (card-games-get game :turn)))
|
||||
(card-games-trick--play game s (card-games-trick--ai-play game s))))
|
||||
(when (and (eq (card-games-get game :phase) 'play) (card-games-trick--hand-over-p game))
|
||||
(card-games-trick--finish-hand game)))
|
||||
|
||||
(defun card-games-trick--finish-hand (game)
|
||||
"Score the finished hand of GAME and start the next, or end the match."
|
||||
(card-games-trick--score-hand game)
|
||||
(if (card-games-trick--game-over-p game)
|
||||
(progn (card-games-put game :phase 'game-over)
|
||||
(card-games-put game :message
|
||||
(format "Game over. %s. Press n for a new match."
|
||||
(card-games-trick--result-string game))))
|
||||
(card-games-trick--begin-hand game)))
|
||||
|
||||
(cl-defmethod card-games-trick--result-string ((game card-games-hearts-game))
|
||||
"Return GAME's Hearts game-over summary."
|
||||
(format "%s wins with the lowest score"
|
||||
(aref card-games-trick-seat-names (card-games-trick--winner-seat game))))
|
||||
|
||||
(cl-defmethod card-games-trick--result-string ((game card-games-spades-game))
|
||||
"Return GAME's Spades game-over summary."
|
||||
(let ((w (card-games-trick--winner-seat game)))
|
||||
(format "%s win" (if (= w 0) "You and North" "West and East"))))
|
||||
|
||||
;;;; AI passing
|
||||
|
||||
(cl-defmethod card-games-trick--ai-pass ((_ card-games-hearts-game) hand)
|
||||
"Return three cards to pass from HAND (shed the most dangerous)."
|
||||
(let ((danger (lambda (c) (+ (* 6 (card-games-hearts--card-points c))
|
||||
(if (and (= (car c) 0) (>= (cdr c) 10)) 5 0)
|
||||
(cdr c)))))
|
||||
(cl-subseq (sort (copy-sequence hand)
|
||||
(lambda (a b) (> (funcall danger a) (funcall danger b))))
|
||||
0 3)))
|
||||
|
||||
(defun card-games-trick--do-pass (game)
|
||||
"Exchange the chosen passing cards among the four seats of GAME."
|
||||
(let* ((dir (card-games-get game :pass-dir))
|
||||
(sel (make-vector 4 nil))
|
||||
(kept (make-vector 4 nil)))
|
||||
(aset sel 0 (copy-sequence (card-games-get game :marks)))
|
||||
(dotimes (s 4)
|
||||
(unless (= s 0)
|
||||
(aset sel s (copy-sequence (card-games-trick--ai-pass game (card-games-trick--hand game s))))))
|
||||
;; what each seat keeps (its hand minus the cards it gives away)
|
||||
(dotimes (s 4)
|
||||
(aset kept s (cl-remove-if (lambda (c) (member c (aref sel s)))
|
||||
(card-games-trick--hand game s))))
|
||||
;; deal each seat's three cards to the seat DIR places along
|
||||
(dotimes (s 4)
|
||||
(let ((r (mod (+ s dir) 4)))
|
||||
(aset kept r (append (aref kept r) (aref sel s)))))
|
||||
(dotimes (s 4)
|
||||
(card-games-trick--set-hand game s (card-games-trick--sort (aref kept s))))
|
||||
(card-games-trick--leader-init game)
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :marks nil)
|
||||
(card-games-put game :message "Cards passed. Play begins.")
|
||||
(card-games-trick--run game)))
|
||||
|
||||
(defun card-games-trick--seat-line (game s)
|
||||
"Return a status line for opponent seat S of GAME."
|
||||
(let* ((n (length (card-games-trick--hand game s)))
|
||||
(bid (and (card-games-get game :bids) (aref (card-games-get game :bids) s)))
|
||||
(won (and (card-games-get game :tricks) (aref (card-games-get game :tricks) s))))
|
||||
(format " %-6s %2d cards%s%s\n" (aref card-games-trick-seat-names s) n
|
||||
(if bid (format " bid %d" bid) "")
|
||||
(if won (format " won %d" won) ""))))
|
||||
|
||||
(defcustom card-games-trick-svg-cards t
|
||||
"When non-nil, draw cards as SVG images on a graphical display."
|
||||
:type 'boolean :group 'card-games)
|
||||
|
||||
(defun card-games-trick--spec (card)
|
||||
"Return the card-games-svg display spec (RANK-STRING . SUIT) for CARD."
|
||||
(cons (aref card-games-trick-ranks (cdr card)) (car card)))
|
||||
|
||||
(cl-defun card-games-trick--svg-row (cards &key cursor marks hints region-tag)
|
||||
"Return an SVG row for CARDS with CURSOR and HINTS, clickable via REGION-TAG.
|
||||
The MARKS list highlights any selected cards."
|
||||
(card-games-svg-hand-image (mapcar #'card-games-trick--spec cards)
|
||||
:cursor cursor :marks marks :hints hints
|
||||
:overlap (if (> (length cards) 11)
|
||||
(max 0 (- card-games-svg-card-width 24)) 0)
|
||||
:region-tag region-tag))
|
||||
|
||||
(defun card-games-trick--draw-backs (svg x y n)
|
||||
"Draw up to three overlapped face-down backs on SVG at X, Y for N cards."
|
||||
(let ((k (min (max n 0) 3)) (xx x))
|
||||
(dotimes (_ k)
|
||||
(card-games-svg-card svg xx y :down t)
|
||||
(setq xx (+ xx 16)))))
|
||||
|
||||
(defun card-games-trick--svg (game)
|
||||
"Return a propertized full-table SVG depiction of trick GAME.
|
||||
The South hand carries clickable (hand . INDEX) regions."
|
||||
(let* ((w card-games-svg-card-width) (h card-games-svg-card-height) (gap card-games-svg-card-gap)
|
||||
(pad 16)
|
||||
(hand (card-games-trick--sort (card-games-trick--hand game 0)))
|
||||
(n (length hand))
|
||||
(overlap (cond ((> n 11) (- w 24)) ((> n 8) 20) (t 0)))
|
||||
(step (max 14 (- (+ w gap) overlap)))
|
||||
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
|
||||
(width (max (+ fanw (* 2 pad)) 720))
|
||||
(cx (/ width 2))
|
||||
(scores (card-games-get game :scores))
|
||||
(trick (card-games-get game :trick))
|
||||
(turn (card-games-get game :turn))
|
||||
(phase (card-games-get game :phase))
|
||||
(marks (card-games-get game :marks))
|
||||
(cursor (card-games-get game :cursor))
|
||||
(bids (card-games-get game :bids))
|
||||
(tks (card-games-get game :tricks))
|
||||
(y-title 6) (y-north 26)
|
||||
(y-tn (+ y-north h 22))
|
||||
(cy (+ y-tn (round (* h 0.55))))
|
||||
(y-ts (+ cy (round (* h 0.15))))
|
||||
(y-south (+ y-ts h 34))
|
||||
(height (+ y-south h 30))
|
||||
(svg (svg-create width height))
|
||||
(lc (card-games-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels
|
||||
((txt (str x y &optional sz bold anchor)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family card-games-svg-font-family
|
||||
(append (and bold '(:font-weight "bold"))
|
||||
(and anchor (list :text-anchor anchor)))))
|
||||
(seat (s x y)
|
||||
(card-games-trick--draw-backs svg x (+ y 6) (length (card-games-trick--hand game s)))
|
||||
(txt (format "%s%s%s%s" (aref card-games-trick-seat-names s)
|
||||
(if (and bids (aref bids s)) (format " bid %d" (aref bids s)) "")
|
||||
(if (and tks (> (aref tks s) 0)) (format " won %d" (aref tks s)) "")
|
||||
(if (= turn s) " <-" ""))
|
||||
x y 11))
|
||||
(trick-card (s x y)
|
||||
(let ((play (assq s trick)))
|
||||
(when play
|
||||
(let ((sp (card-games-trick--spec (cdr play))))
|
||||
(card-games-svg-card svg x y :rank (car sp) :suit (cdr sp)))))))
|
||||
(txt (format "%s -- %s" (oref game vname)
|
||||
(pcase phase
|
||||
('pass "pass three cards") ('bid "bidding")
|
||||
('play (if (= turn 0) "your turn" "opponents playing"))
|
||||
(_ "play")))
|
||||
pad (+ y-title 12) 13 t)
|
||||
(when scores
|
||||
(txt (format "S %d W %d N %d E %d"
|
||||
(aref scores 0) (aref scores 1) (aref scores 2) (aref scores 3))
|
||||
(- width pad) (+ y-title 12) 12 nil "end"))
|
||||
(seat 2 (- cx 40) y-north)
|
||||
(seat 1 pad cy)
|
||||
(seat 3 (- width pad 100) cy)
|
||||
(trick-card 2 (- cx (/ w 2)) y-tn)
|
||||
(trick-card 0 (- cx (/ w 2)) y-ts)
|
||||
(trick-card 1 (- cx w (round (* w 0.4))) (round (- cy (* h 0.25))))
|
||||
(trick-card 3 (+ cx (round (* w 0.4))) (round (- cy (* h 0.25))))
|
||||
(txt (format "Your hand (South)%s"
|
||||
(if (eq phase 'pass) (format " -- marked %d/3" (length marks)) ""))
|
||||
pad (- y-south 6) 11)
|
||||
(let ((x (- cx (/ fanw 2))) (i 0)
|
||||
(legalp (and (eq phase 'play) (= turn 0))))
|
||||
(dolist (c hand)
|
||||
(let ((sp (card-games-trick--spec c))
|
||||
(curp (= i cursor))
|
||||
(markp (member c marks))
|
||||
(hintp (and legalp (card-games-trick--legal-p game 0 c))))
|
||||
(card-games-svg-card svg x y-south :rank (car sp) :suit (cdr sp)
|
||||
:highlight curp :hint hintp)
|
||||
(when markp
|
||||
(svg-rectangle svg (- x 3) (- y-south 3) (+ w 6) (+ h 6)
|
||||
:rx 8 :fill "none" :stroke "#4a90d9" :stroke-width 3))
|
||||
(push (cons (list x y-south (if (= i (1- n)) w step) h) (cons 'hand i)) regions))
|
||||
(setq x (+ x step) i (1+ i))))
|
||||
(txt (or (card-games-get game :message) "") pad (- height 8) 12))
|
||||
(propertize "*" 'display (card-games-svg-image svg (card-games-scale))
|
||||
'card-games-regions (nreverse regions))))
|
||||
|
||||
(defun card-games-trick--render-text (game)
|
||||
"Return a plain-text depiction of trick GAME."
|
||||
(let* ((out (list))
|
||||
(scores (card-games-get game :scores))
|
||||
(marks (card-games-get game :marks))
|
||||
(cursor (card-games-get game :cursor))
|
||||
(hand (card-games-trick--sort (card-games-trick--hand game 0))))
|
||||
(push (format " %s\n" (oref game vname)) out)
|
||||
(when scores
|
||||
(push (format " Scores: South %d West %d North %d East %d\n\n"
|
||||
(aref scores 0) (aref scores 1) (aref scores 2) (aref scores 3))
|
||||
out))
|
||||
(dolist (s '(2 1 3))
|
||||
(push (card-games-trick--seat-line game s) out))
|
||||
(push "\n Trick: " out)
|
||||
(if (null (card-games-get game :trick))
|
||||
(push "(empty)" out)
|
||||
(dolist (play (reverse (card-games-get game :trick)))
|
||||
(push (format "%s:%s " (aref card-games-trick-seat-names (car play))
|
||||
(let ((cs (card-games-trick-card-string (cdr play))))
|
||||
(if (card-games-trick-red-p (cdr play))
|
||||
(propertize cs 'face 'card-games-red-suit) cs)))
|
||||
out)))
|
||||
(push "\n\n Your hand (South):\n " out)
|
||||
(let ((i 0))
|
||||
(dolist (c hand)
|
||||
(let ((cs (card-games-trick-card-string c)) (faces nil))
|
||||
(when (card-games-trick-red-p c) (push 'card-games-red-suit faces))
|
||||
(when (member c marks) (push 'card-games-hint faces))
|
||||
(when (= i cursor) (push 'card-games-cursor faces))
|
||||
(push (propertize (format "%4s" cs) 'face (or faces 'default)) out))
|
||||
(setq i (1+ i))))
|
||||
(push (format "\n\n %s\n" (card-games-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod card-games-render ((game card-games-trick-game))
|
||||
"Return a depiction of GAME.
|
||||
Use a full SVG table on a graphical display, else a plain-text board."
|
||||
(if (and card-games-trick-svg-cards (display-graphic-p))
|
||||
(card-games-trick--svg game)
|
||||
(card-games-trick--render-text game)))
|
||||
|
||||
(cl-defmethod card-games-render-apply ((g card-games-trick-game) action)
|
||||
"Apply click ACTION on G's hand: select that card and play it."
|
||||
(pcase action
|
||||
(`(hand . ,i) (card-games-put g :cursor i) (card-games-trick-act))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun card-games-trick--redisplay ()
|
||||
"Redraw the current trick-game buffer."
|
||||
(let ((game card-games-trick--game) (inhibit-read-only t))
|
||||
(setq card-games-current-game game card-games-redisplay-function #'card-games-trick--redisplay)
|
||||
(setq-local mode-line-process
|
||||
(format " [%s]" (or (card-games-get game :phase) "play")))
|
||||
(erase-buffer)
|
||||
(insert (card-games-render game))
|
||||
(goto-char (point-min))))
|
||||
|
||||
;;;; Commands
|
||||
|
||||
(defun card-games-trick--cursor-card (game)
|
||||
"Return GAME's South card currently under the cursor."
|
||||
(nth (card-games-get game :cursor) (card-games-trick--sort (card-games-trick--hand game 0))))
|
||||
|
||||
(defun card-games-trick-left ()
|
||||
"Move the hand cursor left."
|
||||
(interactive)
|
||||
(let* ((game card-games-trick--game) (n (length (card-games-trick--hand game 0))))
|
||||
(when (> n 0) (card-games-put game :cursor (mod (1- (card-games-get game :cursor)) n)))
|
||||
(card-games-trick--redisplay)))
|
||||
|
||||
(defun card-games-trick-right ()
|
||||
"Move the hand cursor right."
|
||||
(interactive)
|
||||
(let* ((game card-games-trick--game) (n (length (card-games-trick--hand game 0))))
|
||||
(when (> n 0) (card-games-put game :cursor (mod (1+ (card-games-get game :cursor)) n)))
|
||||
(card-games-trick--redisplay)))
|
||||
|
||||
(defun card-games-trick-act ()
|
||||
"Play, or (during the Hearts pass) mark, the selected card."
|
||||
(interactive)
|
||||
(let* ((game card-games-trick--game)
|
||||
(phase (card-games-get game :phase))
|
||||
(card (card-games-trick--cursor-card game)))
|
||||
(pcase phase
|
||||
('play
|
||||
(cond
|
||||
((/= (card-games-get game :turn) 0) (card-games-put game :message "Not your turn."))
|
||||
((not (card-games-trick--legal-p game 0 card))
|
||||
(card-games-put game :message "Illegal play — you must follow suit."))
|
||||
(t (card-games-trick--play game 0 card)
|
||||
(card-games-put game :cursor (max 0 (min (card-games-get game :cursor)
|
||||
(1- (length (card-games-trick--hand game 0))))))
|
||||
(card-games-trick--run game))))
|
||||
('pass
|
||||
(if (member card (card-games-get game :marks))
|
||||
(card-games-put game :marks (remove card (card-games-get game :marks)))
|
||||
(if (>= (length (card-games-get game :marks)) 3)
|
||||
(card-games-put game :message "Three already marked — press p to pass.")
|
||||
(card-games-put game :marks (cons card (card-games-get game :marks))))))
|
||||
(_ (card-games-put game :message "Press n for a new match.")))
|
||||
(card-games-trick--redisplay)))
|
||||
|
||||
(defun card-games-trick-pass ()
|
||||
"Confirm the Hearts pass once three cards are marked."
|
||||
(interactive)
|
||||
(let ((game card-games-trick--game))
|
||||
(if (and (eq (card-games-get game :phase) 'pass) (= 3 (length (card-games-get game :marks))))
|
||||
(card-games-trick--do-pass game)
|
||||
(card-games-put game :message "Mark exactly three cards first."))
|
||||
(card-games-trick--redisplay)))
|
||||
|
||||
(defun card-games-trick-new ()
|
||||
"Start a fresh match in this buffer."
|
||||
(interactive)
|
||||
(card-games-trick--new card-games-trick--game)
|
||||
(card-games-trick--redisplay))
|
||||
|
||||
(defun card-games-trick-redraw () "Redraw the table." (interactive) (card-games-trick--redisplay))
|
||||
|
||||
(defun card-games-trick-help ()
|
||||
"Describe the controls."
|
||||
(interactive)
|
||||
(message "Arrows: choose card RET: play/mark p: pass (Hearts) n: new g: redraw"))
|
||||
|
||||
(defvar card-games-trick-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'card-games-card-click)
|
||||
(define-key map "+" #'card-games-card-zoom-in)
|
||||
(define-key map "=" #'card-games-card-zoom-in)
|
||||
(define-key map "-" #'card-games-card-zoom-out)
|
||||
(define-key map "0" #'card-games-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'card-games-trick-left)
|
||||
(define-key map (kbd "<right>") #'card-games-trick-right)
|
||||
(define-key map (kbd "RET") #'card-games-trick-act)
|
||||
(define-key map (kbd "SPC") #'card-games-trick-act)
|
||||
(define-key map "p" #'card-games-trick-pass)
|
||||
(define-key map "n" #'card-games-trick-new)
|
||||
(define-key map "g" #'card-games-trick-redraw)
|
||||
(define-key map "?" #'card-games-trick-help)
|
||||
map)
|
||||
"Keymap for `card-games-trick-mode'.")
|
||||
|
||||
(define-derived-mode card-games-trick-mode special-mode "Trick"
|
||||
"Major mode for the four-handed trick-taking games."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type card-games-cursor-type))
|
||||
|
||||
(defun card-games-trick--play-game (class)
|
||||
"Start a trick game of CLASS in its own buffer."
|
||||
(let* ((game (make-instance class))
|
||||
(buf (get-buffer-create (format "*%s*" (oref game vname)))))
|
||||
(with-current-buffer buf
|
||||
(card-games-trick-mode)
|
||||
(setq card-games-trick--game game)
|
||||
(card-games-trick--new game)
|
||||
(card-games-trick--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-hearts ()
|
||||
"Play Hearts against three computer opponents."
|
||||
(interactive) (card-games-trick--play-game 'card-games-hearts-game))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-spades ()
|
||||
"Play Spades (partnership) against three computer opponents."
|
||||
(interactive) (card-games-trick--play-game 'card-games-spades-game))
|
||||
|
||||
|
||||
;;;; Whist and Oh Hell
|
||||
|
||||
(defclass card-games-whist-game (card-games-trick-game)
|
||||
((restricted :initform -1) (target :initform 5) (vname :initform "Whist"))
|
||||
"Whist: trump set by the turned card, no bidding, score tricks over six.")
|
||||
|
||||
(defclass card-games-ohhell-game (card-games-trick-game)
|
||||
((restricted :initform -1) (target :initform 0) (vname :initform "Oh Hell"))
|
||||
"Oh Hell: hand size shrinks each round; bid the exact tricks you will take.")
|
||||
|
||||
(cl-defmethod card-games-trick--leader-init ((game card-games-whist-game))
|
||||
"In GAME Whist, the player left of the dealer leads first."
|
||||
(let ((s (mod (1+ (or (card-games-get game :dealer) 3)) 4)))
|
||||
(card-games-put game :leader s) (card-games-put game :turn s)))
|
||||
(cl-defmethod card-games-trick--leader-init ((game card-games-ohhell-game))
|
||||
"In GAME Oh Hell, the player left of the dealer leads first."
|
||||
(let ((s (mod (1+ (or (card-games-get game :dealer) 3)) 4)))
|
||||
(card-games-put game :leader s) (card-games-put game :turn s)))
|
||||
|
||||
(defun card-games-trick--ai-trump-play (game seat)
|
||||
"A generic legal trump-game play for GAME SEAT: follow and win cheaply, else low."
|
||||
(let* ((moves (card-games-trick--legal-moves game seat))
|
||||
(trick (card-games-get game :trick)))
|
||||
(or
|
||||
(if (null trick)
|
||||
(car (last (card-games-trick--sort moves)))
|
||||
(let* ((winner (card-games-trick--winner-of game trick))
|
||||
(partner-winning (and winner (= (card-games-trick--team winner)
|
||||
(card-games-trick--team seat))))
|
||||
(led (card-games-trick--led-suit game)))
|
||||
(if partner-winning
|
||||
(car (card-games-trick--sort moves))
|
||||
(let ((follow (cl-remove-if-not (lambda (c) (= (car c) led)) moves)))
|
||||
(or (car (last (card-games-trick--sort follow)))
|
||||
(car (card-games-trick--sort moves)))))))
|
||||
(car moves))))
|
||||
|
||||
(cl-defmethod card-games-trick--ai-play ((game card-games-whist-game) seat)
|
||||
"Choose a legal Whist card for AI SEAT in GAME."
|
||||
(card-games-trick--ai-trump-play game seat))
|
||||
(cl-defmethod card-games-trick--ai-play ((game card-games-ohhell-game) seat)
|
||||
"Choose a legal Oh Hell card for AI SEAT in GAME."
|
||||
(card-games-trick--ai-trump-play game seat))
|
||||
|
||||
;; Whist
|
||||
(cl-defmethod card-games-trick--begin-hand ((game card-games-whist-game))
|
||||
"Begin a Whist hand in GAME: deal and turn the trump."
|
||||
(card-games-trick--deal game)
|
||||
(card-games-put game :dealer (mod (1+ (or (card-games-get game :dealer) 3)) 4))
|
||||
(oset game trump (car (card-games-get game :last-card))) ; dealer's last card turns trump
|
||||
(card-games-put game :cursor 0)
|
||||
(card-games-trick--leader-init game)
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :message (format "Trump is %s. Take tricks past the book of six."
|
||||
(card-games-suit-glyph (oref game trump))))
|
||||
(card-games-trick--run game))
|
||||
|
||||
(cl-defmethod card-games-trick--score-hand ((game card-games-whist-game))
|
||||
"Score GAME's finished Whist hand."
|
||||
(let ((scores (card-games-get game :scores)) (tricks (card-games-get game :tricks)))
|
||||
(dotimes (team 2)
|
||||
(let ((over (max 0 (- (+ (aref tricks team) (aref tricks (+ team 2))) 6))))
|
||||
(aset scores team (+ (aref scores team) over))
|
||||
(aset scores (+ team 2) (aref scores team))))
|
||||
(card-games-put game :scores scores)))
|
||||
|
||||
(cl-defmethod card-games-trick--game-over-p ((game card-games-whist-game))
|
||||
"Return non-nil when GAME's Whist game is over."
|
||||
(cl-some (lambda (s) (>= s (oref game target))) (append (card-games-get game :scores) nil)))
|
||||
(cl-defmethod card-games-trick--winner-seat ((game card-games-whist-game))
|
||||
"Return the winning seat of GAME's Whist game."
|
||||
(if (>= (aref (card-games-get game :scores) 0) (aref (card-games-get game :scores) 1)) 0 1))
|
||||
(cl-defmethod card-games-trick--result-string ((game card-games-whist-game))
|
||||
"Return GAME's Whist game-over summary."
|
||||
(format "%s win" (if (= 0 (card-games-trick--winner-seat game)) "You and North" "West and East")))
|
||||
|
||||
;; Oh Hell
|
||||
(defconst card-games-ohhell--sizes [7 6 5 4 3 2 1]
|
||||
"Hand sizes dealt in successive Oh Hell rounds.")
|
||||
|
||||
(cl-defmethod card-games-trick--ai-bid ((game card-games-ohhell-game) seat)
|
||||
"Return an exact-tricks bid for GAME AI SEAT in Oh Hell."
|
||||
(let ((hand (card-games-trick--hand game seat)) (trump (oref game trump)) (bid 0))
|
||||
(dolist (c hand)
|
||||
(cond ((= (cdr c) 12) (cl-incf bid))
|
||||
((and (= (car c) trump) (>= (cdr c) 9)) (cl-incf bid))))
|
||||
(min bid (length hand))))
|
||||
|
||||
(cl-defmethod card-games-trick--begin-hand ((game card-games-ohhell-game))
|
||||
"Begin an Oh Hell hand in GAME: deal the round and run the bidding."
|
||||
(let* ((round (or (card-games-get game :round) 0))
|
||||
(hs (aref card-games-ohhell--sizes (min round (1- (length card-games-ohhell--sizes))))))
|
||||
(oset game hand-size hs)
|
||||
(card-games-trick--deal game)
|
||||
(card-games-put game :dealer (mod (1+ (or (card-games-get game :dealer) 3)) 4))
|
||||
(let ((up (car (card-games-get game :deck))))
|
||||
(oset game trump (if up (car up) 0)))
|
||||
(card-games-put game :cursor 0)
|
||||
(let ((bids (make-vector 4 0)))
|
||||
(dotimes (s 4) (unless (= s 0) (aset bids s (card-games-trick--ai-bid game s))))
|
||||
(aset bids 0 (if noninteractive (card-games-trick--ai-bid game 0)
|
||||
(max 0 (min hs (read-number
|
||||
(format "Round %d (trump %s) -- your bid (0-%d): "
|
||||
(1+ round) (card-games-suit-glyph (oref game trump)) hs)
|
||||
(card-games-trick--ai-bid game 0))))))
|
||||
(card-games-put game :bids bids))
|
||||
(card-games-trick--leader-init game)
|
||||
(card-games-put game :phase 'play)
|
||||
(card-games-put game :message (format "Round %d: make EXACTLY your bid (trump %s)."
|
||||
(1+ round) (card-games-suit-glyph (oref game trump))))
|
||||
(card-games-trick--run game)))
|
||||
|
||||
(cl-defmethod card-games-trick--score-hand ((game card-games-ohhell-game))
|
||||
"Score GAME's finished Oh Hell round."
|
||||
(let ((scores (card-games-get game :scores)) (bids (card-games-get game :bids))
|
||||
(tricks (card-games-get game :tricks)))
|
||||
(dotimes (s 4)
|
||||
(when (= (aref tricks s) (aref bids s))
|
||||
(aset scores s (+ (aref scores s) 10 (aref bids s)))))
|
||||
(card-games-put game :scores scores)
|
||||
(card-games-put game :round (1+ (or (card-games-get game :round) 0)))))
|
||||
|
||||
(cl-defmethod card-games-trick--game-over-p ((game card-games-ohhell-game))
|
||||
"Return non-nil when GAME's Oh Hell game is over."
|
||||
(>= (or (card-games-get game :round) 0) (length card-games-ohhell--sizes)))
|
||||
(cl-defmethod card-games-trick--winner-seat ((game card-games-ohhell-game))
|
||||
"Return the winning seat of GAME's Oh Hell game."
|
||||
(let ((best 0)) (dotimes (s 4) (when (> (aref (card-games-get game :scores) s)
|
||||
(aref (card-games-get game :scores) best)) (setq best s)))
|
||||
best))
|
||||
(cl-defmethod card-games-trick--result-string ((game card-games-ohhell-game))
|
||||
"Return GAME's Oh Hell game-over summary."
|
||||
(format "%s wins" (aref card-games-trick-seat-names (card-games-trick--winner-seat game))))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-whist () "Play Whist against three computer opponents."
|
||||
(interactive) (card-games-trick--play-game 'card-games-whist-game))
|
||||
;;;###autoload
|
||||
(defun card-games-ohhell () "Play Oh Hell against three computer opponents."
|
||||
(interactive) (card-games-trick--play-game 'card-games-ohhell-game))
|
||||
|
||||
(provide 'card-games-trick)
|
||||
;;; card-games-trick.el ends here
|
||||
191
card-games.el
191
card-games.el
|
|
@ -1,4 +1,4 @@
|
|||
;;; card-games.el --- Play card games in Emacs (console + SVG) -*- lexical-binding: t; -*-
|
||||
;;; card-games.el --- Play card games (console + SVG) -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
|
|
@ -28,119 +28,119 @@
|
|||
;; 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:
|
||||
;; Run `M-x card-games' for a menu, or start a game directly:
|
||||
;;
|
||||
;; `cg-bid' -- 500, the four-handed partnership trick-taking game,
|
||||
;; `card-games-bid' -- 500, the four-handed partnership trick-taking game,
|
||||
;; played against three computer opponents.
|
||||
;; `cg-gaps' -- Gaps / Montana / "Hell's Half-Acre" solitaire.
|
||||
;; `card-games-gaps' -- Gaps / Montana / "Hell's Half-Acre" solitaire.
|
||||
;;
|
||||
;; New games register themselves by adding to `card-games-list'.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cg-core)
|
||||
(require 'cg-render)
|
||||
(require 'cg-net)
|
||||
(require 'cg-gaps)
|
||||
(require 'cg-bid-ui)
|
||||
(require 'cg-bid-net)
|
||||
(require 'cg-solitaire)
|
||||
(require 'cg-trick)
|
||||
(require 'cg-eights)
|
||||
(require 'cg-patience)
|
||||
(require 'cg-president)
|
||||
(require 'cg-rummy)
|
||||
(require 'cg-rum500)
|
||||
(require 'cg-handfoot)
|
||||
(require 'cg-match)
|
||||
(require 'cg-cribbage)
|
||||
(require 'cg-scopa)
|
||||
(require 'cg-trick-ext)
|
||||
(require 'cg-spite)
|
||||
(require 'cg-bridge)
|
||||
(require 'cg-crapette)
|
||||
(require 'card-games-core)
|
||||
(require 'card-games-render)
|
||||
(require 'card-games-net)
|
||||
(require 'card-games-gaps)
|
||||
(require 'card-games-bid-ui)
|
||||
(require 'card-games-bid-net)
|
||||
(require 'card-games-solitaire)
|
||||
(require 'card-games-trick)
|
||||
(require 'card-games-eights)
|
||||
(require 'card-games-patience)
|
||||
(require 'card-games-president)
|
||||
(require 'card-games-rummy)
|
||||
(require 'card-games-rum500)
|
||||
(require 'card-games-handfoot)
|
||||
(require 'card-games-match)
|
||||
(require 'card-games-cribbage)
|
||||
(require 'card-games-scopa)
|
||||
(require 'card-games-trick-ext)
|
||||
(require 'card-games-spite)
|
||||
(require 'card-games-bridge)
|
||||
(require 'card-games-crapette)
|
||||
|
||||
(defvar card-games-list
|
||||
'(("500 (Bid)" cg-bid
|
||||
'(("500 (Bid)" card-games-bid
|
||||
"Four-handed partnership trick-taking versus three AI opponents.")
|
||||
("Gaps (Montana)" cg-montana
|
||||
("Gaps (Montana)" card-games-montana
|
||||
"Solitaire: a Two anchors each row; build up 2 through King.")
|
||||
("Hell's Half-Acre" cg-hells-half-acre
|
||||
("Hell's Half-Acre" card-games-hells-half-acre
|
||||
"Solitaire: a King anchors each row; build down King through 2.")
|
||||
("Klondike" cg-klondike
|
||||
("Klondike" card-games-klondike
|
||||
"Solitaire: the classic; build the foundations up by suit from the Ace.")
|
||||
("FreeCell" cg-freecell
|
||||
("FreeCell" card-games-freecell
|
||||
"Solitaire: every card in view, four free cells, a game of skill.")
|
||||
("Spider" cg-spider
|
||||
("Spider" card-games-spider
|
||||
"Solitaire: two decks; build down and clear eight same-suit runs.")
|
||||
("Yukon" cg-yukon
|
||||
("Yukon" card-games-yukon
|
||||
"Solitaire: Klondike's layout, all face up; move any buried group.")
|
||||
("Hearts" cg-hearts
|
||||
("Hearts" card-games-hearts
|
||||
"Trick-taking: dodge every heart and the Queen of Spades.")
|
||||
("Spades" cg-spades
|
||||
("Spades" card-games-spades
|
||||
"Trick-taking: partnership bidding to 500; spades are always trump.")
|
||||
("Crazy Eights" cg-eights
|
||||
("Crazy Eights" card-games-eights
|
||||
"Shedding: match the suit or rank; eights are wild.")
|
||||
("Canfield" cg-canfield
|
||||
("Canfield" card-games-canfield
|
||||
"Solitaire: a 13-card reserve and a shifting foundation base rank.")
|
||||
("Russian Bank" cg-russian-bank
|
||||
("Russian Bank" card-games-russian-bank
|
||||
"Solitaire: eight houses down by alternating colour; a reserve feeds them.")
|
||||
("Forty Thieves" cg-forty-thieves
|
||||
("Forty Thieves" card-games-forty-thieves
|
||||
"Solitaire: two decks, ten columns, eight foundations, no redeal.")
|
||||
("Scorpion" cg-scorpion
|
||||
("Scorpion" card-games-scorpion
|
||||
"Solitaire: build down by suit and free four buried King-to-Ace runs.")
|
||||
("Golf" cg-golf
|
||||
("Golf" card-games-golf
|
||||
"Solitaire: clear the layout one rank at a time onto the waste.")
|
||||
("TriPeaks" cg-tripeaks
|
||||
("TriPeaks" card-games-tripeaks
|
||||
"Solitaire: clear three peaks with Ace-King wrapping chains.")
|
||||
("Pyramid" cg-pyramid
|
||||
("Pyramid" card-games-pyramid
|
||||
"Solitaire: remove pairs of cards that sum to thirteen.")
|
||||
("Whist" cg-whist
|
||||
("Whist" card-games-whist
|
||||
"Trick-taking: fixed trump, no bidding, race past the book of six.")
|
||||
("Oh Hell" cg-ohhell
|
||||
("Oh Hell" card-games-ohhell
|
||||
"Trick-taking: shrinking hands; bid the exact tricks you will take.")
|
||||
("President" cg-president
|
||||
("President" card-games-president
|
||||
"Climbing: shed your hand; first out rules, last out scrubs.")
|
||||
("Gin Rummy" cg-gin
|
||||
("Gin Rummy" card-games-gin
|
||||
"Rummy: form melds, knock with little deadwood; head to head to 100.")
|
||||
("Rummy" cg-rummy-basic
|
||||
("Rummy" card-games-rummy-basic
|
||||
"Rummy: meld your whole hand to the table to go out.")
|
||||
("Rummy 500" cg-rum500
|
||||
("Rummy 500" card-games-rum500
|
||||
"Rummy: score the cards you lay down; race past 500.")
|
||||
("Hand & Foot" cg-handfoot
|
||||
("Hand & Foot" card-games-handfoot
|
||||
"Rummy: partnership Canasta cousin; build books from hand and foot.")
|
||||
("Go Fish" cg-go-fish
|
||||
("Go Fish" card-games-go-fish
|
||||
"Matching: ask for ranks and collect books of four.")
|
||||
("Old Maid" cg-old-maid
|
||||
("Old Maid" card-games-old-maid
|
||||
"Matching: shed pairs and avoid the leftover Queen.")
|
||||
("Cribbage" cg-cribbage
|
||||
("Cribbage" card-games-cribbage
|
||||
"Pegging and the show: fifteens, pairs, runs, and his nobs to 121.")
|
||||
("Scopa" cg-scopa
|
||||
("Scopa" card-games-scopa
|
||||
"Capturing: take table cards by value; sweep for a scopa.")
|
||||
("Casino" cg-casino
|
||||
("Casino" card-games-casino
|
||||
"Capturing: pairs and sums; big and little casino, aces, sweeps.")
|
||||
("Euchre" cg-euchre
|
||||
("Euchre" card-games-euchre
|
||||
"Trick-taking: 24 cards, bowers, order up; partnership to 10.")
|
||||
("Pitch" cg-pitch
|
||||
("Pitch" card-games-pitch
|
||||
"Trick-taking: bid, pitch to set trump, score High-Low-Jack-Game.")
|
||||
("Briscola" cg-briscola
|
||||
("Briscola" card-games-briscola
|
||||
"Trick-taking: fixed trump, no follow; capture the points to 61.")
|
||||
("Spite & Malice" cg-spite
|
||||
("Spite & Malice" card-games-spite
|
||||
"Climbing patience: race to empty your goal pile; Kings are wild.")
|
||||
("Bridge" cg-bridge
|
||||
("Bridge" card-games-bridge
|
||||
"Trick-taking: the auction, the dummy, and rubber scoring, to 121.")
|
||||
("Crapette (Russian Bank)" cg-crapette
|
||||
("Crapette (Russian Bank)" card-games-crapette
|
||||
"Two-player Russian Bank versus the computer; empty your reserve, hand, and waste."))
|
||||
"Registry of playable games.
|
||||
Each entry is (NAME COMMAND DESCRIPTION); `card-game' lists them.")
|
||||
Each entry is (NAME COMMAND DESCRIPTION); `card-games' lists them.")
|
||||
|
||||
(defvar card-games--svg-card-vars
|
||||
'(cg-sol-svg-cards cg-trick-svg-cards cg-rummy-svg-cards cg-eights-svg-cards
|
||||
cg-bridge-svg-cards cg-crapette-svg-cards cg-pat-svg-cards cg-pres-svg-cards)
|
||||
'(card-games-sol-svg-cards card-games-trick-svg-cards card-games-rummy-svg-cards card-games-eights-svg-cards
|
||||
card-games-bridge-svg-cards card-games-crapette-svg-cards card-games-pat-svg-cards card-games-pres-svg-cards)
|
||||
"Per-game SVG-cards toggles that `card-games-set-treatment' flips together.")
|
||||
|
||||
(defvar card-games--full-svg-vars
|
||||
'(cg-gaps-svg-ui cg-bid-svg-ui)
|
||||
'(card-games-gaps-svg-ui card-games-bid-svg-ui)
|
||||
"Full-window SVG toggles (Gaps and 500) used by the `full' treatment.")
|
||||
|
||||
(defvar card-games-treatment 'svg
|
||||
|
|
@ -148,7 +148,8 @@ Each entry is (NAME COMMAND DESCRIPTION); `card-game' lists them.")
|
|||
|
||||
;;;###autoload
|
||||
(defun card-games-set-treatment (treatment)
|
||||
"Set how games are drawn: `text' (UNICODE), `svg' (cards), or `full'.
|
||||
"Set how games are drawn to TREATMENT.
|
||||
TREATMENT is `text' (UNICODE), `svg' (cards), or `full'.
|
||||
`full' also uses the full-window SVG table where a game has one (Gaps and
|
||||
500). Takes effect the next time a game is drawn -- press g to redraw an
|
||||
open game. Gaps and 500 are always graphical on a window system."
|
||||
|
|
@ -162,32 +163,32 @@ open game. Gaps and 500 are always graphical on a window system."
|
|||
(when (called-interactively-p 'interactive)
|
||||
(message "Display treatment: %s" treatment)))
|
||||
|
||||
(defun card-game--cycle-treatment (_button)
|
||||
(defun card-games--cycle-treatment (_button)
|
||||
"Cycle the display treatment and refresh the chooser."
|
||||
(card-games-set-treatment
|
||||
(pcase card-games-treatment ('text 'svg) ('svg 'full) (_ 'text)))
|
||||
(card-game))
|
||||
(card-games))
|
||||
|
||||
(defun card-game--cycle-ai (_button)
|
||||
"Cycle the AI difficulty (`cg-ai-level') and refresh the chooser."
|
||||
(setq cg-ai-level (pcase cg-ai-level ('easy 'normal) ('normal 'hard) (_ 'easy)))
|
||||
(card-game))
|
||||
(defun card-games--cycle-ai (_button)
|
||||
"Cycle the AI difficulty (`card-games-ai-level') and refresh the chooser."
|
||||
(setq card-games-ai-level (pcase card-games-ai-level ('easy 'normal) ('normal 'hard) (_ 'easy)))
|
||||
(card-games))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-games-set-ai-level (level)
|
||||
"Set the computer-opponent difficulty to LEVEL (easy, normal, or hard)."
|
||||
(interactive
|
||||
(list (intern (completing-read "AI level: " '("easy" "normal" "hard") nil t))))
|
||||
(setq cg-ai-level level)
|
||||
(setq card-games-ai-level level)
|
||||
(message "AI level: %s" level))
|
||||
|
||||
(defun card-game--launch (button)
|
||||
(defun card-games--launch (button)
|
||||
"Start the game whose command is stored on BUTTON."
|
||||
(let ((cmd (button-get button 'card-game-command)))
|
||||
(let ((cmd (button-get button 'card-games-command)))
|
||||
(quit-window)
|
||||
(call-interactively cmd)))
|
||||
|
||||
(defvar card-game-mode-map
|
||||
(defvar card-games-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(set-keymap-parent map special-mode-map)
|
||||
(define-key map "n" #'forward-button)
|
||||
|
|
@ -195,23 +196,23 @@ open game. Gaps and 500 are always graphical on a window system."
|
|||
(define-key map (kbd "TAB") #'forward-button)
|
||||
(define-key map (kbd "<backtab>") #'backward-button)
|
||||
map)
|
||||
"Keymap for `card-game-mode'.")
|
||||
"Keymap for `card-games-mode'.")
|
||||
|
||||
(define-derived-mode card-game-mode special-mode "Card-Games"
|
||||
"Major mode for the `card-game' chooser."
|
||||
(setq-local cursor-type cg-cursor-type))
|
||||
(define-derived-mode card-games-mode special-mode "Card-Games"
|
||||
"Major mode for the `card-games' chooser."
|
||||
(setq-local cursor-type card-games-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun card-game ()
|
||||
(defun card-games ()
|
||||
"Open a chooser listing the available card games.
|
||||
Press RET (or click) on a game to start it."
|
||||
(interactive)
|
||||
(when (and (boundp 'cg-svg-card-back) (eq cg-svg-card-back 'random)
|
||||
(fboundp 'cg-svg--roll-back))
|
||||
(cg-svg--roll-back)) ; a fresh random back per menu visit
|
||||
(when (and (boundp 'card-games-svg-card-back) (eq card-games-svg-card-back 'random)
|
||||
(fboundp 'card-games-svg--roll-back))
|
||||
(card-games-svg--roll-back)) ; a fresh random back per menu visit
|
||||
(let ((buf (get-buffer-create "*Card Games*")))
|
||||
(with-current-buffer buf
|
||||
(card-game-mode)
|
||||
(card-games-mode)
|
||||
(let ((inhibit-read-only t))
|
||||
(erase-buffer)
|
||||
(insert (propertize " Card Games for Emacs\n" 'face 'bold))
|
||||
|
|
@ -220,17 +221,17 @@ Press RET (or click) on a game to start it."
|
|||
'face 'shadow))
|
||||
(insert " AI opponents: ")
|
||||
(insert-text-button
|
||||
(symbol-name cg-ai-level)
|
||||
(symbol-name card-games-ai-level)
|
||||
'face 'link
|
||||
'help-echo "Click to change the AI difficulty (easy/normal/hard)"
|
||||
'action #'card-game--cycle-ai)
|
||||
'action #'card-games--cycle-ai)
|
||||
(insert (propertize " (click to cycle easy/normal/hard)\n" 'face 'shadow))
|
||||
(insert " Cards: ")
|
||||
(insert-text-button
|
||||
(symbol-name card-games-treatment)
|
||||
'face 'link
|
||||
'help-echo "Click to cycle the display: text / svg / full"
|
||||
'action #'card-game--cycle-treatment)
|
||||
'action #'card-games--cycle-treatment)
|
||||
(insert (propertize " (click to cycle text/svg/full)\n\n" 'face 'shadow))
|
||||
(dolist (g card-games-list)
|
||||
(insert " ")
|
||||
|
|
@ -238,18 +239,14 @@ Press RET (or click) on a game to start it."
|
|||
(format "%-26s" (nth 0 g))
|
||||
'face 'link
|
||||
'help-echo (nth 2 g)
|
||||
'card-game-command (nth 1 g)
|
||||
'action #'card-game--launch)
|
||||
'card-games-command (nth 1 g)
|
||||
'action #'card-games--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)
|
||||
|
|
@ -266,12 +263,12 @@ Press RET (or click) on a game to start it."
|
|||
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))
|
||||
(setq card-games-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)))
|
||||
(setq card-games-svg-theme-colors (plist-get p :theme)))
|
||||
(when (plist-get p :back) (setq card-games-svg-back-color (plist-get p :back)))
|
||||
(when (plist-get p :highlight)
|
||||
(setq cg-svg-highlight-color (plist-get p :highlight)))
|
||||
(setq card-games-svg-highlight-color (plist-get p :highlight)))
|
||||
(message "card-games theme: %s" name)))
|
||||
|
||||
(provide 'card-games)
|
||||
|
|
|
|||
417
cg-bid-net.el
417
cg-bid-net.el
|
|
@ -1,417 +0,0 @@
|
|||
;;; cg-bid-net.el --- Networked live 500 (Bid) -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Live multiplayer 500 over `cg-net'. One Emacs hosts with
|
||||
;; `cg-bid-host'; up to three others join with `cg-bid-join'. The host
|
||||
;; owns the canonical game and sits South (seat 0); joining players take
|
||||
;; seats West, North and East in turn. Any seat left open when play
|
||||
;; begins is driven by the existing AI, so a table of one human and
|
||||
;; three robots, or four humans, or anything between, all work.
|
||||
;;
|
||||
;; The host is authoritative: a client sends a move "intent" (bid, pass,
|
||||
;; discard or play); the host validates it, applies it to the canonical
|
||||
;; game, lets the AI take any open seats, then broadcasts a fresh view
|
||||
;; to every client. Each client receives a per-seat view rotated so the
|
||||
;; recipient sits South: it sees only its own cards, opponents collapse
|
||||
;; to face-down counts, and the kitty stays hidden until won. Because a
|
||||
;; client's view places itself at seat 0, the ordinary single-player
|
||||
;; commands and renderer work unchanged for everyone.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'cg-core)
|
||||
(require 'cg-net)
|
||||
(require 'cg-bid)
|
||||
(require 'cg-bid-ui)
|
||||
|
||||
(defcustom cg-bid-shuffle-partners nil
|
||||
"When non-nil, randomize seating when a hosted game starts.
|
||||
The host keeps South; joined players are shuffled among West, North and
|
||||
East, so it is chance, not arrival order, that decides who partners whom."
|
||||
:type 'boolean :group 'cg-net)
|
||||
|
||||
(defvar cg-bid--net-role nil
|
||||
"Role of this Emacs in a live game: `host', `client', or nil (solo).")
|
||||
|
||||
(defvar cg-bid--net-seat 0
|
||||
"This player's absolute seat in a live game (the host is always 0).")
|
||||
|
||||
(defvar cg-bid--applying-remote nil
|
||||
"Bound non-nil while the host applies a remote player's move.
|
||||
While set, prompts that would block the host (such as nominating a suit
|
||||
for a Joker lead) fall back to an automatic choice.")
|
||||
|
||||
;;;; Per-seat state filter (host -> client)
|
||||
|
||||
(defun cg-bid--rot (x seat)
|
||||
"Rotate absolute seat X into SEAT's frame so SEAT becomes 0.
|
||||
Return nil when X is nil."
|
||||
(and x (mod (- x seat) 4)))
|
||||
|
||||
(defun cg-bid--rot-team (team seat)
|
||||
"Rotate TEAM index (0 or 1) into SEAT's frame.
|
||||
Return nil when TEAM is nil."
|
||||
(and team (if (cl-oddp seat) (- 1 team) team)))
|
||||
|
||||
(defun cg-bid--rotate-vec4 (vec seat)
|
||||
"Return a fresh 4-vector whose element I is VEC element (I+SEAT) mod 4."
|
||||
(let ((v (make-vector 4 nil)))
|
||||
(dotimes (i 4) (aset v i (aref vec (mod (+ i seat) 4))))
|
||||
v))
|
||||
|
||||
(cl-defmethod cg-net-game-state ((game cg-bid-game) &optional seat)
|
||||
"Return GAME's shared state for SEAT, rotated so SEAT sits South.
|
||||
Other players' hands collapse to face-down counts, the kitty is hidden,
|
||||
and a hand exposed by an open misère is revealed to everyone."
|
||||
(let ((seat (or seat 0)))
|
||||
(if (null (cg-get game :hands))
|
||||
;; Lobby: nothing dealt yet.
|
||||
(list :phase (or (cg-get game :phase) 'lobby)
|
||||
:message (or (cg-get game :message) "Waiting for players…")
|
||||
:hand-no (or (cg-get game :hand-no) 0))
|
||||
(let* ((hands (cg-get game :hands))
|
||||
(exposed (cg-get game :exposed))
|
||||
(rhands (make-vector 4 nil))
|
||||
(scores (cg-get game :scores)))
|
||||
(dotimes (i 4)
|
||||
(let* ((abs (mod (+ i seat) 4))
|
||||
(cards (aref hands abs)))
|
||||
(aset rhands i
|
||||
(if (or (= abs seat) (eql abs exposed))
|
||||
(copy-sequence cards)
|
||||
(make-list (length cards) (cons 0 0))))))
|
||||
(list
|
||||
:hands rhands
|
||||
:kitty nil
|
||||
:phase (cg-get game :phase)
|
||||
:contract (cg-get game :contract)
|
||||
:contractor (cg-bid--rot (cg-get game :contractor) seat)
|
||||
:high-bid (cg-get game :high-bid)
|
||||
:high-bidder (cg-bid--rot (cg-get game :high-bidder) seat)
|
||||
:bidder (cg-bid--rot (cg-get game :bidder) seat)
|
||||
:dealer (cg-bid--rot (cg-get game :dealer) seat)
|
||||
:passed (cg-bid--rotate-vec4 (cg-get game :passed) seat)
|
||||
:turn (cg-bid--rot (cg-get game :turn) seat)
|
||||
:leader (cg-bid--rot (cg-get game :leader) seat)
|
||||
:led (cg-get game :led)
|
||||
:trick (mapcar (lambda (p) (cons (cg-bid--rot (car p) seat) (cdr p)))
|
||||
(cg-get game :trick))
|
||||
:last-trick (mapcar (lambda (p) (cons (cg-bid--rot (car p) seat) (cdr p)))
|
||||
(cg-get game :last-trick))
|
||||
:tricks (cg-bid--rotate-vec4 (cg-get game :tricks) seat)
|
||||
:ntricks (cg-get game :ntricks)
|
||||
:exposed (cg-bid--rot exposed seat)
|
||||
:scores (if (cl-oddp seat) (cons (cdr scores) (car scores)) scores)
|
||||
:game-over (cg-bid--rot-team (cg-get game :game-over) seat)
|
||||
:hand-no (cg-get game :hand-no)
|
||||
:hand-result (cg-get game :hand-result)
|
||||
:message (cg-get game :message)
|
||||
:log (cg-get game :log)
|
||||
:log-scroll (cg-get game :log-scroll)
|
||||
:you seat)))))
|
||||
|
||||
(cl-defmethod cg-net-set-game-state ((game cg-bid-game) state)
|
||||
"Install host STATE into GAME on a client, keeping the local cursor and scroll."
|
||||
(let ((old (oref game env)))
|
||||
(oset game env state)
|
||||
(dolist (k '(:cursor :marks :log-scroll))
|
||||
(cg-put game k (and (plist-member old k) (plist-get old k))))))
|
||||
|
||||
;;;; Apply a move on the host
|
||||
|
||||
(cl-defmethod cg-net-apply-move ((game cg-bid-game) seat move)
|
||||
"Apply MOVE made by absolute SEAT to the host's 500 GAME.
|
||||
MOVE is (bid BID), (pass), (discard CARD...) or (play CARD). Return
|
||||
non-nil when the move was legal and applied, so the host broadcasts."
|
||||
(let ((phase (cg-get game :phase)) (ok nil))
|
||||
(pcase move
|
||||
(`(bid ,bid)
|
||||
(when (and (eq phase 'auction) (eql (cg-get game :bidder) seat))
|
||||
(cg-bid--auction-act game seat bid) (setq ok t)))
|
||||
(`(pass)
|
||||
(when (and (eq phase 'auction) (eql (cg-get game :bidder) seat))
|
||||
(cg-bid--auction-act game seat nil) (setq ok t)))
|
||||
(`(discard . ,cards)
|
||||
(when (and (eq phase 'kitty) (eql (cg-get game :contractor) seat)
|
||||
(= (length cards) 5))
|
||||
(cg-bid--discard game seat cards) (setq ok t)))
|
||||
(`(play ,card)
|
||||
(when (and (eq phase 'play) (eql (cg-get game :turn) seat)
|
||||
(member card (cg-bid-legal-cards
|
||||
(cg-bid--hand game seat)
|
||||
(cg-get game :led)
|
||||
(cg-bid-trump (cg-get game :contract)))))
|
||||
(let ((cg-bid--applying-remote t)) (cg-bid--play game seat card))
|
||||
(setq ok t))))
|
||||
(when ok
|
||||
(let ((cg-bid--applying-remote t)) (cg-bid--run game))
|
||||
(cg-bid--net-host-refresh))
|
||||
ok))
|
||||
|
||||
(defun cg-bid--net-nominate-advice (orig game seat)
|
||||
"Around advice for `cg-bid--nominate-suit'.
|
||||
While the host applies a remote move (ORIG GAME SEAT), pick the longest
|
||||
suit automatically instead of prompting."
|
||||
(if cg-bid--applying-remote
|
||||
(let ((counts (make-vector 4 0)) (best 0))
|
||||
(dolist (c (cg-bid--hand game seat))
|
||||
(unless (cg-bid-joker-p c) (cl-incf (aref counts (car c)))))
|
||||
(dotimes (s 4) (when (> (aref counts s) (aref counts best)) (setq best s)))
|
||||
best)
|
||||
(funcall orig game seat)))
|
||||
(advice-add 'cg-bid--nominate-suit :around #'cg-bid--net-nominate-advice)
|
||||
|
||||
;;;; Host bookkeeping and display
|
||||
|
||||
(defun cg-bid--net-host-refresh ()
|
||||
"Redraw the host's own table buffer."
|
||||
(let ((buf (get-buffer "*500 Bid*")))
|
||||
(when (buffer-live-p buf)
|
||||
(with-current-buffer buf (cg-bid--redisplay)))))
|
||||
|
||||
(defun cg-bid--net-broadcast-advice (&rest _)
|
||||
"After advice on `cg-bid--refresh' that broadcasts when hosting."
|
||||
(when (and (eq cg-bid--net-role 'host) (cg-net-hosting-p))
|
||||
(cg-net-host-broadcast)))
|
||||
(advice-add 'cg-bid--refresh :after #'cg-bid--net-broadcast-advice)
|
||||
|
||||
(defun cg-bid--net-lobby-display ()
|
||||
"Show the host's pre-game lobby of seats."
|
||||
(let ((buf (get-buffer "*500 Bid*")))
|
||||
(when (buffer-live-p buf)
|
||||
(with-current-buffer buf
|
||||
(let ((inhibit-read-only t)
|
||||
(seats (cl-remove-duplicates cg-bid--human-seats)))
|
||||
(erase-buffer)
|
||||
(insert "\n 500 — LIVE TABLE (hosting)\n\n")
|
||||
(dotimes (s 4)
|
||||
(insert (format " %-6s %s\n" (aref cg-bid-seat-names s)
|
||||
(cond ((= s 0) "you (host)")
|
||||
((memq s seats) "joined")
|
||||
(t "open — AI will fill")))))
|
||||
(insert "\n Press s to start now")
|
||||
(when cg-bid-shuffle-partners (insert " (partners shuffled)"))
|
||||
(insert ".\n")
|
||||
(goto-char (point-min)))))))
|
||||
|
||||
(defun cg-bid--net-shuffle-seats ()
|
||||
"Randomly reassign joined clients among seats 1, 2 and 3.
|
||||
The host keeps South (seat 0)."
|
||||
(let ((clients (and cg-net--host
|
||||
(cl-remove-if-not #'process-live-p
|
||||
(cg-net-host-clients cg-net--host))))
|
||||
(seats (cg-shuffle (list 1 2 3))))
|
||||
(dolist (p clients) (process-put p 'cg-net-seat (pop seats)))
|
||||
(setq cg-bid--human-seats
|
||||
(cons 0 (mapcar (lambda (p) (process-get p 'cg-net-seat)) clients)))))
|
||||
|
||||
(defun cg-bid--net-start ()
|
||||
"Deal and begin the hosted game, AI filling any open seat."
|
||||
(let ((game cg-bid--game))
|
||||
(when cg-bid-shuffle-partners (cg-bid--net-shuffle-seats))
|
||||
(setq cg-bid--human-seats (cl-remove-duplicates cg-bid--human-seats))
|
||||
(cg-bid--deal game 3)
|
||||
(let ((cg-bid--applying-remote t)) (cg-bid--run game))
|
||||
(cg-bid--net-host-refresh)
|
||||
(cg-net-host-broadcast)))
|
||||
|
||||
(defun cg-bid--net-on-connect (host seat)
|
||||
"Host hook: a client has joined at SEAT (HOST is the server struct)."
|
||||
(when (eq cg-bid--net-role 'host)
|
||||
(if (> seat 3)
|
||||
;; Table full: turn the latecomer away.
|
||||
(let ((p (cl-find seat (cg-net-host-clients host)
|
||||
:key (lambda (q) (process-get q 'cg-net-seat)))))
|
||||
(when p (cg-net--send p '(:type full)) (delete-process p)))
|
||||
(cl-pushnew seat cg-bid--human-seats)
|
||||
(cg-bid--net-lobby-display)
|
||||
(message "Player joined at %s." (aref cg-bid-seat-names seat))
|
||||
(when (= (length (cl-remove-duplicates cg-bid--human-seats)) 4)
|
||||
(cg-bid--net-start)))))
|
||||
|
||||
;;;; Client display
|
||||
|
||||
(defun cg-bid--net-client-update (game)
|
||||
"Redraw the client's buffer after the host sends new state for GAME."
|
||||
(let ((buf (get-buffer "*500 Bid*")))
|
||||
(when (buffer-live-p buf)
|
||||
(with-current-buffer buf
|
||||
(if (memq (cg-get game :phase) '(lobby nil))
|
||||
(let ((inhibit-read-only t))
|
||||
(erase-buffer)
|
||||
(insert "\n 500 — connected to host.\n\n "
|
||||
(or (cg-get game :message)
|
||||
"Waiting for the host to start…")
|
||||
"\n")
|
||||
(goto-char (point-min)))
|
||||
(cg-bid--redisplay))))))
|
||||
|
||||
;;;; Client move interception
|
||||
|
||||
(defun cg-bid--net-client-bid-advice (orig)
|
||||
"Around advice on `cg-bid-make-bid' (ORIG): send the bid, do not apply it."
|
||||
(if (eq cg-bid--net-role 'client)
|
||||
(let ((game cg-bid--game))
|
||||
(if (or (not (eq (cg-get game :phase) 'auction))
|
||||
(/= (cg-get game :bidder) 0))
|
||||
(progn (cg-put game :message "Not your turn to bid.")
|
||||
(cg-bid--redisplay))
|
||||
(let* ((legal (cg-bid--legal-bids game))
|
||||
(completion-ignore-case t)
|
||||
(choices (append
|
||||
(mapcar (lambda (b)
|
||||
(cons (format "%-4s %s (%d)"
|
||||
(cg-bid--code b)
|
||||
(cg-bid-name b)
|
||||
(cg-bid-value b))
|
||||
b))
|
||||
legal)
|
||||
'(("Pass" . pass))))
|
||||
(pick (completing-read
|
||||
"Your bid (e.g. 7H, 8NT, NL; or Pass): "
|
||||
(mapcar #'car choices) nil t))
|
||||
(sel (cdr (assoc pick choices))))
|
||||
(cg-net-send-move (if (eq sel 'pass) '(pass) (list 'bid sel)))
|
||||
(cg-put game :message "Bid sent — waiting…")
|
||||
(cg-bid--redisplay))))
|
||||
(funcall orig)))
|
||||
(advice-add 'cg-bid-make-bid :around #'cg-bid--net-client-bid-advice)
|
||||
|
||||
(defun cg-bid--net-client-pass-advice (orig)
|
||||
"Around advice on `cg-bid-pass' (ORIG): send a pass, do not apply it."
|
||||
(if (eq cg-bid--net-role 'client)
|
||||
(let ((game cg-bid--game))
|
||||
(if (or (not (eq (cg-get game :phase) 'auction))
|
||||
(/= (cg-get game :bidder) 0))
|
||||
(progn (cg-put game :message "Not your turn to bid.")
|
||||
(cg-bid--redisplay))
|
||||
(cg-net-send-move '(pass))
|
||||
(cg-put game :message "Pass sent — waiting…")
|
||||
(cg-bid--redisplay)))
|
||||
(funcall orig)))
|
||||
(advice-add 'cg-bid-pass :around #'cg-bid--net-client-pass-advice)
|
||||
|
||||
(defun cg-bid--net-client-select-advice (orig)
|
||||
"Around advice on `cg-bid-select' (ORIG): send a play, or mark locally."
|
||||
(if (eq cg-bid--net-role 'client)
|
||||
(let* ((game cg-bid--game)
|
||||
(phase (cg-get game :phase))
|
||||
(card (cg-bid--current-card)))
|
||||
(pcase phase
|
||||
('kitty
|
||||
(when (eql (cg-get game :contractor) 0)
|
||||
(let ((marks (cg-get game :marks)))
|
||||
(cg-put game :marks (if (member card marks)
|
||||
(remove card marks)
|
||||
(cons card marks)))
|
||||
(cg-put game :message
|
||||
(format "%d of 5 marked for discard."
|
||||
(length (cg-get game :marks))))
|
||||
(cg-bid--redisplay))))
|
||||
('play
|
||||
(cond
|
||||
((/= (cg-get game :turn) 0)
|
||||
(cg-put game :message "Not your turn.") (cg-bid--redisplay))
|
||||
((null card) (cg-bid--redisplay))
|
||||
(t (cg-net-send-move (list 'play card))
|
||||
(cg-put game :message "Card sent — waiting…")
|
||||
(cg-bid--redisplay))))
|
||||
(_ (cg-bid--redisplay))))
|
||||
(funcall orig)))
|
||||
(advice-add 'cg-bid-select :around #'cg-bid--net-client-select-advice)
|
||||
|
||||
(defun cg-bid--net-client-discard-advice (orig)
|
||||
"Around advice on `cg-bid-discard-marked' (ORIG): send the discard intent."
|
||||
(if (eq cg-bid--net-role 'client)
|
||||
(let* ((game cg-bid--game) (marks (cg-get game :marks)))
|
||||
(cond
|
||||
((not (eq (cg-get game :phase) 'kitty))
|
||||
(cg-put game :message "Nothing to discard now.") (cg-bid--redisplay))
|
||||
((/= (length marks) 5)
|
||||
(cg-put game :message
|
||||
(format "Mark exactly 5 (have %d)." (length marks)))
|
||||
(cg-bid--redisplay))
|
||||
(t (cg-net-send-move (cons 'discard marks))
|
||||
(cg-put game :marks nil)
|
||||
(cg-put game :message "Discard sent — waiting…")
|
||||
(cg-bid--redisplay))))
|
||||
(funcall orig)))
|
||||
(advice-add 'cg-bid-discard-marked :around #'cg-bid--net-client-discard-advice)
|
||||
|
||||
;;;; Commands
|
||||
|
||||
(defun cg-bid-start-now ()
|
||||
"Start a hosted game immediately, AI filling any empty seats."
|
||||
(interactive)
|
||||
(if (and (eq cg-bid--net-role 'host)
|
||||
(eq (cg-get cg-bid--game :phase) 'lobby))
|
||||
(cg-bid--net-start)
|
||||
(message "Not hosting a lobby.")))
|
||||
(define-key cg-bid-mode-map "s" #'cg-bid-start-now)
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-bid-host (port)
|
||||
"Host a live game of 500 on PORT. Others join with `cg-bid-join'."
|
||||
(interactive (list (read-number "Host on port: " cg-net-port)))
|
||||
(let ((buf (get-buffer-create "*500 Bid*")))
|
||||
(with-current-buffer buf
|
||||
(cg-bid-mode)
|
||||
(setq cg-bid--game (make-instance 'cg-bid-game)
|
||||
cg-bid--net-role 'host
|
||||
cg-bid--net-seat 0
|
||||
cg-bid--human-seats '(0))
|
||||
(cg-put cg-bid--game :phase 'lobby)
|
||||
(cg-put cg-bid--game :message "Lobby")
|
||||
(cg-net-host-start cg-bid--game port)
|
||||
(setf (cg-net-host-next-seat cg-net--host) 1)
|
||||
(add-hook 'cg-net-connect-functions #'cg-bid--net-on-connect)
|
||||
(cg-bid--net-lobby-display))
|
||||
(switch-to-buffer buf)
|
||||
(message "Hosting 500 on port %d — waiting for players (press s to start)."
|
||||
port)))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-bid-join (host port name)
|
||||
"Join a hosted game of 500 at HOST and PORT as NAME."
|
||||
(interactive (list (read-string "Host: " "127.0.0.1")
|
||||
(read-number "Port: " cg-net-port)
|
||||
(read-string "Your name: " (user-login-name))))
|
||||
(let ((buf (get-buffer-create "*500 Bid*")))
|
||||
(with-current-buffer buf
|
||||
(cg-bid-mode)
|
||||
(setq cg-bid--game (make-instance 'cg-bid-game)
|
||||
cg-bid--net-role 'client
|
||||
cg-bid--human-seats '(0))
|
||||
(cg-put cg-bid--game :phase 'lobby)
|
||||
(cg-put cg-bid--game :message "Connecting…")
|
||||
(add-hook 'cg-net-state-functions #'cg-bid--net-client-update)
|
||||
(cg-net-connect host port name cg-bid--game)
|
||||
(cg-bid--net-client-update cg-bid--game))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
(provide 'cg-bid-net)
|
||||
;;; cg-bid-net.el ends here
|
||||
1258
cg-bid-ui.el
1258
cg-bid-ui.el
File diff suppressed because it is too large
Load diff
844
cg-bid.el
844
cg-bid.el
|
|
@ -1,844 +0,0 @@
|
|||
;;; 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.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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)) (cg-suit-glyph (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
|
||||
875
cg-bridge.el
875
cg-bridge.el
|
|
@ -1,875 +0,0 @@
|
|||
;;; cg-bridge.el --- Contract Bridge with rubber scoring -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Contract Bridge: you are South, partnered with North, against East and
|
||||
;; West. Each deal has an auction -- bids of a level (1-7) and a strain
|
||||
;; (clubs, diamonds, hearts, spades, or no-trump), plus Pass, Double, and
|
||||
;; Redouble -- followed by the play of thirteen tricks with the dummy (the
|
||||
;; declarer's partner) exposed. Scoring is the classic rubber game: trick
|
||||
;; points below the line race toward game, and bonuses, overtricks, and
|
||||
;; penalties go above; two games win the rubber.
|
||||
;;
|
||||
;; When you are declarer you play both your own hand and the dummy; when
|
||||
;; you defend you play your own cards and the computer plays the rest.
|
||||
;;
|
||||
;; The bidding AI is a deliberately small natural system (it opens on
|
||||
;; about twelve points, raises to game with a fit, and overcalls a good
|
||||
;; long suit); it reaches sensible contracts but is no expert. Cards use
|
||||
;; the package cons (SUIT . RANK), SUIT 0 spades, 1 clubs, 2 diamonds,
|
||||
;; 3 hearts, RANK 0 (Two) .. 12 (Ace).
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'cg-core)
|
||||
(require 'cg-svg)
|
||||
|
||||
(defconst cg-bridge-ranks
|
||||
["2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K" "A"]
|
||||
"Rank labels indexed 0 (Two) .. 12 (Ace).")
|
||||
|
||||
(defconst cg-bridge-strains ["♣" "♦" "♥" "♠" "NT"]
|
||||
"Strain glyphs indexed 0 clubs, 1 diamonds, 2 hearts, 3 spades, 4 no-trump.")
|
||||
|
||||
(defconst cg-bridge--strain-suit [1 2 3 0 nil]
|
||||
"Map a strain index to its trump suit index (nil for no-trump).")
|
||||
|
||||
(defconst cg-bridge--suit-strain [3 0 1 2]
|
||||
"Map a suit index (0 S,1 C,2 D,3 H) to its strain index.")
|
||||
|
||||
(defconst cg-bridge-seat-names ["South" "West" "North" "East"]
|
||||
"Seat names indexed 0..3 clockwise from the human.")
|
||||
|
||||
(defclass cg-bridge-game (cg-game)
|
||||
((vname :initform "Bridge"))
|
||||
"A game of contract Bridge.")
|
||||
|
||||
(defun cg-bridge-card-string (card)
|
||||
"Return a short string for CARD."
|
||||
(if (null card) "·"
|
||||
(concat (aref cg-bridge-ranks (cdr card)) (cg-suit-glyph (car card)))))
|
||||
|
||||
(defun cg-bridge--sort (cards)
|
||||
"Return CARDS sorted by suit then rank (high first) for display."
|
||||
(sort (copy-sequence cards)
|
||||
(lambda (a b) (if (= (car a) (car b)) (> (cdr a) (cdr b)) (< (car a) (car b))))))
|
||||
|
||||
(defun cg-bridge--deck ()
|
||||
"Return a fresh shuffled 52-card deck."
|
||||
(random t)
|
||||
(cg-shuffle (cl-loop for s below 4 append
|
||||
(cl-loop for r below 13 collect (cons s r)))))
|
||||
|
||||
;;;; Hand evaluation
|
||||
|
||||
(defun cg-bridge--hcp (hand)
|
||||
"Return the high-card points of HAND (A=4 K=3 Q=2 J=1)."
|
||||
(let ((p 0))
|
||||
(dolist (c hand p)
|
||||
(setq p (+ p (pcase (cdr c) (12 4) (11 3) (10 2) (9 1) (_ 0)))))))
|
||||
|
||||
(defun cg-bridge--suit-len (hand suit)
|
||||
"Return how many cards of SUIT are in HAND."
|
||||
(cl-count suit hand :key #'car))
|
||||
|
||||
(defun cg-bridge--longest (hand)
|
||||
"Return the suit index HAND holds most of (ties prefer majors, then spades)."
|
||||
(let ((best 0) (bestn -1))
|
||||
;; check in order hearts, diamonds, clubs, spades so spades win ties last
|
||||
(dolist (s '(3 2 1 0))
|
||||
(let ((n (cg-bridge--suit-len hand s)))
|
||||
(when (>= n bestn) (setq bestn n best s))))
|
||||
best))
|
||||
|
||||
(defun cg-bridge--balanced-p (hand)
|
||||
"Return non-nil when HAND has a balanced shape (no void/singleton)."
|
||||
(let ((doubletons 0) (ok t))
|
||||
(dotimes (s 4)
|
||||
(let ((n (cg-bridge--suit-len hand s)))
|
||||
(when (< n 2) (setq ok nil))
|
||||
(when (= n 2) (setq doubletons (1+ doubletons)))))
|
||||
(and ok (<= doubletons 1))))
|
||||
|
||||
;;;; Auction mechanics
|
||||
|
||||
(defsubst cg-bridge--hand (game s) (aref (cg-get game :hands) s))
|
||||
(defsubst cg-bridge--set-hand (game s v) (aset (cg-get game :hands) s v))
|
||||
(defsubst cg-bridge--side (s) (mod s 2))
|
||||
|
||||
(cl-defmethod cg-bridge--deal ((game cg-bridge-game))
|
||||
"Deal a fresh Bridge hand into GAME, leaving it ready for the auction."
|
||||
(let ((deck (cg-bridge--deck)) (hands (make-vector 4 nil)))
|
||||
(dotimes (s 4)
|
||||
(aset hands s (cg-bridge--sort (cl-loop repeat 13 collect (pop deck)))))
|
||||
(cg-put game :hands hands)
|
||||
(cg-put game :calls nil) ; list of (SEAT . CALL), newest first
|
||||
(cg-put game :contract nil) ; (LEVEL . STRAIN)
|
||||
(cg-put game :declarer nil)
|
||||
(cg-put game :doubled 0)
|
||||
(cg-put game :dealer (or (cg-get game :dealer) 0))
|
||||
(cg-put game :bidder (cg-get game :dealer))
|
||||
(cg-put game :phase 'auction)
|
||||
(cg-put game :cursor 0)
|
||||
(cg-put game :bid-level 1) ; UI: level being composed
|
||||
(cg-put game :bid-strain 0)
|
||||
(cg-put game :trick nil)
|
||||
(cg-put game :tricks 0) ; declarer-side tricks won
|
||||
(cg-put game :dummy nil)
|
||||
(cg-put game :exposed nil)
|
||||
(unless (cg-get game :below) (cg-put game :below (make-vector 2 0)))
|
||||
(unless (cg-get game :above) (cg-put game :above (make-vector 2 0)))
|
||||
(unless (cg-get game :games) (cg-put game :games (make-vector 2 0)))
|
||||
(unless (cg-get game :vul) (cg-put game :vul (make-vector 2 nil)))
|
||||
(cg-put game :message "Auction: compose a bid and press RET, or p/d to pass/double.")
|
||||
game))
|
||||
|
||||
(defun cg-bridge--high-bid (game)
|
||||
"Return the highest (LEVEL . STRAIN) bid so far, or nil."
|
||||
(cl-loop for (_s . call) in (cg-get game :calls)
|
||||
when (consp call) return call))
|
||||
|
||||
(defun cg-bridge--high-bidder (game)
|
||||
"Return the seat that made the highest bid, or nil."
|
||||
(cl-loop for (s . call) in (cg-get game :calls)
|
||||
when (consp call) return s))
|
||||
|
||||
(defun cg-bridge--call> (a b)
|
||||
"Return non-nil when bid A is higher than bid B (each (LEVEL . STRAIN))."
|
||||
(or (null b)
|
||||
(> (car a) (car b))
|
||||
(and (= (car a) (car b)) (> (cdr a) (cdr b)))))
|
||||
|
||||
(defun cg-bridge--legal-call-p (game call)
|
||||
"Return non-nil when CALL is legal now in GAME."
|
||||
(let ((high (cg-bridge--high-bid game))
|
||||
(hb (cg-bridge--high-bidder game)))
|
||||
(pcase call
|
||||
('pass t)
|
||||
('double (and high (/= (cg-bridge--side hb) (cg-bridge--side (cg-get game :bidder)))
|
||||
(= (cg-get game :doubled) 0)))
|
||||
('redouble (and high (= (cg-bridge--side hb) (cg-bridge--side (cg-get game :bidder)))
|
||||
(= (cg-get game :doubled) 1)))
|
||||
(_ (and (consp call) (>= (car call) 1) (<= (car call) 7)
|
||||
(cg-bridge--call> call high))))))
|
||||
|
||||
(defun cg-bridge--apply-call (game seat call)
|
||||
"Record CALL by SEAT and update doubling state."
|
||||
(cg-put game :calls (cons (cons seat call) (cg-get game :calls)))
|
||||
(pcase call
|
||||
('double (cg-put game :doubled 1))
|
||||
('redouble (cg-put game :doubled 2))
|
||||
((pred consp) (cg-put game :doubled 0)))
|
||||
(cg-put game :bidder (mod (1+ seat) 4)))
|
||||
|
||||
(defun cg-bridge--auction-done-p (game)
|
||||
"Return non-nil when the auction has ended.
|
||||
Sets up the contract (or a pass-out) as a side effect."
|
||||
(let* ((calls (cg-get game :calls)) (n (length calls)))
|
||||
(cond
|
||||
;; four passes with no bid: passed out
|
||||
((and (= n 4) (cl-every (lambda (c) (eq (cdr c) 'pass)) calls))
|
||||
(cg-put game :phase 'passed-out) t)
|
||||
;; a bid then three passes
|
||||
((and (cg-bridge--high-bid game)
|
||||
(>= n 3)
|
||||
(cl-every (lambda (c) (eq (cdr c) 'pass))
|
||||
(cl-subseq calls 0 3)))
|
||||
(cg-bridge--establish-contract game) t)
|
||||
(t nil))))
|
||||
|
||||
(defun cg-bridge--establish-contract (game)
|
||||
"Set the contract, declarer, and start of play from the finished auction."
|
||||
(let* ((bid (cg-bridge--high-bid game))
|
||||
(side (cg-bridge--side (cg-bridge--high-bidder game)))
|
||||
(strain (cdr bid))
|
||||
(declarer
|
||||
;; first player of SIDE to have named STRAIN
|
||||
(cl-loop for (s . call) in (reverse (cg-get game :calls))
|
||||
when (and (consp call) (= (cdr call) strain)
|
||||
(= (cg-bridge--side s) side))
|
||||
return s)))
|
||||
(cg-put game :contract bid)
|
||||
(cg-put game :declarer declarer)
|
||||
(cg-put game :dummy (mod (+ declarer 2) 4))
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :leader (mod (1+ declarer) 4))
|
||||
(cg-put game :turn (mod (1+ declarer) 4))
|
||||
(cg-put game :trick nil)
|
||||
(cg-put game :tricks 0)
|
||||
(cg-put game :cursor 0)
|
||||
(cg-put game :message
|
||||
(format "Contract: %s by %s. %s leads."
|
||||
(cg-bridge--contract-string game)
|
||||
(aref cg-bridge-seat-names declarer)
|
||||
(aref cg-bridge-seat-names (cg-get game :leader))))))
|
||||
|
||||
(defun cg-bridge--contract-string (game)
|
||||
"Return a label for GAME's contract, e.g. \"4NT x\"."
|
||||
(let ((c (cg-get game :contract)) (d (cg-get game :doubled)))
|
||||
(if (null c) "passed out"
|
||||
(format "%d%s%s" (car c) (aref cg-bridge-strains (cdr c))
|
||||
(pcase d (1 " x") (2 " xx") (_ ""))))))
|
||||
|
||||
;;;; Play mechanics
|
||||
|
||||
(defun cg-bridge--trump (game)
|
||||
"Return the trump suit index for GAME, or nil for no-trump."
|
||||
(and (cg-get game :contract) (aref cg-bridge--strain-suit (cdr (cg-get game :contract)))))
|
||||
|
||||
(defun cg-bridge--led-suit (game)
|
||||
"Return the suit led to the current trick, or nil."
|
||||
(let ((tr (cg-get game :trick)))
|
||||
(and tr (car (cdr (car (last tr)))))))
|
||||
|
||||
(defun cg-bridge--legal-play-p (game seat card)
|
||||
"Return non-nil when SEAT may play CARD now (follow suit if able)."
|
||||
(let ((hand (cg-bridge--hand game seat)) (led (cg-bridge--led-suit game)))
|
||||
(and (member card hand)
|
||||
(or (null led)
|
||||
(= (car card) led)
|
||||
(not (cl-some (lambda (c) (= (car c) led)) hand))))))
|
||||
|
||||
(defun cg-bridge--legal-plays (game seat)
|
||||
"Return SEAT's legal cards now."
|
||||
(cl-remove-if-not (lambda (c) (cg-bridge--legal-play-p game seat c))
|
||||
(cg-bridge--hand game seat)))
|
||||
|
||||
(defun cg-bridge--trick-winner (plays trump)
|
||||
"Return the winning seat of complete PLAYS ((SEAT . CARD), play order)."
|
||||
(let ((best (car plays)))
|
||||
(dolist (p (cdr plays))
|
||||
(let ((bc (cdr best)) (pc (cdr p)))
|
||||
(cond
|
||||
((and trump (= (car pc) trump) (/= (car bc) trump)) (setq best p))
|
||||
((and (= (car pc) (car bc)) (> (cdr pc) (cdr bc))) (setq best p)))))
|
||||
(car best)))
|
||||
|
||||
(defun cg-bridge--play-card (game seat card)
|
||||
"Have SEAT play CARD; resolve and score the trick when it completes."
|
||||
(cg-bridge--set-hand game seat (remove card (cg-bridge--hand game seat)))
|
||||
(cg-put game :trick (cons (cons seat card) (cg-get game :trick)))
|
||||
;; expose the dummy after the opening lead
|
||||
(unless (cg-get game :exposed)
|
||||
(cg-put game :exposed t))
|
||||
(if (= 4 (length (cg-get game :trick)))
|
||||
(let ((w (cg-bridge--trick-winner (reverse (cg-get game :trick))
|
||||
(cg-bridge--trump game))))
|
||||
(when (= (cg-bridge--side w) (cg-bridge--side (cg-get game :declarer)))
|
||||
(cg-put game :tricks (1+ (cg-get game :tricks))))
|
||||
(cg-put game :trick nil)
|
||||
(cg-put game :leader w)
|
||||
(cg-put game :turn w)
|
||||
(cg-put game :last-winner w)
|
||||
(when (cl-every #'null (append (cg-get game :hands) nil))
|
||||
(cg-bridge--score-deal game))
|
||||
w)
|
||||
(cg-put game :turn (mod (1+ seat) 4))
|
||||
nil))
|
||||
|
||||
;;;; Scoring (rubber)
|
||||
|
||||
(defun cg-bridge--undertrick-points (n doubled vul)
|
||||
"Return defender points for N undertricks at DOUBLED level and VUL state."
|
||||
(cond
|
||||
((= doubled 0) (* n (if vul 100 50)))
|
||||
(t (let ((mult (if (= doubled 2) 2 1)) (sum 0))
|
||||
(dotimes (i n)
|
||||
(setq sum (+ sum (* mult (if vul (if (= i 0) 200 300)
|
||||
(cond ((= i 0) 100) ((< i 3) 200) (t 300)))))))
|
||||
sum))))
|
||||
|
||||
(defun cg-bridge--deal-score (level strain doubled vul tricks)
|
||||
"Return a plist scoring a contract result.
|
||||
LEVEL/STRAIN/DOUBLED describe the contract, VUL the declarer's
|
||||
vulnerability, and TRICKS the declarer side's trick count. Keys:
|
||||
:below contracted points, :datk declarer bonus points above the line,
|
||||
:defend defender points, :result tricks over/under the contract."
|
||||
(let* ((need (+ 6 level)) (result (- tricks need))
|
||||
(mult (pcase doubled (0 1) (1 2) (2 4)))
|
||||
(below 0) (datk 0) (defend 0))
|
||||
(if (>= result 0)
|
||||
(progn
|
||||
(setq below (* mult (if (= strain 4) (+ 40 (* 30 (1- level)))
|
||||
(* (if (<= strain 1) 20 30) level))))
|
||||
(when (> result 0)
|
||||
(setq datk (+ datk (if (= doubled 0)
|
||||
(* result (if (= strain 4) 30 (if (<= strain 1) 20 30)))
|
||||
(* result (* (if (= doubled 2) 2 1) (if vul 200 100)))))))
|
||||
(when (> doubled 0) (setq datk (+ datk (if (= doubled 2) 100 50))))
|
||||
(cond ((= level 6) (setq datk (+ datk (if vul 750 500))))
|
||||
((= level 7) (setq datk (+ datk (if vul 1500 1000))))))
|
||||
(setq defend (cg-bridge--undertrick-points (- result) doubled vul)))
|
||||
(list :below below :datk datk :defend defend :result result)))
|
||||
|
||||
(defun cg-bridge--score-deal (game)
|
||||
"Score the finished deal into GAME's rubber state."
|
||||
(let* ((c (cg-get game :contract)) (level (car c)) (strain (cdr c))
|
||||
(decl (cg-get game :declarer)) (side (cg-bridge--side decl))
|
||||
(opp (- 1 side)) (doubled (cg-get game :doubled))
|
||||
(vul (aref (cg-get game :vul) side))
|
||||
(sc (cg-bridge--deal-score level strain doubled vul (cg-get game :tricks)))
|
||||
(below (cg-get game :below)) (above (cg-get game :above)))
|
||||
(aset below side (+ (aref below side) (plist-get sc :below)))
|
||||
(aset above side (+ (aref above side) (plist-get sc :datk)))
|
||||
(aset above opp (+ (aref above opp) (plist-get sc :defend)))
|
||||
(cg-put game :deal-result sc)
|
||||
;; game / rubber bookkeeping
|
||||
(when (>= (aref below side) 100)
|
||||
(let ((games (cg-get game :games)))
|
||||
(aset games side (1+ (aref games side)))
|
||||
(aset (cg-get game :vul) side t)
|
||||
(aset below 0 0) (aset below 1 0)
|
||||
(when (>= (aref games side) 2)
|
||||
(aset above side (+ (aref above side)
|
||||
(if (>= (aref games opp) 1) 500 700)))
|
||||
(cg-put game :rubber-winner side))))
|
||||
(cg-put game :phase 'scored)
|
||||
(cg-put game :message
|
||||
(format "%s: %s. %s"
|
||||
(cg-bridge--contract-string game)
|
||||
(let ((r (plist-get sc :result)))
|
||||
(cond ((>= r 0) (format "made +%d" r))
|
||||
(t (format "down %d" (- r)))))
|
||||
(if (cg-get game :rubber-winner)
|
||||
(format "%s win the rubber! (n: new rubber)"
|
||||
(if (= side 0) "You and North" "East and West"))
|
||||
"(n: next deal)")))))
|
||||
|
||||
;;;; AI -- bidding
|
||||
|
||||
(cl-defmethod cg-bridge--ai-call ((game cg-bridge-game) seat)
|
||||
"Return a call for AI SEAT from a small natural system."
|
||||
(let* ((hand (cg-bridge--hand game seat)) (hcp (cg-bridge--hcp hand))
|
||||
(high (cg-bridge--high-bid game)) (hb (cg-bridge--high-bidder game))
|
||||
(ours (and high (= (cg-bridge--side hb) (cg-bridge--side seat)))))
|
||||
(cond
|
||||
((null high) ; opening
|
||||
(cond ((and (cg-bridge--balanced-p hand) (>= hcp 15) (<= hcp 17)) (cons 1 4))
|
||||
((and (cg-bridge--balanced-p hand) (>= hcp 20) (<= hcp 21)) (cons 2 4))
|
||||
((>= hcp 12)
|
||||
(let ((suit (cg-bridge--longest hand)))
|
||||
(cons 1 (aref cg-bridge--suit-strain suit))))
|
||||
(t 'pass)))
|
||||
(ours ; partner has the contract
|
||||
(let* ((est (+ hcp 13)) (hl (car high)) (hs (cdr high))
|
||||
(fit (or (= hs 4)
|
||||
(>= (cg-bridge--suit-len
|
||||
hand (aref cg-bridge--strain-suit hs)) 3))))
|
||||
(if (and fit (>= est 26) (< hl 4)
|
||||
(cg-bridge--legal-call-p
|
||||
game (cond ((= hs 4) (cons 3 4))
|
||||
((>= hs 2) (cons 4 hs))
|
||||
(t (cons 5 hs)))))
|
||||
(cond ((= hs 4) (cons 3 4)) ((>= hs 2) (cons 4 hs)) (t (cons 5 hs)))
|
||||
'pass)))
|
||||
(t ; opponents have the contract
|
||||
(let* ((suit (cg-bridge--longest hand))
|
||||
(len (cg-bridge--suit-len hand suit))
|
||||
(st (aref cg-bridge--suit-strain suit))
|
||||
(cand (if (> st (cdr high)) (cons (car high) st)
|
||||
(cons (1+ (car high)) st))))
|
||||
(if (and (>= hcp 11) (>= len 5) (<= (car cand) 3)
|
||||
(cg-bridge--legal-call-p game cand))
|
||||
cand 'pass))))))
|
||||
|
||||
;;;; AI -- play
|
||||
|
||||
(cl-defmethod cg-bridge--ai-play ((game cg-bridge-game) seat)
|
||||
"Return a card for AI SEAT: win cheaply or shed low."
|
||||
(let* ((legal (cg-bridge--legal-plays game seat))
|
||||
(trump (cg-bridge--trump game)) (trick (cg-get game :trick)))
|
||||
(if (null trick)
|
||||
;; leading: low from the longest non-trump suit, else lowest
|
||||
(car (sort (copy-sequence legal)
|
||||
(lambda (a b) (< (cdr a) (cdr b)))))
|
||||
(let* ((order (reverse trick))
|
||||
(cur (cg-bridge--trick-winner order trump))
|
||||
(partner (= (cg-bridge--side cur) (cg-bridge--side seat)))
|
||||
(winners (cl-remove-if-not
|
||||
(lambda (c) (= seat (cg-bridge--trick-winner
|
||||
(append order (list (cons seat c))) trump)))
|
||||
legal)))
|
||||
(cond
|
||||
;; partner already winning: throw the lowest card
|
||||
((and partner (>= (length trick) 1))
|
||||
(car (sort (copy-sequence legal) (lambda (a b) (< (cdr a) (cdr b))))))
|
||||
;; can win: take it with the cheapest winner
|
||||
(winners (car (sort winners (lambda (a b) (< (cdr a) (cdr b))))))
|
||||
;; cannot win: discard lowest
|
||||
(t (car (sort (copy-sequence legal) (lambda (a b) (< (cdr a) (cdr b)))))))))))
|
||||
|
||||
(defun cg-bridge--controls (game)
|
||||
"Return the list of seats the human controls during play."
|
||||
(let ((decl (cg-get game :declarer)))
|
||||
(cond ((null decl) nil)
|
||||
((= decl 0) '(0 2)) ; South declares: play hand + dummy
|
||||
((= decl 2) nil) ; North declares: AI plays both
|
||||
(t '(0))))) ; South defends
|
||||
|
||||
(defun cg-bridge--auto-seat-p (game seat)
|
||||
"Return non-nil when SEAT is played automatically (by AI) in GAME."
|
||||
(not (memq seat (cg-bridge--controls game))))
|
||||
|
||||
(defun cg-bridge--run-play (game)
|
||||
"Advance AI plays until a human-controlled seat must act or the deal ends."
|
||||
(let ((guard 0))
|
||||
(while (and (eq (cg-get game :phase) 'play)
|
||||
(cg-bridge--auto-seat-p game (cg-get game :turn))
|
||||
(< guard 60))
|
||||
(setq guard (1+ guard))
|
||||
(cg-bridge--play-card game (cg-get game :turn)
|
||||
(cg-bridge--ai-play game (cg-get game :turn))))))
|
||||
|
||||
(defun cg-bridge--run-auction (game)
|
||||
"Advance the auction through AI seats until South must call or it ends."
|
||||
(let ((guard 0))
|
||||
(while (and (eq (cg-get game :phase) 'auction) (/= (cg-get game :bidder) 0)
|
||||
(< guard 40))
|
||||
(setq guard (1+ guard))
|
||||
(let* ((s (cg-get game :bidder)) (call (cg-bridge--ai-call game s)))
|
||||
(unless (cg-bridge--legal-call-p game call) (setq call 'pass))
|
||||
(cg-bridge--apply-call game s call)
|
||||
(cg-bridge--auction-done-p game)))
|
||||
(when (eq (cg-get game :phase) 'play) (cg-bridge--run-play game))))
|
||||
|
||||
;;;; UI
|
||||
|
||||
(defvar-local cg-bridge--game nil "The Bridge game in the current buffer.")
|
||||
|
||||
(defun cg-bridge--hand-by-suit (cards)
|
||||
"Return CARDS grouped into four lines by suit, as a string."
|
||||
(let ((out '()))
|
||||
(dolist (s '(0 3 2 1)) ; S H D C
|
||||
(let ((in (cg-bridge--sort (cl-remove-if-not (lambda (c) (= (car c) s)) cards))))
|
||||
(push (format " %s %s\n" (cg-suit-glyph s)
|
||||
(if in (mapconcat (lambda (c) (aref cg-bridge-ranks (cdr c))) in " ")
|
||||
"--"))
|
||||
out)))
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(defun cg-bridge--auction-string (game)
|
||||
"Return a compact record of the auction so far."
|
||||
(let ((calls (reverse (cg-get game :calls))) (out '()))
|
||||
(dolist (sc calls)
|
||||
(push (format "%s:%s" (aref cg-bridge-seat-names (car sc))
|
||||
(pcase (cdr sc)
|
||||
('pass "pass") ('double "X") ('redouble "XX")
|
||||
(c (format "%d%s" (car c) (aref cg-bridge-strains (cdr c))))))
|
||||
out))
|
||||
(if out (mapconcat #'identity (nreverse out) " ") "(no calls yet)")))
|
||||
|
||||
(defcustom cg-bridge-svg-cards t
|
||||
"When non-nil, draw cards as SVG images on a graphical display."
|
||||
:type 'boolean :group 'card-games)
|
||||
|
||||
(defun cg-bridge--spec (card)
|
||||
"Return the cg-svg display spec (RANK-STRING . SUIT) for CARD."
|
||||
(cons (aref cg-bridge-ranks (cdr card)) (car card)))
|
||||
|
||||
(cl-defun cg-bridge--svg-row (cards &key cursor hints region-tag)
|
||||
"Return a one-image SVG row for CARDS (clickable + sliderful when REGION-TAG)."
|
||||
(cg-svg-hand-image (mapcar #'cg-bridge--spec cards)
|
||||
:cursor cursor :hints hints
|
||||
:overlap (if (> (length cards) 11)
|
||||
(max 0 (- cg-svg-card-width 26)) 0)
|
||||
:region-tag region-tag))
|
||||
|
||||
(defun cg-bridge--draw-backs (svg x y n)
|
||||
"Draw up to three overlapped backs at X, Y for a hand of N cards."
|
||||
(let ((k (min (max n 0) 3)) (xx x))
|
||||
(dotimes (_ k) (cg-svg-card svg xx y :down t) (setq xx (+ xx 16)))))
|
||||
|
||||
(defun cg-bridge--svg (game)
|
||||
"Return an SVG board for the Bridge GAME (four seats, dummy exposed)."
|
||||
(let* ((w cg-svg-card-width) (h cg-svg-card-height) (gap cg-svg-card-gap) (pad 16)
|
||||
(phase (cg-get game :phase)) (cursor (cg-get game :cursor))
|
||||
(turn (cg-get game :turn)) (dummy (cg-get game :dummy))
|
||||
(exposed (cg-get game :exposed)) (trick (cg-get game :trick))
|
||||
(act (if (and (eq phase 'play) (memq turn (cg-bridge--controls game))) turn 0))
|
||||
(ahand (cg-bridge--sort (cg-bridge--hand game act)))
|
||||
(n (length ahand))
|
||||
(overlap (cond ((> n 11) (- w 26)) ((> n 8) 20) (t 0)))
|
||||
(step (max 14 (- (+ w gap) overlap)))
|
||||
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
|
||||
(width (max (+ fanw (* 2 pad)) 760))
|
||||
(cx (/ width 2))
|
||||
(y-title 6) (y-info 24) (y-north 62)
|
||||
(y-tn (+ y-north h 20))
|
||||
(cyc (+ y-tn (round (* h 0.5))))
|
||||
(y-ts (+ cyc (round (* h 0.15))))
|
||||
(y-hand (+ y-ts h 42))
|
||||
(height (+ y-hand h 30))
|
||||
(svg (svg-create width height))
|
||||
(lc (cg-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels
|
||||
((txt (str x y &optional sz bold)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family cg-svg-font-family (and bold '(:font-weight "bold"))))
|
||||
(seat (s x y)
|
||||
(if (and exposed (eql s dummy) (/= s act))
|
||||
(let ((cs (cg-bridge--sort (cg-bridge--hand game s))) (xx x))
|
||||
(dolist (c cs)
|
||||
(let ((sp (cg-bridge--spec c)))
|
||||
(cg-svg-card svg xx y :rank (car sp) :suit (cdr sp)))
|
||||
(setq xx (+ xx 15))))
|
||||
(cg-bridge--draw-backs svg x (+ y 6) (length (cg-bridge--hand game s))))
|
||||
(txt (format "%s%s%s" (aref cg-bridge-seat-names s)
|
||||
(if (eql s dummy) " (dummy)" "")
|
||||
(if (= turn s) " <-" ""))
|
||||
x y 11))
|
||||
(trick-card (s x y)
|
||||
(let ((play (assq s trick)))
|
||||
(when play
|
||||
(let ((sp (cg-bridge--spec (cdr play))))
|
||||
(cg-svg-card svg x y :rank (car sp) :suit (cdr sp)))))))
|
||||
(txt "Bridge" pad (+ y-title 12) 13 t)
|
||||
(txt (format "Games N-S %d E-W %d Below %d/%d Above %d/%d"
|
||||
(aref (cg-get game :games) 0) (aref (cg-get game :games) 1)
|
||||
(aref (cg-get game :below) 0) (aref (cg-get game :below) 1)
|
||||
(aref (cg-get game :above) 0) (aref (cg-get game :above) 1))
|
||||
pad (+ y-info 8) 11)
|
||||
(pcase phase
|
||||
('auction
|
||||
(txt (format "Auction: %s" (cg-bridge--auction-string game)) pad (+ y-info 24) 11)
|
||||
(txt (format "Your bid: %d %s (arrows compose, RET bids)"
|
||||
(cg-get game :bid-level)
|
||||
(aref cg-bridge-strains (cg-get game :bid-strain)))
|
||||
pad (+ y-info 40) 11))
|
||||
((or 'play 'scored 'passed-out)
|
||||
(txt (format "Contract: %s by %s Declarer tricks: %d"
|
||||
(cg-bridge--contract-string game)
|
||||
(if (cg-get game :declarer)
|
||||
(aref cg-bridge-seat-names (cg-get game :declarer)) "--")
|
||||
(cg-get game :tricks))
|
||||
pad (+ y-info 24) 11)))
|
||||
(seat 2 (- cx 40) y-north)
|
||||
(seat 1 pad cyc)
|
||||
(seat 3 (- width pad 110) cyc)
|
||||
(when (eq phase 'play)
|
||||
(trick-card 2 (- cx (/ w 2)) y-tn)
|
||||
(trick-card 0 (- cx (/ w 2)) y-ts)
|
||||
(trick-card 1 (- cx w (round (* w 0.4))) (round (- cyc (* h 0.25))))
|
||||
(trick-card 3 (+ cx (round (* w 0.4))) (round (- cyc (* h 0.25)))))
|
||||
(txt (format "%s%s" (aref cg-bridge-seat-names act)
|
||||
(cond ((eq phase 'auction) " (you)")
|
||||
((= act 0) " (you)")
|
||||
(t " (dummy -- you play)")))
|
||||
pad (- y-hand 6) 11)
|
||||
(let ((x (max pad (- (/ width 2) (/ fanw 2)))) (i 0)
|
||||
(legalp (and (eq phase 'play) (= turn act))))
|
||||
(dolist (c ahand)
|
||||
(let ((sp (cg-bridge--spec c)) (curp (= i cursor))
|
||||
(hintp (and legalp (cg-bridge--legal-play-p game act c))))
|
||||
(cg-svg-card svg x y-hand :rank (car sp) :suit (cdr sp)
|
||||
:highlight curp :hint hintp)
|
||||
(push (cons (list x y-hand (if (= i (1- n)) w step) h) (cons 'hand i)) regions))
|
||||
(setq x (+ x step) i (1+ i))))
|
||||
(txt (or (cg-get game :message) "") pad (- height 8) 12))
|
||||
(propertize "*" 'display (cg-svg-image svg (cg-scale)) 'cg-regions (nreverse regions))))
|
||||
|
||||
(cl-defmethod cg-render ((game cg-bridge-game))
|
||||
"Return a depiction of the Bridge GAME: SVG board if graphical, else text."
|
||||
(if (and cg-bridge-svg-cards (display-graphic-p))
|
||||
(cg-bridge--svg game)
|
||||
(cg-bridge--render-text game)))
|
||||
|
||||
(defun cg-bridge--render-text (game)
|
||||
"Return a plain-text depiction of the Bridge GAME."
|
||||
(let* ((out '()) (phase (cg-get game :phase)) (cursor (cg-get game :cursor)))
|
||||
(push " Bridge\n" out)
|
||||
(push (format " Rubber: You/North games %d East/West games %d%s\n"
|
||||
(aref (cg-get game :games) 0) (aref (cg-get game :games) 1)
|
||||
(let ((v (cg-get game :vul)))
|
||||
(format " (vul: %s)"
|
||||
(cond ((and (aref v 0) (aref v 1)) "both")
|
||||
((aref v 0) "N-S") ((aref v 1) "E-W") (t "none")))))
|
||||
out)
|
||||
(push (format " Below: You/N %d E/W %d Above: You/N %d E/W %d\n\n"
|
||||
(aref (cg-get game :below) 0) (aref (cg-get game :below) 1)
|
||||
(aref (cg-get game :above) 0) (aref (cg-get game :above) 1))
|
||||
out)
|
||||
(pcase phase
|
||||
('auction
|
||||
(push (format " Auction so far: %s\n\n" (cg-bridge--auction-string game)) out)
|
||||
(push (format " Compose: %d %s (Up/Down level, Left/Right strain)\n\n"
|
||||
(cg-get game :bid-level)
|
||||
(aref cg-bridge-strains (cg-get game :bid-strain)))
|
||||
out))
|
||||
((or 'play 'scored 'passed-out)
|
||||
(push (format " Contract: %s by %s Declarer tricks: %d\n"
|
||||
(cg-bridge--contract-string game)
|
||||
(if (cg-get game :declarer)
|
||||
(aref cg-bridge-seat-names (cg-get game :declarer)) "--")
|
||||
(cg-get game :tricks))
|
||||
out)
|
||||
(when (and (cg-get game :exposed) (cg-get game :dummy))
|
||||
(push (format "\n Dummy (%s):\n "
|
||||
(aref cg-bridge-seat-names (cg-get game :dummy))) out)
|
||||
(if (and cg-bridge-svg-cards (display-graphic-p))
|
||||
(push (cg-bridge--svg-row
|
||||
(cg-bridge--sort (cg-bridge--hand game (cg-get game :dummy)))) out)
|
||||
(push (cg-bridge--hand-by-suit (cg-bridge--hand game (cg-get game :dummy))) out)))
|
||||
(push "\n Trick: " out)
|
||||
(cond
|
||||
((null (cg-get game :trick)) (push "(empty)" out))
|
||||
((and cg-bridge-svg-cards (display-graphic-p))
|
||||
(push (concat (mapconcat (lambda (p) (aref cg-bridge-seat-names (car p)))
|
||||
(reverse (cg-get game :trick)) " ") " ") out)
|
||||
(push (cg-bridge--svg-row (mapcar #'cdr (reverse (cg-get game :trick)))) out))
|
||||
(t (dolist (p (reverse (cg-get game :trick)))
|
||||
(push (format "%s:%s " (aref cg-bridge-seat-names (car p))
|
||||
(cg-bridge-card-string (cdr p))) out))))
|
||||
(push "\n" out)))
|
||||
;; the human's hand (South), or the seat being played from when it is dummy
|
||||
(let* ((act (if (and (eq phase 'play) (memq (cg-get game :turn)
|
||||
(cg-bridge--controls game)))
|
||||
(cg-get game :turn) 0))
|
||||
(hand (cg-bridge--sort (cg-bridge--hand game act))))
|
||||
(push (format "\n %s%s:\n "
|
||||
(aref cg-bridge-seat-names act)
|
||||
(cond ((eq phase 'auction) " (you)")
|
||||
((= act 0) " (you)")
|
||||
(t " (dummy, you play)")))
|
||||
out)
|
||||
(cond
|
||||
((and (eq phase 'play) cg-bridge-svg-cards (display-graphic-p))
|
||||
(let ((hi '()) (i 0))
|
||||
(dolist (c hand)
|
||||
(when (and (= (cg-get game :turn) act) (cg-bridge--legal-play-p game act c))
|
||||
(push i hi))
|
||||
(setq i (1+ i)))
|
||||
(push (cg-bridge--svg-row hand :cursor cursor :hints hi :region-tag 'hand) out)))
|
||||
((eq phase 'play)
|
||||
(let ((i 0))
|
||||
(dolist (c hand)
|
||||
(let ((cs (cg-bridge-card-string c)) (faces nil))
|
||||
(when (cg-red-suit-p (car c)) (push 'cg-red-suit faces))
|
||||
(when (and (= (cg-get game :turn) act)
|
||||
(cg-bridge--legal-play-p game act c)) (push 'cg-hint faces))
|
||||
(when (= i cursor) (push 'cg-cursor faces))
|
||||
(push (propertize (format "%4s" cs) 'face (or faces 'default)) out))
|
||||
(setq i (1+ i)))))
|
||||
(t (push (cg-bridge--hand-by-suit hand) out))))
|
||||
(push (format "\n\n %s\n" (cg-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod cg-render-apply ((g cg-bridge-game) action)
|
||||
"Apply a click ACTION on the hand: select that card and play it."
|
||||
(pcase action
|
||||
(`(hand . ,i) (cg-put g :cursor i) (cg-bridge-play))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun cg-bridge--redisplay ()
|
||||
(let ((game cg-bridge--game) (inhibit-read-only t))
|
||||
(setq cg-current-game game cg-redisplay-function #'cg-bridge--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (cg-get game :phase)))
|
||||
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
|
||||
|
||||
;;;; Auction commands
|
||||
|
||||
(defun cg-bridge-bid-level-up ()
|
||||
"Raise the level being composed."
|
||||
(interactive)
|
||||
(let ((g cg-bridge--game))
|
||||
(cg-put g :bid-level (min 7 (1+ (cg-get g :bid-level))))
|
||||
(cg-bridge--redisplay)))
|
||||
|
||||
(defun cg-bridge-bid-level-down ()
|
||||
"Lower the level being composed."
|
||||
(interactive)
|
||||
(let ((g cg-bridge--game))
|
||||
(cg-put g :bid-level (max 1 (1- (cg-get g :bid-level))))
|
||||
(cg-bridge--redisplay)))
|
||||
|
||||
(defun cg-bridge-bid-strain-left ()
|
||||
"Move the composed strain down (toward clubs)."
|
||||
(interactive)
|
||||
(let ((g cg-bridge--game))
|
||||
(cg-put g :bid-strain (max 0 (1- (cg-get g :bid-strain))))
|
||||
(cg-bridge--redisplay)))
|
||||
|
||||
(defun cg-bridge-bid-strain-right ()
|
||||
"Move the composed strain up (toward no-trump)."
|
||||
(interactive)
|
||||
(let ((g cg-bridge--game))
|
||||
(cg-put g :bid-strain (min 4 (1+ (cg-get g :bid-strain))))
|
||||
(cg-bridge--redisplay)))
|
||||
|
||||
(defun cg-bridge--after-call (g)
|
||||
"Resolve end-of-auction and run AI after South calls in G."
|
||||
(unless (cg-bridge--auction-done-p g)
|
||||
(cg-bridge--run-auction g))
|
||||
(when (eq (cg-get g :phase) 'play) (cg-bridge--run-play g))
|
||||
(cg-bridge--redisplay))
|
||||
|
||||
(defun cg-bridge-bid ()
|
||||
"Make the composed bid."
|
||||
(interactive)
|
||||
(let* ((g cg-bridge--game)
|
||||
(call (cons (cg-get g :bid-level) (cg-get g :bid-strain))))
|
||||
(cond
|
||||
((not (eq (cg-get g :phase) 'auction)) (cg-put g :message "Not bidding now."))
|
||||
((/= (cg-get g :bidder) 0) (cg-put g :message "Not your turn."))
|
||||
((not (cg-bridge--legal-call-p g call))
|
||||
(cg-put g :message "That bid is too low."))
|
||||
(t (cg-bridge--apply-call g 0 call) (cg-bridge--after-call g)))
|
||||
(cg-bridge--redisplay)))
|
||||
|
||||
(defun cg-bridge-pass ()
|
||||
"Pass in the auction."
|
||||
(interactive)
|
||||
(let ((g cg-bridge--game))
|
||||
(if (and (eq (cg-get g :phase) 'auction) (= (cg-get g :bidder) 0))
|
||||
(progn (cg-bridge--apply-call g 0 'pass) (cg-bridge--after-call g))
|
||||
(cg-put g :message "Nothing to pass on."))
|
||||
(cg-bridge--redisplay)))
|
||||
|
||||
(defun cg-bridge-double ()
|
||||
"Double (or redouble) in the auction."
|
||||
(interactive)
|
||||
(let* ((g cg-bridge--game)
|
||||
(call (if (= (cg-get g :doubled) 1) 'redouble 'double)))
|
||||
(if (and (eq (cg-get g :phase) 'auction) (= (cg-get g :bidder) 0)
|
||||
(cg-bridge--legal-call-p g call))
|
||||
(progn (cg-bridge--apply-call g 0 call) (cg-bridge--after-call g))
|
||||
(cg-put g :message "You cannot double now."))
|
||||
(cg-bridge--redisplay)))
|
||||
|
||||
;;;; Play commands
|
||||
|
||||
(defun cg-bridge--act-hand (g)
|
||||
"Return the hand the cursor currently indexes (the seat to act)."
|
||||
(let ((act (if (memq (cg-get g :turn) (cg-bridge--controls g)) (cg-get g :turn) 0)))
|
||||
(cg-bridge--sort (cg-bridge--hand g act))))
|
||||
|
||||
(defun cg-bridge-left ()
|
||||
"Move the cursor left."
|
||||
(interactive)
|
||||
(let* ((g cg-bridge--game) (n (length (cg-bridge--act-hand g))))
|
||||
(cond ((eq (cg-get g :phase) 'auction) (cg-bridge-bid-strain-left))
|
||||
(t (when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n)))
|
||||
(cg-bridge--redisplay)))))
|
||||
|
||||
(defun cg-bridge-right ()
|
||||
"Move the cursor right."
|
||||
(interactive)
|
||||
(let* ((g cg-bridge--game) (n (length (cg-bridge--act-hand g))))
|
||||
(cond ((eq (cg-get g :phase) 'auction) (cg-bridge-bid-strain-right))
|
||||
(t (when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n)))
|
||||
(cg-bridge--redisplay)))))
|
||||
|
||||
(defun cg-bridge-up ()
|
||||
"Raise the bid level (auction only)."
|
||||
(interactive)
|
||||
(if (eq (cg-get cg-bridge--game :phase) 'auction) (cg-bridge-bid-level-up)
|
||||
(cg-bridge--redisplay)))
|
||||
|
||||
(defun cg-bridge-down ()
|
||||
"Lower the bid level (auction only)."
|
||||
(interactive)
|
||||
(if (eq (cg-get cg-bridge--game :phase) 'auction) (cg-bridge-bid-level-down)
|
||||
(cg-bridge--redisplay)))
|
||||
|
||||
(defun cg-bridge-play ()
|
||||
"Play the cursor card, or make the composed bid during the auction."
|
||||
(interactive)
|
||||
(let ((g cg-bridge--game))
|
||||
(if (eq (cg-get g :phase) 'auction)
|
||||
(cg-bridge-bid)
|
||||
(let* ((turn (cg-get g :turn)))
|
||||
(cond
|
||||
((not (eq (cg-get g :phase) 'play)) (cg-put g :message "Press n to continue."))
|
||||
((not (memq turn (cg-bridge--controls g)))
|
||||
(cg-put g :message "Wait for your turn."))
|
||||
(t (let ((card (nth (cg-get g :cursor) (cg-bridge--sort (cg-bridge--hand g turn)))))
|
||||
(if (or (null card) (not (cg-bridge--legal-play-p g turn card)))
|
||||
(cg-put g :message "You must follow suit.")
|
||||
(cg-bridge--play-card g turn card)
|
||||
(cg-put g :cursor 0)
|
||||
(when (eq (cg-get g :phase) 'play) (cg-bridge--run-play g))))))
|
||||
(cg-bridge--redisplay)))))
|
||||
|
||||
(defun cg-bridge-new ()
|
||||
"Deal the next hand, or a fresh rubber when one is over."
|
||||
(interactive)
|
||||
(let ((g cg-bridge--game))
|
||||
(when (or (cg-get g :rubber-winner))
|
||||
(cg-put g :below (make-vector 2 0)) (cg-put g :above (make-vector 2 0))
|
||||
(cg-put g :games (make-vector 2 0)) (cg-put g :vul (make-vector 2 nil))
|
||||
(cg-put g :rubber-winner nil))
|
||||
(cg-put g :dealer (mod (1+ (or (cg-get g :dealer) 0)) 4))
|
||||
(cg-bridge--deal g)
|
||||
(cg-bridge--run-auction g)
|
||||
(cg-bridge--redisplay)))
|
||||
|
||||
(defun cg-bridge-redraw () "Redraw." (interactive) (cg-bridge--redisplay))
|
||||
(defun cg-bridge-help () "Describe the controls." (interactive)
|
||||
(message "Auction: Up/Down level, Left/Right strain, RET bid, p pass, d double. Play: arrows + RET. n: next"))
|
||||
|
||||
(defvar cg-bridge-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'cg-card-click)
|
||||
(define-key map "+" #'cg-card-zoom-in)
|
||||
(define-key map "=" #'cg-card-zoom-in)
|
||||
(define-key map "-" #'cg-card-zoom-out)
|
||||
(define-key map "0" #'cg-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'cg-bridge-left)
|
||||
(define-key map (kbd "<right>") #'cg-bridge-right)
|
||||
(define-key map (kbd "<up>") #'cg-bridge-up)
|
||||
(define-key map (kbd "<down>") #'cg-bridge-down)
|
||||
(define-key map (kbd "RET") #'cg-bridge-play)
|
||||
(define-key map "p" #'cg-bridge-pass)
|
||||
(define-key map "d" #'cg-bridge-double)
|
||||
(define-key map "n" #'cg-bridge-new)
|
||||
(define-key map "g" #'cg-bridge-redraw)
|
||||
(define-key map "?" #'cg-bridge-help)
|
||||
(define-key map "q" #'cg-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `cg-bridge-mode'.")
|
||||
|
||||
(define-derived-mode cg-bridge-mode special-mode "Bridge"
|
||||
"Major mode for contract Bridge."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type cg-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-bridge ()
|
||||
"Play contract Bridge against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Bridge*")))
|
||||
(with-current-buffer buf
|
||||
(cg-bridge-mode)
|
||||
(setq cg-bridge--game (cg-bridge-game))
|
||||
(cg-put cg-bridge--game :dealer 0)
|
||||
(cg-bridge--deal cg-bridge--game)
|
||||
(cg-bridge--run-auction cg-bridge--game)
|
||||
(cg-bridge--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
(provide 'cg-bridge)
|
||||
;;; cg-bridge.el ends here
|
||||
903
cg-crapette.el
903
cg-crapette.el
|
|
@ -1,903 +0,0 @@
|
|||
;;; cg-crapette.el --- Russian Bank (Crapette), two-player vs AI -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Russian Bank -- also called Crapette -- is the competitive, two-player
|
||||
;; ancestor of the single-player patience in `cg-solitaire'. You (South)
|
||||
;; play against one computer opponent (North).
|
||||
;;
|
||||
;; Two 52-card packs are used, one per player. In the centre sit eight
|
||||
;; FOUNDATIONS, built up by suit from the Ace, and eight HOUSES, built
|
||||
;; down in alternating colours; both are common ground either player may
|
||||
;; build on. Each player also has a 13-card RESERVE (its top card face
|
||||
;; up), a WASTE, and a face-down HAND. You win by getting rid of every
|
||||
;; card in your reserve, hand, and waste.
|
||||
;;
|
||||
;; On your turn you make as many legal moves as you like:
|
||||
;; - move the top of your reserve, your waste, or any house onto a
|
||||
;; foundation or a house;
|
||||
;; - move a whole SEQUENCE (a run built down in alternating colours)
|
||||
;; from one house to another -- but only when there are enough empty
|
||||
;; houses to have shifted it a card at a time; and
|
||||
;; - LOAD a card from your reserve or waste onto the opponent's reserve
|
||||
;; or waste when it is the same suit and one rank up or down.
|
||||
;;
|
||||
;; FOUNDATION PRIORITY and "STOP": a card that can go to a foundation must
|
||||
;; be played there before anything else. If you build a house, load your
|
||||
;; opponent, turn a card, or end your turn while a foundation play is
|
||||
;; waiting, your opponent calls "STOP!" and your turn ends at once. The
|
||||
;; piles that owe a foundation play are ringed in the hint colour. Set
|
||||
;; `cg-crapette-stops' to nil for a gentler assist mode that blocks the
|
||||
;; slip with a reminder instead of ending your turn.
|
||||
;;
|
||||
;; When you can do no more, turn the top of your hand: if it fits
|
||||
;; somewhere you keep going, otherwise it goes to your waste and your turn
|
||||
;; ends.
|
||||
;;
|
||||
;; The AI observes foundation priority, empties its reserve first (the
|
||||
;; bottleneck), prefers loading its cards onto you, and looks one move
|
||||
;; ahead to rearrange the houses when that frees a stuck reserve or waste
|
||||
;; card. It never breaks foundation priority, so in practice only you can
|
||||
;; be "stopped".
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cg-core)
|
||||
(require 'cg-svg)
|
||||
|
||||
(defconst cg-crap-ranks
|
||||
["A" "2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K"]
|
||||
"Rank labels indexed 0 (Ace) .. 12 (King).")
|
||||
|
||||
(defcustom cg-crapette-stops t
|
||||
"How Russian Bank enforces foundation priority on your turn.
|
||||
When non-nil (the competitive rule), the opponent calls \"stop\" and you
|
||||
forfeit the rest of your turn if you make any play other than an
|
||||
available foundation move. When nil, such a slip is simply blocked with
|
||||
a reminder and costs you nothing -- a gentler assist mode for learning."
|
||||
:type 'boolean :group 'card-games)
|
||||
|
||||
(defcustom cg-crapette-svg-cards t
|
||||
"When non-nil, draw the board with SVG cards on a graphical display.
|
||||
Set to nil to force the plain-text board everywhere."
|
||||
:type 'boolean :group 'card-games)
|
||||
|
||||
(defclass cg-crapette-game (cg-game)
|
||||
((vname :initform "Russian Bank"))
|
||||
"Two-player Russian Bank (Crapette): you (South) versus one AI opponent.")
|
||||
|
||||
(defvar-local cg-crap--game nil
|
||||
"The `cg-crapette-game' played in the current buffer.")
|
||||
|
||||
(defvar cg-crap--recording t
|
||||
"When nil, `cg-crap--snapshot' does not record (used during the AI turn).")
|
||||
|
||||
|
||||
;;;; Cards
|
||||
|
||||
(defun cg-crap--card-string (card)
|
||||
"Return a short label for CARD, or a dot for an empty pile."
|
||||
(if (null card) "·"
|
||||
(concat (aref cg-crap-ranks (cdr card)) (cg-suit-glyph (car card)))))
|
||||
|
||||
(defun cg-crap--red-p (card)
|
||||
"Return non-nil when CARD is a red suit."
|
||||
(and card (cg-red-suit-p (car card))))
|
||||
|
||||
(defun cg-crap--spec (card)
|
||||
"Return the cg-svg display spec (RANK-STRING . SUIT) for CARD, or nil."
|
||||
(and card (cons (aref cg-crap-ranks (cdr card)) (car card))))
|
||||
|
||||
(defun cg-crap--deck ()
|
||||
"Return one freshly shuffled 52-card deck."
|
||||
(let (cards)
|
||||
(dotimes (s 4) (dotimes (r 13) (push (cons s r) cards)))
|
||||
(cg-shuffle cards)))
|
||||
|
||||
(defun cg-crap--top (pile)
|
||||
"Return the top (last) card of PILE, or nil."
|
||||
(car (last pile)))
|
||||
|
||||
|
||||
;;;; Pile access
|
||||
|
||||
(defun cg-crap--found (g i) "Foundation I of G." (aref (cg-get g :found) i))
|
||||
(defun cg-crap--house (g i) "House I of G." (aref (cg-get g :houses) i))
|
||||
(defun cg-crap--reserve (g p) "Player P's reserve list in G." (aref (cg-get g :reserve) p))
|
||||
(defun cg-crap--waste (g p) "Player P's waste list in G." (aref (cg-get g :waste) p))
|
||||
(defun cg-crap--hand (g p) "Player P's hand list in G." (aref (cg-get g :hand) p))
|
||||
|
||||
|
||||
;;;; Dealing
|
||||
|
||||
(defun cg-crap--deal (game)
|
||||
"Deal a fresh Russian Bank layout into GAME and return it."
|
||||
(let ((d0 (cg-crap--deck)) (d1 (cg-crap--deck))
|
||||
(found (make-vector 8 nil)) (houses (make-vector 8 nil))
|
||||
(reserve (make-vector 2 nil)) (waste (make-vector 2 nil))
|
||||
(hand (make-vector 2 nil)))
|
||||
(dotimes (i 4) (aset houses i (list (pop d0))))
|
||||
(dotimes (i 4) (aset houses (+ 4 i) (list (pop d1))))
|
||||
(aset reserve 0 (cl-loop repeat 13 collect (pop d0)))
|
||||
(aset reserve 1 (cl-loop repeat 13 collect (pop d1)))
|
||||
(aset hand 0 d0)
|
||||
(aset hand 1 d1)
|
||||
(cg-put game :found found)
|
||||
(cg-put game :houses houses)
|
||||
(cg-put game :reserve reserve)
|
||||
(cg-put game :waste waste)
|
||||
(cg-put game :hand hand)
|
||||
(cg-put game :turn 0)
|
||||
(cg-put game :cursor 0)
|
||||
(cg-put game :sel nil)
|
||||
(cg-put game :moves 0)
|
||||
(cg-put game :history nil)
|
||||
(cg-put game :winner nil)
|
||||
(cg-put game :message
|
||||
"Your turn. Foundations first -- skip one and North calls STOP! Build the houses or load North.")
|
||||
game))
|
||||
|
||||
|
||||
;;;; Legality
|
||||
|
||||
(defun cg-crap--found-accepts (game i card)
|
||||
"Return non-nil when CARD may go onto foundation I of GAME."
|
||||
(and card
|
||||
(let ((f (cg-crap--found game i)))
|
||||
(if (null f)
|
||||
(= (cdr card) 0) ; empty foundation takes an Ace
|
||||
(let ((top (cg-crap--top f)))
|
||||
(and (= (car card) (car top))
|
||||
(= (cdr card) (1+ (cdr top)))))))))
|
||||
|
||||
(defun cg-crap--house-accepts (game i card)
|
||||
"Return non-nil when CARD may go onto house I of GAME."
|
||||
(and card
|
||||
(let ((h (cg-crap--house game i)))
|
||||
(if (null h)
|
||||
t ; empty house takes anything
|
||||
(cg-crap--builds-down-p (cg-crap--top h) card)))))
|
||||
|
||||
(defun cg-crap--builds-down-p (upper lower)
|
||||
"Return non-nil when LOWER may sit on UPPER: one rank down, opposite colour."
|
||||
(and upper lower
|
||||
(= (cdr lower) (1- (cdr upper)))
|
||||
(not (eq (cg-crap--red-p upper) (cg-crap--red-p lower)))))
|
||||
|
||||
(defun cg-crap--load-accepts (pile-top card)
|
||||
"Return non-nil when CARD may be loaded onto a pile whose top is PILE-TOP.
|
||||
Loading needs the same suit and a rank one step up or down."
|
||||
(and pile-top card
|
||||
(= (car pile-top) (car card))
|
||||
(= 1 (abs (- (cdr pile-top) (cdr card))))))
|
||||
|
||||
(defun cg-crap--found-for (game card)
|
||||
"Return the index of a foundation that would accept CARD, or nil."
|
||||
(cl-loop for i below 8 when (cg-crap--found-accepts game i card) return i))
|
||||
|
||||
|
||||
;;;; Sequenced house moves
|
||||
|
||||
(defun cg-crap--house-run (game i)
|
||||
"Return the movable top run of house I as a list, bottom-to-top.
|
||||
The run is the longest sequence of cards at the top of the house that is
|
||||
built down in alternating colours."
|
||||
(let ((rev (reverse (cg-crap--house game i)))) ; top-first
|
||||
(if (null rev) nil
|
||||
(let ((run (list (car rev))) (prev (car rev)))
|
||||
(catch 'done
|
||||
(dolist (c (cdr rev)) ; each C sits below PREV
|
||||
(if (cg-crap--builds-down-p c prev)
|
||||
(progn (push c run) (setq prev c)) ; PREV builds down on C
|
||||
(throw 'done nil))))
|
||||
run))))
|
||||
|
||||
(defun cg-crap--free-houses (game)
|
||||
"Return the number of empty houses in GAME."
|
||||
(cl-count-if #'null (append (cg-get game :houses) nil)))
|
||||
|
||||
(defun cg-crap--capacity (game dest-i)
|
||||
"Return how many cards may be moved as a group onto house DEST-I.
|
||||
With F empty houses you may relay F+1 cards onto a non-empty house, or
|
||||
F onto an empty house (the destination itself cannot serve as a relay)."
|
||||
(let ((free (cg-crap--free-houses game)))
|
||||
(if (cg-crap--house game dest-i) (1+ free) free)))
|
||||
|
||||
(defun cg-crap--house-move (game i j &optional want)
|
||||
"Move a legal sequence from house I onto house J in GAME.
|
||||
WANT, when given, is how many of the top cards to move onto an EMPTY
|
||||
house (default the whole run); it is ignored for a non-empty house, where
|
||||
the landing rank fixes the count. Return non-nil on success, the symbol
|
||||
`space' when the sequence is legal but there are too few empty houses,
|
||||
and nil when nothing fits."
|
||||
(if (= i j)
|
||||
nil
|
||||
(let* ((run (cg-crap--house-run game i))
|
||||
(rlen (length run))
|
||||
(dst (cg-crap--house game j))
|
||||
(dsttop (cg-crap--top dst))
|
||||
(cap (cg-crap--capacity game j))
|
||||
(n nil))
|
||||
(when (> rlen 0)
|
||||
(if (null dsttop)
|
||||
(setq n (min (or want rlen) rlen)) ; empty house: the chosen count
|
||||
(cl-loop for k from 0 below rlen ; RUN is bottom-to-top
|
||||
for card = (nth k run)
|
||||
when (cg-crap--builds-down-p dsttop card)
|
||||
do (setq n (- rlen k)) (cl-return)))
|
||||
(cond
|
||||
((or (null n) (< n 1)) nil)
|
||||
((> n cap) 'space)
|
||||
(t
|
||||
(cg-crap--snapshot game)
|
||||
(let* ((pile (cg-crap--house game i))
|
||||
(keep (butlast pile n))
|
||||
(moved (last pile n)))
|
||||
(aset (cg-get game :houses) i keep)
|
||||
(aset (cg-get game :houses) j (append dst moved)))
|
||||
(cg-put game :moves (1+ (cg-get game :moves)))
|
||||
t))))))
|
||||
|
||||
|
||||
;;;; Spots (the cursor visits piles)
|
||||
|
||||
(defun cg-crap--spots (_game)
|
||||
"Return the ordered list of (TYPE . INDEX) spots the cursor visits."
|
||||
(append (list '(res . 0) '(was . 0))
|
||||
(cl-loop for i below 8 collect (cons 'house i))
|
||||
(cl-loop for i below 8 collect (cons 'found i))
|
||||
(list '(res . 1) '(was . 1))))
|
||||
|
||||
(defun cg-crap--sources (_game p)
|
||||
"Return the spots whose top card player P may pick up."
|
||||
(append (list (cons 'res p) (cons 'was p))
|
||||
(cl-loop for i below 8 collect (cons 'house i))))
|
||||
|
||||
(defun cg-crap--spot-top (game spot)
|
||||
"Return the top card available at SPOT of GAME, or nil."
|
||||
(pcase (car spot)
|
||||
('res (cg-crap--top (cg-crap--reserve game (cdr spot))))
|
||||
('was (cg-crap--top (cg-crap--waste game (cdr spot))))
|
||||
('house (cg-crap--top (cg-crap--house game (cdr spot))))
|
||||
('found (cg-crap--top (cg-crap--found game (cdr spot))))))
|
||||
|
||||
(defun cg-crap--source-p (spot p)
|
||||
"Return non-nil when SPOT is a pile player P may take a card from."
|
||||
(pcase (car spot)
|
||||
('res (= (cdr spot) p))
|
||||
('was (= (cdr spot) p))
|
||||
('house t)
|
||||
(_ nil)))
|
||||
|
||||
(defun cg-crap--dest-ok (game from to card p)
|
||||
"Return non-nil when player P may move CARD from spot FROM to spot TO."
|
||||
(pcase (car to)
|
||||
('found (cg-crap--found-accepts game (cdr to) card))
|
||||
('house (cg-crap--house-accepts game (cdr to) card))
|
||||
((or 'res 'was)
|
||||
(and (= (cdr to) (- 1 p)) ; only onto the opponent
|
||||
(memq (car from) '(res was)) ; only your reserve/waste cards load
|
||||
(cg-crap--load-accepts (cg-crap--spot-top game to) card)))))
|
||||
|
||||
|
||||
;;;; Moving cards
|
||||
|
||||
(defun cg-crap--snapshot (game)
|
||||
"Record GAME's mutable state for undo, unless recording is disabled."
|
||||
(when cg-crap--recording
|
||||
(cg-put game :history
|
||||
(cons (list (cg-crap--copy-vec (cg-get game :found))
|
||||
(cg-crap--copy-vec (cg-get game :houses))
|
||||
(cg-crap--copy-vec (cg-get game :reserve))
|
||||
(cg-crap--copy-vec (cg-get game :waste))
|
||||
(cg-crap--copy-vec (cg-get game :hand))
|
||||
(cg-get game :turn))
|
||||
(cg-get game :history)))))
|
||||
|
||||
(defun cg-crap--copy-vec (v)
|
||||
"Return a copy of vector V with each element list copied."
|
||||
(vconcat (mapcar #'copy-sequence v)))
|
||||
|
||||
(defun cg-crap--take (game spot)
|
||||
"Remove and return the top card of SPOT's pile in GAME."
|
||||
(pcase (car spot)
|
||||
('res (let* ((p (cdr spot)) (pile (cg-crap--reserve game p)))
|
||||
(aset (cg-get game :reserve) p (butlast pile 1)) (cg-crap--top pile)))
|
||||
('was (let* ((p (cdr spot)) (pile (cg-crap--waste game p)))
|
||||
(aset (cg-get game :waste) p (butlast pile 1)) (cg-crap--top pile)))
|
||||
('house (let* ((i (cdr spot)) (pile (cg-crap--house game i)))
|
||||
(aset (cg-get game :houses) i (butlast pile 1)) (cg-crap--top pile)))))
|
||||
|
||||
(defun cg-crap--place (game spot card)
|
||||
"Add CARD to the top of SPOT's pile in GAME."
|
||||
(pcase (car spot)
|
||||
('found (let ((i (cdr spot)))
|
||||
(aset (cg-get game :found) i (append (cg-crap--found game i) (list card)))))
|
||||
('house (let ((i (cdr spot)))
|
||||
(aset (cg-get game :houses) i (append (cg-crap--house game i) (list card)))))
|
||||
('res (let ((p (cdr spot)))
|
||||
(aset (cg-get game :reserve) p (append (cg-crap--reserve game p) (list card)))))
|
||||
('was (let ((p (cdr spot)))
|
||||
(aset (cg-get game :waste) p (append (cg-crap--waste game p) (list card)))))))
|
||||
|
||||
(defun cg-crap--move (game from to p)
|
||||
"Move the top card of FROM onto TO for player P.
|
||||
Return non-nil when the move was legal and performed."
|
||||
(let ((card (cg-crap--spot-top game from)))
|
||||
(when (and card (cg-crap--source-p from p) (cg-crap--dest-ok game from to card p))
|
||||
(cg-crap--snapshot game)
|
||||
(cg-crap--take game from)
|
||||
(cg-crap--place game to card)
|
||||
(cg-put game :moves (1+ (cg-get game :moves)))
|
||||
t)))
|
||||
|
||||
(defun cg-crap--do-move (game from to p &optional want)
|
||||
"Perform player P's move from FROM to TO in GAME.
|
||||
A house-to-house move may carry a legal sequence of cards (see
|
||||
`cg-crap--house-move', to which WANT is passed); every other move carries
|
||||
a single card. Returns the same values as those functions (non-nil on
|
||||
success, `space' when a sequence is too long for the empty houses)."
|
||||
(if (and (eq (car from) 'house) (eq (car to) 'house))
|
||||
(cg-crap--house-move game (cdr from) (cdr to) want)
|
||||
(cg-crap--move game from to p)))
|
||||
|
||||
|
||||
;;;; Turn logic
|
||||
|
||||
(defun cg-crap--forced (game p)
|
||||
"Return the source spots of GAME whose top card must go to a foundation."
|
||||
(let (out)
|
||||
(dolist (spot (cg-crap--sources game p))
|
||||
(let ((card (cg-crap--spot-top game spot)))
|
||||
(when (and card (cg-crap--found-for game card)) (push spot out))))
|
||||
(nreverse out)))
|
||||
|
||||
(defun cg-crap--card-playable (game p card)
|
||||
"Return non-nil when CARD has any legal destination for player P."
|
||||
(or (cg-crap--found-for game card)
|
||||
(cl-loop for i below 8 thereis (cg-crap--house-accepts game i card))
|
||||
(cg-crap--load-accepts (cg-crap--top (cg-crap--reserve game (- 1 p))) card)
|
||||
(cg-crap--load-accepts (cg-crap--top (cg-crap--waste game (- 1 p))) card)))
|
||||
|
||||
(defun cg-crap--won-p (game p)
|
||||
"Return non-nil when player P has emptied reserve, hand, and waste."
|
||||
(and (null (cg-crap--reserve game p))
|
||||
(null (cg-crap--hand game p))
|
||||
(null (cg-crap--waste game p))))
|
||||
|
||||
(cl-defmethod cg-won-p ((game cg-crapette-game))
|
||||
"Return non-nil when you (South) have won GAME."
|
||||
(eq (cg-get game :winner) 0))
|
||||
|
||||
(defun cg-crap--msg (game s)
|
||||
"Set GAME's status message to S."
|
||||
(cg-put game :message s))
|
||||
|
||||
(defun cg-crap--after-human-move (game)
|
||||
"Note a win after a human move in GAME."
|
||||
(when (cg-crap--won-p game 0)
|
||||
(cg-put game :winner 0)
|
||||
(cg-crap--msg game "You emptied your cards -- you win!")))
|
||||
|
||||
(defun cg-crap--end-turn (game)
|
||||
"Pass the turn from you to the AI, run it, and return control to you."
|
||||
(unless (cg-get game :winner)
|
||||
(cg-put game :sel nil)
|
||||
(cg-put game :turn 1)
|
||||
(let ((cg-crap--recording nil))
|
||||
(cg-crap--ai-play game))
|
||||
(unless (cg-get game :winner)
|
||||
(cg-put game :turn 0)
|
||||
(cg-put game :history nil))))
|
||||
|
||||
(defun cg-crap--stop (game)
|
||||
"Enforce foundation priority: call \"stop\" or block, per `cg-crapette-stops'.
|
||||
Return non-nil when the offending action must be abandoned by its caller."
|
||||
(when (cg-crap--forced game 0)
|
||||
(if cg-crapette-stops
|
||||
(let ((note "North calls STOP -- you must play to a foundation first!"))
|
||||
(message "%s" note)
|
||||
(cg-put game :sel nil)
|
||||
(cg-crap--end-turn game)
|
||||
(cg-put game :message (concat note " " (cg-get game :message))))
|
||||
(cg-crap--msg game "Play to a foundation first (press f on a highlighted pile)."))
|
||||
t))
|
||||
|
||||
|
||||
;;;; The AI opponent (player 1)
|
||||
|
||||
(defun cg-crap--ai-found-move (game)
|
||||
"Return an AI (SOURCE . FOUNDATION) foundation move, or nil."
|
||||
(cl-loop for spot in (cg-crap--sources game 1)
|
||||
for card = (cg-crap--spot-top game spot)
|
||||
for fi = (and card (cg-crap--found-for game card))
|
||||
when fi return (cons spot (cons 'found fi))))
|
||||
|
||||
(defun cg-crap--ai-unload-move (game)
|
||||
"Return the best AI (SOURCE . DEST) move that empties its reserve or waste.
|
||||
Emptying the RESERVE is the goal of the game, so it outscores the waste;
|
||||
LOADING a card onto you (which also burdens you) outscores building a
|
||||
house. Every such move reduces the AI's own cards, so its turn ends."
|
||||
(let ((best nil) (bestscore 0))
|
||||
(dolist (spot (list (cons 'res 1) (cons 'was 1)))
|
||||
(let ((card (cg-crap--spot-top game spot))
|
||||
(base (if (eq (car spot) 'res) 40 0))) ; the reserve is the bottleneck
|
||||
(when card
|
||||
(dolist (dst (list (cons 'res 0) (cons 'was 0)))
|
||||
(when (cg-crap--load-accepts (cg-crap--spot-top game dst) card)
|
||||
(let ((sc (+ base 60))) ; loading: rid a card AND burden you
|
||||
(when (> sc bestscore)
|
||||
(setq bestscore sc best (cons spot dst))))))
|
||||
(cl-loop for i below 8
|
||||
when (cg-crap--house-accepts game i card)
|
||||
do (let ((sc (+ base 50))) ; else build it onto a house
|
||||
(when (> sc bestscore)
|
||||
(setq bestscore sc best (cons spot (cons 'house i)))))
|
||||
(cl-return)))))
|
||||
best))
|
||||
|
||||
(defun cg-crap--ai-enabling-move (game)
|
||||
"Return a single-card house->house move that unlocks an unload, or nil.
|
||||
This is the crafty bit: when the AI cannot place its reserve or waste top
|
||||
anywhere, it looks one move ahead for a house rearrangement that would
|
||||
make such a placement legal. It only fires when no direct unload exists,
|
||||
and only when the shuffle genuinely opens one, so the turn still ends."
|
||||
(when (null (cg-crap--ai-unload-move game))
|
||||
(catch 'found
|
||||
(dotimes (i 8)
|
||||
(dotimes (j 8)
|
||||
(let ((pilei (cg-crap--house game i)) (pilej (cg-crap--house game j)))
|
||||
(when (and (/= i j) pilei)
|
||||
(let ((card (cg-crap--top pilei)))
|
||||
(when (cg-crap--house-accepts game j card)
|
||||
(aset (cg-get game :houses) i (butlast pilei 1))
|
||||
(aset (cg-get game :houses) j (append pilej (list card)))
|
||||
(let ((opens (cg-crap--ai-unload-move game)))
|
||||
(aset (cg-get game :houses) i pilei)
|
||||
(aset (cg-get game :houses) j pilej)
|
||||
(when opens
|
||||
(throw 'found (cons (cons 'house i) (cons 'house j)))))))))))
|
||||
nil)))
|
||||
|
||||
(defun cg-crap--ai-greedy-move (game)
|
||||
"A simple first-fit unload move -- the `easy' AI.
|
||||
Empties the reserve or waste top onto the first legal spot, without the
|
||||
scoring or the house-rearranging lookahead of the tougher levels."
|
||||
(catch 'm
|
||||
(dolist (spot (list (cons 'res 1) (cons 'was 1)))
|
||||
(let ((card (cg-crap--spot-top game spot)))
|
||||
(when card
|
||||
(dolist (dst (list (cons 'res 0) (cons 'was 0)))
|
||||
(when (cg-crap--load-accepts (cg-crap--spot-top game dst) card)
|
||||
(throw 'm (cons spot dst))))
|
||||
(cl-loop for i below 8
|
||||
when (cg-crap--house-accepts game i card)
|
||||
do (throw 'm (cons spot (cons 'house i)))))))
|
||||
nil))
|
||||
|
||||
(defun cg-crap--ai-play (game)
|
||||
"Play the AI opponent's whole turn on GAME, per `cg-ai-level'."
|
||||
(let ((guard 0) (level cg-ai-level))
|
||||
(catch 'done
|
||||
(while t
|
||||
(when (> (setq guard (1+ guard)) 800) (throw 'done nil))
|
||||
(when (cg-crap--won-p game 1) (throw 'done nil))
|
||||
(let ((mv (or (cg-crap--ai-found-move game)
|
||||
(if (eq level 'easy)
|
||||
(cg-crap--ai-greedy-move game)
|
||||
(cg-crap--ai-unload-move game))
|
||||
(and (eq level 'hard) (cg-crap--ai-enabling-move game)))))
|
||||
(cond
|
||||
(mv (cg-crap--move game (car mv) (cdr mv) 1))
|
||||
((cg-crap--hand game 1)
|
||||
(let* ((hand (cg-crap--hand game 1)) (card (cg-crap--top hand)))
|
||||
(aset (cg-get game :hand) 1 (butlast hand 1))
|
||||
(aset (cg-get game :waste) 1 (append (cg-crap--waste game 1) (list card)))
|
||||
(unless (cg-crap--card-playable game 1 card) (throw 'done 'flip-end))))
|
||||
(t (throw 'done 'stuck))))))
|
||||
(if (cg-crap--won-p game 1)
|
||||
(progn (cg-put game :winner 1)
|
||||
(cg-crap--msg game "Your opponent emptied their cards -- you lose."))
|
||||
(cg-crap--msg game "Your opponent finished their turn. Your move."))))
|
||||
|
||||
|
||||
;;;; Rendering (text)
|
||||
|
||||
(defun cg-crap--render (g)
|
||||
"Return a propertized depiction of Russian Bank game G."
|
||||
(let* ((spots (cg-crap--spots g))
|
||||
(cur (nth (cg-get g :cursor) spots))
|
||||
(sel (cg-get g :sel))
|
||||
(forced (cg-crap--forced g 0))
|
||||
(turn (cg-get g :turn))
|
||||
(win (cg-get g :winner)))
|
||||
(cl-flet ((cell (spot label)
|
||||
(let* ((card (cg-crap--spot-top g spot))
|
||||
(txt (concat label (cg-crap--card-string card)))
|
||||
(face (cond ((equal spot cur) 'cg-cursor)
|
||||
((equal spot sel) 'cg-hint)
|
||||
((member spot forced) 'cg-hint)
|
||||
((cg-crap--red-p card) 'cg-red-suit)
|
||||
(t 'default))))
|
||||
(propertize (format "%-8s" txt) 'face face))))
|
||||
(concat
|
||||
(format " Russian Bank -- %s\n\n"
|
||||
(cond ((eq win 0) "you win!")
|
||||
((eq win 1) "you lose")
|
||||
((= turn 0) "your turn")
|
||||
(t "opponent's turn")))
|
||||
(format " Opponent (North) hand:%2d reserve:%2d waste:%2d\n "
|
||||
(length (cg-crap--hand g 1)) (length (cg-crap--reserve g 1))
|
||||
(length (cg-crap--waste g 1)))
|
||||
(cell '(res . 1) "R:") (cell '(was . 1) "W:") "\n\n"
|
||||
" Foundations (build up by suit)\n "
|
||||
(cell '(found . 0) "") (cell '(found . 1) "")
|
||||
(cell '(found . 2) "") (cell '(found . 3) "") "\n "
|
||||
(cell '(found . 4) "") (cell '(found . 5) "")
|
||||
(cell '(found . 6) "") (cell '(found . 7) "") "\n\n"
|
||||
" Houses (build down, alternating colours)\n "
|
||||
(cell '(house . 0) "") (cell '(house . 1) "")
|
||||
(cell '(house . 2) "") (cell '(house . 3) "") "\n "
|
||||
(cell '(house . 4) "") (cell '(house . 5) "")
|
||||
(cell '(house . 6) "") (cell '(house . 7) "") "\n\n"
|
||||
(format " You (South) hand:%2d reserve:%2d waste:%2d\n "
|
||||
(length (cg-crap--hand g 0)) (length (cg-crap--reserve g 0))
|
||||
(length (cg-crap--waste g 0)))
|
||||
(cell '(res . 0) "R:") (cell '(was . 0) "W:") "\n\n"
|
||||
(format " %s\n" (cg-get g :message))
|
||||
(cg-crap--holding-line g)))))
|
||||
|
||||
(defun cg-crap--holding-line (g)
|
||||
"Return a line showing the picked-up house run, marking the held top cards.
|
||||
Empty when nothing (or a single card) is held from a house."
|
||||
(let ((sel (cg-get g :sel)))
|
||||
(if (not (and sel (eq (car sel) 'house)))
|
||||
""
|
||||
(let* ((run (cg-crap--house-run g (cdr sel)))
|
||||
(m (length run))
|
||||
(held (min (or (cg-get g :sel-n) m) m))
|
||||
(i 0) (parts nil))
|
||||
(if (< m 2)
|
||||
""
|
||||
(dolist (c run)
|
||||
(let ((on (>= i (- m held))))
|
||||
(push (propertize (concat (cg-crap--card-string c) " ")
|
||||
'face (cond (on 'cg-hint)
|
||||
((cg-crap--red-p c) 'cg-red-suit)
|
||||
(t 'shadow)))
|
||||
parts))
|
||||
(setq i (1+ i)))
|
||||
(concat " Holding: " (apply #'concat (nreverse parts))
|
||||
(format "(moving top %d of %d)\n" held m)))))))
|
||||
|
||||
(defun cg-crap--svg (g)
|
||||
"Return (DISPLAY-STRING . REGIONS) drawing Russian Bank game G as SVG.
|
||||
REGIONS maps clicked rectangles to (TYPE . INDEX) spots."
|
||||
(let* ((w cg-svg-card-width) (h cg-svg-card-height)
|
||||
(gap cg-svg-card-gap) (pad 12) (colgap 14)
|
||||
(vdown (max 16 (round (* h 0.26))))
|
||||
(spots (cg-crap--spots g))
|
||||
(cur (nth (cg-get g :cursor) spots))
|
||||
(sel (cg-get g :sel))
|
||||
(forced (cg-crap--forced g 0))
|
||||
(heldn (and sel (eq (car sel) 'house)
|
||||
(min (or (cg-get g :sel-n) 0)
|
||||
(length (cg-crap--house-run g (cdr sel))))))
|
||||
(houses (cg-get g :houses))
|
||||
(maxlen (apply #'max 1 (mapcar #'length (append houses nil))))
|
||||
(fx (+ w gap)) (hx (+ w colgap))
|
||||
(width (+ (* 2 pad) (* 8 w) (* 7 colgap)))
|
||||
(y-title 6) (y-opp 34)
|
||||
(y-found (+ y-opp h 30))
|
||||
(y-house (+ y-found h 30))
|
||||
(house-h (+ h (* (1- maxlen) vdown)))
|
||||
(y-you (+ y-house house-h 28))
|
||||
(height (+ y-you h 34))
|
||||
(svg (svg-create width height))
|
||||
(lc (cg-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels
|
||||
((txt (str x y &optional sz bold)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family cg-svg-font-family
|
||||
(if bold (list :font-weight "bold") nil)))
|
||||
(curp (spot) (equal spot cur))
|
||||
(forcedp (spot) (and (member spot forced) t))
|
||||
(pile-cell (spot x y)
|
||||
(let ((spec (cg-crap--spec (cg-crap--spot-top g spot))))
|
||||
(if spec
|
||||
(cg-svg-card svg x y :rank (car spec) :suit (cdr spec)
|
||||
:highlight (curp spot) :hint (forcedp spot))
|
||||
(cg-svg-card svg x y :gap t :highlight (curp spot)))
|
||||
(push (cons (list x y w h) spot) regions))))
|
||||
(txt (format "Russian Bank -- %s"
|
||||
(cond ((eq (cg-get g :winner) 0) "you win!")
|
||||
((eq (cg-get g :winner) 1) "you lose")
|
||||
((= (cg-get g :turn) 0) "your turn")
|
||||
(t "opponent's turn")))
|
||||
pad (+ y-title 12) 13 t)
|
||||
(txt (format "North reserve %d waste %d hand %d"
|
||||
(length (cg-crap--reserve g 1)) (length (cg-crap--waste g 1))
|
||||
(length (cg-crap--hand g 1)))
|
||||
pad (- y-opp 4))
|
||||
(pile-cell '(res . 1) pad y-opp)
|
||||
(pile-cell '(was . 1) (+ pad fx) y-opp)
|
||||
(txt "Foundations" pad (- y-found 4))
|
||||
(dotimes (i 8) (pile-cell (cons 'found i) (+ pad (* i fx)) y-found))
|
||||
(txt "Houses" pad (- y-house 4))
|
||||
(dotimes (i 8)
|
||||
(let* ((x (+ pad (* i hx))) (s (cons 'house i))
|
||||
(pile (aref houses i)) (len (length pile)))
|
||||
(push (cons (list x y-house w house-h) s) regions)
|
||||
(if (= len 0)
|
||||
(cg-svg-card svg x y-house :gap t :highlight (curp s))
|
||||
(let ((y y-house) (k 0))
|
||||
(dolist (card pile)
|
||||
(let ((spec (cg-crap--spec card)) (topp (= k (1- len))))
|
||||
(cg-svg-card svg x y :rank (car spec) :suit (cdr spec)
|
||||
:highlight (and topp (curp s))
|
||||
:hint (and topp (forcedp s)))
|
||||
(when (and (equal sel s) heldn (>= k (- len heldn)))
|
||||
(svg-rectangle svg (- x 3) (- y 3) (+ w 6) (+ h 6)
|
||||
:rx 8 :fill "none" :stroke "#4a90d9" :stroke-width 3)))
|
||||
(setq y (+ y vdown) k (1+ k)))))))
|
||||
(txt (format "You reserve %d waste %d hand %d"
|
||||
(length (cg-crap--reserve g 0)) (length (cg-crap--waste g 0))
|
||||
(length (cg-crap--hand g 0)))
|
||||
pad (- y-you 4))
|
||||
(pile-cell '(res . 0) pad y-you)
|
||||
(pile-cell '(was . 0) (+ pad fx) y-you)
|
||||
(txt (cg-get g :message) pad (- height 10) 12))
|
||||
(let ((rev (nreverse regions)))
|
||||
(cons (propertize "*" 'display (cg-svg-image svg (cg-scale))
|
||||
'cg-regions rev)
|
||||
rev))))
|
||||
|
||||
(defun cg-crap-mouse (event)
|
||||
"Handle a click on the SVG board: select that pile and act on it."
|
||||
(interactive "e")
|
||||
(let* ((g cg-crap--game) (spot (cg-mouse-action event)))
|
||||
(when spot
|
||||
(let ((idx (cl-position spot (cg-crap--spots g) :test #'equal)))
|
||||
(when idx (cg-put g :cursor idx) (cg-crap-act))))))
|
||||
|
||||
(cl-defmethod cg-render ((game cg-crapette-game))
|
||||
"Return a text depiction of GAME."
|
||||
(cg-crap--render game))
|
||||
|
||||
(defun cg-crap--redisplay ()
|
||||
"Redraw the current Russian Bank buffer (SVG on a graphical display)."
|
||||
(let ((g cg-crap--game) (inhibit-read-only t))
|
||||
(setq cg-current-game g)
|
||||
(setq-local cg-redisplay-function #'cg-crap--redisplay)
|
||||
(setq-local mode-line-process
|
||||
(format " [%s]"
|
||||
(cond ((eq (cg-get g :winner) 0) "you win")
|
||||
((eq (cg-get g :winner) 1) "you lose")
|
||||
((= (cg-get g :turn) 0) "your turn")
|
||||
(t "opponent"))))
|
||||
(erase-buffer)
|
||||
(if (and cg-crapette-svg-cards (display-graphic-p))
|
||||
(insert (car (cg-crap--svg g)) "\n")
|
||||
(insert (cg-crap--render g)))
|
||||
(cg-insert-legend
|
||||
"arrows/click move · RET pick up/drop · [ ] group size · f foundation · SPC turn · e end · u undo · n new · q menu")
|
||||
(goto-char (point-min))))
|
||||
|
||||
|
||||
;;;; Commands
|
||||
|
||||
(defun cg-crap--move-cursor (g d)
|
||||
"Move G's cursor by D spots and redisplay."
|
||||
(let ((n (length (cg-crap--spots g))))
|
||||
(cg-put g :cursor (mod (+ (cg-get g :cursor) d) n)))
|
||||
(cg-crap--redisplay))
|
||||
|
||||
(defun cg-crap-left () "Move the cursor to the previous pile."
|
||||
(interactive) (cg-crap--move-cursor cg-crap--game -1))
|
||||
(defun cg-crap-right () "Move the cursor to the next pile."
|
||||
(interactive) (cg-crap--move-cursor cg-crap--game 1))
|
||||
|
||||
(defun cg-crap--your-turn-p (g)
|
||||
"Return non-nil when it is your move (and warn otherwise)."
|
||||
(cond ((cg-get g :winner)
|
||||
(cg-crap--msg g "The game is over -- press n for a new game.") nil)
|
||||
((/= (cg-get g :turn) 0)
|
||||
(cg-crap--msg g "Wait for your turn.") nil)
|
||||
(t t)))
|
||||
|
||||
(defun cg-crap-act ()
|
||||
"Pick up the card under the cursor, or drop the picked-up card there."
|
||||
(interactive)
|
||||
(let* ((g cg-crap--game) (spots (cg-crap--spots g))
|
||||
(spot (nth (cg-get g :cursor) spots)) (sel (cg-get g :sel)))
|
||||
(when (cg-crap--your-turn-p g)
|
||||
(if sel
|
||||
(unless (and (not (eq (car spot) 'found)) (cg-crap--stop g))
|
||||
(let ((res (cg-crap--do-move g sel spot 0 (cg-get g :sel-n))))
|
||||
(cond
|
||||
((eq res 'space)
|
||||
(cg-crap--msg g "Not enough empty houses to move that many cards."))
|
||||
(res (cg-put g :sel nil) (cg-put g :sel-n nil) (cg-crap--after-human-move g))
|
||||
(t (cg-crap--msg g "That card can't go there.")))))
|
||||
(if (and (cg-crap--source-p spot 0) (cg-crap--spot-top g spot))
|
||||
(let* ((top (cg-crap--spot-top g spot))
|
||||
(run (and (eq (car spot) 'house) (cg-crap--house-run g (cdr spot))))
|
||||
(n (length run)))
|
||||
(cg-put g :sel spot)
|
||||
(cg-put g :sel-n (max 1 n))
|
||||
(cg-crap--msg g
|
||||
(if (> n 1)
|
||||
(format "Picked up a run of %d (%s on top) -- [ / ] to change how many, drop on a house."
|
||||
n (cg-crap--card-string top))
|
||||
(format "Picked up %s -- choose where to drop it."
|
||||
(cg-crap--card-string top)))))
|
||||
(cg-crap--msg g "Nothing of yours to pick up there."))))
|
||||
(cg-crap--redisplay)))
|
||||
|
||||
(defun cg-crap-found ()
|
||||
"Send the card under the cursor (or the picked-up card) to a foundation."
|
||||
(interactive)
|
||||
(let* ((g cg-crap--game) (spots (cg-crap--spots g))
|
||||
(spot (nth (cg-get g :cursor) spots)))
|
||||
(when (cg-crap--your-turn-p g)
|
||||
(let* ((src (or (cg-get g :sel) spot))
|
||||
(card (and (cg-crap--source-p src 0) (cg-crap--spot-top g src)))
|
||||
(fi (and card (cg-crap--found-for g card))))
|
||||
(if (and fi (cg-crap--move g src (cons 'found fi) 0))
|
||||
(progn (cg-put g :sel nil) (cg-crap--after-human-move g))
|
||||
(cg-crap--msg g "No foundation accepts that card."))))
|
||||
(cg-crap--redisplay)))
|
||||
|
||||
(defun cg-crap--hold-adjust (d)
|
||||
"Change how many cards of a picked-up house run you hold, by D."
|
||||
(let* ((g cg-crap--game) (sel (cg-get g :sel)))
|
||||
(when (cg-crap--your-turn-p g)
|
||||
(if (and sel (eq (car sel) 'house))
|
||||
(let* ((m (length (cg-crap--house-run g (cdr sel))))
|
||||
(new (max 1 (min m (+ (or (cg-get g :sel-n) m) d)))))
|
||||
(cg-put g :sel-n new)
|
||||
(cg-crap--msg g (format "Holding the top %d of %d -- drop on an empty house."
|
||||
new m)))
|
||||
(cg-crap--msg g "Pick up a house run first, then [ and ] set how many to move.")))
|
||||
(cg-crap--redisplay)))
|
||||
|
||||
(defun cg-crap-hold-less ()
|
||||
"Hold one fewer card of the picked-up run."
|
||||
(interactive) (cg-crap--hold-adjust -1))
|
||||
|
||||
(defun cg-crap-hold-more ()
|
||||
"Hold one more card of the picked-up run."
|
||||
(interactive) (cg-crap--hold-adjust 1))
|
||||
|
||||
(defun cg-crap-draw ()
|
||||
"Turn the top card of your hand onto your waste.
|
||||
If it fits nowhere your turn ends."
|
||||
(interactive)
|
||||
(let ((g cg-crap--game))
|
||||
(when (cg-crap--your-turn-p g)
|
||||
(unless (cg-crap--stop g)
|
||||
(if (null (cg-crap--hand g 0))
|
||||
(cg-crap--msg g "Your hand is empty -- press e to end your turn.")
|
||||
(cg-crap--snapshot g)
|
||||
(let* ((hand (cg-crap--hand g 0)) (card (cg-crap--top hand)))
|
||||
(aset (cg-get g :hand) 0 (butlast hand 1))
|
||||
(aset (cg-get g :waste) 0 (append (cg-crap--waste g 0) (list card)))
|
||||
(cg-put g :sel nil)
|
||||
(if (cg-crap--card-playable g 0 card)
|
||||
(cg-crap--msg g (format "Turned %s onto your waste -- play on."
|
||||
(cg-crap--card-string card)))
|
||||
(progn
|
||||
(cg-crap--msg g (format "Turned %s -- nothing to do, your turn ends."
|
||||
(cg-crap--card-string card)))
|
||||
(cg-crap--end-turn g)))))))
|
||||
(cg-crap--redisplay)))
|
||||
|
||||
(defun cg-crap-end ()
|
||||
"End your turn and let the opponent play."
|
||||
(interactive)
|
||||
(let ((g cg-crap--game))
|
||||
(when (cg-crap--your-turn-p g)
|
||||
(unless (cg-crap--stop g)
|
||||
(cg-crap--msg g "You end your turn.")
|
||||
(cg-crap--end-turn g)))
|
||||
(cg-crap--redisplay)))
|
||||
|
||||
(defun cg-crap-undo ()
|
||||
"Undo your last move this turn."
|
||||
(interactive)
|
||||
(let* ((g cg-crap--game) (h (cg-get g :history)))
|
||||
(if (null h)
|
||||
(cg-crap--msg g "Nothing to undo.")
|
||||
(let ((s (car h)))
|
||||
(cg-put g :found (nth 0 s)) (cg-put g :houses (nth 1 s))
|
||||
(cg-put g :reserve (nth 2 s)) (cg-put g :waste (nth 3 s))
|
||||
(cg-put g :hand (nth 4 s)) (cg-put g :turn (nth 5 s))
|
||||
(cg-put g :history (cdr h)) (cg-put g :sel nil) (cg-put g :winner nil)
|
||||
(cg-crap--msg g "Undid a move.")))
|
||||
(cg-crap--redisplay)))
|
||||
|
||||
(defun cg-crap-new ()
|
||||
"Deal a fresh Russian Bank game."
|
||||
(interactive)
|
||||
(cg-crap--deal cg-crap--game)
|
||||
(cg-crap--redisplay))
|
||||
|
||||
(defun cg-crap-redraw () "Redraw the board." (interactive) (cg-crap--redisplay))
|
||||
|
||||
(defun cg-crap-help ()
|
||||
"Describe the controls."
|
||||
(interactive)
|
||||
(message
|
||||
"Arrows: move RET: pick up/drop [ ]: how many cards of a run f: to foundation SPC: turn a card e: end u: undo n: new q: menu"))
|
||||
|
||||
(defvar cg-crapette-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map (kbd "<left>") #'cg-crap-left)
|
||||
(define-key map (kbd "<right>") #'cg-crap-right)
|
||||
(define-key map (kbd "<up>") #'cg-crap-left)
|
||||
(define-key map (kbd "<down>") #'cg-crap-right)
|
||||
(define-key map (kbd "RET") #'cg-crap-act)
|
||||
(define-key map [mouse-1] #'cg-crap-mouse)
|
||||
(define-key map "+" #'cg-card-zoom-in)
|
||||
(define-key map "=" #'cg-card-zoom-in)
|
||||
(define-key map "-" #'cg-card-zoom-out)
|
||||
(define-key map "0" #'cg-card-zoom-reset)
|
||||
(define-key map (kbd "SPC") #'cg-crap-draw)
|
||||
(define-key map "f" #'cg-crap-found)
|
||||
(define-key map "[" #'cg-crap-hold-less)
|
||||
(define-key map "]" #'cg-crap-hold-more)
|
||||
(define-key map "d" #'cg-crap-draw)
|
||||
(define-key map "e" #'cg-crap-end)
|
||||
(define-key map "u" #'cg-crap-undo)
|
||||
(define-key map "n" #'cg-crap-new)
|
||||
(define-key map "g" #'cg-crap-redraw)
|
||||
(define-key map "?" #'cg-crap-help)
|
||||
(define-key map "q" #'cg-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `cg-crapette-mode'.")
|
||||
|
||||
(define-derived-mode cg-crapette-mode special-mode "Crapette"
|
||||
"Major mode for two-player Russian Bank (Crapette)."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type cg-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-crapette ()
|
||||
"Play two-player Russian Bank (Crapette) against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Russian Bank (Crapette)*")))
|
||||
(with-current-buffer buf
|
||||
(cg-crapette-mode)
|
||||
(setq cg-crap--game (cg-crap--deal (cg-crapette-game)))
|
||||
(cg-crap--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;###autoload
|
||||
(defalias 'cg-russian-bank-duel #'cg-crapette
|
||||
"Alias for `cg-crapette'.")
|
||||
|
||||
(provide 'cg-crapette)
|
||||
;;; cg-crapette.el ends here
|
||||
526
cg-cribbage.el
526
cg-cribbage.el
|
|
@ -1,526 +0,0 @@
|
|||
;;; cg-cribbage.el --- Cribbage, with pegging and the show -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Two-handed Cribbage to 121, against the computer.
|
||||
;;
|
||||
;; Each deal you lay two cards away to the crib (which belongs to the
|
||||
;; dealer), cut a starter, then play the pegging round -- adding cards
|
||||
;; toward 31 and scoring fifteens, pairs, runs, and the go. Then comes
|
||||
;; the show, where both hands and the crib are counted for fifteens,
|
||||
;; pairs, runs, flushes, and his nobs. The deal alternates.
|
||||
;;
|
||||
;; Cards use the package cons (SUIT . RANK), RANK 0 (Ace) .. 12 (King);
|
||||
;; for counting, an Ace is one, face cards ten, the rest their pip value.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'cg-core)
|
||||
(require 'cg-rummy)
|
||||
|
||||
(defcustom cg-cribbage-target 121
|
||||
"Points needed to win a game of Cribbage."
|
||||
:type 'integer :group 'card-games)
|
||||
|
||||
(defclass cg-cribbage-game (cg-game)
|
||||
((vname :initform "Cribbage"))
|
||||
"A two-handed game of Cribbage.")
|
||||
|
||||
;;;; Scoring primitives
|
||||
|
||||
(defun cg-crib--val (card)
|
||||
"Return CARD's counting value (Ace 1, faces 10, else pip)."
|
||||
(let ((r (cdr card))) (if (<= r 8) (1+ r) 10)))
|
||||
|
||||
(defun cg-crib--count-15s (cards)
|
||||
"Return points for all subsets of CARDS summing to fifteen."
|
||||
(let ((n (length cards)) (vec (vconcat cards)) (count 0))
|
||||
(dotimes (mask (ash 1 n))
|
||||
(let ((sum 0))
|
||||
(dotimes (i n)
|
||||
(when (/= 0 (logand mask (ash 1 i)))
|
||||
(setq sum (+ sum (cg-crib--val (aref vec i))))))
|
||||
(when (= sum 15) (setq count (+ count 2)))))
|
||||
count))
|
||||
|
||||
(defun cg-crib--count-pairs (cards)
|
||||
"Return points for all pairs in CARDS."
|
||||
(let ((cnt (make-vector 13 0)) (tot 0))
|
||||
(dolist (c cards) (aset cnt (cdr c) (1+ (aref cnt (cdr c)))))
|
||||
(dotimes (r 13)
|
||||
(let ((k (aref cnt r))) (setq tot (+ tot (* k (1- k)))))) ; 2*C(k,2)=k*(k-1)
|
||||
tot))
|
||||
|
||||
(defun cg-crib--count-runs (cards)
|
||||
"Return points for all runs of three or more in CARDS (with multiplicity)."
|
||||
(let ((cnt (make-vector 13 0)) (total 0) (r 0))
|
||||
(dolist (c cards) (aset cnt (cdr c) (1+ (aref cnt (cdr c)))))
|
||||
(while (< r 13)
|
||||
(if (= 0 (aref cnt r)) (setq r (1+ r))
|
||||
(let ((len 0) (mult 1))
|
||||
(while (and (< r 13) (> (aref cnt r) 0))
|
||||
(setq len (1+ len) mult (* mult (aref cnt r)) r (1+ r)))
|
||||
(when (>= len 3) (setq total (+ total (* len mult)))))))
|
||||
total))
|
||||
|
||||
(defun cg-crib--flush (hand starter is-crib)
|
||||
"Return flush points for the four-card HAND with STARTER.
|
||||
A crib (IS-CRIB) flush must include the starter."
|
||||
(let ((s (car (car hand))))
|
||||
(cond ((not (cl-every (lambda (c) (= (car c) s)) hand)) 0)
|
||||
((= (car starter) s) 5)
|
||||
(is-crib 0)
|
||||
(t 4))))
|
||||
|
||||
(defun cg-crib--nobs (hand starter)
|
||||
"Return 1 when HAND holds the Jack of the STARTER's suit, else 0."
|
||||
(if (cl-find-if (lambda (c) (and (= (cdr c) 10) (= (car c) (car starter)))) hand)
|
||||
1 0))
|
||||
|
||||
(defun cg-crib--score-show (hand starter &optional is-crib)
|
||||
"Return the show score of the four-card HAND with STARTER.
|
||||
IS-CRIB applies the stricter crib flush rule."
|
||||
(let ((all (cons starter hand)))
|
||||
(+ (cg-crib--count-15s all)
|
||||
(cg-crib--count-pairs all)
|
||||
(cg-crib--count-runs all)
|
||||
(cg-crib--flush hand starter is-crib)
|
||||
(cg-crib--nobs hand starter))))
|
||||
|
||||
(defun cg-crib--peg-score (seq total)
|
||||
"Return pegging points for the play whose sequence is SEQ (newest first).
|
||||
TOTAL is the running count after the play."
|
||||
(let ((pts 0))
|
||||
(when (= total 15) (setq pts (+ pts 2)))
|
||||
(when (= total 31) (setq pts (+ pts 2)))
|
||||
;; pairs: leading same-rank run in SEQ
|
||||
(let ((r (cdr (car seq))) (m 0) (lst seq) (stop nil))
|
||||
(while (and lst (not stop))
|
||||
(if (= (cdr (car lst)) r) (setq m (1+ m) lst (cdr lst)) (setq stop t)))
|
||||
(setq pts (+ pts (pcase m (2 2) (3 6) (4 12) (_ 0)))))
|
||||
;; runs: largest k>=3 whose last k cards form a consecutive run
|
||||
(let ((best 0) (k (length seq)))
|
||||
(while (>= k 3)
|
||||
(let* ((lastk (cl-subseq seq 0 k))
|
||||
(ranks (sort (mapcar #'cdr lastk) #'<)))
|
||||
(when (and (= (length ranks) (length (delete-dups (copy-sequence ranks))))
|
||||
(= (- (car (last ranks)) (car ranks)) (1- k)))
|
||||
(setq best (max best k))))
|
||||
(setq k (1- k)))
|
||||
(setq pts (+ pts best)))
|
||||
pts))
|
||||
|
||||
;;;; Setup and flow
|
||||
|
||||
(defsubst cg-crib--hand (game s) (aref (cg-get game :hands) s))
|
||||
(defsubst cg-crib--set-hand (game s v) (aset (cg-get game :hands) s v))
|
||||
(defsubst cg-crib--play (game s) (aref (cg-get game :play) s))
|
||||
(defsubst cg-crib--set-play (game s v) (aset (cg-get game :play) s v))
|
||||
|
||||
(defun cg-crib--who (s) (if (= s 0) "You" "Computer"))
|
||||
|
||||
(cl-defmethod cg-crib--deal ((game cg-cribbage-game))
|
||||
"Deal a fresh Cribbage hand into GAME."
|
||||
(let ((deck (cg-rummy-deck)) (hands (make-vector 2 nil)))
|
||||
(dotimes (s 2)
|
||||
(aset hands s (cg-rummy-sort-hand (cl-loop repeat 6 collect (pop deck)))))
|
||||
(cg-put game :hands hands)
|
||||
(cg-put game :deck deck)
|
||||
(cg-put game :crib nil)
|
||||
(cg-put game :starter nil)
|
||||
(cg-put game :phase 'discard)
|
||||
(cg-put game :cursor 0)
|
||||
(cg-put game :marks nil)
|
||||
(unless (cg-get game :scores) (cg-put game :scores (make-vector 2 0)))
|
||||
(unless (integerp (cg-get game :dealer)) (cg-put game :dealer 1))
|
||||
(cg-put game :message "Discard two cards to the crib: SPC marks, m confirms.")
|
||||
game))
|
||||
|
||||
(defun cg-crib--add (game s pts)
|
||||
"Add PTS to seat S and end the game if it reaches the target."
|
||||
(when (> pts 0)
|
||||
(aset (cg-get game :scores) s (+ (aref (cg-get game :scores) s) pts))
|
||||
(when (>= (aref (cg-get game :scores) s) cg-cribbage-target)
|
||||
(cg-put game :phase 'game-over)
|
||||
(cg-put game :winner s))))
|
||||
|
||||
(defun cg-crib--ai-discard (game s)
|
||||
"Return the two cards seat S should lay away (keep the best four)."
|
||||
(let* ((hand (cg-crib--hand game s)) (best nil) (bestv -1))
|
||||
(dolist (combo (cg-rummy--combinations hand 4))
|
||||
(let ((v (cg-crib--score-show combo '(0 . 0)))) ; rough: no starter
|
||||
(when (> v bestv) (setq bestv v best combo))))
|
||||
(cl-set-difference hand best :test #'equal)))
|
||||
|
||||
(cl-defmethod cg-crib--start-play ((game cg-cribbage-game))
|
||||
"Cut the starter and begin the pegging round."
|
||||
(let* ((deck (cg-get game :deck))
|
||||
(starter (nth (random (length deck)) deck))
|
||||
(dealer (cg-get game :dealer)))
|
||||
(cg-put game :starter starter)
|
||||
(when (= (cdr starter) 10) ; his heels: starter is a Jack
|
||||
(cg-crib--add game dealer 2))
|
||||
(cg-put game :play (vector (cg-crib--hand game 0) (cg-crib--hand game 1)))
|
||||
(cg-put game :seq nil)
|
||||
(cg-put game :total 0)
|
||||
(cg-put game :go nil)
|
||||
(cg-put game :last-player nil)
|
||||
(cg-put game :pturn (- 1 dealer)) ; non-dealer leads
|
||||
(cg-put game :phase (if (eq (cg-get game :phase) 'game-over) 'game-over 'play))
|
||||
(cg-put game :cursor 0)
|
||||
(cg-put game :message
|
||||
(format "Pegging: %s leads. Starter is %s."
|
||||
(cg-crib--who (- 1 dealer)) (cg-rummy-card-string starter)))))
|
||||
|
||||
(defun cg-crib--legal (game s)
|
||||
"Return seat S's play-cards that fit under 31."
|
||||
(cl-remove-if (lambda (c) (> (cg-crib--val c) (- 31 (cg-get game :total))))
|
||||
(cg-crib--play game s)))
|
||||
|
||||
(defun cg-crib--peg-play (game s card)
|
||||
"Seat S plays CARD into the pegging round and pegs any points."
|
||||
(cg-crib--set-play game s (cl-remove card (cg-crib--play game s) :test #'equal :count 1))
|
||||
(cg-put game :seq (cons card (cg-get game :seq)))
|
||||
(cg-put game :total (+ (cg-get game :total) (cg-crib--val card)))
|
||||
(cg-put game :last-player s)
|
||||
(cg-put game :go nil)
|
||||
(let ((pts (cg-crib--peg-score (cg-get game :seq) (cg-get game :total))))
|
||||
(cg-crib--add game s pts)
|
||||
(cg-put game :message
|
||||
(format "%s played %s (count %d)%s."
|
||||
(cg-crib--who s) (cg-rummy-card-string card) (cg-get game :total)
|
||||
(if (> pts 0) (format " for %d" pts) ""))))
|
||||
(if (= (cg-get game :total) 31)
|
||||
(cg-crib--peg-reset game)
|
||||
(cg-put game :pturn (- 1 s))))
|
||||
|
||||
(defun cg-crib--peg-reset (game)
|
||||
"Reset the running count; the player after the last to play leads."
|
||||
(cg-put game :seq nil)
|
||||
(cg-put game :total 0)
|
||||
(cg-put game :go nil)
|
||||
(cg-put game :pturn (- 1 (cg-get game :last-player))))
|
||||
|
||||
(defun cg-crib--peg-over-p (game)
|
||||
"Return non-nil when both players have played out their cards."
|
||||
(and (null (cg-crib--play game 0)) (null (cg-crib--play game 1))))
|
||||
|
||||
(defun cg-crib--peg-go (game s)
|
||||
"Handle seat S being unable to play (a go)."
|
||||
(let ((other (- 1 s)))
|
||||
(if (cg-crib--legal game other)
|
||||
(cg-put game :pturn other) ; opponent plays on
|
||||
;; neither can play: last player pegs one for the go, then reset
|
||||
(when (cg-get game :last-player)
|
||||
(cg-crib--add game (cg-get game :last-player) 1)
|
||||
(cg-put game :message
|
||||
(format "%s pegs 1 for the go." (cg-crib--who (cg-get game :last-player)))))
|
||||
(cg-crib--peg-reset game))))
|
||||
|
||||
(cl-defmethod cg-crib--ai-play ((game cg-cribbage-game) s)
|
||||
"Have AI seat S either play its best pegging card or declare a go."
|
||||
(let ((legal (cg-crib--legal game s)))
|
||||
(if (null legal) (cg-crib--peg-go game s)
|
||||
(let ((best (car legal)) (bestv -1))
|
||||
(dolist (c legal)
|
||||
(let* ((seq (cons c (cg-get game :seq)))
|
||||
(tot (+ (cg-get game :total) (cg-crib--val c)))
|
||||
(v (cg-crib--peg-score seq tot)))
|
||||
;; prefer points; tie-break toward keeping count off 5 and 21
|
||||
(when (or (> v bestv)
|
||||
(and (= v bestv) (> (cg-crib--val c) (cg-crib--val best))))
|
||||
(setq best c bestv v))))
|
||||
(cg-crib--peg-play game s best)))))
|
||||
|
||||
(defun cg-crib--peg-advance (game)
|
||||
"Run AI pegging turns until it is your turn or the round ends."
|
||||
(let ((guard 0))
|
||||
(while (and (eq (cg-get game :phase) 'play) (not (cg-crib--peg-over-p game))
|
||||
(/= (cg-get game :pturn) 0) (< guard 200))
|
||||
(setq guard (1+ guard))
|
||||
(cg-crib--ai-play game (cg-get game :pturn))))
|
||||
;; if it is your turn but you have no legal play, auto-go
|
||||
(when (and (eq (cg-get game :phase) 'play) (not (cg-crib--peg-over-p game))
|
||||
(= (cg-get game :pturn) 0) (null (cg-crib--legal game 0)))
|
||||
(cg-crib--peg-go game 0)
|
||||
(cg-crib--peg-advance game))
|
||||
(when (and (eq (cg-get game :phase) 'play) (cg-crib--peg-over-p game))
|
||||
(cg-crib--show game)))
|
||||
|
||||
(cl-defmethod cg-crib--show ((game cg-cribbage-game))
|
||||
"Count the hands and the crib, then set up the next deal."
|
||||
(let* ((starter (cg-get game :starter))
|
||||
(dealer (cg-get game :dealer)) (pone (- 1 dealer))
|
||||
(h-pone (cg-crib--hand game pone)) (h-dealer (cg-crib--hand game dealer))
|
||||
(crib (cg-get game :crib))
|
||||
(s-pone (cg-crib--score-show h-pone starter))
|
||||
(s-dealer (cg-crib--score-show h-dealer starter))
|
||||
(s-crib (cg-crib--score-show crib starter t)))
|
||||
;; count in order: non-dealer, dealer, crib (a player may win mid-count)
|
||||
(cg-crib--add game pone s-pone)
|
||||
(when (not (eq (cg-get game :phase) 'game-over)) (cg-crib--add game dealer s-dealer))
|
||||
(when (not (eq (cg-get game :phase) 'game-over)) (cg-crib--add game dealer s-crib))
|
||||
(cg-put game :show (list :pone s-pone :dealer s-dealer :crib s-crib))
|
||||
(unless (eq (cg-get game :phase) 'game-over) (cg-put game :phase 'show))
|
||||
(cg-put game :message
|
||||
(format "Show: %s %d, %s %d, crib %d. %s"
|
||||
(cg-crib--who pone) s-pone (cg-crib--who dealer) s-dealer s-crib
|
||||
(if (eq (cg-get game :phase) 'game-over)
|
||||
(format "%s wins! (n: new game)" (cg-crib--who (cg-get game :winner)))
|
||||
"(n: next deal)")))))
|
||||
|
||||
;;;; UI
|
||||
|
||||
(defvar-local cg-crib--game nil "The Cribbage game in the current buffer.")
|
||||
|
||||
(defun cg-crib--svg (game)
|
||||
"Return an SVG board for the Cribbage GAME (with a peg-track)."
|
||||
(let* ((w cg-svg-card-width) (h cg-svg-card-height) (gap cg-svg-card-gap) (pad 16)
|
||||
(phase (cg-get game :phase)) (scores (cg-get game :scores))
|
||||
(hand (if (eq phase 'play) (cg-crib--play game 0) (cg-crib--hand game 0)))
|
||||
(n (length hand)) (cursor (cg-get game :cursor)) (marks (cg-get game :marks))
|
||||
(overlap (cond ((> n 11) (- w 24)) ((> n 8) 20) (t 0)))
|
||||
(step (max 14 (- (+ w gap) overlap)))
|
||||
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
|
||||
(target cg-cribbage-target) (barw 220) (peg-h 14) (peg-gap 8)
|
||||
(y-title 6) (y-peg 26)
|
||||
(y-mid (+ y-peg (* 2 (+ peg-h peg-gap)) 18))
|
||||
(y-hand (+ y-mid h 44))
|
||||
(height (+ y-hand h 30))
|
||||
(width (max (+ fanw (* 2 pad)) (+ pad 90 barw 120) 620))
|
||||
(svg (svg-create width height))
|
||||
(lc (cg-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels ((txt (str x y &optional sz bold)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family cg-svg-font-family (and bold '(:font-weight "bold"))))
|
||||
(peg (label sc y)
|
||||
(txt label pad (+ y 11) 12)
|
||||
(let ((bx (+ pad 90)))
|
||||
(svg-rectangle svg bx y barw peg-h :rx 4 :fill "none"
|
||||
:stroke lc :stroke-width 1)
|
||||
(svg-rectangle svg bx y
|
||||
(round (* barw (/ (float (min sc target)) target)))
|
||||
peg-h :rx 4 :fill "#3aa15a")
|
||||
(txt (format "%d" sc) (+ bx barw 8) (+ y 11) 12)))
|
||||
(crow (cards x y)
|
||||
(let ((xx x))
|
||||
(dolist (c cards)
|
||||
(let ((sp (cg-rummy--card-spec c)))
|
||||
(cg-svg-card svg xx y :rank (car sp) :suit (cdr sp)))
|
||||
(setq xx (+ xx (round (* w 0.5))))))))
|
||||
(txt (format "Cribbage (to %d)" target) pad (+ y-title 12) 13 t)
|
||||
(peg "You" (aref scores 0) y-peg)
|
||||
(peg "Computer" (aref scores 1) (+ y-peg peg-h peg-gap))
|
||||
(txt (format "%s deals" (cg-crib--who (cg-get game :dealer)))
|
||||
(+ pad 90 barw 60) (+ y-peg 11) 11)
|
||||
(let ((mx pad))
|
||||
(when (cg-get game :starter)
|
||||
(let ((sp (cg-rummy--card-spec (cg-get game :starter))))
|
||||
(cg-svg-card svg mx y-mid :rank (car sp) :suit (cdr sp))
|
||||
(txt "Starter" mx (+ y-mid h 13) 11)
|
||||
(setq mx (+ mx w gap 24))))
|
||||
(cond
|
||||
((eq phase 'play)
|
||||
(txt (format "Count: %d" (cg-get game :total)) mx (- y-mid 4) 12)
|
||||
(crow (reverse (cg-get game :seq)) mx y-mid))
|
||||
((memq phase '(show game-over))
|
||||
(when (cg-get game :crib)
|
||||
(txt (format "Crib (%s)" (cg-crib--who (cg-get game :dealer))) mx (- y-mid 4) 11)
|
||||
(crow (cg-get game :crib) mx y-mid)))))
|
||||
(txt (format "Your %s" (if (eq phase 'play) "cards" "hand")) pad (- y-hand 6) 11)
|
||||
(let ((x (max pad (- (/ width 2) (/ fanw 2)))) (i 0))
|
||||
(dolist (c hand)
|
||||
(let ((sp (cg-rummy--card-spec c)) (curp (= i cursor))
|
||||
(markp (and marks (memq i marks))))
|
||||
(cg-svg-card svg x y-hand :rank (car sp) :suit (cdr sp) :highlight curp)
|
||||
(when markp
|
||||
(svg-rectangle svg (- x 3) (- y-hand 3) (+ w 6) (+ h 6)
|
||||
:rx 8 :fill "none" :stroke "#4a90d9" :stroke-width 3))
|
||||
(push (cons (list x y-hand (if (= i (1- n)) w step) h) (cons 'hand i)) regions))
|
||||
(setq x (+ x step) i (1+ i))))
|
||||
(txt (or (cg-get game :message) "") pad (- height 8) 12))
|
||||
(propertize "*" 'display (cg-svg-image svg (cg-scale)) 'cg-regions (nreverse regions))))
|
||||
|
||||
(cl-defmethod cg-render ((game cg-cribbage-game))
|
||||
"Return a depiction of the Cribbage GAME: SVG board if graphical, else text."
|
||||
(if (and cg-rummy-svg-cards (display-graphic-p))
|
||||
(cg-crib--svg game)
|
||||
(cg-crib--render-text game)))
|
||||
|
||||
(defun cg-crib--render-text (game)
|
||||
"Return a plain-text depiction of the Cribbage GAME."
|
||||
(let* ((out '()) (scores (cg-get game :scores)) (phase (cg-get game :phase))
|
||||
(cursor (cg-get game :cursor)))
|
||||
(push (format " Cribbage to %d\n\n" cg-cribbage-target) out)
|
||||
(push (format " You %d Computer %d %s deals\n\n"
|
||||
(aref scores 0) (aref scores 1) (cg-crib--who (cg-get game :dealer)))
|
||||
out)
|
||||
(when (cg-get game :starter)
|
||||
(push (format " Starter: %s\n" (cg-rummy-card-string (cg-get game :starter))) out))
|
||||
(when (eq phase 'play)
|
||||
(push (format " Count: %d\n Played: %s\n" (cg-get game :total)
|
||||
(mapconcat #'cg-rummy-card-string (reverse (cg-get game :seq)) " "))
|
||||
out))
|
||||
(when (memq phase '(show game-over))
|
||||
(let ((sh (cg-get game :show)))
|
||||
(when sh
|
||||
(push (format " Crib (%s): %s\n"
|
||||
(cg-crib--who (cg-get game :dealer))
|
||||
(mapconcat #'cg-rummy-card-string (cg-get game :crib) " ")) out))))
|
||||
(let* ((hand (if (eq phase 'play) (cg-crib--play game 0) (cg-crib--hand game 0))))
|
||||
(push (format "\n Your %s:\n " (if (eq phase 'play) "cards" "hand")) out)
|
||||
(push (cg-rummy--render-cards hand cursor (cg-get game :marks) nil 'hand) out))
|
||||
(push (format "\n\n %s\n" (cg-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod cg-render-apply ((g cg-cribbage-game) action)
|
||||
"Apply a click ACTION on the hand to GAME G."
|
||||
(pcase action
|
||||
(`(hand . ,i) (cg-put g :cursor i))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun cg-crib--redisplay ()
|
||||
(let ((game cg-crib--game) (inhibit-read-only t))
|
||||
(setq cg-current-game game cg-redisplay-function #'cg-crib--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (cg-get game :phase)))
|
||||
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
|
||||
|
||||
(defun cg-crib--cur-list (g)
|
||||
(if (eq (cg-get g :phase) 'play) (cg-crib--play g 0) (cg-crib--hand g 0)))
|
||||
|
||||
(defun cg-crib-left ()
|
||||
"Move the cursor left."
|
||||
(interactive)
|
||||
(let* ((g cg-crib--game) (n (length (cg-crib--cur-list g))))
|
||||
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n)))
|
||||
(cg-crib--redisplay)))
|
||||
|
||||
(defun cg-crib-right ()
|
||||
"Move the cursor right."
|
||||
(interactive)
|
||||
(let* ((g cg-crib--game) (n (length (cg-crib--cur-list g))))
|
||||
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n)))
|
||||
(cg-crib--redisplay)))
|
||||
|
||||
(defun cg-crib-mark ()
|
||||
"Toggle a discard mark on the cursor card (discard phase)."
|
||||
(interactive)
|
||||
(let* ((g cg-crib--game) (i (cg-get g :cursor)) (marks (cg-get g :marks)))
|
||||
(when (eq (cg-get g :phase) 'discard)
|
||||
(cg-put g :marks (if (memq i marks) (delq i marks)
|
||||
(if (>= (length marks) 2) marks (cons i marks)))))
|
||||
(cg-crib--redisplay)))
|
||||
|
||||
(defun cg-crib-confirm ()
|
||||
"Confirm your two crib discards and start play."
|
||||
(interactive)
|
||||
(let* ((g cg-crib--game) (hand (cg-crib--hand g 0))
|
||||
(marks (cg-get g :marks)))
|
||||
(if (or (not (eq (cg-get g :phase) 'discard)) (/= (length marks) 2))
|
||||
(progn (cg-put g :message "Mark exactly two cards (SPC), then m.")
|
||||
(cg-crib--redisplay))
|
||||
(let ((mine (mapcar (lambda (i) (nth i hand)) marks))
|
||||
(ai (cg-crib--ai-discard g 1)))
|
||||
(cg-crib--set-hand g 0 (cl-set-difference hand mine :test #'equal))
|
||||
(cg-crib--set-hand g 1 (cl-set-difference (cg-crib--hand g 1) ai :test #'equal))
|
||||
(cg-put g :crib (append mine ai))
|
||||
(cg-put g :marks nil) (cg-put g :cursor 0)
|
||||
(cg-crib--start-play g)
|
||||
(cg-crib--peg-advance g)
|
||||
(cg-crib--redisplay)))))
|
||||
|
||||
(defun cg-crib-play ()
|
||||
"Play the cursor card in pegging, or declare a go if you cannot."
|
||||
(interactive)
|
||||
(let* ((g cg-crib--game))
|
||||
(cond
|
||||
((not (eq (cg-get g :phase) 'play)) (cg-put g :message "Not the pegging round."))
|
||||
((/= (cg-get g :pturn) 0) (cg-put g :message "Not your turn."))
|
||||
((null (cg-crib--legal g 0))
|
||||
(cg-crib--peg-go g 0) (cg-crib--peg-advance g))
|
||||
(t (let ((card (nth (cg-get g :cursor) (cg-crib--play g 0))))
|
||||
(if (or (null card) (> (cg-crib--val card) (- 31 (cg-get g :total))))
|
||||
(cg-put g :message "That card would go over 31 -- choose another.")
|
||||
(cg-crib--peg-play g 0 card)
|
||||
(cg-put g :cursor 0)
|
||||
(cg-crib--peg-advance g)))))
|
||||
(cg-crib--redisplay)))
|
||||
|
||||
(defun cg-crib-new ()
|
||||
"Start the next deal, or a new game when one is over."
|
||||
(interactive)
|
||||
(let ((g cg-crib--game))
|
||||
(when (eq (cg-get g :phase) 'game-over)
|
||||
(cg-put g :scores (make-vector 2 0)) (cg-put g :dealer 1))
|
||||
(cg-put g :dealer (- 1 (cg-get g :dealer))) ; alternate the deal
|
||||
(cg-put g :show nil)
|
||||
(cg-crib--deal g)
|
||||
(cg-crib--redisplay)))
|
||||
|
||||
(defun cg-crib-redraw () "Redraw." (interactive) (cg-crib--redisplay))
|
||||
(defun cg-crib-help () "Describe the controls." (interactive)
|
||||
(message "Arrows: choose SPC: mark (discard) m: confirm crib RET: play/go n: next g: redraw"))
|
||||
|
||||
(defvar cg-cribbage-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'cg-card-click)
|
||||
(define-key map "+" #'cg-card-zoom-in)
|
||||
(define-key map "=" #'cg-card-zoom-in)
|
||||
(define-key map "-" #'cg-card-zoom-out)
|
||||
(define-key map "0" #'cg-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'cg-crib-left)
|
||||
(define-key map (kbd "<right>") #'cg-crib-right)
|
||||
(define-key map (kbd "SPC") #'cg-crib-mark)
|
||||
(define-key map "m" #'cg-crib-confirm)
|
||||
(define-key map (kbd "RET") #'cg-crib-play)
|
||||
(define-key map "n" #'cg-crib-new)
|
||||
(define-key map "g" #'cg-crib-redraw)
|
||||
(define-key map "?" #'cg-crib-help)
|
||||
(define-key map "q" #'cg-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `cg-cribbage-mode'.")
|
||||
|
||||
(define-derived-mode cg-cribbage-mode special-mode "Cribbage"
|
||||
"Major mode for Cribbage."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type cg-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-cribbage ()
|
||||
"Play two-handed Cribbage against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Cribbage*")))
|
||||
(with-current-buffer buf
|
||||
(cg-cribbage-mode)
|
||||
(setq cg-crib--game (cg-cribbage-game))
|
||||
(cg-crib--deal cg-crib--game)
|
||||
(cg-crib--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
(provide 'cg-cribbage)
|
||||
;;; cg-cribbage.el ends here
|
||||
444
cg-eights.el
444
cg-eights.el
|
|
@ -1,444 +0,0 @@
|
|||
;;; cg-eights.el --- Crazy Eights, a shedding card game -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Crazy Eights: shed your whole hand by matching the suit or rank of the
|
||||
;; card on top of the discard pile. Eights are wild -- play one any time
|
||||
;; and name the suit that must follow. If you cannot play, draw a card.
|
||||
;; You are the South player; the others are simple AI. This is the direct
|
||||
;; ancestor of UNO, and the shedding engine generalises to climbing games
|
||||
;; such as President.
|
||||
;;
|
||||
;; Cards are the package-standard cons (SUIT . RANK) with SUIT 0 spades,
|
||||
;; 1 clubs, 2 diamonds, 3 hearts and RANK 0 (the Two) .. 12 (the Ace).
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'cg-core)
|
||||
(require 'cg-svg)
|
||||
|
||||
(defconst cg-eights-ranks
|
||||
["2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K" "A"]
|
||||
"Rank labels indexed 0 (Two) .. 12 (Ace).")
|
||||
|
||||
(defconst cg-eights--wild 6 "Rank index of the wild Eight.")
|
||||
|
||||
(defcustom cg-eights-players 3
|
||||
"Number of players in Crazy Eights, including you (2-4)."
|
||||
:type '(choice (const 2) (const 3) (const 4)) :group 'card-games)
|
||||
|
||||
(defun cg-eights-card-string (card)
|
||||
"Return a short string for CARD."
|
||||
(if (null card) "·"
|
||||
(concat (aref cg-eights-ranks (cdr card)) (cg-suit-glyph (car card)))))
|
||||
|
||||
(defsubst cg-eights-red-p (card) (and card (cg-red-suit-p (car card))))
|
||||
|
||||
(defun cg-eights--value (card)
|
||||
"Return the scoring value of CARD held at the end of a hand."
|
||||
(cond ((= (cdr card) cg-eights--wild) 50)
|
||||
((>= (cdr card) 9) 10) ; J Q K
|
||||
((= (cdr card) 12) 1) ; (Ace handled above by >=9? no)
|
||||
(t (+ 2 (cdr card)))))
|
||||
|
||||
(defun cg-eights--deck ()
|
||||
"Return a fresh shuffled 52-card deck."
|
||||
(random t)
|
||||
(cg-shuffle (cl-loop for s below 4 append
|
||||
(cl-loop for r below 13 collect (cons s r)))))
|
||||
|
||||
(defclass cg-eights-game (cg-game)
|
||||
((vname :initform "Crazy Eights"))
|
||||
"A game of Crazy Eights.")
|
||||
|
||||
(defsubst cg-eights--hand (game s) (aref (cg-get game :hands) s))
|
||||
(defsubst cg-eights--set-hand (game s v) (aset (cg-get game :hands) s v))
|
||||
(defsubst cg-eights--top (game) (car (cg-get game :discard)))
|
||||
|
||||
(cl-defmethod cg-eights--deal ((game cg-eights-game))
|
||||
"Deal a fresh Crazy Eights hand into GAME."
|
||||
(let* ((n (max 2 (min 4 cg-eights-players)))
|
||||
(deck (cg-eights--deck))
|
||||
(per (if (= n 2) 7 5))
|
||||
(hands (make-vector n nil)))
|
||||
(dotimes (s n)
|
||||
(aset hands s (cl-loop repeat per collect (pop deck))))
|
||||
;; turn up a starter that is not an eight
|
||||
(let ((start (pop deck)))
|
||||
(while (= (cdr start) cg-eights--wild)
|
||||
(setq deck (append deck (list start)) start (pop deck)))
|
||||
(cg-put game :discard (list start))
|
||||
(cg-put game :suit (car start)))
|
||||
(cg-put game :stock deck)
|
||||
(cg-put game :hands hands)
|
||||
(cg-put game :nplayers n)
|
||||
(cg-put game :turn 0)
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :passes 0)
|
||||
(cg-put game :cursor 0)
|
||||
(unless (cg-get game :scores) (cg-put game :scores (make-vector n 0)))
|
||||
(cg-put game :message "Match the suit or rank; eights are wild. d draws.")
|
||||
game))
|
||||
|
||||
(cl-defmethod cg-eights--legal-p ((game cg-eights-game) card)
|
||||
"Return non-nil when CARD may be played onto the discard now."
|
||||
(or (= (cdr card) cg-eights--wild)
|
||||
(= (car card) (cg-get game :suit))
|
||||
(= (cdr card) (cdr (cg-eights--top game)))))
|
||||
|
||||
(defun cg-eights--legal-moves (game s)
|
||||
"Return the cards in seat S's hand that may be played now."
|
||||
(cl-remove-if-not (lambda (c) (cg-eights--legal-p game c))
|
||||
(cg-eights--hand game s)))
|
||||
|
||||
(defun cg-eights--best-suit (game s)
|
||||
"Return the suit seat S holds most of (ignoring eights)."
|
||||
(let ((counts (make-vector 4 0)))
|
||||
(dolist (c (cg-eights--hand game s))
|
||||
(unless (= (cdr c) cg-eights--wild)
|
||||
(aset counts (car c) (1+ (aref counts (car c))))))
|
||||
(let ((best 0))
|
||||
(dotimes (i 4) (when (> (aref counts i) (aref counts best)) (setq best i)))
|
||||
best)))
|
||||
|
||||
(cl-defmethod cg-eights--play ((game cg-eights-game) s card &optional suit)
|
||||
"Have seat S play CARD; SUIT names the next suit for a wild eight."
|
||||
(cg-eights--set-hand game s (remove card (cg-eights--hand game s)))
|
||||
(cg-put game :discard (cons card (cg-get game :discard)))
|
||||
(cg-put game :suit (if (= (cdr card) cg-eights--wild)
|
||||
(or suit (cg-eights--best-suit game s))
|
||||
(car card)))
|
||||
(cg-put game :passes 0)
|
||||
(if (null (cg-eights--hand game s))
|
||||
(cg-eights--finish game s)
|
||||
(cg-put game :turn (mod (1+ s) (cg-get game :nplayers)))))
|
||||
|
||||
(defun cg-eights--draw-card (game s)
|
||||
"Move one card from the stock to seat S's hand, recycling if needed.
|
||||
Return the drawn card, or nil when none is available."
|
||||
(when (and (null (cg-get game :stock)) (cdr (cg-get game :discard)))
|
||||
(let ((top (car (cg-get game :discard))))
|
||||
(cg-put game :stock (cg-shuffle (cdr (cg-get game :discard))))
|
||||
(cg-put game :discard (list top))))
|
||||
(let ((stock (cg-get game :stock)))
|
||||
(when stock
|
||||
(let ((card (car stock)))
|
||||
(cg-put game :stock (cdr stock))
|
||||
(cg-eights--set-hand game s (cons card (cg-eights--hand game s)))
|
||||
card))))
|
||||
|
||||
(cl-defmethod cg-eights--finish ((game cg-eights-game) winner)
|
||||
"Record WINNER going out and score the other hands against them."
|
||||
(let ((sum 0))
|
||||
(dotimes (s (cg-get game :nplayers))
|
||||
(unless (= s winner)
|
||||
(dolist (c (cg-eights--hand game s))
|
||||
(setq sum (+ sum (cg-eights--value c))))))
|
||||
(aset (cg-get game :scores) winner (+ (aref (cg-get game :scores) winner) sum))
|
||||
(cg-put game :phase 'game-over)
|
||||
(cg-put game :winner winner)
|
||||
(cg-put game :message
|
||||
(format "%s goes out and scores %d. Press n for a new deal."
|
||||
(if (= winner 0) "You" (format "Player %d" winner)) sum))))
|
||||
|
||||
(cl-defmethod cg-eights--ai-turn ((game cg-eights-game) s)
|
||||
"Take seat S's whole turn: play if able, otherwise draw then play or pass."
|
||||
(let ((moves (cg-eights--legal-moves game s)))
|
||||
(unless moves
|
||||
;; draw up to a small limit looking for a play
|
||||
(let ((tries 0))
|
||||
(while (and (not moves) (< tries 60) (cg-eights--draw-card game s))
|
||||
(setq moves (cg-eights--legal-moves game s) tries (1+ tries)))))
|
||||
(if moves
|
||||
;; prefer a non-eight of lowest value; keep eights for later
|
||||
(let* ((non (cl-remove-if (lambda (c) (= (cdr c) cg-eights--wild)) moves))
|
||||
(pick (car (sort (copy-sequence (or non moves))
|
||||
(lambda (a b) (< (cg-eights--value a)
|
||||
(cg-eights--value b)))))))
|
||||
(cg-eights--play game s pick))
|
||||
;; truly stuck: pass
|
||||
(cg-put game :passes (1+ (cg-get game :passes)))
|
||||
(cg-put game :turn (mod (1+ s) (cg-get game :nplayers))))))
|
||||
|
||||
(defun cg-eights--run (game)
|
||||
"Advance AI seats until it is the human's turn or the hand ends."
|
||||
(while (and (eq (cg-get game :phase) 'play)
|
||||
(/= (cg-get game :turn) 0)
|
||||
(< (cg-get game :passes) (cg-get game :nplayers)))
|
||||
(cg-eights--ai-turn game (cg-get game :turn)))
|
||||
(when (>= (cg-get game :passes) (cg-get game :nplayers))
|
||||
(cg-eights--deadlock game)))
|
||||
|
||||
(cl-defmethod cg-eights--deadlock ((game cg-eights-game))
|
||||
"End a hand in which everyone passed; lowest hand value wins."
|
||||
(let ((best 0) (bestv most-positive-fixnum))
|
||||
(dotimes (s (cg-get game :nplayers))
|
||||
(let ((v (apply #'+ (mapcar #'cg-eights--value (cg-eights--hand game s)))))
|
||||
(when (< v bestv) (setq bestv v best s))))
|
||||
(cg-eights--finish game best)))
|
||||
|
||||
;;;; UI
|
||||
|
||||
(defvar-local cg-eights--game nil "The Crazy Eights game in the current buffer.")
|
||||
|
||||
(defcustom cg-eights-svg-cards t
|
||||
"When non-nil, draw the hand as SVG on a graphical display."
|
||||
:type 'boolean :group 'card-games)
|
||||
|
||||
(defun cg-eights--spec (card)
|
||||
"Return the cg-svg display spec (RANK-STRING . SUIT) for CARD."
|
||||
(cons (aref cg-eights-ranks (cdr card)) (car card)))
|
||||
|
||||
(defun cg-eights--board-svg (game)
|
||||
"Return an SVG board for the Crazy Eights GAME."
|
||||
(let* ((w cg-svg-card-width) (h cg-svg-card-height) (gap cg-svg-card-gap) (pad 16)
|
||||
(hand (cg-eights--hand game 0)) (n (length hand))
|
||||
(cursor (cg-get game :cursor))
|
||||
(top (cg-eights--top game)) (suit (cg-get game :suit))
|
||||
(overlap (cond ((> n 11) (- w 24)) ((> n 8) 20) (t 0)))
|
||||
(step (max 14 (- (+ w gap) overlap)))
|
||||
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
|
||||
(np (cg-get game :nplayers)) (nstock (length (cg-get game :stock)))
|
||||
(y-title 6) (y-info 26)
|
||||
(y-mid (+ y-info (* (1- np) 16) 14))
|
||||
(y-hand (+ y-mid h 42))
|
||||
(height (+ y-hand h 30))
|
||||
(width (max (+ fanw (* 2 pad)) 560))
|
||||
(svg (svg-create width height))
|
||||
(lc (cg-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels ((txt (str x y &optional sz bold)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family cg-svg-font-family (and bold '(:font-weight "bold")))))
|
||||
(txt "Crazy Eights" pad (+ y-title 12) 13 t)
|
||||
(let ((yy (+ y-info 4)))
|
||||
(dotimes (s np)
|
||||
(unless (= s 0)
|
||||
(txt (format "Player %d: %d cards (score %d)" s
|
||||
(length (cg-eights--hand game s)) (aref (cg-get game :scores) s))
|
||||
pad yy 12)
|
||||
(setq yy (+ yy 16)))))
|
||||
(cg-svg-card svg pad y-mid :down (> nstock 0) :gap (= nstock 0))
|
||||
(txt (format "Stock %d" nstock) pad (+ y-mid h 13) 11)
|
||||
(let ((dx (+ pad w gap 28)) (sp (cg-eights--spec top)))
|
||||
(cg-svg-card svg dx y-mid :rank (car sp) :suit (cdr sp))
|
||||
(txt "Discard" dx (+ y-mid h 13) 11)
|
||||
(let ((sx (+ dx w gap 34))
|
||||
(col (if (cg-red-suit-p suit) "#c0392b" "#2c3e50")))
|
||||
(txt "Suit in play" sx (- y-mid 4) 11)
|
||||
(svg-text svg (cg-suit-glyph suit) :x (+ sx 12) :y (+ y-mid 46)
|
||||
:font-size 44 :fill col :font-family cg-svg-font-family)))
|
||||
(txt "Your hand" pad (- y-hand 6) 11)
|
||||
(let ((x (max pad (- (/ width 2) (/ fanw 2)))) (i 0))
|
||||
(dolist (c hand)
|
||||
(let ((sp (cg-eights--spec c)) (curp (= i cursor))
|
||||
(hintp (cg-eights--legal-p game c)))
|
||||
(cg-svg-card svg x y-hand :rank (car sp) :suit (cdr sp)
|
||||
:highlight curp :hint hintp)
|
||||
(push (cons (list x y-hand (if (= i (1- n)) w step) h) (cons 'hand i)) regions))
|
||||
(setq x (+ x step) i (1+ i))))
|
||||
(txt (or (cg-get game :message) "") pad (- height 8) 12))
|
||||
(propertize "*" 'display (cg-svg-image svg (cg-scale)) 'cg-regions (nreverse regions))))
|
||||
|
||||
(cl-defmethod cg-render ((game cg-eights-game))
|
||||
"Return a depiction of GAME: an SVG board if graphical, else text."
|
||||
(if (and cg-eights-svg-cards (display-graphic-p))
|
||||
(cg-eights--board-svg game)
|
||||
(cg-eights--render-text game)))
|
||||
|
||||
(defun cg-eights--render-text (game)
|
||||
"Return a plain-text depiction of GAME."
|
||||
(let* ((out (list)) (top (cg-eights--top game))
|
||||
(hand (cg-eights--hand game 0)) (cursor (cg-get game :cursor)))
|
||||
(push (format " Crazy Eights\n\n") out)
|
||||
(dotimes (s (cg-get game :nplayers))
|
||||
(unless (= s 0)
|
||||
(push (format " Player %d: %d cards (score %d)\n"
|
||||
s (length (cg-eights--hand game s))
|
||||
(aref (cg-get game :scores) s)) out)))
|
||||
(push (format "\n Discard top: %s Suit in play: %s Stock: %d\n\n"
|
||||
(let ((cs (cg-eights-card-string top)))
|
||||
(if (cg-eights-red-p top) (propertize cs 'face 'cg-red-suit) cs))
|
||||
(cg-suit-glyph (cg-get game :suit))
|
||||
(length (cg-get game :stock)))
|
||||
out)
|
||||
(push (format " Your hand (score %d):\n " (aref (cg-get game :scores) 0)) out)
|
||||
(if (and cg-eights-svg-cards (display-graphic-p))
|
||||
(let ((hi '()) (i 0))
|
||||
(dolist (c hand) (when (cg-eights--legal-p game c) (push i hi)) (setq i (1+ i)))
|
||||
(push (cg-svg-hand-image (mapcar #'cg-eights--spec hand)
|
||||
:cursor cursor :hints hi
|
||||
:overlap (if (> (length hand) 11)
|
||||
(max 0 (- cg-svg-card-width 24)) 0)
|
||||
:region-tag 'hand)
|
||||
out))
|
||||
(let ((i 0))
|
||||
(dolist (c hand)
|
||||
(let ((cs (cg-eights-card-string c)) (faces nil))
|
||||
(when (cg-eights-red-p c) (push 'cg-red-suit faces))
|
||||
(when (cg-eights--legal-p game c) (push 'cg-hint faces))
|
||||
(when (= i cursor) (push 'cg-cursor faces))
|
||||
(push (propertize (format "%4s" cs) 'face (or faces 'default)) out))
|
||||
(setq i (1+ i)))))
|
||||
(push (format "\n\n %s\n" (cg-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod cg-render-apply ((g cg-eights-game) action)
|
||||
"Apply a click ACTION on the hand to GAME G (a click also plays)."
|
||||
(pcase action
|
||||
(`(hand . ,i)
|
||||
(cg-put g :cursor i)
|
||||
(when (and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0))
|
||||
(cg-eights-act)))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun cg-eights--redisplay ()
|
||||
"Redraw the Crazy Eights buffer."
|
||||
(let ((game cg-eights--game) (inhibit-read-only t))
|
||||
(setq cg-current-game game cg-redisplay-function #'cg-eights--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (cg-get game :phase)))
|
||||
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
|
||||
|
||||
(defun cg-eights--cursor-card (game)
|
||||
(nth (cg-get game :cursor) (cg-eights--hand game 0)))
|
||||
|
||||
(defun cg-eights-left ()
|
||||
"Move the hand cursor left."
|
||||
(interactive)
|
||||
(let* ((game cg-eights--game) (n (length (cg-eights--hand game 0))))
|
||||
(when (> n 0) (cg-put game :cursor (mod (1- (cg-get game :cursor)) n)))
|
||||
(cg-eights--redisplay)))
|
||||
|
||||
(defun cg-eights-right ()
|
||||
"Move the hand cursor right."
|
||||
(interactive)
|
||||
(let* ((game cg-eights--game) (n (length (cg-eights--hand game 0))))
|
||||
(when (> n 0) (cg-put game :cursor (mod (1+ (cg-get game :cursor)) n)))
|
||||
(cg-eights--redisplay)))
|
||||
|
||||
(defun cg-eights--choose-suit (game)
|
||||
"Return a suit the human names for a wild eight."
|
||||
(if noninteractive (cg-eights--best-suit game 0)
|
||||
(let* ((names (mapcar (lambda (i) (cons (aref cg-suit-names i) i)) '(0 1 2 3)))
|
||||
(pick (completing-read "Name the suit: " (mapcar #'car names) nil t)))
|
||||
(cdr (assoc pick names)))))
|
||||
|
||||
(defun cg-eights-act ()
|
||||
"Play the selected card if it is legal."
|
||||
(interactive)
|
||||
(let* ((game cg-eights--game) (card (cg-eights--cursor-card game)))
|
||||
(cond
|
||||
((not (eq (cg-get game :phase) 'play)) (cg-put game :message "Press n for a new deal."))
|
||||
((/= (cg-get game :turn) 0) (cg-put game :message "Not your turn."))
|
||||
((null card) (cg-put game :message "No card selected."))
|
||||
((not (cg-eights--legal-p game card))
|
||||
(cg-put game :message "That card does not match — draw with d if stuck."))
|
||||
(t (let ((suit (and (= (cdr card) cg-eights--wild) (cg-eights--choose-suit game))))
|
||||
(cg-eights--play game 0 card suit)
|
||||
(cg-put game :cursor 0)
|
||||
(cg-eights--run game))))
|
||||
(cg-eights--redisplay)))
|
||||
|
||||
(defun cg-eights-draw ()
|
||||
"Draw a card; if the stock cannot help, pass your turn."
|
||||
(interactive)
|
||||
(let ((game cg-eights--game))
|
||||
(when (eq (cg-get game :phase) 'play)
|
||||
(if (= (cg-get game :turn) 0)
|
||||
(let ((card (cg-eights--draw-card game 0)))
|
||||
(if card
|
||||
(cg-put game :message (format "You drew %s." (cg-eights-card-string card)))
|
||||
(cg-put game :passes (1+ (cg-get game :passes)))
|
||||
(cg-put game :turn (mod 1 (cg-get game :nplayers)))
|
||||
(cg-put game :message "Nothing to draw — you pass.")
|
||||
(cg-eights--run game)))
|
||||
(cg-put game :message "Not your turn.")))
|
||||
(cg-eights--redisplay)))
|
||||
|
||||
(defun cg-eights-pass ()
|
||||
"Pass your turn (only sensible after drawing with an empty stock)."
|
||||
(interactive)
|
||||
(let ((game cg-eights--game))
|
||||
(when (and (eq (cg-get game :phase) 'play) (= (cg-get game :turn) 0))
|
||||
(cg-put game :passes (1+ (cg-get game :passes)))
|
||||
(cg-put game :turn (mod 1 (cg-get game :nplayers)))
|
||||
(cg-eights--run game))
|
||||
(cg-eights--redisplay)))
|
||||
|
||||
(defun cg-eights-new ()
|
||||
"Deal a fresh hand."
|
||||
(interactive)
|
||||
(cg-eights--deal cg-eights--game)
|
||||
(cg-eights--run cg-eights--game)
|
||||
(cg-eights--redisplay))
|
||||
|
||||
(defun cg-eights-redraw () "Redraw." (interactive) (cg-eights--redisplay))
|
||||
(defun cg-eights-help ()
|
||||
"Describe the controls."
|
||||
(interactive)
|
||||
(message "Arrows or click: choose/play RET: play d: draw x: pass +/-: size n: new g: redraw"))
|
||||
|
||||
(defvar cg-eights-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'cg-card-click)
|
||||
(define-key map "+" #'cg-card-zoom-in)
|
||||
(define-key map "=" #'cg-card-zoom-in)
|
||||
(define-key map "-" #'cg-card-zoom-out)
|
||||
(define-key map "0" #'cg-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'cg-eights-left)
|
||||
(define-key map (kbd "<right>") #'cg-eights-right)
|
||||
(define-key map (kbd "RET") #'cg-eights-act)
|
||||
(define-key map (kbd "SPC") #'cg-eights-act)
|
||||
(define-key map "d" #'cg-eights-draw)
|
||||
(define-key map "x" #'cg-eights-pass)
|
||||
(define-key map "n" #'cg-eights-new)
|
||||
(define-key map "g" #'cg-eights-redraw)
|
||||
(define-key map "?" #'cg-eights-help)
|
||||
(define-key map "q" #'cg-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `cg-eights-mode'.")
|
||||
|
||||
(define-derived-mode cg-eights-mode special-mode "Crazy8"
|
||||
"Major mode for Crazy Eights."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type cg-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-eights ()
|
||||
"Play Crazy Eights against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Crazy Eights*")))
|
||||
(with-current-buffer buf
|
||||
(cg-eights-mode)
|
||||
(setq cg-eights--game (cg-eights-game))
|
||||
(cg-eights--deal cg-eights--game)
|
||||
(cg-eights--run cg-eights--game)
|
||||
(cg-eights--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
(provide 'cg-eights)
|
||||
;;; cg-eights.el ends here
|
||||
868
cg-gaps.el
868
cg-gaps.el
|
|
@ -1,868 +0,0 @@
|
|||
;;; 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.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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)
|
||||
(require 'cg-render)
|
||||
|
||||
|
||||
;;;; 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))
|
||||
(cg-suit-glyph (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
|
||||
"Each row one suit, %s. Move to a green + gap and press RET (or click it). ? = 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 "q" "menu" #'cg-quit-to-menu "Back to the game list")
|
||||
(cg-gaps--key-button "?" "help" #'cg-gaps-help "Show the rules and keys")
|
||||
(insert "\n"))
|
||||
|
||||
(cl-defmethod cg-renderer-draw ((_renderer cg-text-renderer) (game cg-gaps-game))
|
||||
"Draw the Gaps GAME as UNICODE text with the control line."
|
||||
(insert (cg-render game))
|
||||
(cg-gaps--insert-controls))
|
||||
|
||||
(cl-defmethod cg-renderer-draw ((_renderer cg-svg-renderer) (game cg-gaps-game))
|
||||
"Draw the Gaps GAME as an inline SVG board with the control line."
|
||||
(cg-gaps--insert-graphical game)
|
||||
(cg-gaps--insert-controls))
|
||||
|
||||
(cl-defmethod cg-renderer-draw ((_renderer cg-svg-fill-renderer) (game cg-gaps-game))
|
||||
"Draw the Gaps GAME as a full-window SVG table."
|
||||
(cg-gaps--insert-svg-ui game))
|
||||
|
||||
(defun cg-gaps--treatment ()
|
||||
"Return the display treatment symbol for the current Gaps buffer.
|
||||
Honours `cg-gaps-svg-ui' and whether the display is graphical."
|
||||
(cond ((and cg-gaps-svg-ui (display-graphic-p)) 'svg-fill)
|
||||
((display-graphic-p) 'svg)
|
||||
(t 'text)))
|
||||
|
||||
(defun cg-gaps--redisplay ()
|
||||
"Redraw the current Gaps buffer through its renderer.
|
||||
The treatment is chosen by `cg-gaps--treatment' and dispatched with
|
||||
`cg-renderer-draw'."
|
||||
(let* ((game cg-gaps--game)
|
||||
(inhibit-read-only t)
|
||||
(renderer (cg-render-set-treatment game (cg-gaps--treatment))))
|
||||
(setq-local mode-line-process (cg-gaps--mode-line game))
|
||||
(erase-buffer)
|
||||
(cg-renderer-draw renderer game)
|
||||
(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)
|
||||
(define-key map "q" #'cg-quit-to-menu)
|
||||
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 cg-cursor-type)
|
||||
(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
|
||||
796
cg-handfoot.el
796
cg-handfoot.el
|
|
@ -1,796 +0,0 @@
|
|||
;;; cg-handfoot.el --- Hand and Foot, a partnership rummy -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Hand & Foot, a Canasta cousin played in partnerships. Each player is
|
||||
;; dealt two packets: a "hand" played first and a "foot" taken up once the
|
||||
;; hand is gone. Partners build *books* -- three or more cards of one
|
||||
;; rank, suits ignored -- on the table; a book of seven is complete (a
|
||||
;; "pile"), clean if it holds no wild card and dirty if it does. Twos and
|
||||
;; Jokers are wild. You go out, ending the round, once your side owns at
|
||||
;; least two complete books and you can empty your foot.
|
||||
;;
|
||||
;; You partner the North player against East and West, all three of them
|
||||
;; computer opponents. Mark cards with SPC, meld them with m, lay off onto
|
||||
;; a book with l, and discard with RET.
|
||||
;;
|
||||
;; This Hand & Foot includes the round-by-round go-down minimum (50, 90,
|
||||
;; 120, then 150), the red-three bonus (100 each, or 200 each for all four),
|
||||
;; and picking up the discard pile -- meld its top card with two matching
|
||||
;; naturals (`p') to take the top card plus several cards beneath it.
|
||||
;; Cards use the package cons
|
||||
;; (SUIT . RANK), RANK 0 (Ace) .. 12 (King), with jokers as (joker . 0).
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'cg-core)
|
||||
(require 'cg-rummy)
|
||||
|
||||
(defcustom cg-handfoot-target 5000
|
||||
"Points a partnership needs to win Hand & Foot."
|
||||
:type 'integer :group 'card-games)
|
||||
|
||||
(defcustom cg-handfoot-pickup-count 7
|
||||
"Cards taken (top included) when picking up the discard pile."
|
||||
:type 'integer :group 'card-games)
|
||||
|
||||
(defconst cg-handfoot--minimums [50 90 120 150]
|
||||
"Initial go-down minimum by round, the last value repeating thereafter.")
|
||||
|
||||
(defconst cg-handfoot--names ["You" "West" "North" "East"]
|
||||
"Seat labels; North is your partner.")
|
||||
|
||||
(defclass cg-handfoot-game (cg-rummy-game)
|
||||
((vname :initform "Hand & Foot"))
|
||||
"A game of Hand & Foot.")
|
||||
|
||||
;;;; Cards
|
||||
|
||||
(defun cg-hf--wild-p (card)
|
||||
"Return non-nil when CARD is wild (a Joker or a Two)."
|
||||
(or (cg-rummy-joker-p card) (= (cdr card) 1)))
|
||||
|
||||
(defun cg-hf--three-p (card)
|
||||
"Return non-nil when CARD is a three (never meldable)."
|
||||
(and (not (cg-rummy-joker-p card)) (= (cdr card) 2)))
|
||||
|
||||
(defun cg-hf--red-three-p (card)
|
||||
"Return non-nil when CARD is a red three (a bonus card)."
|
||||
(and (not (cg-rummy-joker-p card)) (= (cdr card) 2) (cg-red-suit-p (car card))))
|
||||
|
||||
(defun cg-hf-value (card)
|
||||
"Return the Hand & Foot point value of CARD."
|
||||
(cond ((cg-rummy-joker-p card) 50)
|
||||
(t (let ((r (cdr card)))
|
||||
(cond ((= r 1) 20) ; Two (wild)
|
||||
((= r 0) 20) ; Ace
|
||||
((= r 2) 5) ; Three
|
||||
((<= r 6) 5) ; 4 5 6 7
|
||||
(t 10)))))) ; 8 9 10 J Q K
|
||||
|
||||
(defun cg-hf--book-rank (cards)
|
||||
"Return the natural rank shared by CARDS, or nil if invalid."
|
||||
(let ((nats (cl-remove-if #'cg-hf--wild-p cards)))
|
||||
(and nats
|
||||
(let ((r (cdr (car nats))))
|
||||
(and (cl-every (lambda (c) (= (cdr c) r)) nats)
|
||||
(/= r 2)
|
||||
r)))))
|
||||
|
||||
(defun cg-hf--book-valid-p (cards)
|
||||
"Return non-nil when CARDS form a legal book."
|
||||
(let* ((nats (cl-remove-if #'cg-hf--wild-p cards))
|
||||
(wilds (cl-remove-if-not #'cg-hf--wild-p cards)))
|
||||
(and (>= (length cards) 3)
|
||||
(cg-hf--book-rank cards)
|
||||
(>= (length nats) 2)
|
||||
(<= (length wilds) 3)
|
||||
(<= (length wilds) (length nats)))))
|
||||
|
||||
(defun cg-hf--book-complete-p (cards) (>= (length cards) 7))
|
||||
(defun cg-hf--book-clean-p (cards) (not (cl-some #'cg-hf--wild-p cards)))
|
||||
|
||||
;;;; Setup
|
||||
|
||||
(defun cg-hf--team (game s) (mod s (cg-get game :nteams)))
|
||||
|
||||
(cl-defmethod cg-hf--deal ((game cg-handfoot-game))
|
||||
"Deal a fresh round into GAME."
|
||||
(let* ((n (cg-get game :nplayers))
|
||||
(decks (1+ n))
|
||||
(deck (cg-rummy-deck decks 2))
|
||||
(hands (make-vector n nil)) (feet (make-vector n nil))
|
||||
(stage (make-vector n 0)))
|
||||
(dotimes (s n)
|
||||
(aset hands s (cg-rummy-sort-hand (cl-loop repeat 11 collect (pop deck))))
|
||||
(aset feet s (cg-rummy-sort-hand (cl-loop repeat 11 collect (pop deck)))))
|
||||
(cg-put game :hands hands)
|
||||
(cg-put game :feet feet)
|
||||
(cg-put game :stage stage)
|
||||
(cg-put game :books (make-vector (cg-get game :nteams) nil))
|
||||
(cg-put game :round (1+ (or (cg-get game :round) -1)))
|
||||
(cg-put game :down (make-vector (cg-get game :nteams) nil))
|
||||
(cg-put game :redthrees (make-vector (cg-get game :nteams) nil))
|
||||
(cg-put game :discard (list (pop deck)))
|
||||
(cg-put game :stock deck)
|
||||
(dotimes (s n) (cg-hf--collect-red-threes game s))
|
||||
(cg-put game :turn 0)
|
||||
(cg-put game :step 'draw)
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :cursor 0)
|
||||
(cg-put game :marks nil)
|
||||
(cg-put game :message "Your turn: s draws two cards.")
|
||||
game))
|
||||
|
||||
(defun cg-hf--books (game team) (aref (cg-get game :books) team))
|
||||
(defun cg-hf--set-books (game team v) (aset (cg-get game :books) team v))
|
||||
|
||||
(defun cg-hf--down-p (game team)
|
||||
"Return non-nil when TEAM has met this round's go-down minimum."
|
||||
(aref (cg-get game :down) team))
|
||||
|
||||
(defun cg-hf--min-for-round (game)
|
||||
"Return the go-down minimum for GAME's current round."
|
||||
(let ((r (or (cg-get game :round) 0)))
|
||||
(aref cg-handfoot--minimums
|
||||
(min r (1- (length cg-handfoot--minimums))))))
|
||||
|
||||
(defun cg-hf--collect-red-threes (game s)
|
||||
"Move seat S's red threes to its team pile, drawing replacements.
|
||||
Return the number collected."
|
||||
(let ((team (cg-hf--team game s)) (moved 0) (again t))
|
||||
(while again
|
||||
(setq again nil)
|
||||
(let ((rt (cl-find-if #'cg-hf--red-three-p (cg-rummy--hand game s))))
|
||||
(when rt
|
||||
(cg-rummy--set-hand game s (cg-rummy--remove1 rt (cg-rummy--hand game s)))
|
||||
(aset (cg-get game :redthrees) team
|
||||
(cons rt (aref (cg-get game :redthrees) team)))
|
||||
(setq moved (1+ moved))
|
||||
(let ((stock (cg-get game :stock)))
|
||||
(when stock
|
||||
(cg-rummy--set-hand game s (cg-rummy-sort-hand
|
||||
(cons (car stock) (cg-rummy--hand game s))))
|
||||
(cg-put game :stock (cdr stock))))
|
||||
(setq again t))))
|
||||
moved))
|
||||
|
||||
(defun cg-hf--take-foot (game s)
|
||||
"Move seat S onto its foot, collecting any red threes it holds."
|
||||
(aset (cg-get game :stage) s 1)
|
||||
(cg-rummy--set-hand game s (aref (cg-get game :feet) s))
|
||||
(cg-hf--collect-red-threes game s))
|
||||
|
||||
(defun cg-hf--pickup-eligible (game s)
|
||||
"Return non-nil when seat S may pick up the discard pile.
|
||||
That needs two natural cards in hand matching a meldable top discard."
|
||||
(let ((top (cg-rummy--top game)))
|
||||
(and top (not (cg-hf--wild-p top)) (not (cg-hf--three-p top))
|
||||
(>= (cl-count-if (lambda (c) (and (not (cg-hf--wild-p c))
|
||||
(= (cdr c) (cdr top))))
|
||||
(cg-rummy--hand game s))
|
||||
2))))
|
||||
|
||||
(defun cg-hf--pickup (game s)
|
||||
"Seat S picks up the discard pile, melding its top card.
|
||||
Take the top card plus up to `cg-handfoot-pickup-count' - 1 cards beneath
|
||||
it into hand, melding the top with two matching naturals. Return the top
|
||||
card, or nil if ineligible."
|
||||
(when (cg-hf--pickup-eligible game s)
|
||||
(let* ((pile (cg-get game :discard)) (top (car pile)) (rank (cdr top))
|
||||
(team (cg-hf--team game s)) (books (cg-hf--books game team))
|
||||
(nats (cl-remove-if-not
|
||||
(lambda (c) (and (not (cg-hf--wild-p c)) (= (cdr c) rank)))
|
||||
(cg-rummy--hand game s)))
|
||||
(two (list (nth 0 nats) (nth 1 nats)))
|
||||
(existing (cl-find-if
|
||||
(lambda (bk) (and (not (cg-hf--book-complete-p bk))
|
||||
(equal (cg-hf--book-rank bk) rank)))
|
||||
books))
|
||||
(rest (cdr pile))
|
||||
(ntake (min (1- cg-handfoot-pickup-count) (length rest)))
|
||||
(take (cl-subseq rest 0 ntake))
|
||||
(remain (nthcdr ntake rest)))
|
||||
(dolist (c two)
|
||||
(cg-rummy--set-hand game s (cg-rummy--remove1 c (cg-rummy--hand game s))))
|
||||
(if existing
|
||||
(setcar (memq existing books)
|
||||
(cg-rummy-sort-hand (append (list top) two existing)))
|
||||
(cg-hf--set-books game team
|
||||
(append books (list (cg-rummy-sort-hand (cons top two))))))
|
||||
(cg-put game :discard remain)
|
||||
(dolist (c take)
|
||||
(cg-rummy--set-hand game s (cg-rummy-sort-hand
|
||||
(cons c (cg-rummy--hand game s)))))
|
||||
(cg-hf--collect-red-threes game s)
|
||||
top)))
|
||||
|
||||
(defun cg-hf--partition-books (cards)
|
||||
"Partition CARDS into valid books, or nil if they can't all be used.
|
||||
Naturals group by rank (each rank needs two), and wilds fill the groups."
|
||||
(if (or (null cards) (cl-some #'cg-hf--three-p cards)) nil
|
||||
(let ((wilds (cl-remove-if-not #'cg-hf--wild-p cards))
|
||||
(byrank (make-hash-table :test 'eql)) (groups '()) (ok t))
|
||||
(dolist (c cards)
|
||||
(unless (cg-hf--wild-p c) (push c (gethash (cdr c) byrank))))
|
||||
(maphash (lambda (_r cs) (push cs groups)) byrank)
|
||||
(when (or (null groups) (cl-some (lambda (g) (< (length g) 2)) groups))
|
||||
(setq ok nil))
|
||||
(when ok
|
||||
(let ((w (copy-sequence wilds)) (books '()))
|
||||
(dolist (g (sort groups (lambda (a b) (< (length a) (length b)))))
|
||||
(let ((bk (copy-sequence g)))
|
||||
(while (and (< (length bk) 3) w) (push (pop w) bk))
|
||||
(push bk books)))
|
||||
(dolist (wcard w)
|
||||
(let ((tgt (cl-find-if
|
||||
(lambda (bk)
|
||||
(and (< (length bk) 7)
|
||||
(< (cl-count-if #'cg-hf--wild-p bk) 3)
|
||||
(< (cl-count-if #'cg-hf--wild-p bk)
|
||||
(cl-count-if-not #'cg-hf--wild-p bk))))
|
||||
books)))
|
||||
(if tgt (setcar (memq tgt books) (cons wcard tgt)) (setq ok nil))))
|
||||
(if (and ok (cl-every #'cg-hf--book-valid-p books)) books nil))))))
|
||||
|
||||
(defun cg-hf--initial-meld (game s cards)
|
||||
"Lay CARDS as seat S's initial meld, meeting the round minimum.
|
||||
Return non-nil when the team goes down."
|
||||
(let* ((books (cg-hf--partition-books cards))
|
||||
(team (cg-hf--team game s)))
|
||||
(when (and books
|
||||
(cl-subsetp cards (cg-rummy--hand game s) :test #'equal)
|
||||
(>= (apply #'+ (mapcar #'cg-hf-value cards))
|
||||
(cg-hf--min-for-round game)))
|
||||
(dolist (c cards)
|
||||
(cg-rummy--set-hand game s (cg-rummy--remove1 c (cg-rummy--hand game s))))
|
||||
(cg-hf--set-books game team
|
||||
(append (cg-hf--books game team)
|
||||
(mapcar #'cg-rummy-sort-hand books)))
|
||||
(aset (cg-get game :down) team t)
|
||||
t)))
|
||||
|
||||
(defun cg-hf--ai-go-down (game s)
|
||||
"Try to lay seat S's initial meld meeting the round minimum.
|
||||
Return non-nil when the team goes down."
|
||||
(let* ((hand (cg-rummy--hand game s))
|
||||
(byrank (make-hash-table :test 'eql))
|
||||
(wilds (cl-remove-if-not #'cg-hf--wild-p hand)) (cards '()))
|
||||
(dolist (c hand)
|
||||
(unless (or (cg-hf--wild-p c) (cg-hf--three-p c))
|
||||
(push c (gethash (cdr c) byrank))))
|
||||
(let ((w (copy-sequence wilds)))
|
||||
(maphash (lambda (_r cs)
|
||||
(cond ((>= (length cs) 3) (setq cards (append cs cards)))
|
||||
((and (= (length cs) 2) w)
|
||||
(setq cards (append cs (list (pop w)) cards)))))
|
||||
byrank))
|
||||
(when (and cards (>= (apply #'+ (mapcar #'cg-hf-value cards))
|
||||
(cg-hf--min-for-round game)))
|
||||
(cg-hf--initial-meld game s cards))))
|
||||
|
||||
(defun cg-hf--ai-meld (game s)
|
||||
"Meld for seat S, going down only when the round minimum is met."
|
||||
(let ((team (cg-hf--team game s)))
|
||||
(unless (cg-hf--down-p game team) (cg-hf--ai-go-down game s))
|
||||
(when (cg-hf--down-p game team) (cg-hf--ai-extend game s))))
|
||||
|
||||
;;;; Engine
|
||||
|
||||
(defun cg-hf--draw2 (game s)
|
||||
"Draw two stock cards into seat S's hand. Return nil if stock runs out."
|
||||
(let ((ok t))
|
||||
(dotimes (_ 2)
|
||||
(let ((stock (cg-get game :stock)))
|
||||
(if (null stock) (setq ok nil)
|
||||
(cg-rummy--set-hand game s (cg-rummy-sort-hand
|
||||
(cons (car stock) (cg-rummy--hand game s))))
|
||||
(cg-put game :stock (cdr stock)))))
|
||||
ok))
|
||||
|
||||
(defun cg-hf--meld (game s cards)
|
||||
"Have seat S lay CARDS as a new book for their team. Return non-nil on win."
|
||||
(when (and (cg-hf--book-valid-p cards)
|
||||
(cl-subsetp cards (cg-rummy--hand game s) :test #'equal))
|
||||
(let ((team (cg-hf--team game s)))
|
||||
(dolist (c cards)
|
||||
(cg-rummy--set-hand game s (cg-rummy--remove1 c (cg-rummy--hand game s))))
|
||||
(cg-hf--set-books game team
|
||||
(append (cg-hf--books game team)
|
||||
(list (cg-rummy-sort-hand (copy-sequence cards)))))
|
||||
t)))
|
||||
|
||||
(defun cg-rummy--remove1 (card list)
|
||||
"Return LIST with one copy of CARD (an `equal' match) removed."
|
||||
(let ((seen nil))
|
||||
(cl-remove-if (lambda (c) (and (not seen) (equal c card) (setq seen t))) list)))
|
||||
|
||||
(defun cg-hf--layoff (game s card)
|
||||
"Lay CARD off onto a team book it fits. Return non-nil on success."
|
||||
(let* ((team (cg-hf--team game s)) (books (cg-hf--books game team)) (done nil))
|
||||
(catch 'hit
|
||||
(dolist (bk books)
|
||||
(unless (cg-hf--book-complete-p bk)
|
||||
(let ((cand (cons card bk)))
|
||||
(when (cg-hf--book-valid-p cand)
|
||||
(cg-rummy--set-hand game s (cg-rummy--remove1 card (cg-rummy--hand game s)))
|
||||
(setcar (memq bk books) (cg-rummy-sort-hand cand))
|
||||
(setq done t)
|
||||
(throw 'hit t))))))
|
||||
done))
|
||||
|
||||
(defun cg-hf--advance (game s)
|
||||
"After a play, take up the foot or finish, then pass the turn."
|
||||
(let ((stage (cg-get game :stage)))
|
||||
(when (and (= (aref stage s) 0) (null (cg-rummy--hand game s)))
|
||||
;; hand exhausted: pick up the foot
|
||||
(cg-hf--take-foot game s))
|
||||
(if (and (= (aref stage s) 1) (null (cg-rummy--hand game s))
|
||||
(cg-hf--can-go-out-p game (cg-hf--team game s)))
|
||||
(cg-hf--score-round game s)
|
||||
(cg-put game :turn (mod (1+ s) (cg-get game :nplayers)))
|
||||
(cg-put game :step 'draw))))
|
||||
|
||||
(defun cg-hf--can-go-out-p (game team)
|
||||
"Return non-nil when TEAM owns at least two complete books."
|
||||
(>= (cl-count-if #'cg-hf--book-complete-p (cg-hf--books game team)) 2))
|
||||
|
||||
(defun cg-hf--discard (game s card)
|
||||
"Discard CARD from seat S and end the play portion of the turn."
|
||||
(cg-rummy--set-hand game s (cg-rummy--remove1 card (cg-rummy--hand game s)))
|
||||
(cg-put game :discard (cons card (cg-get game :discard)))
|
||||
(cg-hf--advance game s))
|
||||
|
||||
(cl-defmethod cg-hf--score-round ((game cg-handfoot-game) outseat)
|
||||
"Score the round (OUTSEAT went out, or nil if the stock ran dry)."
|
||||
(let* ((nt (cg-get game :nteams)) (scores (cg-get game :scores)))
|
||||
(dotimes (team nt)
|
||||
(let ((pts 0))
|
||||
(dolist (bk (cg-hf--books game team))
|
||||
(dolist (c bk) (setq pts (+ pts (cg-hf-value c))))
|
||||
(when (cg-hf--book-complete-p bk)
|
||||
(setq pts (+ pts (if (cg-hf--book-clean-p bk) 500 300)))))
|
||||
(when (and outseat (= (cg-hf--team game outseat) team))
|
||||
(setq pts (+ pts 100))) ; going-out bonus
|
||||
(let ((k (length (aref (cg-get game :redthrees) team))))
|
||||
(setq pts (+ pts (* k (if (>= k 4) 200 100))))) ; red threes
|
||||
;; subtract cards left in members' hands and feet
|
||||
(dotimes (s (cg-get game :nplayers))
|
||||
(when (= (cg-hf--team game s) team)
|
||||
(dolist (c (cg-rummy--hand game s)) (setq pts (- pts (cg-hf-value c))))
|
||||
(when (= (aref (cg-get game :stage) s) 0)
|
||||
(dolist (c (aref (cg-get game :feet) s))
|
||||
(setq pts (- pts (cg-hf-value c)))))))
|
||||
(aset scores team (+ (aref scores team) pts))))
|
||||
(let ((win nil) (best most-negative-fixnum))
|
||||
(dotimes (team nt)
|
||||
(when (and (>= (aref scores team) cg-handfoot-target)
|
||||
(> (aref scores team) best))
|
||||
(setq win team best (aref scores team))))
|
||||
(cg-put game :phase (if win 'game-over 'round-over))
|
||||
(cg-put game :winner (or win (and outseat (cg-hf--team game outseat))))
|
||||
(cg-put game :reveal t)
|
||||
(cg-put game :message
|
||||
(concat
|
||||
(if outseat (format "%s goes out! " (aref cg-handfoot--names outseat))
|
||||
"Stock exhausted. ")
|
||||
(if win (format "Team %d wins the game! (n: new game)" win)
|
||||
(format "Round over. Scores: %s. (n: next round)"
|
||||
(cg-hf--scores-string game))))))))
|
||||
|
||||
(defun cg-hf--scores-string (game)
|
||||
"Return a compact per-team score line for GAME."
|
||||
(let ((scores (cg-get game :scores)) (parts '()))
|
||||
(dotimes (team (cg-get game :nteams))
|
||||
(push (format "Team %d %d" team (aref scores team)) parts))
|
||||
(mapconcat #'identity (nreverse parts) " · ")))
|
||||
|
||||
;;;; AI
|
||||
|
||||
(defun cg-hf--ai-extend (game s)
|
||||
"Extend and add books for seat S once the team is down."
|
||||
;; lay off naturals onto existing incomplete team books
|
||||
(let ((again t))
|
||||
(while again
|
||||
(setq again nil)
|
||||
(let ((card (cl-find-if
|
||||
(lambda (c)
|
||||
(and (not (cg-hf--wild-p c)) (not (cg-hf--three-p c))
|
||||
(cl-find-if
|
||||
(lambda (bk) (and (not (cg-hf--book-complete-p bk))
|
||||
(equal (cg-hf--book-rank bk) (cdr c))))
|
||||
(cg-hf--books game (cg-hf--team game s)))))
|
||||
(cg-rummy--hand game s))))
|
||||
(when card (cg-hf--layoff game s card) (setq again t)))))
|
||||
;; start new books from ranks with >=3 naturals in hand
|
||||
(let ((again t))
|
||||
(while again
|
||||
(setq again nil)
|
||||
(let* ((hand (cg-rummy--hand game s))
|
||||
(byrank (make-hash-table :test 'eql)) (target nil))
|
||||
(dolist (c hand)
|
||||
(unless (or (cg-hf--wild-p c) (cg-hf--three-p c))
|
||||
(push c (gethash (cdr c) byrank))))
|
||||
(maphash (lambda (_r cs) (when (and (not target) (>= (length cs) 3))
|
||||
(setq target cs)))
|
||||
byrank)
|
||||
(when target
|
||||
(cg-hf--meld game s (cl-subseq target 0 (min 7 (length target))))
|
||||
(setq again t)))))
|
||||
;; push a nearly-complete book to seven with a spare wild
|
||||
(let ((again t))
|
||||
(while again
|
||||
(setq again nil)
|
||||
(let ((wild (cl-find-if #'cg-hf--wild-p (cg-rummy--hand game s)))
|
||||
(team (cg-hf--team game s)))
|
||||
(when wild
|
||||
(let ((bk (cl-find-if
|
||||
(lambda (b)
|
||||
(and (not (cg-hf--book-complete-p b))
|
||||
(>= (length b) 5)
|
||||
(> (cl-count-if-not #'cg-hf--wild-p b)
|
||||
(cl-count-if #'cg-hf--wild-p b))
|
||||
(< (cl-count-if #'cg-hf--wild-p b) 3)))
|
||||
(cg-hf--books game team))))
|
||||
(when bk
|
||||
(cg-rummy--set-hand game s (cg-rummy--remove1 wild (cg-rummy--hand game s)))
|
||||
(setcar (memq bk (cg-hf--books game team))
|
||||
(cg-rummy-sort-hand (cons wild bk)))
|
||||
(setq again t))))))))
|
||||
|
||||
(defun cg-hf--ai-discard-card (game s)
|
||||
"Return the card seat S should discard."
|
||||
(let ((hand (cg-rummy--hand game s)))
|
||||
(or (cl-find-if #'cg-hf--three-p hand)
|
||||
;; a high singleton, else the first card
|
||||
(let ((byrank (make-hash-table :test 'eql)) (best (car hand)) (bestv -1))
|
||||
(dolist (c hand) (unless (cg-hf--wild-p c)
|
||||
(push c (gethash (cdr c) byrank))))
|
||||
(maphash (lambda (_r cs)
|
||||
(when (= (length cs) 1)
|
||||
(let ((v (cg-hf-value (car cs))))
|
||||
(when (> v bestv) (setq best (car cs) bestv v)))))
|
||||
byrank)
|
||||
best))))
|
||||
|
||||
(cl-defmethod cg-hf--ai-turn ((game cg-handfoot-game) s)
|
||||
"Play seat S's whole turn."
|
||||
(let ((got (or (and (> (length (cg-get game :stock)) 30)
|
||||
(cg-hf--pickup-eligible game s)
|
||||
(cg-hf--pickup game s))
|
||||
(cg-hf--draw2 game s))))
|
||||
(if (not got)
|
||||
(cg-hf--score-round game nil)
|
||||
(cg-hf--ai-meld game s)
|
||||
(when (eq (cg-get game :phase) 'play)
|
||||
;; if the hand emptied through melding, pick up the foot and meld again
|
||||
(when (and (= (aref (cg-get game :stage) s) 0) (null (cg-rummy--hand game s)))
|
||||
(cg-hf--take-foot game s)
|
||||
(cg-hf--ai-meld game s))
|
||||
(when (eq (cg-get game :phase) 'play)
|
||||
(if (cg-rummy--hand game s)
|
||||
(cg-hf--discard game s (cg-hf--ai-discard-card game s))
|
||||
(cg-hf--advance game s)))))))
|
||||
|
||||
(defun cg-hf--run (game)
|
||||
"Advance AI seats until it is your turn or the round ends."
|
||||
(while (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0))
|
||||
(cg-hf--ai-turn game (cg-get game :turn))))
|
||||
|
||||
;;;; UI
|
||||
|
||||
(defvar-local cg-hf--game nil "The Hand & Foot game in the current buffer.")
|
||||
|
||||
(defun cg-hf--svg (game)
|
||||
"Return an SVG board for the Hand & Foot GAME."
|
||||
(let* ((scores (cg-get game :scores)) (infos '()) (melds '()))
|
||||
(dotimes (team (cg-get game :nteams))
|
||||
(push (format "Team %d (score %d)%s%s" team (aref scores team)
|
||||
(if (cg-hf--down-p game team) " down"
|
||||
(format " needs %d" (cg-hf--min-for-round game)))
|
||||
(let ((k (length (aref (cg-get game :redthrees) team))))
|
||||
(if (> k 0) (format " red3:%d" k) "")))
|
||||
infos)
|
||||
(dolist (bk (cg-hf--books game team))
|
||||
(push (cons (format "T%d%s" team
|
||||
(if (cg-hf--book-complete-p bk)
|
||||
(if (cg-hf--book-clean-p bk) " clean" " dirty") ""))
|
||||
bk)
|
||||
melds)))
|
||||
(dotimes (s (cg-get game :nplayers))
|
||||
(unless (= s 0)
|
||||
(push (format "%s: %d in hand%s" (aref cg-handfoot--names s)
|
||||
(length (cg-rummy--hand game s))
|
||||
(if (= (aref (cg-get game :stage) s) 1) " (on foot)" ""))
|
||||
infos)))
|
||||
(cg-rummy--board-svg
|
||||
:title (format "Hand & Foot target %d round %d (min %d)"
|
||||
cg-handfoot-target (1+ (or (cg-get game :round) 0))
|
||||
(cg-hf--min-for-round game))
|
||||
:infos (nreverse infos) :melds (nreverse melds)
|
||||
:discard (cg-rummy--top game) :stock (length (cg-get game :stock))
|
||||
:hand (cg-rummy--hand game 0) :cursor (cg-get game :cursor)
|
||||
:marks (cg-get game :marks) :message (cg-get game :message))))
|
||||
|
||||
(cl-defmethod cg-render ((game cg-handfoot-game))
|
||||
"Return a depiction of the Hand & Foot GAME: SVG board if graphical, else text."
|
||||
(if (and cg-rummy-svg-cards (display-graphic-p))
|
||||
(cg-hf--svg game)
|
||||
(cg-hf--render-text game)))
|
||||
|
||||
(defun cg-hf--render-text (game)
|
||||
"Return a plain-text depiction of the Hand & Foot GAME."
|
||||
(let* ((out '()) (scores (cg-get game :scores))
|
||||
(hand (cg-rummy--hand game 0)) (cursor (cg-get game :cursor)))
|
||||
(push (format " Hand & Foot target %d round %d (go-down minimum %d)\n\n"
|
||||
cg-handfoot-target (1+ (or (cg-get game :round) 0))
|
||||
(cg-hf--min-for-round game)) out)
|
||||
(dotimes (team (cg-get game :nteams))
|
||||
(push (format " Team %d (score %d)%s%s:\n" team (aref scores team)
|
||||
(if (cg-hf--down-p game team) " down"
|
||||
(format " needs %d to go down" (cg-hf--min-for-round game)))
|
||||
(let ((k (length (aref (cg-get game :redthrees) team))))
|
||||
(if (> k 0) (format " red3:%d" k) ""))) out)
|
||||
(let ((bks (cg-hf--books game team)))
|
||||
(if bks
|
||||
(dolist (bk bks)
|
||||
(push (format " %s%s\n"
|
||||
(mapconcat #'cg-rummy-card-string bk " ")
|
||||
(cond ((cg-hf--book-complete-p bk)
|
||||
(if (cg-hf--book-clean-p bk) " [clean pile]" " [dirty pile]"))
|
||||
(t "")))
|
||||
out))
|
||||
(push " (no books yet)\n" out))))
|
||||
(push "\n" out)
|
||||
(dotimes (s (cg-get game :nplayers))
|
||||
(unless (= s 0)
|
||||
(push (format " %-6s %d in hand%s\n" (aref cg-handfoot--names s)
|
||||
(length (cg-rummy--hand game s))
|
||||
(if (= (aref (cg-get game :stage) s) 1) " (on foot)" ""))
|
||||
out)))
|
||||
(push (format "\n Discard: %s (pile %d) Stock: %d\n\n"
|
||||
(let ((cs (cg-rummy-card-string (cg-rummy--top game))) (tp (cg-rummy--top game)))
|
||||
(if (and tp (not (cg-rummy-joker-p tp)) (cg-red-suit-p (car tp)))
|
||||
(propertize cs 'face 'cg-red-suit) cs))
|
||||
(length (cg-get game :discard))
|
||||
(length (cg-get game :stock)))
|
||||
out)
|
||||
(push (format " Your %s:\n " (if (= (aref (cg-get game :stage) 0) 1) "foot" "hand")) out)
|
||||
(push (cg-rummy--render-cards hand cursor (cg-get game :marks) nil 'hand) out)
|
||||
(push (format "\n\n %s\n" (cg-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod cg-render-apply ((g cg-handfoot-game) action)
|
||||
"Apply a click ACTION on the hand to GAME G."
|
||||
(pcase action
|
||||
(`(hand . ,i) (cg-put g :cursor i))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun cg-hf--redisplay ()
|
||||
"Redraw the Hand & Foot buffer."
|
||||
(let ((game cg-hf--game) (inhibit-read-only t))
|
||||
(setq cg-current-game game cg-redisplay-function #'cg-hf--redisplay)
|
||||
(setq-local mode-line-process
|
||||
(format " [%s]" (or (cg-get game :step) (cg-get game :phase))))
|
||||
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
|
||||
|
||||
(defun cg-hf--clamp (g)
|
||||
"Keep G's cursor in range and drop stale marks."
|
||||
(let ((n (length (cg-rummy--hand g 0))))
|
||||
(cg-put g :cursor (if (> n 0) (min (cg-get g :cursor) (1- n)) 0))
|
||||
(cg-put g :marks (cl-remove-if (lambda (i) (>= i n)) (cg-get g :marks)))))
|
||||
|
||||
(defun cg-hf--my-turn-p (g)
|
||||
(and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0)))
|
||||
|
||||
(defun cg-hf-left ()
|
||||
"Move the hand cursor left."
|
||||
(interactive)
|
||||
(let* ((g cg-hf--game) (n (length (cg-rummy--hand g 0))))
|
||||
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n)))
|
||||
(cg-hf--redisplay)))
|
||||
|
||||
(defun cg-hf-right ()
|
||||
"Move the hand cursor right."
|
||||
(interactive)
|
||||
(let* ((g cg-hf--game) (n (length (cg-rummy--hand g 0))))
|
||||
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n)))
|
||||
(cg-hf--redisplay)))
|
||||
|
||||
(defun cg-hf-mark ()
|
||||
"Toggle a mark on the card under the cursor."
|
||||
(interactive)
|
||||
(let* ((g cg-hf--game) (i (cg-get g :cursor)) (marks (cg-get g :marks)))
|
||||
(cg-put g :marks (if (memq i marks) (delq i marks) (cons i marks)))
|
||||
(cg-hf--redisplay)))
|
||||
|
||||
(defun cg-hf--marked (g)
|
||||
"Return the marked cards in G's hand."
|
||||
(let ((hand (cg-rummy--hand g 0)))
|
||||
(mapcar (lambda (i) (nth i hand)) (sort (copy-sequence (cg-get g :marks)) #'<))))
|
||||
|
||||
(defun cg-hf-meld ()
|
||||
"Meld the marked cards.
|
||||
Until your team is down you must mark a complete initial meld -- one or
|
||||
more valid books totalling at least the round minimum -- and lay it in one
|
||||
action. After that, mark single books as usual."
|
||||
(interactive)
|
||||
(let* ((g cg-hf--game) (cards (cg-hf--marked g)) (team (cg-hf--team g 0)))
|
||||
(cond
|
||||
((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s)."))
|
||||
((not (cg-hf--down-p g team))
|
||||
(if (cg-hf--initial-meld g 0 cards)
|
||||
(progn
|
||||
(cg-put g :marks nil) (cg-hf--clamp g)
|
||||
(when (and (= (aref (cg-get g :stage) 0) 0) (null (cg-rummy--hand g 0)))
|
||||
(cg-hf--take-foot g 0) (cg-hf--clamp g))
|
||||
(cg-put g :message
|
||||
(format "You're down! (met the %d minimum.) Meld more, lay off, or discard."
|
||||
(cg-hf--min-for-round g))))
|
||||
(cg-put g :message
|
||||
(format "Initial meld must be valid books totalling >= %d; mark them all, then m."
|
||||
(cg-hf--min-for-round g)))))
|
||||
((not (cg-hf--book-valid-p cards))
|
||||
(cg-put g :message "Not a legal book: 3+ of a rank, 2+ natural, wilds <= naturals."))
|
||||
((cg-hf--meld g 0 cards)
|
||||
(cg-put g :marks nil) (cg-hf--clamp g)
|
||||
(if (and (= (aref (cg-get g :stage) 0) 0) (null (cg-rummy--hand g 0)))
|
||||
(progn (cg-hf--take-foot g 0) (cg-hf--clamp g)
|
||||
(cg-put g :message "Hand cleared -- foot picked up! Keep melding or discard (RET)."))
|
||||
(unless (and (= (aref (cg-get g :stage) 0) 1) (null (cg-rummy--hand g 0)))
|
||||
(cg-put g :message "Booked. Meld more, lay off (l), or discard (RET)."))))
|
||||
(t (cg-put g :message "Could not meld those cards.")))
|
||||
(cg-hf--redisplay)))
|
||||
|
||||
(defun cg-hf-layoff ()
|
||||
"Lay the cursor card (or marked cards) off onto a team book."
|
||||
(interactive)
|
||||
(let* ((g cg-hf--game) (marks (cg-hf--marked g)))
|
||||
(cond
|
||||
((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s)."))
|
||||
(t (let ((cards (or marks (list (nth (cg-get g :cursor) (cg-rummy--hand g 0)))))
|
||||
(any nil))
|
||||
(dolist (c cards) (when (and c (cg-hf--layoff g 0 c)) (setq any t)))
|
||||
(cg-put g :marks nil) (cg-hf--clamp g)
|
||||
(cg-put g :message (if any "Laid off." "That card fits none of your books.")))))
|
||||
(cg-hf--redisplay)))
|
||||
|
||||
(defun cg-hf-draw ()
|
||||
"Draw two cards from the stock."
|
||||
(interactive)
|
||||
(let ((g cg-hf--game))
|
||||
(cond
|
||||
((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((not (eq (cg-get g :step) 'draw)) (cg-put g :message "You already drew."))
|
||||
((cg-hf--draw2 g 0)
|
||||
(cg-hf--collect-red-threes g 0)
|
||||
(cg-put g :step 'play) (cg-hf--clamp g)
|
||||
(cg-put g :message "Meld (m), lay off (l), then discard (RET)."))
|
||||
(t (cg-hf--score-round g nil)))
|
||||
(cg-hf--redisplay)))
|
||||
|
||||
(defun cg-hf-pickup ()
|
||||
"Pick up the discard pile by melding its top card (Hand & Foot)."
|
||||
(interactive)
|
||||
(let ((g cg-hf--game))
|
||||
(cond
|
||||
((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((not (eq (cg-get g :step) 'draw)) (cg-put g :message "You already drew."))
|
||||
((not (cg-hf--pickup-eligible g 0))
|
||||
(cg-put g :message
|
||||
"Can't pick up: you need two natural cards matching the top discard."))
|
||||
(t (let ((top (cg-hf--pickup g 0)))
|
||||
(cg-put g :step 'play) (cg-hf--clamp g)
|
||||
(cg-put g :message
|
||||
(format "Picked up the pile, melding %s. Meld more, lay off, or discard."
|
||||
(cg-rummy-card-string top))))))
|
||||
(cg-hf--redisplay)))
|
||||
|
||||
(defun cg-hf-discard ()
|
||||
"Discard the cursor card and end your turn."
|
||||
(interactive)
|
||||
(let* ((g cg-hf--game) (card (nth (cg-get g :cursor) (cg-rummy--hand g 0))))
|
||||
(cond
|
||||
((not (cg-hf--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s)."))
|
||||
((null card) (cg-put g :message "No card selected."))
|
||||
(t (cg-hf--discard g 0 card)
|
||||
(cg-put g :marks nil)
|
||||
(when (memq (cg-get g :phase) '(play))
|
||||
(cg-put g :message "You discarded.")
|
||||
(cg-hf--run g))))
|
||||
(cg-hf--redisplay)))
|
||||
|
||||
(defun cg-hf-new ()
|
||||
"Deal a fresh round, or a new game when one is over."
|
||||
(interactive)
|
||||
(let ((g cg-hf--game))
|
||||
(when (eq (cg-get g :phase) 'game-over)
|
||||
(cg-put g :scores (make-vector (cg-get g :nteams) 0))
|
||||
(cg-put g :round -1))
|
||||
(cg-put g :reveal nil)
|
||||
(cg-hf--deal g)
|
||||
(cg-hf--run g)
|
||||
(cg-hf--redisplay)))
|
||||
|
||||
(defun cg-hf-redraw () "Redraw the board." (interactive) (cg-hf--redisplay))
|
||||
|
||||
(defun cg-hf-help ()
|
||||
"Describe the Hand & Foot controls."
|
||||
(interactive)
|
||||
(message "Arrows: choose SPC: mark m: meld l: lay off s: draw 2 p: pick up pile RET: discard n: new"))
|
||||
|
||||
(defvar cg-handfoot-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'cg-card-click)
|
||||
(define-key map "+" #'cg-card-zoom-in)
|
||||
(define-key map "=" #'cg-card-zoom-in)
|
||||
(define-key map "-" #'cg-card-zoom-out)
|
||||
(define-key map "0" #'cg-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'cg-hf-left)
|
||||
(define-key map (kbd "<right>") #'cg-hf-right)
|
||||
(define-key map (kbd "SPC") #'cg-hf-mark)
|
||||
(define-key map "m" #'cg-hf-meld)
|
||||
(define-key map "l" #'cg-hf-layoff)
|
||||
(define-key map "s" #'cg-hf-draw)
|
||||
(define-key map "p" #'cg-hf-pickup)
|
||||
(define-key map (kbd "RET") #'cg-hf-discard)
|
||||
(define-key map "n" #'cg-hf-new)
|
||||
(define-key map "g" #'cg-hf-redraw)
|
||||
(define-key map "?" #'cg-hf-help)
|
||||
(define-key map "q" #'cg-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `cg-handfoot-mode'.")
|
||||
|
||||
(define-derived-mode cg-handfoot-mode special-mode "Hand&Foot"
|
||||
"Major mode for Hand & Foot."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type cg-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-handfoot ()
|
||||
"Play Hand & Foot, partnering North against two AI opponents."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Hand & Foot*")))
|
||||
(with-current-buffer buf
|
||||
(cg-handfoot-mode)
|
||||
(setq cg-hf--game (cg-handfoot-game))
|
||||
(cg-put cg-hf--game :nplayers 4)
|
||||
(cg-put cg-hf--game :nteams 2)
|
||||
(cg-put cg-hf--game :scores (make-vector 2 0))
|
||||
(cg-hf--deal cg-hf--game)
|
||||
(cg-hf--run cg-hf--game)
|
||||
(cg-hf--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;###autoload
|
||||
(defalias 'cg-hand-and-foot #'cg-handfoot)
|
||||
|
||||
(provide 'cg-handfoot)
|
||||
;;; cg-handfoot.el ends here
|
||||
608
cg-match.el
608
cg-match.el
|
|
@ -1,608 +0,0 @@
|
|||
;;; cg-match.el --- Go Fish and Old Maid -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Two children's classics that turn on matching ranks rather than melding.
|
||||
;;
|
||||
;; `cg-go-fish' -- Go Fish. On your turn ask another player for a rank
|
||||
;; you already hold; collect all four of a rank to lay down a book.
|
||||
;; Whoever lays down the most books wins.
|
||||
;; `cg-old-maid' -- Old Maid. One Queen is removed, so one stays
|
||||
;; unpaired. Discard pairs, then draw blind from your neighbour; do
|
||||
;; not be the one left holding the odd Queen.
|
||||
;;
|
||||
;; You are the first player; the rest are computer opponents. Cards use
|
||||
;; the package cons (SUIT . RANK), RANK 0 (Ace) .. 12 (King).
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'cg-core)
|
||||
(require 'cg-rummy)
|
||||
|
||||
;;;; Go Fish
|
||||
|
||||
(defcustom cg-go-fish-players 3
|
||||
"Number of players in Go Fish, including you (2-5)."
|
||||
:type '(choice (const 2) (const 3) (const 4) (const 5)) :group 'card-games)
|
||||
|
||||
(defclass cg-go-fish-game (cg-game)
|
||||
((vname :initform "Go Fish"))
|
||||
"A game of Go Fish.")
|
||||
|
||||
(defsubst cg-gf--hand (game s) (aref (cg-get game :hands) s))
|
||||
(defsubst cg-gf--set-hand (game s v) (aset (cg-get game :hands) s v))
|
||||
|
||||
(defun cg-gf--books (game s) (aref (cg-get game :books) s))
|
||||
|
||||
(defun cg-gf--rank-count (hand rank)
|
||||
"Return how many cards of RANK are in HAND."
|
||||
(cl-count rank hand :key #'cdr))
|
||||
|
||||
(defun cg-gf--check-books (game s)
|
||||
"Lay down any completed four-of-a-kind books from seat S's hand."
|
||||
(dotimes (r 13)
|
||||
(when (>= (cg-gf--rank-count (cg-gf--hand game s) r) 4)
|
||||
(cg-gf--set-hand game s (cl-remove r (cg-gf--hand game s) :key #'cdr))
|
||||
(aset (cg-get game :books) s (1+ (aref (cg-get game :books) s))))))
|
||||
|
||||
(cl-defmethod cg-gf--deal ((game cg-go-fish-game))
|
||||
"Deal a fresh Go Fish game into GAME."
|
||||
(let* ((n (max 2 (min 5 cg-go-fish-players)))
|
||||
(deck (cg-rummy-deck)) (per (if (<= n 3) 7 5))
|
||||
(hands (make-vector n nil)))
|
||||
(dotimes (s n) (aset hands s (cl-loop repeat per collect (pop deck))))
|
||||
(cg-put game :hands hands)
|
||||
(cg-put game :books (make-vector n 0))
|
||||
(cg-put game :nplayers n)
|
||||
(cg-put game :stock deck)
|
||||
(cg-put game :turn 0)
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :cursor 0)
|
||||
(dotimes (s n)
|
||||
(cg-gf--set-hand game s (cg-rummy-sort-hand (cg-gf--hand game s)))
|
||||
(cg-gf--check-books game s))
|
||||
(cg-put game :message "Pick a card, then press 1-4 to ask that player for its rank.")
|
||||
game))
|
||||
|
||||
(defun cg-gf--draw (game s)
|
||||
"Draw one stock card into seat S's hand. Return it, or nil if empty."
|
||||
(let ((stock (cg-get game :stock)))
|
||||
(when stock
|
||||
(cg-gf--set-hand game s (cg-rummy-sort-hand (cons (car stock) (cg-gf--hand game s))))
|
||||
(cg-put game :stock (cdr stock))
|
||||
(car stock))))
|
||||
|
||||
(defun cg-gf--total-books (game)
|
||||
(let ((sum 0)) (dotimes (s (cg-get game :nplayers))
|
||||
(setq sum (+ sum (cg-gf--books game s))))
|
||||
sum))
|
||||
|
||||
(defun cg-gf--maybe-over (game)
|
||||
"End the game when all thirteen books are made."
|
||||
(when (>= (cg-gf--total-books game) 13)
|
||||
(let ((best 0))
|
||||
(dotimes (s (cg-get game :nplayers))
|
||||
(when (> (cg-gf--books game s) (cg-gf--books game best)) (setq best s)))
|
||||
(cg-put game :phase 'game-over)
|
||||
(cg-put game :winner best)
|
||||
(cg-put game :message
|
||||
(format "Game over. %s wins with %d books! (n: new game)"
|
||||
(cg-gf--who best) (cg-gf--books game best))))))
|
||||
|
||||
(defun cg-gf--who (s) (if (= s 0) "You" (format "Player %d" s)))
|
||||
|
||||
(cl-defmethod cg-gf--ask ((game cg-go-fish-game) asker target rank)
|
||||
"ASKER asks TARGET for RANK. Return non-nil if ASKER keeps the turn."
|
||||
(let* ((got (cl-remove-if-not (lambda (c) (= (cdr c) rank)) (cg-gf--hand game target)))
|
||||
(keep nil))
|
||||
(if got
|
||||
(progn
|
||||
(cg-gf--set-hand game target (cl-remove rank (cg-gf--hand game target) :key #'cdr))
|
||||
(cg-gf--set-hand game asker
|
||||
(cg-rummy-sort-hand (append got (cg-gf--hand game asker))))
|
||||
(cg-put game :message
|
||||
(format "%s took %d %s%s from %s."
|
||||
(cg-gf--who asker) (length got)
|
||||
(aref cg-rummy-ranks rank) (if (> (length got) 1) "s" "")
|
||||
(cg-gf--who target)))
|
||||
(setq keep t))
|
||||
;; go fish
|
||||
(let ((drawn (cg-gf--draw game asker)))
|
||||
(cg-put game :message
|
||||
(format "%s asked %s for %ss -- go fish!%s"
|
||||
(cg-gf--who asker) (cg-gf--who target) (aref cg-rummy-ranks rank)
|
||||
(cond ((null drawn) " (stock empty)")
|
||||
((= (cdr drawn) rank) " Fished it -- go again!")
|
||||
(t ""))))
|
||||
(when (and drawn (= (cdr drawn) rank)) (setq keep t))))
|
||||
(cg-gf--check-books game asker)
|
||||
;; refill an empty hand from the stock if possible
|
||||
(when (and (null (cg-gf--hand game asker)) (cg-get game :stock))
|
||||
(cg-gf--draw game asker))
|
||||
(cg-gf--maybe-over game)
|
||||
(when (and (eq (cg-get game :phase) 'play) (not keep))
|
||||
(cg-put game :turn (cg-gf--next game asker)))
|
||||
keep))
|
||||
|
||||
(defun cg-gf--next (game s)
|
||||
"Return the next seat after S that still has cards (or stock to draw)."
|
||||
(let ((n (cg-get game :nplayers)) (i (mod (1+ s) (cg-get game :nplayers))) (tries 0))
|
||||
(while (and (< tries n) (null (cg-gf--hand game i)) (null (cg-get game :stock)))
|
||||
(setq i (mod (1+ i) n) tries (1+ tries)))
|
||||
i))
|
||||
|
||||
(defun cg-gf--start-turn (game s)
|
||||
"Ready seat S to act: draw up if empty; pass the turn if it cannot ask.
|
||||
Return non-nil when S can ask."
|
||||
(when (and (null (cg-gf--hand game s)) (cg-get game :stock))
|
||||
(cg-gf--draw game s))
|
||||
(cg-gf--maybe-over game)
|
||||
(cond ((not (eq (cg-get game :phase) 'play)) nil)
|
||||
((cg-gf--hand game s) t)
|
||||
(t (cg-put game :turn (cg-gf--next game s)) nil)))
|
||||
|
||||
(cl-defmethod cg-gf--ai-turn ((game cg-go-fish-game) s)
|
||||
"Take seat S's whole AI turn (it may keep asking)."
|
||||
(when (cg-gf--start-turn game s)
|
||||
(let ((guard 0))
|
||||
(while (and (= (cg-get game :turn) s) (eq (cg-get game :phase) 'play)
|
||||
(cg-gf--hand game s) (< guard 40))
|
||||
(setq guard (1+ guard))
|
||||
(let* ((hand (cg-gf--hand game s))
|
||||
(counts (make-vector 13 0)) (rank (cdr (car hand))))
|
||||
(dolist (c hand) (aset counts (cdr c) (1+ (aref counts (cdr c)))))
|
||||
(dotimes (r 13) (when (> (aref counts r) (aref counts rank)) (setq rank r)))
|
||||
(let* ((others (cl-loop for o below (cg-get game :nplayers)
|
||||
unless (= o s) when (cg-gf--hand game o) collect o))
|
||||
(target (and others (nth (random (length others)) others))))
|
||||
(if target (cg-gf--ask game s target rank)
|
||||
(cg-put game :turn (cg-gf--next game s)))))))))
|
||||
|
||||
(defun cg-gf--run (game)
|
||||
"Advance AI seats until it is your turn or the game ends."
|
||||
(let ((guard 0))
|
||||
(while (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0) (< guard 1000))
|
||||
(setq guard (1+ guard))
|
||||
(cg-gf--ai-turn game (cg-get game :turn))))
|
||||
(when (and (eq (cg-get game :phase) 'play) (= (cg-get game :turn) 0))
|
||||
(unless (cg-gf--start-turn game 0)
|
||||
(when (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0))
|
||||
(cg-gf--run game)))))
|
||||
|
||||
;;;; Go Fish UI
|
||||
|
||||
(defvar-local cg-gf--game nil "The Go Fish game in the current buffer.")
|
||||
|
||||
(cl-defmethod cg-render ((game cg-go-fish-game))
|
||||
"Return a propertized depiction of the Go Fish GAME."
|
||||
(let* ((out '()) (hand (cg-gf--hand game 0)) (cursor (cg-get game :cursor)))
|
||||
(push " Go Fish\n\n" out)
|
||||
(dotimes (s (cg-get game :nplayers))
|
||||
(unless (= s 0)
|
||||
(push (format " Player %d: %d cards books %d\n"
|
||||
s (length (cg-gf--hand game s)) (cg-gf--books game s)) out)))
|
||||
(push (format "\n Stock: %d Your books: %d\n\n"
|
||||
(length (cg-get game :stock)) (cg-gf--books game 0)) out)
|
||||
(push " Your hand:\n " out)
|
||||
(push (cg-rummy--render-cards hand cursor nil nil 'hand) out)
|
||||
(push (format "\n\n %s\n" (cg-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod cg-render-apply ((g cg-go-fish-game) action)
|
||||
"Apply a click ACTION on the hand to GAME G."
|
||||
(pcase action
|
||||
(`(hand . ,i) (cg-put g :cursor i))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun cg-gf--hand-ranks (game)
|
||||
"Return the distinct ranks in your hand, low to high (Ace..King)."
|
||||
(let ((seen (make-vector 13 nil)) (out '()))
|
||||
(dolist (c (cg-gf--hand game 0)) (aset seen (cdr c) t))
|
||||
(dotimes (r 13) (when (aref seen r) (push r out)))
|
||||
(nreverse out)))
|
||||
|
||||
(defun cg-gf--pick-rank (button)
|
||||
"Select the rank stored on BUTTON, ready to ask a player for it.
|
||||
Moves the hand cursor to a card of that rank so the existing
|
||||
1-4 player keys ask for it."
|
||||
(let* ((g cg-gf--game) (rank (button-get button 'cg-gf-rank))
|
||||
(i (cl-position rank (cg-gf--hand g 0) :key #'cdr)))
|
||||
(when i (cg-put g :cursor i))
|
||||
(cg-put g :message
|
||||
(format "Ask which player for %s? Press 1-%d."
|
||||
(aref cg-rummy-ranks rank) (1- (cg-get g :nplayers))))
|
||||
(cg-gf--redisplay)))
|
||||
|
||||
(defun cg-gf--insert-rank-picker (game)
|
||||
"Insert a row of clickable rank buttons for the ranks in your hand.
|
||||
Each rank is a large, easy target, so you pick what to ask for by rank
|
||||
instead of hunting for one overlapped card in a big hand."
|
||||
(let* ((ranks (cg-gf--hand-ranks game))
|
||||
(cur (nth (cg-get game :cursor) (cg-gf--hand game 0)))
|
||||
(cur-rank (and cur (cdr cur))))
|
||||
(when ranks
|
||||
(insert "\n Ask for: ")
|
||||
(dolist (r ranks)
|
||||
(insert-text-button
|
||||
(format " %s " (aref cg-rummy-ranks r))
|
||||
'face (if (eql r cur-rank) 'cg-hint 'link)
|
||||
'mouse-face 'highlight 'follow-link t
|
||||
'help-echo (format "Ask a player for %ss" (aref cg-rummy-ranks r))
|
||||
'cg-gf-rank r
|
||||
'action #'cg-gf--pick-rank)
|
||||
(insert " "))
|
||||
(insert "\n"))))
|
||||
|
||||
(defun cg-gf--redisplay ()
|
||||
(let ((game cg-gf--game) (inhibit-read-only t))
|
||||
(setq cg-current-game game cg-redisplay-function #'cg-gf--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (cg-get game :phase)))
|
||||
(erase-buffer)
|
||||
(insert (cg-render game))
|
||||
(cg-gf--insert-rank-picker game)
|
||||
(cg-insert-legend "click a rank (or arrows) · 1-4 ask that player · n new · q menu · ? help")
|
||||
(goto-char (point-min))))
|
||||
|
||||
(defun cg-gf-left ()
|
||||
"Move the hand cursor left."
|
||||
(interactive)
|
||||
(let* ((g cg-gf--game) (n (length (cg-gf--hand g 0))))
|
||||
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n)))
|
||||
(cg-gf--redisplay)))
|
||||
|
||||
(defun cg-gf-right ()
|
||||
"Move the hand cursor right."
|
||||
(interactive)
|
||||
(let* ((g cg-gf--game) (n (length (cg-gf--hand g 0))))
|
||||
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n)))
|
||||
(cg-gf--redisplay)))
|
||||
|
||||
(defun cg-gf-ask ()
|
||||
"Ask the player whose number you pressed for the cursor card's rank."
|
||||
(interactive)
|
||||
(let* ((g cg-gf--game)
|
||||
(target (- last-command-event ?0))
|
||||
(card (nth (cg-get g :cursor) (cg-gf--hand g 0))))
|
||||
(cond
|
||||
((not (eq (cg-get g :phase) 'play)) (cg-put g :message "Press n for a new game."))
|
||||
((/= (cg-get g :turn) 0) (cg-put g :message "Not your turn."))
|
||||
((null card) (cg-put g :message "Pick a card first."))
|
||||
((or (< target 1) (>= target (cg-get g :nplayers)))
|
||||
(cg-put g :message "No such player to ask."))
|
||||
((null (cg-gf--hand g target)) (cg-put g :message "That player has no cards."))
|
||||
(t (cg-gf--ask g 0 target (cdr card))
|
||||
(cg-put g :cursor 0)
|
||||
(unless (= (cg-get g :turn) 0) (cg-gf--run g))))
|
||||
(cg-gf--redisplay)))
|
||||
|
||||
(defun cg-gf-new () "Deal a new Go Fish game." (interactive)
|
||||
(cg-gf--deal cg-gf--game) (cg-gf--redisplay))
|
||||
(defun cg-gf-redraw () "Redraw." (interactive) (cg-gf--redisplay))
|
||||
(defun cg-gf-help () "Describe the controls." (interactive)
|
||||
(message
|
||||
"Click a rank (or arrows) to choose 1-4: ask that player n: new q: menu"))
|
||||
|
||||
(defvar cg-go-fish-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'cg-card-click)
|
||||
(define-key map "+" #'cg-card-zoom-in)
|
||||
(define-key map "=" #'cg-card-zoom-in)
|
||||
(define-key map "-" #'cg-card-zoom-out)
|
||||
(define-key map "0" #'cg-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'cg-gf-left)
|
||||
(define-key map (kbd "<right>") #'cg-gf-right)
|
||||
(dolist (k '("1" "2" "3" "4")) (define-key map k #'cg-gf-ask))
|
||||
(define-key map "n" #'cg-gf-new)
|
||||
(define-key map "g" #'cg-gf-redraw)
|
||||
(define-key map "?" #'cg-gf-help)
|
||||
(define-key map "q" #'cg-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `cg-go-fish-mode'.")
|
||||
|
||||
(define-derived-mode cg-go-fish-mode special-mode "GoFish"
|
||||
"Major mode for Go Fish."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type cg-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-go-fish ()
|
||||
"Play Go Fish against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Go Fish*")))
|
||||
(with-current-buffer buf
|
||||
(cg-go-fish-mode)
|
||||
(setq cg-gf--game (cg-go-fish-game))
|
||||
(cg-gf--deal cg-gf--game)
|
||||
(cg-gf--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
|
||||
;;;; Old Maid
|
||||
|
||||
(defcustom cg-old-maid-players 3
|
||||
"Number of players in Old Maid, including you (2-5)."
|
||||
:type '(choice (const 2) (const 3) (const 4) (const 5)) :group 'card-games)
|
||||
|
||||
(defclass cg-old-maid-game (cg-game)
|
||||
((vname :initform "Old Maid"))
|
||||
"A game of Old Maid.")
|
||||
|
||||
(defsubst cg-om--hand (game s) (aref (cg-get game :hands) s))
|
||||
(defsubst cg-om--set-hand (game s v) (aset (cg-get game :hands) s v))
|
||||
|
||||
(defun cg-om--discard-pairs (hand)
|
||||
"Return HAND with every matched pair of ranks removed."
|
||||
(let ((out '()) (byrank (make-hash-table :test 'eql)))
|
||||
(dolist (c hand) (push c (gethash (cdr c) byrank)))
|
||||
(maphash (lambda (_r cs)
|
||||
(when (cl-oddp (length cs)) (push (car cs) out)))
|
||||
byrank)
|
||||
(cg-rummy-sort-hand out)))
|
||||
|
||||
(cl-defmethod cg-om--deal ((game cg-old-maid-game))
|
||||
"Deal a fresh Old Maid game into GAME (one Queen removed)."
|
||||
(let* ((n (max 2 (min 5 cg-old-maid-players)))
|
||||
(deck (cl-remove (cons 0 11) (cg-rummy-deck) :test #'equal :count 1))
|
||||
(hands (make-vector n nil)) (i 0))
|
||||
(dolist (c deck)
|
||||
(aset hands i (cons c (aref hands i)))
|
||||
(setq i (mod (1+ i) n)))
|
||||
(dotimes (s n) (aset hands s (cg-om--discard-pairs (aref hands s))))
|
||||
(cg-put game :hands hands)
|
||||
(cg-put game :nplayers n)
|
||||
(cg-put game :turn 0)
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :pick 0)
|
||||
(cg-put game :message "Draw a card from the next player: arrows pick, RET draws.")
|
||||
(cg-om--skip-empty game)
|
||||
game))
|
||||
|
||||
(defun cg-om--active (game)
|
||||
"Return the list of seats still holding cards."
|
||||
(cl-loop for s below (cg-get game :nplayers)
|
||||
when (cg-om--hand game s) collect s))
|
||||
|
||||
(defun cg-om--target (game s)
|
||||
"Return the next active seat after S to draw from."
|
||||
(let ((n (cg-get game :nplayers)) (i (mod (1+ s) (cg-get game :nplayers))) (tries 0))
|
||||
(while (and (< tries n) (or (= i s) (null (cg-om--hand game i))))
|
||||
(setq i (mod (1+ i) n) tries (1+ tries)))
|
||||
(and (cg-om--hand game i) i)))
|
||||
|
||||
(defun cg-om--skip-empty (game)
|
||||
"Advance the turn past any seat that has run out of cards."
|
||||
(let ((n (cg-get game :nplayers)) (tries 0))
|
||||
(while (and (< tries n) (null (cg-om--hand game (cg-get game :turn))))
|
||||
(cg-put game :turn (mod (1+ (cg-get game :turn)) n))
|
||||
(setq tries (1+ tries)))))
|
||||
|
||||
(defun cg-om--total (game)
|
||||
(let ((sum 0)) (dotimes (s (cg-get game :nplayers))
|
||||
(setq sum (+ sum (length (cg-om--hand game s)))))
|
||||
sum))
|
||||
|
||||
(cl-defmethod cg-om--draw ((game cg-old-maid-game) drawer idx)
|
||||
"DRAWER takes card IDX from the next active hand, then discards a pair."
|
||||
(let ((target (cg-om--target game drawer)))
|
||||
(when target
|
||||
(let* ((thand (cg-om--hand game target))
|
||||
(card (nth (min idx (1- (length thand))) thand)))
|
||||
(cg-om--set-hand game target (cl-remove card thand :test #'equal :count 1))
|
||||
(cg-om--set-hand game drawer
|
||||
(cg-om--discard-pairs (cons card (cg-om--hand game drawer))))
|
||||
(cg-put game :message
|
||||
(format "%s drew from %s."
|
||||
(if (= drawer 0) "You" (format "Player %d" drawer))
|
||||
(if (= target 0) "you" (format "Player %d" target))))))
|
||||
(if (<= (cg-om--total game) 1)
|
||||
(cg-om--finish game)
|
||||
(cg-put game :turn (mod (1+ drawer) (cg-get game :nplayers)))
|
||||
(cg-put game :pick 0)
|
||||
(cg-om--skip-empty game))))
|
||||
|
||||
(cl-defmethod cg-om--finish ((game cg-old-maid-game))
|
||||
"End the game; whoever holds the last card is the Old Maid."
|
||||
(let ((loser (car (cg-om--active game))))
|
||||
(cg-put game :phase 'game-over)
|
||||
(cg-put game :winner loser)
|
||||
(cg-put game :message
|
||||
(if loser
|
||||
(format "%s is left holding the Old Maid! (n: new game)"
|
||||
(if (= loser 0) "You are" (format "Player %d is" loser)))
|
||||
"All paired off -- a draw! (n: new game)"))))
|
||||
|
||||
(defun cg-om--ai-turn (game s)
|
||||
"Take seat S's AI turn: draw a random card from the next hand."
|
||||
(let ((target (cg-om--target game s)))
|
||||
(if (null target) (cg-om--finish game)
|
||||
(cg-om--draw game s (random (length (cg-om--hand game target)))))))
|
||||
|
||||
(defun cg-om--run (game)
|
||||
"Advance AI seats until it is your turn or the game ends."
|
||||
(let ((guard 0))
|
||||
(while (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0) (< guard 500))
|
||||
(setq guard (1+ guard))
|
||||
(cg-om--ai-turn game (cg-get game :turn)))))
|
||||
|
||||
;;;; Old Maid UI
|
||||
|
||||
(defvar-local cg-om--game nil "The Old Maid game in the current buffer.")
|
||||
|
||||
(defun cg-om--svg (game)
|
||||
"Return an SVG board for the Old Maid GAME."
|
||||
(let* ((w cg-svg-card-width) (h cg-svg-card-height) (gap cg-svg-card-gap) (pad 16)
|
||||
(hand (cg-om--hand game 0)) (n (length hand))
|
||||
(target (cg-om--target game 0)) (pick (or (cg-get game :pick) 0))
|
||||
(yourp (and target (eq (cg-get game :phase) 'play) (= (cg-get game :turn) 0)))
|
||||
(np (cg-get game :nplayers))
|
||||
(overlap (cond ((> n 11) (- w 24)) ((> n 8) 20) (t 0)))
|
||||
(step (max 14 (- (+ w gap) overlap)))
|
||||
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
|
||||
(bstep 20)
|
||||
(tn (and target (length (cg-om--hand game target))))
|
||||
(y-title 6) (y-info 26)
|
||||
(y-target (+ y-info (* (1- np) 16) 18))
|
||||
(y-hand (+ y-target h 42))
|
||||
(targetw (if (and yourp tn (> tn 0)) (+ (* (1- tn) bstep) w) 0))
|
||||
(height (+ y-hand h 30))
|
||||
(width (max (+ fanw (* 2 pad)) (+ targetw (* 2 pad)) 560))
|
||||
(svg (svg-create width height))
|
||||
(lc (cg-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels ((txt (str x y &optional sz bold)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family cg-svg-font-family (and bold '(:font-weight "bold")))))
|
||||
(txt "Old Maid" pad (+ y-title 12) 13 t)
|
||||
(let ((yy (+ y-info 4)))
|
||||
(dotimes (s np)
|
||||
(unless (= s 0)
|
||||
(txt (format "Player %d: %d cards%s" s (length (cg-om--hand game s))
|
||||
(if (eql s target) " <- draw from here" ""))
|
||||
pad yy 12)
|
||||
(setq yy (+ yy 16)))))
|
||||
(when (and yourp tn (> tn 0))
|
||||
(txt (format "Pick a card from Player %d:" target) pad (- y-target 6) 11)
|
||||
(let ((x pad))
|
||||
(dotimes (i tn)
|
||||
(cg-svg-card svg x y-target :down t :highlight (= i pick))
|
||||
(push (cons (list x y-target (if (= i (1- tn)) w bstep) h) (cons 'pick i))
|
||||
regions)
|
||||
(setq x (+ x bstep)))))
|
||||
(txt "Your hand" pad (- y-hand 6) 11)
|
||||
(let ((x (max pad (- (/ width 2) (/ fanw 2)))))
|
||||
(dolist (c hand)
|
||||
(let ((sp (cg-rummy--card-spec c)))
|
||||
(cg-svg-card svg x y-hand :rank (car sp) :suit (cdr sp)))
|
||||
(setq x (+ x step))))
|
||||
(txt (or (cg-get game :message) "") pad (- height 8) 12))
|
||||
(propertize "*" 'display (cg-svg-image svg (cg-scale)) 'cg-regions (nreverse regions))))
|
||||
|
||||
(cl-defmethod cg-render-apply ((g cg-old-maid-game) action)
|
||||
"Apply a click ACTION: pick that card from the target and draw it."
|
||||
(pcase action
|
||||
(`(pick . ,i) (cg-put g :pick i) (cg-om-draw))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(cl-defmethod cg-render ((game cg-old-maid-game))
|
||||
"Return a depiction of the Old Maid GAME: SVG board if graphical, else text."
|
||||
(if (and cg-rummy-svg-cards (display-graphic-p))
|
||||
(cg-om--svg game)
|
||||
(cg-om--render-text game)))
|
||||
|
||||
(defun cg-om--render-text (game)
|
||||
"Return a plain-text depiction of the Old Maid GAME."
|
||||
(let* ((out '()) (target (cg-om--target game 0)))
|
||||
(push " Old Maid\n\n" out)
|
||||
(dotimes (s (cg-get game :nplayers))
|
||||
(unless (= s 0)
|
||||
(push (format " Player %d: %d cards%s\n" s (length (cg-om--hand game s))
|
||||
(if (eql s target) " <- you draw from here" "")) out)))
|
||||
(when (and target (eq (cg-get game :phase) 'play) (= (cg-get game :turn) 0))
|
||||
(push (format "\n Player %d's cards (pick one to draw):\n " target) out)
|
||||
(let ((np (length (cg-om--hand game target))) (pk (cg-get game :pick)))
|
||||
(dotimes (i np)
|
||||
(push (propertize " ##" 'face (if (= i pk) 'cg-cursor 'cg-gap)) out))))
|
||||
(push "\n\n Your hand:\n " out)
|
||||
(push (cg-rummy--render-cards (cg-om--hand game 0) -1 nil) out)
|
||||
(push (format "\n\n %s\n" (cg-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(defun cg-om--redisplay ()
|
||||
(let ((game cg-om--game) (inhibit-read-only t))
|
||||
(setq cg-current-game game cg-redisplay-function #'cg-om--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (cg-get game :phase)))
|
||||
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
|
||||
|
||||
(defun cg-om-left ()
|
||||
"Move the pick cursor left over the target's cards."
|
||||
(interactive)
|
||||
(let* ((g cg-om--game) (target (cg-om--target g 0))
|
||||
(np (and target (length (cg-om--hand g target)))))
|
||||
(when (and np (> np 0)) (cg-put g :pick (mod (1- (cg-get g :pick)) np)))
|
||||
(cg-om--redisplay)))
|
||||
|
||||
(defun cg-om-right ()
|
||||
"Move the pick cursor right over the target's cards."
|
||||
(interactive)
|
||||
(let* ((g cg-om--game) (target (cg-om--target g 0))
|
||||
(np (and target (length (cg-om--hand g target)))))
|
||||
(when (and np (> np 0)) (cg-put g :pick (mod (1+ (cg-get g :pick)) np)))
|
||||
(cg-om--redisplay)))
|
||||
|
||||
(defun cg-om-draw ()
|
||||
"Draw the selected card from the next player."
|
||||
(interactive)
|
||||
(let ((g cg-om--game))
|
||||
(cond
|
||||
((not (eq (cg-get g :phase) 'play)) (cg-put g :message "Press n for a new game."))
|
||||
((/= (cg-get g :turn) 0) (cg-put g :message "Not your turn."))
|
||||
(t (cg-om--draw g 0 (cg-get g :pick))
|
||||
(unless (= (cg-get g :turn) 0) (cg-om--run g))))
|
||||
(cg-om--redisplay)))
|
||||
|
||||
(defun cg-om-new () "Deal a new Old Maid game." (interactive)
|
||||
(cg-om--deal cg-om--game) (cg-om--redisplay))
|
||||
(defun cg-om-redraw () "Redraw." (interactive) (cg-om--redisplay))
|
||||
(defun cg-om-help () "Describe the controls." (interactive)
|
||||
(message "Arrows: pick a card from the next player RET: draw it n: new g: redraw"))
|
||||
|
||||
(defvar cg-old-maid-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'cg-card-click)
|
||||
(define-key map "+" #'cg-card-zoom-in)
|
||||
(define-key map "=" #'cg-card-zoom-in)
|
||||
(define-key map "-" #'cg-card-zoom-out)
|
||||
(define-key map "0" #'cg-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'cg-om-left)
|
||||
(define-key map (kbd "<right>") #'cg-om-right)
|
||||
(define-key map (kbd "RET") #'cg-om-draw)
|
||||
(define-key map "n" #'cg-om-new)
|
||||
(define-key map "g" #'cg-om-redraw)
|
||||
(define-key map "?" #'cg-om-help)
|
||||
(define-key map "q" #'cg-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `cg-old-maid-mode'.")
|
||||
|
||||
(define-derived-mode cg-old-maid-mode special-mode "OldMaid"
|
||||
"Major mode for Old Maid."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type cg-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-old-maid ()
|
||||
"Play Old Maid against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Old Maid*")))
|
||||
(with-current-buffer buf
|
||||
(cg-old-maid-mode)
|
||||
(setq cg-om--game (cg-old-maid-game))
|
||||
(cg-om--deal cg-om--game)
|
||||
(cg-om--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
(provide 'cg-match)
|
||||
;;; cg-match.el ends here
|
||||
226
cg-net.el
226
cg-net.el
|
|
@ -1,226 +0,0 @@
|
|||
;;; cg-net.el --- Networked multiplayer for card games -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Host-authoritative networking for the card games. One Emacs is the
|
||||
;; HOST: it owns the canonical game and listens for players. Other
|
||||
;; Emacsen CONNECT as clients, send move "intents", and receive the new
|
||||
;; game state to redraw. Because the games are turn-based there is
|
||||
;; nothing to merge, so this is a simple authoritative server rather
|
||||
;; than a CRDT; crdt.el is kept in reserve for any future free-form
|
||||
;; shared state.
|
||||
;;
|
||||
;; Transport is line-delimited s-expressions over `make-network-process'
|
||||
;; (plain TCP), so it works wherever Emacs has TCP -- including an
|
||||
;; Android client joining a desktop host. A message is a plist with a
|
||||
;; `:type' key:
|
||||
;;
|
||||
;; client -> host: (:type hello :name NAME)
|
||||
;; (:type move :move MOVE)
|
||||
;; host -> client: (:type welcome :seat N)
|
||||
;; (:type state :state SEXP)
|
||||
;;
|
||||
;; A game plugs in by defining methods on `cg-net-apply-move' (host
|
||||
;; side) and, if its state is not just the env plist, on
|
||||
;; `cg-net-game-state' / `cg-net-set-game-state'. Clients add a
|
||||
;; redraw function to `cg-net-state-functions'.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cg-core)
|
||||
|
||||
(defgroup cg-net nil
|
||||
"Networked play for card games."
|
||||
:group 'card-games
|
||||
:prefix "cg-net-")
|
||||
|
||||
(defcustom cg-net-port 7500
|
||||
"Default TCP port used to host or join a game."
|
||||
:type 'integer :group 'cg-net)
|
||||
|
||||
(defvar cg-net-state-functions nil
|
||||
"Abnormal hook run on a client after the game state is updated.
|
||||
Each function is called with the client's game object.")
|
||||
|
||||
(defvar cg-net-connect-functions nil
|
||||
"Abnormal hook run on the host when a client connects.
|
||||
Each function is called with (HOST SEAT): the `cg-net-host' struct and
|
||||
the seat number just assigned to the new connection.")
|
||||
|
||||
;;;; Game integration points
|
||||
|
||||
(cl-defgeneric cg-net-apply-move (game seat move)
|
||||
"Apply MOVE made by SEAT to GAME on the host.
|
||||
Return non-nil when the move was accepted (and state should broadcast).")
|
||||
|
||||
(cl-defgeneric cg-net-game-state (game &optional seat)
|
||||
"Return a `read'able representation of GAME's shared state for SEAT.
|
||||
SEAT is the recipient's seat number, letting a game hide other players'
|
||||
private information; nil requests the full host view.")
|
||||
|
||||
(cl-defmethod cg-net-game-state ((game cg-game) &optional _seat)
|
||||
"Default: return GAME's env plist (no per-seat filtering)."
|
||||
(oref game env))
|
||||
|
||||
(cl-defgeneric cg-net-set-game-state (game state)
|
||||
"Replace GAME's shared state with STATE on a client.")
|
||||
|
||||
(cl-defmethod cg-net-set-game-state ((game cg-game) state)
|
||||
"Default: install STATE as GAME's env plist."
|
||||
(oset game env state))
|
||||
|
||||
;;;; Wire protocol
|
||||
|
||||
(defun cg-net--send (proc msg)
|
||||
"Send MSG (a sexp) to PROC as one newline-terminated line."
|
||||
(when (process-live-p proc)
|
||||
(let ((print-length nil) (print-level nil))
|
||||
(process-send-string proc (concat (prin1-to-string msg) "\n")))))
|
||||
|
||||
(defun cg-net--filter (handler)
|
||||
"Return a process filter dispatching each complete line to HANDLER.
|
||||
HANDLER is called with (PROC MSG)."
|
||||
(lambda (proc string)
|
||||
(let ((buf (concat (or (process-get proc 'cg-net-buf) "") string))
|
||||
(start 0) nl)
|
||||
(while (setq nl (string-search "\n" buf start))
|
||||
(let ((line (substring buf start nl)))
|
||||
(setq start (1+ nl))
|
||||
(unless (string-empty-p line)
|
||||
(condition-case err
|
||||
(funcall handler proc (car (read-from-string line)))
|
||||
(error (message "cg-net: bad message: %S" err)))))
|
||||
)
|
||||
(process-put proc 'cg-net-buf (substring buf start)))))
|
||||
|
||||
;;;; Host
|
||||
|
||||
(cl-defstruct (cg-net-host (:constructor cg-net--host-make))
|
||||
server game (clients nil) (next-seat 0))
|
||||
|
||||
(defvar cg-net--host nil
|
||||
"The running `cg-net-host', or nil when not hosting.")
|
||||
|
||||
(defun cg-net-hosting-p ()
|
||||
"Return non-nil when this Emacs is hosting a game."
|
||||
(and cg-net--host (process-live-p (cg-net-host-server cg-net--host))))
|
||||
|
||||
(defun cg-net-host-start (game &optional port)
|
||||
"Begin hosting GAME on PORT (default `cg-net-port'). Return the server process."
|
||||
(let* ((port (or port cg-net-port))
|
||||
(server (make-network-process
|
||||
:name "cg-host" :server t :service port
|
||||
:host "0.0.0.0" :family 'ipv4 :coding 'utf-8
|
||||
:log #'cg-net--host-accept)))
|
||||
(setq cg-net--host (cg-net--host-make :server server :game game))
|
||||
server))
|
||||
|
||||
(defun cg-net-host-stop ()
|
||||
"Stop hosting and close all client connections."
|
||||
(when cg-net--host
|
||||
(dolist (c (cg-net-host-clients cg-net--host))
|
||||
(when (process-live-p c) (delete-process c)))
|
||||
(when (process-live-p (cg-net-host-server cg-net--host))
|
||||
(delete-process (cg-net-host-server cg-net--host)))
|
||||
(setq cg-net--host nil)))
|
||||
|
||||
(defun cg-net--host-accept (_server connection _message)
|
||||
"Set up an accepted CONNECTION: assign a seat and send the current state."
|
||||
(let ((seat (cg-net-host-next-seat cg-net--host)))
|
||||
(setf (cg-net-host-next-seat cg-net--host) (1+ seat))
|
||||
(push connection (cg-net-host-clients cg-net--host))
|
||||
(process-put connection 'cg-net-seat seat)
|
||||
(set-process-coding-system connection 'utf-8 'utf-8)
|
||||
(set-process-filter connection (cg-net--filter #'cg-net--host-handle))
|
||||
(cg-net--send connection (list :type 'welcome :seat seat))
|
||||
(cg-net--send connection
|
||||
(list :type 'state
|
||||
:state (cg-net-game-state (cg-net-host-game cg-net--host) seat)))
|
||||
(run-hook-with-args 'cg-net-connect-functions cg-net--host seat)))
|
||||
|
||||
(defun cg-net--host-handle (proc msg)
|
||||
"Handle one message MSG from a client PROC on the host."
|
||||
(pcase (plist-get msg :type)
|
||||
('hello (process-put proc 'cg-net-name (plist-get msg :name)))
|
||||
('move
|
||||
(let ((seat (process-get proc 'cg-net-seat))
|
||||
(game (cg-net-host-game cg-net--host)))
|
||||
(when (cg-net-apply-move game seat (plist-get msg :move))
|
||||
(cg-net-host-broadcast))))))
|
||||
|
||||
(defun cg-net-host-broadcast ()
|
||||
"Send each connected client the game state filtered for its seat."
|
||||
(when cg-net--host
|
||||
(let ((game (cg-net-host-game cg-net--host)))
|
||||
(dolist (c (cg-net-host-clients cg-net--host))
|
||||
(cg-net--send c (list :type 'state
|
||||
:state (cg-net-game-state
|
||||
game (process-get c 'cg-net-seat))))))))
|
||||
|
||||
;;;; Client
|
||||
|
||||
(cl-defstruct (cg-net-client (:constructor cg-net--client-make))
|
||||
proc game (seat nil))
|
||||
|
||||
(defvar cg-net--client nil
|
||||
"The active `cg-net-client', or nil when not connected.")
|
||||
|
||||
(defun cg-net-connected-p ()
|
||||
"Return non-nil when connected to a host as a client."
|
||||
(and cg-net--client (process-live-p (cg-net-client-proc cg-net--client))))
|
||||
|
||||
(defun cg-net-connect (host port name game)
|
||||
"Connect to HOST on PORT as NAME, syncing into the local GAME.
|
||||
Return the new `cg-net-client'."
|
||||
(let ((proc (make-network-process
|
||||
:name "cg-client" :host host :service port
|
||||
:family 'ipv4 :coding 'utf-8)))
|
||||
(setq cg-net--client (cg-net--client-make :proc proc :game game))
|
||||
(set-process-coding-system proc 'utf-8 'utf-8)
|
||||
(set-process-filter proc (cg-net--filter #'cg-net--client-handle))
|
||||
(cg-net--send proc (list :type 'hello :name name))
|
||||
cg-net--client))
|
||||
|
||||
(defun cg-net-disconnect ()
|
||||
"Disconnect from the host."
|
||||
(when (and cg-net--client (process-live-p (cg-net-client-proc cg-net--client)))
|
||||
(delete-process (cg-net-client-proc cg-net--client)))
|
||||
(setq cg-net--client nil))
|
||||
|
||||
(defun cg-net--client-handle (_proc msg)
|
||||
"Handle one message MSG from the host on a client."
|
||||
(pcase (plist-get msg :type)
|
||||
('welcome (setf (cg-net-client-seat cg-net--client) (plist-get msg :seat)))
|
||||
('state
|
||||
(let ((game (cg-net-client-game cg-net--client)))
|
||||
(cg-net-set-game-state game (plist-get msg :state))
|
||||
(run-hook-with-args 'cg-net-state-functions game)))))
|
||||
|
||||
(defun cg-net-send-move (move)
|
||||
"Send MOVE to the host from this client."
|
||||
(cg-net--send (cg-net-client-proc cg-net--client) (list :type 'move :move move)))
|
||||
|
||||
(provide 'cg-net)
|
||||
;;; cg-net.el ends here
|
||||
449
cg-patience.el
449
cg-patience.el
|
|
@ -1,449 +0,0 @@
|
|||
;;; cg-patience.el --- Pile solitaires (Golf, TriPeaks, Pyramid) -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Three "pile" solitaires that clear a fixed layout of cards rather than
|
||||
;; building tableau columns:
|
||||
;;
|
||||
;; `cg-golf' -- move an exposed card to the waste when it is one rank
|
||||
;; above or below the waste's top card; deal when stuck.
|
||||
;; `cg-tripeaks' -- the same, on three overlapping peaks, with Ace-King
|
||||
;; wrapping so long chains are possible.
|
||||
;; `cg-pyramid' -- remove pairs of exposed cards whose ranks sum to 13
|
||||
;; (Kings go alone); deal from the stock to help.
|
||||
;;
|
||||
;; A board is a vector of card slots; each slot lists the slots that cover
|
||||
;; it, and a slot is "exposed" (playable) once all its coverers are gone.
|
||||
;; Cards are the package-standard cons (SUIT . RANK) with RANK 0 Ace .. 12
|
||||
;; King; a rank's value for the sum-of-13 rule is RANK + 1.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'cg-core)
|
||||
(require 'cg-svg)
|
||||
|
||||
(defconst cg-pat-ranks
|
||||
["A" "2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K"]
|
||||
"Rank labels indexed 0 (Ace) .. 12 (King).")
|
||||
|
||||
(defun cg-pat-card-string (card)
|
||||
"Return a short string for CARD, or a dot for an empty slot."
|
||||
(if (null card) "·"
|
||||
(concat (aref cg-pat-ranks (cdr card)) (cg-suit-glyph (car card)))))
|
||||
|
||||
(defsubst cg-pat-red-p (card) (and card (cg-red-suit-p (car card))))
|
||||
|
||||
(defun cg-pat--deck () (cg-shuffle (cl-loop for s below 4 append
|
||||
(cl-loop for r below 13 collect (cons s r)))))
|
||||
|
||||
;;;; Classes
|
||||
|
||||
(defclass cg-patience-game (cg-game)
|
||||
((mode :initform 'build :documentation "Play mode: build (waste) or sum13.")
|
||||
(wrap :initform nil :documentation "Whether Ace-King wrap in build mode.")
|
||||
(vname :initform "Patience"))
|
||||
"Abstract base for the pile solitaires."
|
||||
:abstract t)
|
||||
|
||||
(defclass cg-golf-game (cg-patience-game)
|
||||
((mode :initform 'build) (wrap :initform nil) (vname :initform "Golf")))
|
||||
(defclass cg-tripeaks-game (cg-patience-game)
|
||||
((mode :initform 'build) (wrap :initform t) (vname :initform "TriPeaks")))
|
||||
(defclass cg-pyramid-game (cg-patience-game)
|
||||
((mode :initform 'sum13) (vname :initform "Pyramid")))
|
||||
|
||||
;;;; Layouts -- return (CARDS-VECTOR COVER-VECTOR ROWS), ROWS for display.
|
||||
|
||||
(cl-defgeneric cg-pat--layout (game deck)
|
||||
"Build GAME's board from DECK; return (CARDS COVER ROWS STOCK WASTE).")
|
||||
|
||||
(cl-defmethod cg-pat--layout ((_ cg-golf-game) deck)
|
||||
(let ((cards (make-vector 35 nil)) (cover (make-vector 35 nil)) (rows nil))
|
||||
(dotimes (c 7) (dotimes (r 5)
|
||||
(let ((i (+ (* c 5) r)))
|
||||
(aset cards i (pop deck))
|
||||
(when (< r 4) (aset cover i (list (+ i 1)))))))
|
||||
(dotimes (r 5) (push (cl-loop for c below 7 collect (+ (* c 5) r)) rows))
|
||||
(let ((waste (list (pop deck))))
|
||||
(list cards cover (nreverse rows) deck waste))))
|
||||
|
||||
(cl-defmethod cg-pat--layout ((_ cg-tripeaks-game) deck)
|
||||
(let ((cards (make-vector 28 nil))
|
||||
(cover (vector '(3 4) '(5 6) '(7 8)
|
||||
'(9 10) '(10 11) '(12 13) '(13 14) '(15 16) '(16 17)
|
||||
'(18 19) '(19 20) '(20 21) '(21 22) '(22 23) '(23 24)
|
||||
'(24 25) '(25 26) '(26 27)
|
||||
nil nil nil nil nil nil nil nil nil nil))
|
||||
(rows (list '(0 1 2) '(3 4 5 6 7 8)
|
||||
'(9 10 11 12 13 14 15 16 17)
|
||||
'(18 19 20 21 22 23 24 25 26 27))))
|
||||
(dotimes (i 28) (aset cards i (pop deck)))
|
||||
(let ((waste (list (pop deck))))
|
||||
(list cards cover rows deck waste))))
|
||||
|
||||
(cl-defmethod cg-pat--layout ((_ cg-pyramid-game) deck)
|
||||
(let ((cards (make-vector 28 nil)) (cover (make-vector 28 nil)) (rows nil))
|
||||
(dotimes (r 7)
|
||||
(let ((start (/ (* r (1+ r)) 2)) (row nil))
|
||||
(dotimes (i (1+ r))
|
||||
(let ((idx (+ start i)))
|
||||
(aset cards idx (pop deck))
|
||||
(push idx row)
|
||||
(when (< r 6)
|
||||
(let ((below (/ (* (1+ r) (+ r 2)) 2)))
|
||||
(aset cover idx (list (+ below i) (+ below i 1)))))))
|
||||
(push (nreverse row) rows)))
|
||||
(list cards cover (nreverse rows) deck nil)))
|
||||
|
||||
;;;; Engine
|
||||
|
||||
(cl-defmethod cg-pat--deal ((game cg-patience-game))
|
||||
"Deal a fresh board into GAME."
|
||||
(random t)
|
||||
(cl-destructuring-bind (cards cover rows stock waste) (cg-pat--layout game (cg-pat--deck))
|
||||
(cg-put game :cards cards)
|
||||
(cg-put game :cover cover)
|
||||
(cg-put game :rows rows)
|
||||
(cg-put game :stock stock)
|
||||
(cg-put game :waste waste)
|
||||
(cg-put game :marks nil)
|
||||
(cg-put game :cursor 0)
|
||||
(cg-put game :moves 0)
|
||||
(cg-put game :history nil)
|
||||
(cg-put game :message
|
||||
(if (eq (oref game mode) 'sum13)
|
||||
"Remove pairs summing to 13; Kings go alone. RET marks, stock deals."
|
||||
"Move a card one rank from the waste top. RET plays; stock deals."))
|
||||
game))
|
||||
|
||||
(defun cg-pat--exposed-p (game i)
|
||||
"Return non-nil when board slot I is present and uncovered."
|
||||
(let ((cards (cg-get game :cards)))
|
||||
(and (aref cards i)
|
||||
(cl-every (lambda (j) (null (aref cards j))) (aref (cg-get game :cover) i)))))
|
||||
|
||||
(defun cg-pat--exposed (game)
|
||||
"Return the list of exposed board slot indices."
|
||||
(cl-loop for i below (length (cg-get game :cards))
|
||||
when (cg-pat--exposed-p game i) collect i))
|
||||
|
||||
(defun cg-pat--spots (game)
|
||||
"Return the ordered spots the cursor can visit."
|
||||
(append (mapcar (lambda (i) (cons 'slot i)) (cg-pat--exposed game))
|
||||
'((waste . 0) (stock . 0))))
|
||||
|
||||
(defun cg-pat--waste-top (game) (car (last (cg-get game :waste))))
|
||||
|
||||
(defun cg-pat--board-empty-p (game)
|
||||
"Return non-nil when every board slot has been cleared."
|
||||
(cl-every #'null (append (cg-get game :cards) nil)))
|
||||
|
||||
(cl-defmethod cg-won-p ((game cg-patience-game))
|
||||
"Return non-nil when the board has been cleared."
|
||||
(cg-pat--board-empty-p game))
|
||||
|
||||
(defun cg-pat--adjacent (a b wrap)
|
||||
"Return non-nil when ranks A and B differ by one (or wrap Ace-King)."
|
||||
(let ((d (abs (- a b)))) (or (= d 1) (and wrap (= d 12)))))
|
||||
|
||||
(defun cg-pat--snapshot (game)
|
||||
"Record an undo snapshot of GAME."
|
||||
(cg-put game :history
|
||||
(cons (list (copy-sequence (cg-get game :cards))
|
||||
(copy-sequence (cg-get game :stock))
|
||||
(copy-sequence (cg-get game :waste))
|
||||
(cg-get game :moves))
|
||||
(cg-get game :history))))
|
||||
|
||||
(defun cg-pat--restore (game)
|
||||
"Undo the last move of GAME, if any."
|
||||
(let ((h (cg-get game :history)))
|
||||
(when h
|
||||
(cl-destructuring-bind (cards stock waste moves) (car h)
|
||||
(cg-put game :cards cards) (cg-put game :stock stock)
|
||||
(cg-put game :waste waste) (cg-put game :moves moves))
|
||||
(cg-put game :history (cdr h))
|
||||
(cg-put game :marks nil)
|
||||
t)))
|
||||
|
||||
(defun cg-pat--deal-stock (game)
|
||||
"Turn one card from the stock to the waste."
|
||||
(let ((stock (cg-get game :stock)))
|
||||
(if (null stock)
|
||||
(cg-put game :message "The stock is empty.")
|
||||
(cg-pat--snapshot game)
|
||||
(cg-put game :waste (append (cg-get game :waste) (last stock 1)))
|
||||
(cg-put game :stock (butlast stock 1))
|
||||
(cg-put game :marks nil)
|
||||
(cg-put game :message "Dealt a card."))))
|
||||
|
||||
(defun cg-pat--value (card) "Sum-of-13 value of CARD." (1+ (cdr card)))
|
||||
|
||||
(defun cg-pat--remove-slot (game i)
|
||||
"Clear board slot I."
|
||||
(aset (cg-get game :cards) i nil))
|
||||
|
||||
;;;; Interaction
|
||||
|
||||
(defvar-local cg-pat--game nil "The pile-solitaire game in the current buffer.")
|
||||
|
||||
(defun cg-pat--cur-spot (game)
|
||||
(let ((spots (cg-pat--spots game)))
|
||||
(nth (min (cg-get game :cursor) (1- (length spots))) spots)))
|
||||
|
||||
(defun cg-pat-act ()
|
||||
"Play the spot under the cursor (build move, sum-13 mark, or deal)."
|
||||
(interactive)
|
||||
(let* ((game cg-pat--game) (spot (cg-pat--cur-spot game)))
|
||||
(pcase (car spot)
|
||||
('stock (cg-pat--deal-stock game))
|
||||
('waste (when (eq (oref game mode) 'sum13) (cg-pat--toggle-mark game (cons 'waste 0))))
|
||||
('slot
|
||||
(let* ((i (cdr spot)) (card (aref (cg-get game :cards) i)))
|
||||
(if (eq (oref game mode) 'build)
|
||||
(let ((top (cg-pat--waste-top game)))
|
||||
(if (and top (cg-pat--adjacent (cdr card) (cdr top) (oref game wrap)))
|
||||
(progn (cg-pat--snapshot game)
|
||||
(cg-put game :waste (append (cg-get game :waste) (list card)))
|
||||
(cg-pat--remove-slot game i)
|
||||
(cg-put game :moves (1+ (cg-get game :moves)))
|
||||
(cg-put game :message "Played."))
|
||||
(cg-put game :message "That card is not adjacent to the waste top.")))
|
||||
;; sum13
|
||||
(if (= 13 (cg-pat--value card))
|
||||
(progn (cg-pat--snapshot game) (cg-pat--remove-slot game i)
|
||||
(cg-put game :moves (1+ (cg-get game :moves)))
|
||||
(cg-put game :marks nil)
|
||||
(cg-put game :message "King removed."))
|
||||
(cg-pat--toggle-mark game (cons 'slot i)))))))
|
||||
(cg-pat--after game)))
|
||||
|
||||
(defun cg-pat--mark-value (game m)
|
||||
"Return the card value of mark M (a slot or the waste)."
|
||||
(pcase (car m)
|
||||
('slot (cg-pat--value (aref (cg-get game :cards) (cdr m))))
|
||||
('waste (let ((w (cg-pat--waste-top game))) (and w (cg-pat--value w))))))
|
||||
|
||||
(defun cg-pat--toggle-mark (game m)
|
||||
"Toggle mark M; when two marks sum to 13, remove both."
|
||||
(if (member m (cg-get game :marks))
|
||||
(cg-put game :marks (remove m (cg-get game :marks)))
|
||||
(cg-put game :marks (cons m (cg-get game :marks))))
|
||||
(let ((marks (cg-get game :marks)))
|
||||
(when (= 2 (length marks))
|
||||
(if (= 13 (+ (cg-pat--mark-value game (nth 0 marks))
|
||||
(cg-pat--mark-value game (nth 1 marks))))
|
||||
(progn (cg-pat--snapshot game)
|
||||
(dolist (mm marks)
|
||||
(pcase (car mm)
|
||||
('slot (cg-pat--remove-slot game (cdr mm)))
|
||||
('waste (cg-put game :waste (butlast (cg-get game :waste) 1)))))
|
||||
(cg-put game :moves (1+ (cg-get game :moves)))
|
||||
(cg-put game :marks nil)
|
||||
(cg-put game :message "Pair removed."))
|
||||
(cg-put game :marks nil)
|
||||
(cg-put game :message "Those do not sum to 13.")))))
|
||||
|
||||
(defun cg-pat--after (game)
|
||||
"Redisplay GAME and announce a win."
|
||||
(cg-pat--redisplay)
|
||||
(when (cg-won-p game)
|
||||
(cg-put game :message "Board cleared -- you won! Press n for a new game.")
|
||||
(cg-pat--redisplay)
|
||||
(message "Solved!")))
|
||||
|
||||
(defun cg-pat--move (delta)
|
||||
(let* ((game cg-pat--game) (n (length (cg-pat--spots game))))
|
||||
(cg-put game :cursor (mod (+ (cg-get game :cursor) delta) n))
|
||||
(cg-pat--redisplay)))
|
||||
|
||||
(defun cg-pat-left () "Cursor left." (interactive) (cg-pat--move -1))
|
||||
(defun cg-pat-right () "Cursor right." (interactive) (cg-pat--move 1))
|
||||
(defun cg-pat-undo () "Undo." (interactive)
|
||||
(let ((game cg-pat--game))
|
||||
(cg-put game :message (if (cg-pat--restore game) "Undid a move." "Nothing to undo."))
|
||||
(cg-pat--redisplay)))
|
||||
(defun cg-pat-new () "New deal." (interactive)
|
||||
(cg-pat--deal cg-pat--game) (cg-pat--redisplay))
|
||||
(defun cg-pat-redraw () "Redraw." (interactive) (cg-pat--redisplay))
|
||||
(defun cg-pat-help () "Controls." (interactive)
|
||||
(message "Arrows or click: move/play RET: play/mark/deal u: undo +/-: size n: new"))
|
||||
|
||||
;;;; Rendering
|
||||
|
||||
(defun cg-pat--render-card (card &optional exposed marked cursor)
|
||||
(let ((s (cg-pat-card-string card)) (faces nil))
|
||||
(when (cg-pat-red-p card) (push 'cg-red-suit faces))
|
||||
(when (and card (not exposed)) (push 'cg-gap faces))
|
||||
(when marked (push 'cg-hint faces))
|
||||
(when cursor (push 'cg-cursor faces))
|
||||
(propertize (format "%4s" s) 'face (or faces 'default))))
|
||||
|
||||
(defcustom cg-pat-svg-cards t
|
||||
"When non-nil, draw the patience board as SVG on a graphical display."
|
||||
:type 'boolean :group 'card-games)
|
||||
|
||||
(defun cg-pat--spec (card)
|
||||
"Return the cg-svg display spec (RANK-STRING . SUIT) for CARD, or nil."
|
||||
(and card (cons (aref cg-pat-ranks (cdr card)) (car card))))
|
||||
|
||||
(defun cg-pat--svg (game)
|
||||
"Return a propertized, clickable one-image SVG board for patience GAME.
|
||||
Exposed slots, the waste, and the stock each carry a click region (the
|
||||
matching spot); a card-size slider sits below."
|
||||
(let* ((w cg-svg-card-width) (h cg-svg-card-height) (pad 12) (gap cg-svg-card-gap)
|
||||
(rowstep 30) (rows (cg-get game :rows)) (cur (cg-pat--cur-spot game))
|
||||
(marks (cg-get game :marks)) (lc (cg-color 'shadow :foreground "gray40"))
|
||||
(maxlen (apply #'max 1 (mapcar #'length rows))) (nrows (length rows))
|
||||
(sh (cg-svg-slider-height))
|
||||
(width (+ (* 2 pad) (max (* maxlen (+ w gap)) (cg-svg-slider-width))))
|
||||
(boardh (+ (* (1- nrows) rowstep) h)) (bottom-y (+ pad boardh 26))
|
||||
(slider-y (+ bottom-y h 10))
|
||||
(height (+ slider-y sh pad)) (svg (svg-create width height))
|
||||
(r 0) (regions '()))
|
||||
(dolist (row rows)
|
||||
(let* ((len (length row)) (x0 (/ (- width (* len (+ w gap))) 2))
|
||||
(y (+ pad (* r rowstep))) (c 0))
|
||||
(dolist (i row)
|
||||
(let* ((card (aref (cg-get game :cards) i)) (x (+ x0 (* c (+ w gap)))))
|
||||
(when card
|
||||
(cg-svg-card svg x y :rank (car (cg-pat--spec card))
|
||||
:suit (cdr (cg-pat--spec card))
|
||||
:highlight (equal cur (cons 'slot i))
|
||||
:hint (and (member (cons 'slot i) marks) t))
|
||||
(when (cg-pat--exposed-p game i)
|
||||
(push (cons (list x y w h) (cons 'slot i)) regions))))
|
||||
(setq c (1+ c))))
|
||||
(setq r (1+ r)))
|
||||
(svg-text svg "Waste" :x pad :y (- bottom-y 3) :font-size 11 :fill lc
|
||||
:font-family cg-svg-font-family)
|
||||
(let ((wt (cg-pat--waste-top game)))
|
||||
(if wt (cg-svg-card svg pad bottom-y :rank (car (cg-pat--spec wt))
|
||||
:suit (cdr (cg-pat--spec wt))
|
||||
:highlight (equal cur '(waste . 0))
|
||||
:hint (and (member '(waste . 0) marks) t))
|
||||
(cg-svg-card svg pad bottom-y :gap t :highlight (equal cur '(waste . 0)))))
|
||||
(push (cons (list pad bottom-y w h) (cons 'waste 0)) regions)
|
||||
(svg-text svg (format "Stock(%d)" (length (cg-get game :stock)))
|
||||
:x (+ pad w gap) :y (- bottom-y 3) :font-size 11 :fill lc
|
||||
:font-family cg-svg-font-family)
|
||||
(if (cg-get game :stock)
|
||||
(cg-svg-card svg (+ pad w gap) bottom-y :down t :highlight (equal cur '(stock . 0)))
|
||||
(cg-svg-card svg (+ pad w gap) bottom-y :gap t :highlight (equal cur '(stock . 0))))
|
||||
(push (cons (list (+ pad w gap) bottom-y w h) (cons 'stock 0)) regions)
|
||||
(setq regions (append (nreverse regions)
|
||||
(cg-svg-slider-draw svg pad slider-y cg-card-scale)))
|
||||
(propertize "*" 'display (cg-svg-image svg (cg-scale)) 'cg-regions regions)))
|
||||
|
||||
(cl-defmethod cg-render-apply ((g cg-patience-game) action)
|
||||
"Apply a click ACTION (a board spot) to GAME G: select that spot and play."
|
||||
(pcase action
|
||||
((or `(slot . ,_) `(waste . ,_) `(stock . ,_))
|
||||
(let ((idx (cl-position action (cg-pat--spots g) :test #'equal)))
|
||||
(when idx (cg-put g :cursor idx) (cg-pat-act))))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(cl-defmethod cg-render ((game cg-patience-game))
|
||||
"Return a propertized depiction of GAME (SVG on a graphical display)."
|
||||
(if (and cg-pat-svg-cards (display-graphic-p))
|
||||
(cg-pat--svg game)
|
||||
(cg-pat--render-text game)))
|
||||
|
||||
(defun cg-pat--render-text (game)
|
||||
"Return a plain-text depiction of patience GAME."
|
||||
(let* ((cur (cg-pat--cur-spot game)) (marks (cg-get game :marks)) (out (list)))
|
||||
(push (format " %s Moves: %d\n\n" (oref game vname) (cg-get game :moves)) out)
|
||||
(dolist (row (cg-get game :rows))
|
||||
(push " " out)
|
||||
(dolist (i row)
|
||||
(let* ((card (aref (cg-get game :cards) i))
|
||||
(exp (cg-pat--exposed-p game i))
|
||||
(mk (member (cons 'slot i) marks))
|
||||
(cz (equal cur (cons 'slot i))))
|
||||
(push (if card (cg-pat--render-card card exp mk cz) " ") out)))
|
||||
(push "\n" out))
|
||||
(push (format "\n Waste: %s Stock: %d\n"
|
||||
(let ((w (cg-pat--waste-top game)))
|
||||
(cg-pat--render-card w t (member '(waste . 0) marks)
|
||||
(equal cur '(waste . 0))))
|
||||
(length (cg-get game :stock)))
|
||||
out)
|
||||
(push (format " %s\n" (if (equal cur '(stock . 0))
|
||||
(propertize "[stock]" 'face 'cg-cursor) "")) out)
|
||||
(push (format "\n %s\n" (cg-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(defun cg-pat--redisplay ()
|
||||
(let ((game cg-pat--game) (inhibit-read-only t))
|
||||
(setq cg-current-game game cg-redisplay-function #'cg-pat--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (if (cg-won-p game) "solved" "playing")))
|
||||
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
|
||||
|
||||
;;;; Mode and commands
|
||||
|
||||
(defvar cg-pat-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'cg-card-click)
|
||||
(define-key map "+" #'cg-card-zoom-in)
|
||||
(define-key map "=" #'cg-card-zoom-in)
|
||||
(define-key map "-" #'cg-card-zoom-out)
|
||||
(define-key map "0" #'cg-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'cg-pat-left)
|
||||
(define-key map (kbd "<right>") #'cg-pat-right)
|
||||
(define-key map (kbd "<up>") #'cg-pat-left)
|
||||
(define-key map (kbd "<down>") #'cg-pat-right)
|
||||
(define-key map (kbd "RET") #'cg-pat-act)
|
||||
(define-key map (kbd "SPC") #'cg-pat-act)
|
||||
(define-key map "u" #'cg-pat-undo)
|
||||
(define-key map "n" #'cg-pat-new)
|
||||
(define-key map "g" #'cg-pat-redraw)
|
||||
(define-key map "?" #'cg-pat-help)
|
||||
(define-key map "q" #'cg-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `cg-pat-mode'.")
|
||||
|
||||
(define-derived-mode cg-pat-mode special-mode "Patience"
|
||||
"Major mode for the pile solitaires."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type cg-cursor-type))
|
||||
|
||||
(defun cg-pat--play (class)
|
||||
(let* ((game (cg-pat--deal (make-instance class)))
|
||||
(buf (get-buffer-create (format "*%s*" (oref game vname)))))
|
||||
(with-current-buffer buf
|
||||
(cg-pat-mode) (setq cg-pat--game game) (cg-pat--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-golf () "Play Golf solitaire." (interactive) (cg-pat--play 'cg-golf-game))
|
||||
;;;###autoload
|
||||
(defun cg-tripeaks () "Play TriPeaks solitaire." (interactive) (cg-pat--play 'cg-tripeaks-game))
|
||||
;;;###autoload
|
||||
(defun cg-pyramid () "Play Pyramid solitaire." (interactive) (cg-pat--play 'cg-pyramid-game))
|
||||
|
||||
(provide 'cg-patience)
|
||||
;;; cg-patience.el ends here
|
||||
426
cg-president.el
426
cg-president.el
|
|
@ -1,426 +0,0 @@
|
|||
;;; cg-president.el --- President (Scum), a climbing card game -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; President (also Scum, Asshole, Daihinmin): a climbing/shedding game.
|
||||
;; The leader plays one to four cards of a single rank; each player in turn
|
||||
;; must beat it with the same number of a higher rank or pass. Once all but
|
||||
;; one have passed, the pile clears and the last player to play leads again.
|
||||
;; The first player out is President, the last is Scum; on the next deal the
|
||||
;; Scum hands the President their two best cards and gets two junk cards back.
|
||||
;;
|
||||
;; You are the South player (seat 0); the rest are simple AI. Card power
|
||||
;; runs 3 (low) .. K, A, then the Two (highest). Cards are the package
|
||||
;; cons (SUIT . RANK) with RANK 0 (the Two) .. 12 (the Ace).
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'cg-core)
|
||||
(require 'cg-svg)
|
||||
|
||||
(defconst cg-pres-ranks
|
||||
["2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K" "A"]
|
||||
"Rank labels indexed 0 (Two) .. 12 (Ace).")
|
||||
|
||||
(defconst cg-pres-titles ["President" "Vice-President" "Citizen"
|
||||
"Vice-Scum" "Scum"]
|
||||
"Finishing titles from first out to last.")
|
||||
|
||||
(defcustom cg-president-players 4
|
||||
"Number of players in President, including you (3-6)."
|
||||
:type 'integer :group 'card-games)
|
||||
|
||||
(defun cg-pres--power (rank)
|
||||
"Return the climbing power of RANK; the Two (RANK 0) is highest."
|
||||
(if (= rank 0) 13 rank))
|
||||
|
||||
(defun cg-pres-card-string (card)
|
||||
(if (null card) "·"
|
||||
(concat (aref cg-pres-ranks (cdr card)) (cg-suit-glyph (car card)))))
|
||||
|
||||
(defsubst cg-pres-red-p (card) (and card (cg-red-suit-p (car card))))
|
||||
|
||||
(defun cg-pres--deck ()
|
||||
(cg-shuffle (cl-loop for s below 4 append
|
||||
(cl-loop for r below 13 collect (cons s r)))))
|
||||
|
||||
(defun cg-pres--sort (cards)
|
||||
"Sort CARDS by climbing power then suit."
|
||||
(sort (copy-sequence cards)
|
||||
(lambda (a b) (if (= (cg-pres--power (cdr a)) (cg-pres--power (cdr b)))
|
||||
(< (car a) (car b))
|
||||
(< (cg-pres--power (cdr a)) (cg-pres--power (cdr b)))))))
|
||||
|
||||
(defclass cg-president-game (cg-game)
|
||||
((vname :initform "President"))
|
||||
"A game of President (Scum).")
|
||||
|
||||
(defsubst cg-pres--hand (game s) (aref (cg-get game :hands) s))
|
||||
(defsubst cg-pres--set-hand (game s v) (aset (cg-get game :hands) s v))
|
||||
(defsubst cg-pres--name (_game s)
|
||||
(if (= s 0) "You" (format "Player %d" s)))
|
||||
|
||||
;;;; Dealing and the inter-game exchange
|
||||
|
||||
(cl-defmethod cg-pres--deal ((game cg-president-game))
|
||||
(let* ((n (max 3 (min 6 cg-president-players)))
|
||||
(deck (cg-pres--deck))
|
||||
(hands (make-vector n nil))
|
||||
(s 0))
|
||||
(while deck
|
||||
(push (pop deck) (aref hands (mod s n)))
|
||||
(cl-incf s))
|
||||
(dotimes (i n) (aset hands i (cg-pres--sort (aref hands i))))
|
||||
(cg-put game :hands hands)
|
||||
(cg-put game :nplayers n)
|
||||
(cg-pres--exchange game) ; carry out roles from the last deal
|
||||
(cg-put game :count 0)
|
||||
(cg-put game :top -1)
|
||||
(cg-put game :passed (make-vector n nil))
|
||||
(cg-put game :out nil)
|
||||
(cg-put game :last-player nil)
|
||||
(cg-put game :turn 0)
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :cursor 0)
|
||||
(unless (cg-get game :games) (cg-put game :games 0))
|
||||
(cg-put game :message
|
||||
"Lead any rank; others beat it with a higher one or pass. p passes.")
|
||||
game))
|
||||
|
||||
(defun cg-pres--best (hand k) "The K highest-power cards of HAND." (last (cg-pres--sort hand) k))
|
||||
(defun cg-pres--worst (hand k) "The K lowest-power cards of HAND." (cl-subseq (cg-pres--sort hand) 0 k))
|
||||
|
||||
(cl-defmethod cg-pres--exchange ((game cg-president-game))
|
||||
"Trade cards by rank from the previous deal's finishing order, if any."
|
||||
(let ((order (cg-get game :order)) (n (cg-get game :nplayers)))
|
||||
(when (and order (= (length order) n) (>= n 4))
|
||||
(let* ((prez (nth 0 order)) (scum (nth (1- n) order))
|
||||
(vp (nth 1 order)) (vice (nth (- n 2) order)))
|
||||
(cg-pres--give game scum prez 2) ; scum's 2 best -> president
|
||||
(cg-pres--give game prez scum 2 t) ; president's 2 worst -> scum
|
||||
(cg-pres--give game vice vp 1)
|
||||
(cg-pres--give game vp vice 1 t)))))
|
||||
|
||||
(defun cg-pres--give (game from to k &optional worst)
|
||||
"Move K cards (best, or WORST) from seat FROM to seat TO."
|
||||
(let* ((cards (if worst (cg-pres--worst (cg-pres--hand game from) k)
|
||||
(cg-pres--best (cg-pres--hand game from) k))))
|
||||
(cg-pres--set-hand game from
|
||||
(cl-set-difference (cg-pres--hand game from) cards :test #'equal))
|
||||
(cg-pres--set-hand game to
|
||||
(cg-pres--sort (append (cg-pres--hand game to) cards)))))
|
||||
|
||||
;;;; Move logic
|
||||
|
||||
(defun cg-pres--rank-counts (game s)
|
||||
"Return an alist (RANK . COUNT) for seat S's hand."
|
||||
(let ((tbl nil))
|
||||
(dolist (c (cg-pres--hand game s))
|
||||
(setf (alist-get (cdr c) tbl 0) (1+ (alist-get (cdr c) tbl 0))))
|
||||
tbl))
|
||||
|
||||
(defun cg-pres--legal-ranks (game s)
|
||||
"Return the ranks seat S may legally play now."
|
||||
(let ((cnt (cg-get game :count)) (top (cg-get game :top)))
|
||||
(cl-loop for (r . c) in (cg-pres--rank-counts game s)
|
||||
when (if (= cnt 0) t (and (>= c cnt) (> (cg-pres--power r) top)))
|
||||
collect r)))
|
||||
|
||||
(defun cg-pres--remove-n (hand rank n)
|
||||
"Remove N cards of RANK from HAND."
|
||||
(let ((out nil) (left n))
|
||||
(dolist (c hand) (if (and (> left 0) (= (cdr c) rank))
|
||||
(cl-decf left) (push c out)))
|
||||
(nreverse out)))
|
||||
|
||||
(defun cg-pres--in-game (game)
|
||||
"Seats that still hold cards."
|
||||
(cl-loop for s below (cg-get game :nplayers)
|
||||
unless (memq s (cg-get game :out)) collect s))
|
||||
|
||||
(defun cg-pres--round-active (game)
|
||||
"Seats that can still act on the current pile."
|
||||
(cl-loop for s below (cg-get game :nplayers)
|
||||
unless (or (memq s (cg-get game :out)) (aref (cg-get game :passed) s))
|
||||
collect s))
|
||||
|
||||
(defun cg-pres--next (game from)
|
||||
"Next seat after FROM that is still in the round."
|
||||
(let ((n (cg-get game :nplayers)) (s from) (res nil))
|
||||
(dotimes (_ n)
|
||||
(setq s (mod (1+ s) n))
|
||||
(when (and (not res)
|
||||
(not (memq s (cg-get game :out)))
|
||||
(not (aref (cg-get game :passed) s)))
|
||||
(setq res s)))
|
||||
(or res from)))
|
||||
|
||||
(defun cg-pres--clear (game)
|
||||
"Clear the pile; the last player to play leads (or the next active seat)."
|
||||
(cg-put game :count 0) (cg-put game :top -1)
|
||||
(cg-put game :passed (make-vector (cg-get game :nplayers) nil))
|
||||
(let ((last (cg-get game :last-player)))
|
||||
(cg-put game :turn (if (and last (not (memq last (cg-get game :out)))) last
|
||||
(cg-pres--next game (or last 0)))))
|
||||
(cg-put game :message "Pile cleared."))
|
||||
|
||||
(defun cg-pres--check-finish (game)
|
||||
"End the game when only one player still holds cards (the Scum)."
|
||||
(let ((in (cg-pres--in-game game)))
|
||||
(when (<= (length in) 1)
|
||||
(when in (cg-put game :out (append (cg-get game :out) in)))
|
||||
(cg-put game :order (cg-get game :out))
|
||||
(cg-put game :games (1+ (or (cg-get game :games) 0)))
|
||||
(cg-put game :phase 'game-over)
|
||||
(cg-put game :message (cg-pres--result game))
|
||||
t)))
|
||||
|
||||
(defun cg-pres--advance (game)
|
||||
"Decide the next turn or clear the pile after a move."
|
||||
(unless (cg-pres--check-finish game)
|
||||
(let* ((active (cg-pres--round-active game))
|
||||
(last (cg-get game :last-player))
|
||||
(others (and last (cl-remove last active))))
|
||||
(if (and (> (cg-get game :count) 0) (null others))
|
||||
(cg-pres--clear game)
|
||||
(cg-put game :turn (cg-pres--next game (cg-get game :turn)))))))
|
||||
|
||||
(defun cg-pres--play (game seat rank n)
|
||||
"Seat SEAT plays N cards of RANK."
|
||||
(cg-pres--set-hand game seat (cg-pres--remove-n (cg-pres--hand game seat) rank n))
|
||||
(cg-put game :count n) (cg-put game :top (cg-pres--power rank))
|
||||
(cg-put game :last-player seat)
|
||||
(when (null (cg-pres--hand game seat))
|
||||
(cg-put game :out (append (cg-get game :out) (list seat))))
|
||||
(cg-put game :message (format "%s plays %d × %s" (cg-pres--name game seat)
|
||||
n (aref cg-pres-ranks rank)))
|
||||
(cg-pres--advance game))
|
||||
|
||||
(defun cg-pres--pass (game seat)
|
||||
"Seat SEAT passes for the current pile."
|
||||
(aset (cg-get game :passed) seat t)
|
||||
(cg-put game :message (format "%s passes." (cg-pres--name game seat)))
|
||||
(cg-pres--advance game))
|
||||
|
||||
(defun cg-pres--ai-move (game seat)
|
||||
"Make seat SEAT's move: lead low, beat low, or pass."
|
||||
(let* ((cnt (cg-get game :count)) (top (cg-get game :top))
|
||||
(counts (cg-pres--rank-counts game seat)))
|
||||
(if (= cnt 0)
|
||||
(let ((r (caar (cl-sort counts #'< :key (lambda (x) (cg-pres--power (car x)))))))
|
||||
(cg-pres--play game seat r 1))
|
||||
(let ((cand (cl-loop for (r . c) in counts
|
||||
when (and (>= c cnt) (> (cg-pres--power r) top)) collect r)))
|
||||
(if cand
|
||||
(cg-pres--play game seat
|
||||
(car (cl-sort cand #'< :key #'cg-pres--power)) cnt)
|
||||
(cg-pres--pass game seat))))))
|
||||
|
||||
(defun cg-pres--result (game)
|
||||
"Return a finishing summary string."
|
||||
(let* ((order (cg-get game :order)) (n (length order)) (parts nil))
|
||||
(dotimes (i n)
|
||||
(let ((title (cond ((= i 0) "President") ((= i (1- n)) "Scum")
|
||||
((= i 1) "Vice-President") ((= i (- n 2)) "Vice-Scum")
|
||||
(t "Citizen"))))
|
||||
(push (format "%s: %s" title (cg-pres--name game (nth i order))) parts)))
|
||||
(concat "Game over -- " (mapconcat #'identity (nreverse parts) ", ")
|
||||
". Press n for the next deal.")))
|
||||
|
||||
;;;; UI
|
||||
|
||||
(defvar-local cg-pres--game nil "The President game in the current buffer.")
|
||||
|
||||
(defun cg-pres--run (game)
|
||||
"Advance AI seats until it is the human's turn or the game ends."
|
||||
(while (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0))
|
||||
(cg-pres--ai-move game (cg-get game :turn))))
|
||||
|
||||
(defun cg-pres--hand-ranks (game)
|
||||
"Distinct ranks in seat 0's hand, ordered by power."
|
||||
(let ((rs (delete-dups (mapcar #'cdr (cg-pres--hand game 0)))))
|
||||
(cl-sort rs #'< :key #'cg-pres--power)))
|
||||
|
||||
(defun cg-pres-act (&optional count)
|
||||
"Play the selected rank. With prefix COUNT, lead that many of it."
|
||||
(interactive "P")
|
||||
(let* ((game cg-pres--game)
|
||||
(ranks (cg-pres--hand-ranks game)))
|
||||
(cond
|
||||
((not (eq (cg-get game :phase) 'play)) (cg-put game :message "Press n for a new deal."))
|
||||
((/= (cg-get game :turn) 0) (cg-put game :message "Not your turn."))
|
||||
((null ranks) (cg-put game :message "You are out."))
|
||||
(t (let* ((rank (nth (min (cg-get game :cursor) (1- (length ranks))) ranks))
|
||||
(have (cl-count rank (mapcar #'cdr (cg-pres--hand game 0))))
|
||||
(need (cg-get game :count)))
|
||||
(if (= need 0)
|
||||
(let ((n (min have (max 1 (prefix-numeric-value (or count 1))))))
|
||||
(cg-pres--play game 0 rank n)
|
||||
(cg-put game :cursor 0)
|
||||
(cg-pres--run game))
|
||||
(if (and (>= have need) (> (cg-pres--power rank) (cg-get game :top)))
|
||||
(progn (cg-pres--play game 0 rank need)
|
||||
(cg-put game :cursor 0)
|
||||
(cg-pres--run game))
|
||||
(cg-put game :message
|
||||
(format "Need %d of a rank higher than the pile." need)))))))
|
||||
(cg-pres--redisplay)))
|
||||
|
||||
(defun cg-pres-pass ()
|
||||
"Pass for the current pile."
|
||||
(interactive)
|
||||
(let ((game cg-pres--game))
|
||||
(cond
|
||||
((/= (cg-get game :turn) 0) (cg-put game :message "Not your turn."))
|
||||
((= (cg-get game :count) 0) (cg-put game :message "You lead -- you must play."))
|
||||
(t (cg-pres--pass game 0) (cg-pres--run game)))
|
||||
(cg-pres--redisplay)))
|
||||
|
||||
(defun cg-pres-left () "Cursor left." (interactive)
|
||||
(let* ((g cg-pres--game) (n (length (cg-pres--hand-ranks g))))
|
||||
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n))) (cg-pres--redisplay)))
|
||||
(defun cg-pres-right () "Cursor right." (interactive)
|
||||
(let* ((g cg-pres--game) (n (length (cg-pres--hand-ranks g))))
|
||||
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n))) (cg-pres--redisplay)))
|
||||
(defun cg-pres-new () "New deal." (interactive)
|
||||
(cg-pres--deal cg-pres--game) (cg-pres--run cg-pres--game) (cg-pres--redisplay))
|
||||
(defun cg-pres-redraw () "Redraw." (interactive) (cg-pres--redisplay))
|
||||
(defun cg-pres-help () "Controls." (interactive)
|
||||
(message "Arrows or click: choose/play RET: play (C-u N to lead N) p: pass +/-: size n: new"))
|
||||
|
||||
(defcustom cg-pres-svg-cards t
|
||||
"When non-nil, draw the hand as SVG on a graphical display."
|
||||
:type 'boolean :group 'card-games)
|
||||
|
||||
(defun cg-pres--svg (game)
|
||||
"Return a propertized, clickable SVG row of the hand: one card per rank.
|
||||
Each rank maps to a (hand . INDEX) region and a card-size slider sits below."
|
||||
(let* ((w cg-svg-card-width) (h cg-svg-card-height) (pad 10)
|
||||
(gap (+ cg-svg-card-gap 8)) (ranks (cg-pres--hand-ranks game))
|
||||
(cur (cg-get game :cursor)) (hand (cg-pres--hand game 0))
|
||||
(n (length ranks)) (lc (cg-color 'shadow :foreground "gray40"))
|
||||
(sh (cg-svg-slider-height)) (slider-y (+ pad h 22))
|
||||
(width (+ (* 2 pad) (max (+ w gap) (* n (+ w gap)) (cg-svg-slider-width))))
|
||||
(height (+ slider-y sh pad)) (svg (svg-create width height))
|
||||
(x pad) (i 0) (regions '()))
|
||||
(dolist (r ranks)
|
||||
(let* ((cnt (cl-count r (mapcar #'cdr hand)))
|
||||
(suit (car (cl-find r hand :key #'cdr))))
|
||||
(cg-svg-card svg x pad :rank (aref cg-pres-ranks r) :suit suit
|
||||
:highlight (= i cur))
|
||||
(svg-text svg (format "x%d" cnt) :x (+ x 3) :y (+ pad h 15)
|
||||
:font-size 13 :fill lc :font-family cg-svg-font-family)
|
||||
(push (cons (list x pad w h) (cons 'hand i)) regions))
|
||||
(setq x (+ x w gap) i (1+ i)))
|
||||
(setq regions (append (nreverse regions)
|
||||
(cg-svg-slider-draw svg pad slider-y cg-card-scale)))
|
||||
(propertize "*" 'display (cg-svg-image svg (cg-scale)) 'cg-regions regions)))
|
||||
|
||||
(cl-defmethod cg-render ((game cg-president-game))
|
||||
"Return a propertized string depicting GAME for a text display."
|
||||
(let* ((out (list)) (ranks (cg-pres--hand-ranks game))
|
||||
(cur (cg-get game :cursor)))
|
||||
(push (format " President\n\n") out)
|
||||
(dotimes (s (cg-get game :nplayers))
|
||||
(unless (= s 0)
|
||||
(push (format " Player %d: %d cards%s\n" s (length (cg-pres--hand game s))
|
||||
(if (memq s (cg-get game :out)) " (out)" "")) out)))
|
||||
(push (format "\n Pile: %s\n\n"
|
||||
(if (> (cg-get game :count) 0)
|
||||
(format "%d × power-%d (last: %s)"
|
||||
(cg-get game :count) (cg-get game :top)
|
||||
(cg-pres--name game (cg-get game :last-player)))
|
||||
"empty -- your lead"))
|
||||
out)
|
||||
(push " Your hand (by rank):\n " out)
|
||||
(if (and cg-pres-svg-cards (display-graphic-p))
|
||||
(push (cg-pres--svg game) out)
|
||||
(let ((i 0))
|
||||
(dolist (r ranks)
|
||||
(let* ((cnt (cl-count r (mapcar #'cdr (cg-pres--hand game 0))))
|
||||
(str (format "%s×%d" (aref cg-pres-ranks r) cnt))
|
||||
(faces nil))
|
||||
(when (= i cur) (push 'cg-cursor faces))
|
||||
(push (propertize (format "%6s" str) 'face (or faces 'default)) out))
|
||||
(cl-incf i))))
|
||||
(push (format "\n\n %s\n" (cg-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod cg-render-apply ((g cg-president-game) action)
|
||||
"Apply a click ACTION on the rank row to GAME G (a click also plays)."
|
||||
(pcase action
|
||||
(`(hand . ,i)
|
||||
(cg-put g :cursor i)
|
||||
(when (and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0))
|
||||
(cg-pres-act)))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun cg-pres--redisplay ()
|
||||
(let ((game cg-pres--game) (inhibit-read-only t))
|
||||
(setq cg-current-game game cg-redisplay-function #'cg-pres--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (cg-get game :phase)))
|
||||
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
|
||||
|
||||
(defvar cg-pres-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'cg-card-click)
|
||||
(define-key map "+" #'cg-card-zoom-in)
|
||||
(define-key map "=" #'cg-card-zoom-in)
|
||||
(define-key map "-" #'cg-card-zoom-out)
|
||||
(define-key map "0" #'cg-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'cg-pres-left)
|
||||
(define-key map (kbd "<right>") #'cg-pres-right)
|
||||
(define-key map (kbd "RET") #'cg-pres-act)
|
||||
(define-key map (kbd "SPC") #'cg-pres-act)
|
||||
(define-key map "p" #'cg-pres-pass)
|
||||
(define-key map "n" #'cg-pres-new)
|
||||
(define-key map "g" #'cg-pres-redraw)
|
||||
(define-key map "?" #'cg-pres-help)
|
||||
(define-key map "q" #'cg-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `cg-pres-mode'.")
|
||||
|
||||
(define-derived-mode cg-pres-mode special-mode "President"
|
||||
"Major mode for President."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type cg-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-president ()
|
||||
"Play President (Scum) against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*President*")))
|
||||
(with-current-buffer buf
|
||||
(cg-pres-mode)
|
||||
(setq cg-pres--game (cg-president-game))
|
||||
(cg-pres--deal cg-pres--game)
|
||||
(cg-pres--run cg-pres--game)
|
||||
(cg-pres--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
(provide 'cg-president)
|
||||
;;; cg-president.el ends here
|
||||
666
cg-rum500.el
666
cg-rum500.el
|
|
@ -1,666 +0,0 @@
|
|||
;;; cg-rum500.el --- Basic Rummy and Rummy 500 -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Two table-meld rummy games sharing one engine, built on the meld
|
||||
;; finder in cg-rummy.el.
|
||||
;;
|
||||
;; In a table-meld game you draw a card, lay melds face-up on the table,
|
||||
;; lay single cards off onto melds already there, and end your turn by
|
||||
;; discarding. Empty your hand to go out.
|
||||
;;
|
||||
;; `cg-rummy-basic' -- plain Rummy: the first player to meld their whole
|
||||
;; hand wins the deal and scores the cards left in the others' hands.
|
||||
;; `cg-rum500' -- Rummy 500: you score the cards you lay down and lose
|
||||
;; the cards left in your hand; first past 500 wins. In Rummy 500 you
|
||||
;; may take a card from anywhere in the discard pile (T): you take that
|
||||
;; card and everything above it, and the chosen card is melded at once.
|
||||
;;
|
||||
;; You are the South player (seat 0); the rest are simple AI. To meld,
|
||||
;; mark cards with SPC and press m; to lay a card off, put the cursor on
|
||||
;; it and press l.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'cg-core)
|
||||
(require 'cg-rummy)
|
||||
|
||||
(defclass cg-tablemeld-game (cg-rummy-game)
|
||||
((nplayers :initarg :nplayers :initform 2)
|
||||
(hand-size :initarg :hand-size :initform 10)
|
||||
(ace-15 :initarg :ace-15 :initform nil)
|
||||
(ace-high :initarg :ace-high :initform nil)
|
||||
(target :initarg :target :initform 100)
|
||||
(score-style :initarg :score-style :initform 'go-out)
|
||||
(deep-pickup :initarg :deep-pickup :initform nil))
|
||||
"Abstract base for table-meld rummy games (Basic Rummy, Rummy 500)."
|
||||
:abstract t)
|
||||
|
||||
;;;; Engine
|
||||
|
||||
(cl-defmethod cg-tm--deal ((game cg-tablemeld-game))
|
||||
"Deal a fresh hand into GAME."
|
||||
(let* ((n (oref game nplayers))
|
||||
(deck (cg-rummy-deck))
|
||||
(per (oref game hand-size))
|
||||
(hands (make-vector n nil)))
|
||||
(dotimes (s n)
|
||||
(aset hands s (cg-rummy-sort-hand (cl-loop repeat per collect (pop deck)))))
|
||||
(cg-put game :hands hands)
|
||||
(cg-put game :nplayers n)
|
||||
(cg-put game :discard (list (pop deck)))
|
||||
(cg-put game :stock deck)
|
||||
(cg-put game :table nil)
|
||||
(cg-put game :laid (make-vector n 0))
|
||||
(cg-put game :turn 0)
|
||||
(cg-put game :step 'draw)
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :cursor 0)
|
||||
(cg-put game :marks nil)
|
||||
(unless (cg-get game :scores) (cg-put game :scores (make-vector n 0)))
|
||||
(cg-put game :message "Your turn: s draws from stock, t takes the discard.")
|
||||
game))
|
||||
|
||||
(defun cg-tm--ace-high (game) (oref game ace-high))
|
||||
(defun cg-tm--ace-15 (game) (oref game ace-15))
|
||||
(defun cg-tm--deep-pickup (game) (oref game deep-pickup))
|
||||
|
||||
(defun cg-tm--draw (game s)
|
||||
"Move one stock card to seat S's hand; return it or nil if stock empty."
|
||||
(let ((stock (cg-get game :stock)))
|
||||
(when stock
|
||||
(let ((c (pop stock)))
|
||||
(cg-put game :stock stock)
|
||||
(cg-rummy--set-hand game s (cg-rummy-sort-hand
|
||||
(cons c (cg-rummy--hand game s))))
|
||||
c))))
|
||||
|
||||
(defun cg-tm--take-top (game s)
|
||||
"Move the discard top to seat S's hand and return it."
|
||||
(let ((c (cg-rummy--top game)))
|
||||
(when c
|
||||
(cg-put game :discard (cdr (cg-get game :discard)))
|
||||
(cg-rummy--set-hand game s (cg-rummy-sort-hand
|
||||
(cons c (cg-rummy--hand game s))))
|
||||
c)))
|
||||
|
||||
(defun cg-tm--meld-value (game cards)
|
||||
"Return the total point value of CARDS for GAME's scoring."
|
||||
(apply #'+ (mapcar (lambda (c) (cg-rummy-value c (cg-tm--ace-15 game))) cards)))
|
||||
|
||||
(cl-defmethod cg-tm--meld ((game cg-tablemeld-game) s cards)
|
||||
"Have seat S meld CARDS onto the table. Return non-nil on success."
|
||||
(when (cg-rummy-meld-p cards :min 3 :ace-high (cg-tm--ace-high game)
|
||||
:distinct-suits t)
|
||||
(dolist (c cards) (cg-rummy--set-hand game s (remove c (cg-rummy--hand game s))))
|
||||
(cg-put game :table (append (cg-get game :table)
|
||||
(list (cons s (copy-sequence cards)))))
|
||||
(let ((laid (cg-get game :laid)))
|
||||
(aset laid s (+ (aref laid s) (cg-tm--meld-value game cards))))
|
||||
t))
|
||||
|
||||
(cl-defmethod cg-tm--layoff ((game cg-tablemeld-game) s card)
|
||||
"Have seat S lay CARD off onto a matching table meld. Return non-nil on success."
|
||||
(let ((rec (cl-find-if
|
||||
(lambda (r) (cg-rummy-meld-p (cons card (cdr r)) :min 3
|
||||
:ace-high (cg-tm--ace-high game)))
|
||||
(cg-get game :table))))
|
||||
(when rec
|
||||
(cg-rummy--set-hand game s (remove card (cg-rummy--hand game s)))
|
||||
(setcdr rec (cg-rummy-sort-hand (cons card (cdr rec))))
|
||||
(let ((laid (cg-get game :laid)))
|
||||
(aset laid s (+ (aref laid s) (cg-rummy-value card (cg-tm--ace-15 game)))))
|
||||
t)))
|
||||
|
||||
(cl-defmethod cg-tm--score-hand ((game cg-tablemeld-game) outseat)
|
||||
"Score the hand ended by OUTSEAT (or nil for a washed-out hand)."
|
||||
(let* ((n (cg-get game :nplayers)) (scores (cg-get game :scores))
|
||||
(style (oref game score-style)))
|
||||
(cond
|
||||
((eq style 'go-out)
|
||||
(when outseat
|
||||
(let ((sum 0))
|
||||
(dotimes (s n)
|
||||
(unless (= s outseat)
|
||||
(dolist (c (cg-rummy--hand game s))
|
||||
(setq sum (+ sum (cg-rummy-value c))))))
|
||||
(aset scores outseat (+ (aref scores outseat) sum)))))
|
||||
((eq style 'meld-points)
|
||||
(let ((laid (cg-get game :laid)))
|
||||
(dotimes (s n)
|
||||
(let ((rem (apply #'+ (mapcar (lambda (c)
|
||||
(cg-rummy-value c (cg-tm--ace-15 game)))
|
||||
(cg-rummy--hand game s)))))
|
||||
(aset scores s (+ (aref scores s) (- (aref laid s) rem))))))))
|
||||
;; decide if the game is over
|
||||
(let ((win nil) (best most-negative-fixnum))
|
||||
(dotimes (s n)
|
||||
(when (and (>= (aref scores s) (oref game target))
|
||||
(> (aref scores s) best))
|
||||
(setq win s best (aref scores s))))
|
||||
(cg-put game :phase (if win 'game-over 'hand-over))
|
||||
(cg-put game :winner (or win outseat))
|
||||
(cg-put game :reveal t)
|
||||
(cg-put game :message
|
||||
(if win
|
||||
(format "%s wins the game with %d! (n: new game)"
|
||||
(cg-tm--who win) (aref scores win))
|
||||
(concat (if outseat (format "%s goes out. " (cg-tm--who outseat))
|
||||
"Stock exhausted. ")
|
||||
(format "Scores: %s. (n: next hand)"
|
||||
(cg-tm--scores-string game))))))))
|
||||
|
||||
(defun cg-tm--who (s) (if (= s 0) "You" (format "Player %d" s)))
|
||||
|
||||
(defun cg-tm--scores-string (game)
|
||||
"Return a compact \"You N · P1 N ...\" score line for GAME."
|
||||
(let ((scores (cg-get game :scores)) (parts '()))
|
||||
(dotimes (s (cg-get game :nplayers))
|
||||
(push (format "%s %d" (if (= s 0) "You" (format "P%d" s)) (aref scores s))
|
||||
parts))
|
||||
(mapconcat #'identity (nreverse parts) " · ")))
|
||||
|
||||
(cl-defmethod cg-tm--end-turn ((game cg-tablemeld-game) s)
|
||||
"Finish seat S's turn: go out if the hand is empty, else advance."
|
||||
(if (null (cg-rummy--hand game s))
|
||||
(cg-tm--score-hand game s)
|
||||
(cg-put game :turn (mod (1+ s) (cg-get game :nplayers)))
|
||||
(cg-put game :step 'draw)))
|
||||
|
||||
(cl-defmethod cg-tm--discard ((game cg-tablemeld-game) s card)
|
||||
"Discard CARD from seat S and finish the turn."
|
||||
(cg-rummy--set-hand game s (remove card (cg-rummy--hand game s)))
|
||||
(cg-put game :discard (cons card (cg-get game :discard)))
|
||||
(cg-tm--end-turn game s))
|
||||
|
||||
;;;; AI
|
||||
|
||||
(defun cg-tm--ai-melds (game s)
|
||||
"Lay down every meld seat S can, keeping a card back to discard.
|
||||
Return non-nil if any meld was laid."
|
||||
(let ((did nil) (again t))
|
||||
(while again
|
||||
(setq again nil)
|
||||
(let* ((hand (cg-rummy--hand game s))
|
||||
(p (cg-rummy-best-partition hand :ace-high (cg-tm--ace-high game)
|
||||
:ace-15 (cg-tm--ace-15 game)))
|
||||
(melds (plist-get p :melds))
|
||||
;; keep one card to discard: skip a meld if it would empty the hand
|
||||
(melded (apply #'+ (mapcar #'length melds))))
|
||||
(when (and melds (= melded (length hand)))
|
||||
(setq melds (cdr (sort melds (lambda (a b) (< (length a) (length b)))))))
|
||||
(when melds
|
||||
(cg-tm--meld game s (car melds))
|
||||
(setq did t again t))))
|
||||
did))
|
||||
|
||||
(defun cg-tm--ai-layoffs (game s)
|
||||
"Lay off every fitting card from seat S, keeping a card back to discard."
|
||||
(let ((again t))
|
||||
(while again
|
||||
(setq again nil)
|
||||
(when (> (length (cg-rummy--hand game s)) 1)
|
||||
(let ((card (cl-find-if
|
||||
(lambda (c)
|
||||
(cl-find-if
|
||||
(lambda (r) (cg-rummy-meld-p (cons c (cdr r)) :min 3
|
||||
:ace-high (cg-tm--ace-high game)))
|
||||
(cg-get game :table)))
|
||||
(cg-rummy--hand game s))))
|
||||
(when card (cg-tm--layoff game s card) (setq again t)))))))
|
||||
|
||||
(defun cg-tm--ai-discard-card (game s)
|
||||
"Return the best card for seat S to discard (highest deadwood)."
|
||||
(let* ((hand (cg-rummy--hand game s))
|
||||
(p (cg-rummy-best-partition hand :ace-high (cg-tm--ace-high game)
|
||||
:ace-15 (cg-tm--ace-15 game)))
|
||||
(dead (or (plist-get p :deadwood) hand))
|
||||
(best (car dead)) (bestv -1))
|
||||
(dolist (c dead best)
|
||||
(let ((v (cg-rummy-value c (cg-tm--ace-15 game))))
|
||||
(when (> v bestv) (setq best c bestv v))))))
|
||||
|
||||
(defun cg-tm--meld-for-target (game cards target)
|
||||
"Return a minimal valid meld (card list) containing TARGET drawn from CARDS.
|
||||
Return nil when TARGET cannot join a set or run with the other CARDS."
|
||||
(let* ((ace-high (cg-tm--ace-high game))
|
||||
(pool (cons target cards))
|
||||
(cands (cg-rummy--candidate-melds pool :ace-high ace-high))
|
||||
(vec (vconcat pool))
|
||||
(withtgt (cl-remove-if-not (lambda (m) (memq 0 m)) cands)))
|
||||
(when withtgt
|
||||
(setq withtgt (sort withtgt (lambda (a b) (< (length a) (length b)))))
|
||||
(mapcar (lambda (i) (aref vec i)) (car withtgt)))))
|
||||
|
||||
(defun cg-tm--take-deep (game s depth)
|
||||
"Seat S takes the card DEPTH-deep in the discard pile, plus all above it.
|
||||
The chosen card is melded or laid off at once, as Rummy 500 requires; the
|
||||
rest enter the hand. Return a status string, or nil when the move is not
|
||||
legal (the chosen card cannot be used immediately)."
|
||||
(let* ((pile (cg-get game :discard)) (n (length pile)))
|
||||
(when (and (cg-tm--deep-pickup game) (>= depth 0) (< depth n))
|
||||
(let* ((target (nth depth pile))
|
||||
(above (cl-subseq pile 0 depth))
|
||||
(avail (append (cg-rummy--hand game s) above))
|
||||
(lay (cl-find-if
|
||||
(lambda (r)
|
||||
(cg-rummy-meld-p (cons target (cdr r)) :min 3
|
||||
:ace-high (cg-tm--ace-high game)))
|
||||
(cg-get game :table)))
|
||||
(meld (unless lay (cg-tm--meld-for-target game avail target))))
|
||||
(when (or lay meld)
|
||||
(let ((taken (cl-subseq pile 0 (1+ depth))))
|
||||
(cg-put game :discard (nthcdr (1+ depth) pile))
|
||||
(dolist (c taken)
|
||||
(cg-rummy--set-hand game s (cg-rummy-sort-hand
|
||||
(cons c (cg-rummy--hand game s))))))
|
||||
(if lay (cg-tm--layoff game s target) (cg-tm--meld game s meld))
|
||||
(format "Took %d card%s and used %s."
|
||||
(1+ depth) (if (= depth 0) "" "s")
|
||||
(cg-rummy-card-string target)))))))
|
||||
|
||||
(defun cg-tm--ai-deep-pickup (game s)
|
||||
"Try a worthwhile below-the-top discard pickup for seat S.
|
||||
Return non-nil when one was taken."
|
||||
(when (cg-tm--deep-pickup game)
|
||||
(let* ((pile (cg-get game :discard)) (n (length pile))
|
||||
(limit (min n 7)) (hand (cg-rummy--hand game s)) (chosen nil))
|
||||
(cl-loop for d from 1 below limit
|
||||
for target = (nth d pile)
|
||||
for above = (cl-subseq pile 0 d)
|
||||
when (cg-tm--meld-for-target game (append hand above) target)
|
||||
do (setq chosen d) (cl-return))
|
||||
(when chosen (cg-tm--take-deep game s chosen)))))
|
||||
|
||||
(cl-defmethod cg-tm--ai-turn ((game cg-tablemeld-game) s)
|
||||
"Play seat S's whole turn."
|
||||
(let* ((deep (cg-tm--ai-deep-pickup game s))
|
||||
(drew (if deep t
|
||||
(let* ((hand (cg-rummy--hand game s))
|
||||
(up (cg-rummy--top game))
|
||||
(cur (cg-rummy-deadwood hand (cg-tm--ace-high game)
|
||||
(cg-tm--ace-15 game)))
|
||||
(with (and up (cg-rummy-deadwood
|
||||
(cons up hand)
|
||||
(cg-tm--ace-high game) (cg-tm--ace-15 game)))))
|
||||
(if (and up with (< with cur))
|
||||
(cg-tm--take-top game s)
|
||||
(cg-tm--draw game s))))))
|
||||
(if (not drew)
|
||||
(cg-tm--score-hand game nil)
|
||||
(cg-tm--ai-melds game s)
|
||||
(cg-tm--ai-layoffs game s)
|
||||
(when (eq (cg-get game :phase) 'play)
|
||||
(if (null (cg-rummy--hand game s))
|
||||
(cg-tm--end-turn game s) ; melded out, no discard needed
|
||||
(cg-tm--discard game s (cg-tm--ai-discard-card game s)))))))
|
||||
|
||||
(defun cg-tm--run (game)
|
||||
"Advance AI seats until it is the human's turn or the hand ends."
|
||||
(while (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0))
|
||||
(cg-tm--ai-turn game (cg-get game :turn))))
|
||||
|
||||
;;;; UI
|
||||
|
||||
(defvar-local cg-tm--game nil "The table-meld game in the current buffer.")
|
||||
|
||||
(defun cg-tm--discard-string (game)
|
||||
"Return the discard-pile display line for GAME.
|
||||
Deep-pickup games show the whole pile with depth indices (0 = top)."
|
||||
(cl-flet ((paint (c)
|
||||
(let ((cs (cg-rummy-card-string c)))
|
||||
(if (and c (not (cg-rummy-joker-p c)) (cg-red-suit-p (car c)))
|
||||
(propertize cs 'face 'cg-red-suit) cs))))
|
||||
(let ((pile (cg-get game :discard)))
|
||||
(if (and (cg-tm--deep-pickup game) (cdr pile))
|
||||
(concat "Discard (0=top): "
|
||||
(let ((i -1))
|
||||
(mapconcat
|
||||
(lambda (c) (setq i (1+ i)) (format "%d:%s" i (paint c)))
|
||||
(cl-subseq pile 0 (min (length pile) 12)) " ")))
|
||||
(concat "Discard: " (paint (cg-rummy--top game)))))))
|
||||
|
||||
(defun cg-tm--layoff-hint (game)
|
||||
"Return a predicate marking cards that can be laid off in GAME now."
|
||||
(lambda (c)
|
||||
(cl-find-if (lambda (r) (cg-rummy-meld-p (cons c (cdr r)) :min 3
|
||||
:ace-high (cg-tm--ace-high game)))
|
||||
(cg-get game :table))))
|
||||
|
||||
(defun cg-tm--svg (game)
|
||||
"Return an SVG board for the table-meld GAME."
|
||||
(let* ((scores (cg-get game :scores)) (laid (cg-get game :laid))
|
||||
(meldp (oref game score-style)))
|
||||
(cg-rummy--board-svg
|
||||
:title (format "%s (target %d)" (oref game vname) (oref game target))
|
||||
:infos (let (out)
|
||||
(dotimes (s (cg-get game :nplayers))
|
||||
(unless (= s 0)
|
||||
(push (format "Player %d: %d cards score %d%s"
|
||||
s (length (cg-rummy--hand game s)) (aref scores s)
|
||||
(if (eq meldp 'meld-points)
|
||||
(format " laid %d" (aref laid s)) ""))
|
||||
out)))
|
||||
(nreverse out))
|
||||
:melds (mapcar (lambda (rec)
|
||||
(cons (if (= (car rec) 0) "you" (format "P%d" (car rec)))
|
||||
(cdr rec)))
|
||||
(cg-get game :table))
|
||||
:discard (cg-rummy--top game) :stock (length (cg-get game :stock))
|
||||
:hand (cg-rummy--hand game 0) :cursor (cg-get game :cursor)
|
||||
:marks (cg-get game :marks) :hint-fn (cg-tm--layoff-hint game)
|
||||
:message (cg-get game :message))))
|
||||
|
||||
(cl-defmethod cg-render ((game cg-tablemeld-game))
|
||||
"Return a depiction of the table-meld GAME: SVG board if graphical, else text."
|
||||
(if (and cg-rummy-svg-cards (display-graphic-p))
|
||||
(cg-tm--svg game)
|
||||
(cg-tm--render-text game)))
|
||||
|
||||
(defun cg-tm--render-text (game)
|
||||
"Return a plain-text depiction of the table-meld GAME."
|
||||
(let* ((out '()) (scores (cg-get game :scores))
|
||||
(laid (cg-get game :laid)) (meldp (oref game score-style))
|
||||
(hand (cg-rummy--hand game 0)) (cursor (cg-get game :cursor)))
|
||||
(push (format " %s target %d\n\n" (oref game vname) (oref game target)) out)
|
||||
(dotimes (s (cg-get game :nplayers))
|
||||
(unless (= s 0)
|
||||
(push (format " Player %d: %d cards score %d%s\n"
|
||||
s (length (cg-rummy--hand game s)) (aref scores s)
|
||||
(if (eq meldp 'meld-points)
|
||||
(format " (laid %d)" (aref laid s)) ""))
|
||||
out)))
|
||||
(push "\n Table:\n" out)
|
||||
(if (cg-get game :table)
|
||||
(dolist (rec (cg-get game :table))
|
||||
(push (format " [%s] %s\n" (if (= (car rec) 0) "you" (format "P%d" (car rec)))
|
||||
(mapconcat #'cg-rummy-card-string (cdr rec) " "))
|
||||
out))
|
||||
(push " (empty)\n" out))
|
||||
(push (format "\n %s Stock: %d\n\n"
|
||||
(cg-tm--discard-string game)
|
||||
(length (cg-get game :stock)))
|
||||
out)
|
||||
(push (format " Your hand%s:\n "
|
||||
(if (eq meldp 'meld-points) (format " (laid %d, score %d)"
|
||||
(aref laid 0) (aref scores 0))
|
||||
(format " (score %d)" (aref scores 0))))
|
||||
out)
|
||||
(push (cg-rummy--render-cards hand cursor (cg-get game :marks)
|
||||
(cg-tm--layoff-hint game) 'hand)
|
||||
out)
|
||||
(push (format "\n\n %s\n" (cg-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod cg-render-apply ((g cg-tablemeld-game) action)
|
||||
"Apply a click ACTION on the hand to GAME G."
|
||||
(pcase action
|
||||
(`(hand . ,i) (cg-put g :cursor i))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun cg-tm--redisplay ()
|
||||
"Redraw the table-meld buffer."
|
||||
(let ((game cg-tm--game) (inhibit-read-only t))
|
||||
(setq cg-current-game game cg-redisplay-function #'cg-tm--redisplay)
|
||||
(setq-local mode-line-process
|
||||
(format " [%s]" (or (cg-get game :step) (cg-get game :phase))))
|
||||
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
|
||||
|
||||
(defun cg-tm--clamp-cursor (g)
|
||||
"Keep G's cursor within the hand and drop stale marks."
|
||||
(let ((n (length (cg-rummy--hand g 0))))
|
||||
(cg-put g :cursor (if (> n 0) (min (cg-get g :cursor) (1- n)) 0))
|
||||
(cg-put g :marks (cl-remove-if (lambda (i) (>= i n)) (cg-get g :marks)))))
|
||||
|
||||
(defun cg-tm--my-turn-p (g)
|
||||
(and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0)))
|
||||
|
||||
(defun cg-tm-left ()
|
||||
"Move the hand cursor left."
|
||||
(interactive)
|
||||
(let* ((g cg-tm--game) (n (length (cg-rummy--hand g 0))))
|
||||
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n)))
|
||||
(cg-tm--redisplay)))
|
||||
|
||||
(defun cg-tm-right ()
|
||||
"Move the hand cursor right."
|
||||
(interactive)
|
||||
(let* ((g cg-tm--game) (n (length (cg-rummy--hand g 0))))
|
||||
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n)))
|
||||
(cg-tm--redisplay)))
|
||||
|
||||
(defun cg-tm-mark ()
|
||||
"Toggle a mark on the card under the cursor (for melding)."
|
||||
(interactive)
|
||||
(let* ((g cg-tm--game) (i (cg-get g :cursor)) (marks (cg-get g :marks)))
|
||||
(cg-put g :marks (if (memq i marks) (delq i marks) (cons i marks)))
|
||||
(cg-tm--redisplay)))
|
||||
|
||||
(defun cg-tm--marked-cards (g)
|
||||
"Return the cards currently marked in G's hand."
|
||||
(let ((hand (cg-rummy--hand g 0)))
|
||||
(mapcar (lambda (i) (nth i hand)) (sort (copy-sequence (cg-get g :marks)) #'<))))
|
||||
|
||||
(defun cg-tm-meld ()
|
||||
"Meld the marked cards onto the table."
|
||||
(interactive)
|
||||
(let* ((g cg-tm--game) (cards (cg-tm--marked-cards g)))
|
||||
(cond
|
||||
((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s or t)."))
|
||||
((< (length cards) 3) (cg-put g :message "Mark at least three cards (SPC), then m."))
|
||||
((cg-tm--meld g 0 cards)
|
||||
(cg-put g :marks nil) (cg-tm--clamp-cursor g)
|
||||
(cg-put g :message "Melded. Lay off with l, meld more, or discard (RET)."))
|
||||
(t (cg-put g :message "Those cards are not a valid set or run.")))
|
||||
(cg-tm--redisplay)))
|
||||
|
||||
(defun cg-tm-layoff ()
|
||||
"Lay the cursor card (or marked cards) off onto a table meld."
|
||||
(interactive)
|
||||
(let* ((g cg-tm--game) (marks (cg-tm--marked-cards g)))
|
||||
(cond
|
||||
((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s or t)."))
|
||||
(t (let ((cards (or marks (list (nth (cg-get g :cursor) (cg-rummy--hand g 0)))))
|
||||
(any nil))
|
||||
(dolist (c cards) (when (and c (cg-tm--layoff g 0 c)) (setq any t)))
|
||||
(cg-put g :marks nil) (cg-tm--clamp-cursor g)
|
||||
(cg-put g :message (if any "Laid off." "That card fits no meld on the table.")))))
|
||||
(cg-tm--redisplay)))
|
||||
|
||||
(defun cg-tm-draw-stock ()
|
||||
"Draw the top stock card."
|
||||
(interactive)
|
||||
(let ((g cg-tm--game))
|
||||
(cond
|
||||
((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((not (eq (cg-get g :step) 'draw)) (cg-put g :message "You already drew."))
|
||||
((cg-tm--draw g 0)
|
||||
(cg-put g :step 'play) (cg-tm--clamp-cursor g)
|
||||
(cg-put g :message "Meld (m), lay off (l), then discard (RET)."))
|
||||
(t (cg-tm--score-hand g nil)))
|
||||
(cg-tm--redisplay)))
|
||||
|
||||
(defun cg-tm-take ()
|
||||
"Take the discard top into your hand."
|
||||
(interactive)
|
||||
(let ((g cg-tm--game))
|
||||
(cond
|
||||
((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((not (eq (cg-get g :step) 'draw)) (cg-put g :message "You already drew."))
|
||||
((null (cg-rummy--top g)) (cg-put g :message "The discard pile is empty."))
|
||||
(t (let ((c (cg-tm--take-top g 0)))
|
||||
(cg-put g :step 'play) (cg-tm--clamp-cursor g)
|
||||
(cg-put g :message (format "Took %s. Meld (m), lay off (l), discard (RET)."
|
||||
(cg-rummy-card-string c))))))
|
||||
(cg-tm--redisplay)))
|
||||
|
||||
(defun cg-tm-take-deep ()
|
||||
"Take a card from below the top of the discard pile (Rummy 500).
|
||||
You take that card and every card lying on top of it; the chosen card is
|
||||
melded or laid off at once, the rest go into your hand."
|
||||
(interactive)
|
||||
(let* ((g cg-tm--game) (pile (cg-get g :discard)) (n (length pile)))
|
||||
(cond
|
||||
((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((not (cg-tm--deep-pickup g))
|
||||
(cg-put g :message "This game lets you take only the top discard (t)."))
|
||||
((not (eq (cg-get g :step) 'draw)) (cg-put g :message "You already drew."))
|
||||
((< n 1) (cg-put g :message "The discard pile is empty."))
|
||||
(t (let ((depth (read-number
|
||||
(format "Take how deep? 0=top .. %d (you must meld that card): "
|
||||
(1- n)) 0)))
|
||||
(if (and (integerp depth) (>= depth 0) (< depth n))
|
||||
(let ((desc (cg-tm--take-deep g 0 depth)))
|
||||
(if desc
|
||||
(progn (cg-put g :step 'play) (cg-tm--clamp-cursor g)
|
||||
(cg-put g :message
|
||||
(concat desc " Meld, lay off, or discard (RET).")))
|
||||
(cg-put g :message
|
||||
"You can't use that card right now -- choose another.")))
|
||||
(cg-put g :message "No card at that depth.")))))
|
||||
(cg-tm--redisplay)))
|
||||
|
||||
(defun cg-tm-discard ()
|
||||
"Discard the cursor card and end your turn."
|
||||
(interactive)
|
||||
(let* ((g cg-tm--game) (card (nth (cg-get g :cursor) (cg-rummy--hand g 0))))
|
||||
(cond
|
||||
((not (cg-tm--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((eq (cg-get g :step) 'draw) (cg-put g :message "Draw first (s or t)."))
|
||||
((null card) (cg-put g :message "No card selected."))
|
||||
(t (cg-tm--discard g 0 card)
|
||||
(cg-put g :marks nil)
|
||||
(when (eq (cg-get g :phase) 'play)
|
||||
(cg-put g :message "You discarded.")
|
||||
(cg-tm--run g))))
|
||||
(cg-tm--redisplay)))
|
||||
|
||||
(defun cg-tm-new ()
|
||||
"Deal a fresh hand, or a new game when one is over."
|
||||
(interactive)
|
||||
(let ((g cg-tm--game))
|
||||
(when (eq (cg-get g :phase) 'game-over)
|
||||
(cg-put g :scores (make-vector (oref g nplayers) 0)))
|
||||
(cg-put g :reveal nil)
|
||||
(cg-tm--deal g)
|
||||
(cg-tm--run g)
|
||||
(cg-tm--redisplay)))
|
||||
|
||||
(defun cg-tm-redraw () "Redraw the board." (interactive) (cg-tm--redisplay))
|
||||
|
||||
(defun cg-tm-help ()
|
||||
"Describe the table-meld controls."
|
||||
(interactive)
|
||||
(message "Arrows: choose SPC: mark m: meld l: lay off s: draw t: take T: deep take RET: discard n: new"))
|
||||
|
||||
(defvar cg-tm-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'cg-card-click)
|
||||
(define-key map "+" #'cg-card-zoom-in)
|
||||
(define-key map "=" #'cg-card-zoom-in)
|
||||
(define-key map "-" #'cg-card-zoom-out)
|
||||
(define-key map "0" #'cg-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'cg-tm-left)
|
||||
(define-key map (kbd "<right>") #'cg-tm-right)
|
||||
(define-key map (kbd "SPC") #'cg-tm-mark)
|
||||
(define-key map "m" #'cg-tm-meld)
|
||||
(define-key map "l" #'cg-tm-layoff)
|
||||
(define-key map "s" #'cg-tm-draw-stock)
|
||||
(define-key map "t" #'cg-tm-take)
|
||||
(define-key map "T" #'cg-tm-take-deep)
|
||||
(define-key map (kbd "RET") #'cg-tm-discard)
|
||||
(define-key map "n" #'cg-tm-new)
|
||||
(define-key map "g" #'cg-tm-redraw)
|
||||
(define-key map "?" #'cg-tm-help)
|
||||
(define-key map "q" #'cg-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `cg-tm-mode'.")
|
||||
|
||||
(define-derived-mode cg-tm-mode special-mode "Rummy"
|
||||
"Major mode for the table-meld rummy games."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type cg-cursor-type))
|
||||
|
||||
(defun cg-tm--start (game buffer-name)
|
||||
"Start GAME in a buffer named BUFFER-NAME."
|
||||
(let ((buf (get-buffer-create buffer-name)))
|
||||
(with-current-buffer buf
|
||||
(cg-tm-mode)
|
||||
(setq cg-tm--game game)
|
||||
(cg-tm--deal game)
|
||||
(cg-tm--run game)
|
||||
(cg-tm--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;; The two games
|
||||
|
||||
(defcustom cg-rummy-basic-players 2
|
||||
"Number of players in Basic Rummy, including you (2-4)."
|
||||
:type '(choice (const 2) (const 3) (const 4)) :group 'card-games)
|
||||
|
||||
(defclass cg-rummy-basic-game (cg-tablemeld-game)
|
||||
((vname :initform "Rummy")
|
||||
(score-style :initform 'go-out)
|
||||
(target :initform 100))
|
||||
"A game of plain Rummy.")
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-rummy-basic ()
|
||||
"Play Basic Rummy against the computer."
|
||||
(interactive)
|
||||
(let ((n (max 2 (min 4 cg-rummy-basic-players))))
|
||||
(cg-tm--start (cg-rummy-basic-game :nplayers n :hand-size (if (= n 2) 10 7))
|
||||
"*Rummy*")))
|
||||
|
||||
(defcustom cg-rum500-players 3
|
||||
"Number of players in Rummy 500, including you (2-4)."
|
||||
:type '(choice (const 2) (const 3) (const 4)) :group 'card-games)
|
||||
|
||||
(defclass cg-rum500-game (cg-tablemeld-game)
|
||||
((vname :initform "Rummy 500")
|
||||
(score-style :initform 'meld-points)
|
||||
(ace-15 :initform t)
|
||||
(ace-high :initform t)
|
||||
(deep-pickup :initform t)
|
||||
(target :initform 500))
|
||||
"A game of Rummy 500.")
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-rum500 ()
|
||||
"Play Rummy 500 against the computer."
|
||||
(interactive)
|
||||
(let ((n (max 2 (min 4 cg-rum500-players))))
|
||||
(cg-tm--start (cg-rum500-game :nplayers n :hand-size (if (= n 2) 13 7))
|
||||
"*Rummy 500*")))
|
||||
|
||||
;;;###autoload
|
||||
(defalias 'cg-rummy-500 #'cg-rum500)
|
||||
|
||||
(provide 'cg-rum500)
|
||||
;;; cg-rum500.el ends here
|
||||
786
cg-rummy.el
786
cg-rummy.el
|
|
@ -1,786 +0,0 @@
|
|||
;;; cg-rummy.el --- Rummy meld engine and Gin Rummy -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; The shared meld engine for the rummy family, plus Gin Rummy.
|
||||
;;
|
||||
;; A "meld" is a list of cards that is either a *set* (three or four cards
|
||||
;; of the same rank) or a *run* (three or more cards of the same suit in
|
||||
;; consecutive rank). The engine validates melds, enumerates the melds
|
||||
;; latent in a hand, and -- the hard part -- finds the layout that leaves
|
||||
;; the least deadwood, which drives both knock detection and the AI.
|
||||
;;
|
||||
;; Cards use the package-standard cons (SUIT . RANK) with SUIT 0 spades,
|
||||
;; 1 clubs, 2 diamonds, 3 hearts, and RANK 0 (Ace) .. 12 (King). A joker,
|
||||
;; used only by Hand & Foot, is the cons (joker . 0).
|
||||
;;
|
||||
;; Gin Rummy: a two-handed game of ten-card hands. Draw from the stock or
|
||||
;; take the discard, then discard one card. Knock when your deadwood is
|
||||
;; ten or less, or go gin with none; your opponent then lays off onto your
|
||||
;; melds. First to 100 points wins. This file also provides the abstract
|
||||
;; `cg-rummy-game' base and the rendering helpers reused by the other
|
||||
;; rummy games (cg-rum500.el, cg-handfoot.el).
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'cg-core)
|
||||
(require 'cg-svg)
|
||||
|
||||
(defconst cg-rummy-ranks
|
||||
["A" "2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K"]
|
||||
"Rank labels indexed 0 (Ace) .. 12 (King).")
|
||||
|
||||
(defface cg-rummy-mark '((t :background "steelblue" :foreground "white"))
|
||||
"Face for a card the player has marked toward a meld."
|
||||
:group 'card-games)
|
||||
|
||||
(defun cg-rummy-card-string (card)
|
||||
"Return a short label for CARD, or a dot for nil."
|
||||
(cond ((null card) "·")
|
||||
((eq (car card) 'joker) (cg-suit-glyph 'joker))
|
||||
(t (concat (aref cg-rummy-ranks (cdr card)) (cg-suit-glyph (car card))))))
|
||||
|
||||
(defun cg-rummy-joker-p (card)
|
||||
"Return non-nil when CARD is a joker."
|
||||
(and card (eq (car card) 'joker)))
|
||||
|
||||
(defun cg-rummy-value (card &optional ace-15)
|
||||
"Return the point value of CARD.
|
||||
Faces and tens are 10, an Ace is 1 (or 15 when ACE-15 is non-nil), and
|
||||
other cards their pip value. A joker is worth 0 here; games that use
|
||||
jokers value them separately."
|
||||
(cond ((or (null card) (cg-rummy-joker-p card)) 0)
|
||||
(t (let ((r (cdr card)))
|
||||
(cond ((= r 0) (if ace-15 15 1))
|
||||
((<= r 8) (1+ r))
|
||||
(t 10))))))
|
||||
|
||||
|
||||
;;;; Meld predicates
|
||||
|
||||
(defun cg-rummy--consec-p (ranks)
|
||||
"Return non-nil when sorted RANKS rise by exactly one with no repeats."
|
||||
(let ((ok t) (prev nil))
|
||||
(dolist (r ranks ok)
|
||||
(when (and prev (/= r (1+ prev))) (setq ok nil))
|
||||
(setq prev r))))
|
||||
|
||||
(cl-defun cg-rummy-set-p (cards &key (min 3) distinct-suits)
|
||||
"Return non-nil when CARDS form a set (>= MIN cards of one rank).
|
||||
With DISTINCT-SUITS, every suit must differ (a single-deck rule)."
|
||||
(and (>= (length cards) min)
|
||||
(not (cl-some #'cg-rummy-joker-p cards))
|
||||
(let ((r (cdr (car cards))))
|
||||
(cl-every (lambda (c) (= (cdr c) r)) cards))
|
||||
(or (not distinct-suits)
|
||||
(let ((suits (mapcar #'car cards)))
|
||||
(= (length suits)
|
||||
(length (delete-dups (copy-sequence suits))))))))
|
||||
|
||||
(cl-defun cg-rummy-run-p (cards &key (min 3) ace-high)
|
||||
"Return non-nil when CARDS form a run (>= MIN cards, one suit, in sequence).
|
||||
With ACE-HIGH, an Ace may sit above the King (Q-K-A)."
|
||||
(and (>= (length cards) min)
|
||||
(not (cl-some #'cg-rummy-joker-p cards))
|
||||
(let ((suit (car (car cards)))
|
||||
(ranks (sort (mapcar #'cdr cards) #'<)))
|
||||
(and (cl-every (lambda (c) (= (car c) suit)) cards)
|
||||
(= (length ranks) (length (delete-dups (copy-sequence ranks))))
|
||||
(or (cg-rummy--consec-p ranks)
|
||||
(and ace-high (eql (car ranks) 0)
|
||||
(cg-rummy--consec-p (sort (cons 13 (cdr ranks)) #'<))))))))
|
||||
|
||||
(cl-defun cg-rummy-meld-p (cards &key (min 3) ace-high distinct-suits)
|
||||
"Return non-nil when CARDS form a valid set or run.
|
||||
MIN, ACE-HIGH and DISTINCT-SUITS are passed through to the predicates."
|
||||
(or (cg-rummy-set-p cards :min min :distinct-suits distinct-suits)
|
||||
(cg-rummy-run-p cards :min min :ace-high ace-high)))
|
||||
|
||||
|
||||
;;;; Candidate melds and best partition
|
||||
|
||||
(defun cg-rummy--combinations (lst k)
|
||||
"Return all K-element combinations of LST, each as a list."
|
||||
(cond ((= k 0) (list nil))
|
||||
((null lst) nil)
|
||||
(t (append
|
||||
(mapcar (lambda (c) (cons (car lst) c))
|
||||
(cg-rummy--combinations (cdr lst) (1- k)))
|
||||
(cg-rummy--combinations (cdr lst) k)))))
|
||||
|
||||
(defun cg-rummy--runs-in (pairs)
|
||||
"Return index-lists of runs (length >= 3) within PAIRS.
|
||||
PAIRS is a list of (RANK . INDEX) sorted ascending by RANK."
|
||||
(let ((res '()) (vec (vconcat pairs)))
|
||||
(let ((n (length vec)))
|
||||
(dotimes (i n)
|
||||
(let ((idxs (list (cdr (aref vec i))))
|
||||
(last (car (aref vec i)))
|
||||
(j (1+ i)))
|
||||
(while (and (< j n) (= (car (aref vec j)) (1+ last)))
|
||||
(setq last (car (aref vec j)))
|
||||
(setq idxs (cons (cdr (aref vec j)) idxs))
|
||||
(when (>= (length idxs) 3)
|
||||
(push (reverse idxs) res))
|
||||
(setq j (1+ j))))))
|
||||
res))
|
||||
|
||||
(cl-defun cg-rummy--candidate-melds (cards &key ace-high)
|
||||
"Return candidate melds for CARDS as a list of index-lists.
|
||||
Each index-list refers to positions in CARDS. With ACE-HIGH, high runs
|
||||
ending in an Ace are also generated."
|
||||
(let* ((vec (vconcat cards)) (n (length vec)) (melds '()))
|
||||
;; sets, grouped by rank
|
||||
(let ((byrank (make-hash-table :test 'eql)))
|
||||
(dotimes (i n)
|
||||
(let ((c (aref vec i)))
|
||||
(unless (cg-rummy-joker-p c)
|
||||
(push i (gethash (cdr c) byrank)))))
|
||||
(maphash
|
||||
(lambda (_r idxs)
|
||||
(when (>= (length idxs) 3)
|
||||
(dolist (k '(3 4))
|
||||
(dolist (combo (cg-rummy--combinations idxs k))
|
||||
(when (cg-rummy-set-p (mapcar (lambda (i) (aref vec i)) combo)
|
||||
:distinct-suits t)
|
||||
(push (sort (copy-sequence combo) #'<) melds))))))
|
||||
byrank))
|
||||
;; runs, grouped by suit
|
||||
(let ((bysuit (make-hash-table :test 'eql)))
|
||||
(dotimes (i n)
|
||||
(let ((c (aref vec i)))
|
||||
(unless (cg-rummy-joker-p c)
|
||||
(push (cons (cdr c) i) (gethash (car c) bysuit)))))
|
||||
(maphash
|
||||
(lambda (_s pairs)
|
||||
(let ((sorted (sort (copy-sequence pairs)
|
||||
(lambda (a b) (< (car a) (car b))))))
|
||||
(dolist (m (cg-rummy--runs-in sorted)) (push (sort m #'<) melds)))
|
||||
(when (and ace-high (assq 0 pairs))
|
||||
(let* ((hi (mapcar (lambda (p) (if (= (car p) 0) (cons 13 (cdr p)) p))
|
||||
pairs))
|
||||
(sh (sort hi (lambda (a b) (< (car a) (car b))))))
|
||||
(dolist (m (cg-rummy--runs-in sh)) (push (sort m #'<) melds)))))
|
||||
bysuit))
|
||||
(delete-dups melds)))
|
||||
|
||||
(cl-defun cg-rummy-best-partition (cards &key ace-high ace-15)
|
||||
"Return the lowest-deadwood layout of CARDS.
|
||||
The result is a plist (:melds MELDS :deadwood CARDS :count N) where MELDS
|
||||
is a list of card-lists, DEADWOOD the unmelded cards and N their value
|
||||
sum. ACE-HIGH allows Q-K-A runs; ACE-15 scores Aces at 15."
|
||||
(let* ((vec (vconcat cards)) (n (length vec))
|
||||
(cand (cg-rummy--candidate-melds cards :ace-high ace-high))
|
||||
(mmasks (mapcar (lambda (m)
|
||||
(let ((b 0)) (dolist (i m) (setq b (logior b (ash 1 i))))
|
||||
b))
|
||||
cand))
|
||||
(memo (make-hash-table :test 'eql))
|
||||
(full (1- (ash 1 n))))
|
||||
(cl-labels
|
||||
((cval (i) (cg-rummy-value (aref vec i) ace-15))
|
||||
(lowbit (avail)
|
||||
(let ((i 0)) (while (zerop (logand avail (ash 1 i))) (setq i (1+ i))) i))
|
||||
(solve (avail)
|
||||
(if (zerop avail) (cons 0 '())
|
||||
(or (gethash avail memo)
|
||||
(let* ((i (lowbit avail))
|
||||
(ibit (ash 1 i))
|
||||
(sub0 (solve (logxor avail ibit)))
|
||||
(best (cons (+ (cval i) (car sub0)) (cdr sub0))))
|
||||
(dolist (mask mmasks)
|
||||
(when (and (/= 0 (logand mask ibit))
|
||||
(= mask (logand mask avail)))
|
||||
(let ((sub (solve (logand avail (lognot mask)))))
|
||||
(when (< (car sub) (car best))
|
||||
(setq best (cons (car sub) (cons mask (cdr sub))))))))
|
||||
(puthash avail best memo)
|
||||
best)))))
|
||||
(let* ((res (solve full)) (maskmelds (cdr res)) (used 0))
|
||||
(dolist (m maskmelds) (setq used (logior used m)))
|
||||
(list :melds
|
||||
(mapcar (lambda (mask)
|
||||
(let ((cl '()))
|
||||
(dotimes (i n)
|
||||
(when (/= 0 (logand mask (ash 1 i)))
|
||||
(push (aref vec i) cl)))
|
||||
(nreverse cl)))
|
||||
maskmelds)
|
||||
:deadwood
|
||||
(let ((dl '()))
|
||||
(dotimes (i n)
|
||||
(when (= 0 (logand used (ash 1 i))) (push (aref vec i) dl)))
|
||||
(nreverse dl))
|
||||
:count (car res))))))
|
||||
|
||||
(defun cg-rummy-deadwood (cards &optional ace-high ace-15)
|
||||
"Return the minimum deadwood value of CARDS.
|
||||
ACE-HIGH and ACE-15 are passed to `cg-rummy-best-partition'."
|
||||
(plist-get (cg-rummy-best-partition cards :ace-high ace-high :ace-15 ace-15)
|
||||
:count))
|
||||
|
||||
(defun cg-rummy-layoff-p (card melds &optional ace-high)
|
||||
"Return the first meld in MELDS that CARD extends, or nil.
|
||||
ACE-HIGH allows extending a run with a high Ace."
|
||||
(cl-find-if (lambda (m)
|
||||
(cg-rummy-meld-p (cons card m) :min 3 :ace-high ace-high))
|
||||
melds))
|
||||
|
||||
|
||||
;;;; Shared deck and base game
|
||||
|
||||
(defun cg-rummy-deck (&optional ndecks jokers)
|
||||
"Return a shuffled deck of NDECKS standard packs plus JOKERS jokers each.
|
||||
NDECKS defaults to 1 and JOKERS to 0."
|
||||
(random t)
|
||||
(let ((cards '()))
|
||||
(dotimes (_ (or ndecks 1))
|
||||
(dotimes (s 4) (dotimes (r 13) (push (cons s r) cards)))
|
||||
(dotimes (_ (or jokers 0)) (push (cons 'joker 0) cards)))
|
||||
(cg-shuffle cards)))
|
||||
|
||||
(defclass cg-rummy-game (cg-game) ()
|
||||
"Abstract base for rummy-style draw-and-discard games."
|
||||
:abstract t)
|
||||
|
||||
(defsubst cg-rummy--hand (game s) (aref (cg-get game :hands) s))
|
||||
(defsubst cg-rummy--set-hand (game s v) (aset (cg-get game :hands) s v))
|
||||
(defsubst cg-rummy--top (game) (car (cg-get game :discard)))
|
||||
|
||||
(defun cg-rummy-sort-hand (cards)
|
||||
"Return CARDS sorted by suit then rank for display, jokers last."
|
||||
(sort (copy-sequence cards)
|
||||
(lambda (a b)
|
||||
(let ((sa (if (cg-rummy-joker-p a) 99 (car a)))
|
||||
(sb (if (cg-rummy-joker-p b) 99 (car b))))
|
||||
(if (= sa sb) (< (cdr a) (cdr b)) (< sa sb))))))
|
||||
|
||||
(defcustom cg-rummy-svg-cards t
|
||||
"When non-nil, draw cards as SVG images on a graphical display.
|
||||
Set to nil to force the plain-text card row everywhere."
|
||||
:type 'boolean :group 'card-games)
|
||||
|
||||
(defun cg-rummy--card-spec (card)
|
||||
"Return the cg-svg display spec (RANK-STRING . SUIT) for CARD."
|
||||
(if (cg-rummy-joker-p card) (cons "" 'joker)
|
||||
(cons (aref cg-rummy-ranks (cdr card)) (car card))))
|
||||
|
||||
(defun cg-rummy--svg-row (cards cursor marks hint-fn &optional region-tag)
|
||||
"Return a one-image SVG row for CARDS (clickable + sliderful when REGION-TAG).
|
||||
HINT-FN is an optional predicate marking playable cards."
|
||||
(let ((hints (when hint-fn
|
||||
(let ((hs '()) (i 0))
|
||||
(dolist (c cards) (when (funcall hint-fn c) (push i hs))
|
||||
(setq i (1+ i)))
|
||||
hs))))
|
||||
(cg-svg-hand-image (mapcar #'cg-rummy--card-spec cards)
|
||||
:cursor (and (integerp cursor) (>= cursor 0) cursor)
|
||||
:marks marks :hints hints
|
||||
:overlap (if (> (length cards) 11)
|
||||
(max 0 (- cg-svg-card-width 24)) 0)
|
||||
:region-tag region-tag)))
|
||||
|
||||
(defun cg-rummy--render-cards (cards cursor marks &optional hint-fn region-tag)
|
||||
"Return a propertized row of CARDS.
|
||||
CURSOR is the highlighted index, MARKS a list of marked indices, and
|
||||
HINT-FN an optional predicate marking playable cards. When REGION-TAG is
|
||||
non-nil the SVG row is clickable (each card mapped to (REGION-TAG . INDEX))
|
||||
and carries a card-size slider. Draws SVG cards on a graphical display
|
||||
\(see `cg-rummy-svg-cards'), else a plain-text row."
|
||||
(if (and cg-rummy-svg-cards (display-graphic-p))
|
||||
(cg-rummy--svg-row cards cursor marks hint-fn region-tag)
|
||||
(let ((i 0) (out '()))
|
||||
(dolist (c cards)
|
||||
(let ((cs (cg-rummy-card-string c)) (faces nil))
|
||||
(when (and (not (cg-rummy-joker-p c)) (cg-red-suit-p (car c)))
|
||||
(push 'cg-red-suit faces))
|
||||
(when (and hint-fn (funcall hint-fn c)) (push 'cg-hint faces))
|
||||
(when (memq i marks) (push 'cg-rummy-mark faces))
|
||||
(when (eql i cursor) (push 'cg-cursor faces))
|
||||
(push (propertize (format "%4s" cs) 'face (or faces 'default)) out))
|
||||
(setq i (1+ i)))
|
||||
(apply #'concat (nreverse out)))))
|
||||
|
||||
(defun cg-rummy--board-svg (&rest args)
|
||||
"Draw a rummy-style board; return a propertized display string.
|
||||
Keyword ARGS: :title :infos :melds :discard :stock :hand :cursor :marks
|
||||
:hint-fn :message. :melds is a list of (LABEL . CARDS), or the symbol
|
||||
`none' to hide the table area. The hand carries (hand . INDEX) regions."
|
||||
(let* ((title (or (plist-get args :title) ""))
|
||||
(infos (plist-get args :infos))
|
||||
(raw-melds (plist-get args :melds))
|
||||
(show-table (not (eq raw-melds 'none)))
|
||||
(melds (and show-table raw-melds))
|
||||
(raw-discard (plist-get args :discard))
|
||||
(show-discard (not (eq raw-discard 'none)))
|
||||
(discard (and show-discard raw-discard))
|
||||
(stock (or (plist-get args :stock) 0))
|
||||
(stock-label (or (plist-get args :stock-label) "Stock"))
|
||||
(hand (plist-get args :hand))
|
||||
(cursor (or (plist-get args :cursor) 0))
|
||||
(marks (plist-get args :marks))
|
||||
(hint-fn (plist-get args :hint-fn))
|
||||
(msg (or (plist-get args :message) ""))
|
||||
(w cg-svg-card-width) (h cg-svg-card-height) (gap cg-svg-card-gap)
|
||||
(pad 16) (label-w 46)
|
||||
(n (length hand))
|
||||
(overlap (cond ((> n 11) (- w 24)) ((> n 8) 20) (t 0)))
|
||||
(step (max 14 (- (+ w gap) overlap)))
|
||||
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
|
||||
(mstep (max 16 (round (* w 0.5))))
|
||||
(n-info (length infos))
|
||||
(y-title 6) (y-info 26)
|
||||
(y-sd (+ y-info (* n-info 16) 8))
|
||||
(meld-rowh (+ h 8))
|
||||
(y-melds (+ y-sd h 26))
|
||||
(melds-area (if show-table (+ (* (max 1 (length melds)) meld-rowh) 16) 6))
|
||||
(y-hand (+ y-melds melds-area))
|
||||
(height (+ y-hand h 30))
|
||||
(meld-maxw (if melds
|
||||
(apply #'max 0
|
||||
(mapcar (lambda (m)
|
||||
(+ label-w
|
||||
(let ((k (length (cdr m))))
|
||||
(if (> k 0) (+ (* (1- k) mstep) w) w))))
|
||||
melds))
|
||||
0))
|
||||
(width (max (+ fanw (* 2 pad)) (+ meld-maxw (* 2 pad)) 640))
|
||||
(svg (svg-create width height))
|
||||
(lc (cg-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels ((txt (str x y &optional sz bold)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family cg-svg-font-family
|
||||
(and bold '(:font-weight "bold"))))
|
||||
(drow (specs x y stp)
|
||||
(let ((xx x))
|
||||
(dolist (sp specs)
|
||||
(if sp (cg-svg-card svg xx y :rank (car sp) :suit (cdr sp))
|
||||
(cg-svg-card svg xx y :gap t))
|
||||
(setq xx (+ xx stp))))))
|
||||
(txt title pad (+ y-title 12) 13 t)
|
||||
(let ((yy (+ y-info 4)))
|
||||
(dolist (line infos) (txt line pad yy 12) (setq yy (+ yy 16))))
|
||||
(cg-svg-card svg pad y-sd :down (> stock 0) :gap (= stock 0))
|
||||
(txt (format "%s %d" stock-label stock) pad (+ y-sd h 13) 11)
|
||||
(when show-discard
|
||||
(let ((dx (+ pad w gap 24)))
|
||||
(if discard
|
||||
(let ((sp (cg-rummy--card-spec discard)))
|
||||
(cg-svg-card svg dx y-sd :rank (car sp) :suit (cdr sp)))
|
||||
(cg-svg-card svg dx y-sd :gap t))
|
||||
(txt "Discard" dx (+ y-sd h 13) 11)))
|
||||
(when show-table
|
||||
(txt "Table" pad (- y-melds 4) 11)
|
||||
(if (null melds)
|
||||
(txt "(no melds yet)" (+ pad label-w) (+ y-melds (round (* h 0.5))) 11)
|
||||
(let ((yy y-melds))
|
||||
(dolist (m melds)
|
||||
(txt (car m) pad (+ yy (round (* h 0.55))) 11)
|
||||
(drow (mapcar #'cg-rummy--card-spec (cdr m)) (+ pad label-w) yy mstep)
|
||||
(setq yy (+ yy meld-rowh))))))
|
||||
(txt "Your hand" pad (- y-hand 6) 11)
|
||||
(let ((x (max pad (- (/ width 2) (/ fanw 2)))) (i 0))
|
||||
(dolist (c hand)
|
||||
(let ((sp (cg-rummy--card-spec c))
|
||||
(curp (= i cursor))
|
||||
(markp (and marks (memq i marks)))
|
||||
(hintp (and hint-fn (funcall hint-fn c))))
|
||||
(cg-svg-card svg x y-hand :rank (car sp) :suit (cdr sp)
|
||||
:highlight curp :hint hintp)
|
||||
(when markp
|
||||
(svg-rectangle svg (- x 3) (- y-hand 3) (+ w 6) (+ h 6)
|
||||
:rx 8 :fill "none" :stroke "#4a90d9" :stroke-width 3))
|
||||
(push (cons (list x y-hand (if (= i (1- n)) w step) h) (cons 'hand i)) regions))
|
||||
(setq x (+ x step) i (1+ i))))
|
||||
(txt msg pad (- height 8) 12))
|
||||
(propertize "*" 'display (cg-svg-image svg (cg-scale))
|
||||
'cg-regions (nreverse regions))))
|
||||
|
||||
(defun cg-rummy--melds-string (melds)
|
||||
"Return a one-line depiction of MELDS (a list of card-lists)."
|
||||
(mapconcat (lambda (m) (mapconcat #'cg-rummy-card-string m " "))
|
||||
melds " | "))
|
||||
|
||||
|
||||
;;;; Gin Rummy
|
||||
|
||||
(defcustom cg-gin-target 100
|
||||
"Points needed to win a game of Gin Rummy."
|
||||
:type 'integer :group 'card-games)
|
||||
|
||||
(defclass cg-gin-game (cg-rummy-game)
|
||||
((vname :initform "Gin Rummy"))
|
||||
"A two-handed game of Gin Rummy.")
|
||||
|
||||
(cl-defmethod cg-gin--deal ((game cg-gin-game))
|
||||
"Deal a fresh Gin hand into GAME."
|
||||
(let ((deck (cg-rummy-deck)) (hands (make-vector 2 nil)))
|
||||
(dotimes (s 2)
|
||||
(aset hands s (cg-rummy-sort-hand (cl-loop repeat 10 collect (pop deck)))))
|
||||
(cg-put game :hands hands)
|
||||
(cg-put game :discard (list (pop deck)))
|
||||
(cg-put game :stock deck)
|
||||
(cg-put game :turn 0)
|
||||
(cg-put game :step 'draw)
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :cursor 0)
|
||||
(unless (cg-get game :scores) (cg-put game :scores (make-vector 2 0)))
|
||||
(cg-put game :message
|
||||
"Your turn: s draws from stock, t takes the discard.")
|
||||
game))
|
||||
|
||||
(defun cg-gin--deadwood (cards) (cg-rummy-deadwood cards))
|
||||
|
||||
(defun cg-gin--draw (game s)
|
||||
"Move one stock card to seat S's hand; return it or nil if stock empty."
|
||||
(let ((stock (cg-get game :stock)))
|
||||
(when stock
|
||||
(let ((c (pop stock)))
|
||||
(cg-put game :stock stock)
|
||||
(cg-rummy--set-hand game s (cons c (cg-rummy--hand game s)))
|
||||
c))))
|
||||
|
||||
(defun cg-gin--take (game s)
|
||||
"Move the discard top to seat S's hand and return it."
|
||||
(let ((c (cg-rummy--top game)))
|
||||
(cg-put game :discard (cdr (cg-get game :discard)))
|
||||
(cg-rummy--set-hand game s (cons c (cg-rummy--hand game s)))
|
||||
c))
|
||||
|
||||
(defun cg-gin--discard (game s card)
|
||||
"Discard CARD from seat S's hand onto the pile."
|
||||
(cg-rummy--set-hand game s (cg-rummy-sort-hand
|
||||
(remove card (cg-rummy--hand game s))))
|
||||
(cg-put game :discard (cons card (cg-get game :discard))))
|
||||
|
||||
(defun cg-gin--ai-best-discard (game s)
|
||||
"Return the card seat S should discard to minimise its deadwood."
|
||||
(let ((hand (cg-rummy--hand game s)) (best nil) (bestv most-positive-fixnum))
|
||||
(dolist (c hand best)
|
||||
(let ((d (cg-gin--deadwood (remove c hand))))
|
||||
(when (or (< d bestv)
|
||||
(and (= d bestv) best
|
||||
(> (cg-rummy-value c) (cg-rummy-value best))))
|
||||
(setq best c bestv d))))))
|
||||
|
||||
(cl-defmethod cg-gin--ai-turn ((game cg-gin-game) s)
|
||||
"Play seat S's whole turn, then hand control back."
|
||||
(let* ((hand (cg-rummy--hand game s))
|
||||
(cur (cg-gin--deadwood hand))
|
||||
(up (cg-rummy--top game))
|
||||
(with (and up (cg-gin--deadwood (cons up hand))))
|
||||
;; take the discard only when it strictly helps
|
||||
(drew (if (and up with (< with cur))
|
||||
(cg-gin--take game s)
|
||||
(cg-gin--draw game s))))
|
||||
(if (not drew)
|
||||
(cg-gin--exhaust game) ; stock exhausted: wash the hand
|
||||
(let ((card (cg-gin--ai-best-discard game s)))
|
||||
(cg-gin--discard game s card)
|
||||
(let ((dw (cg-gin--deadwood (cg-rummy--hand game s))))
|
||||
(if (<= dw 10)
|
||||
(cg-gin--knock game s)
|
||||
(cg-put game :turn 0)
|
||||
(cg-put game :step 'draw)
|
||||
(cg-put game :message
|
||||
(format "Opponent discarded %s. s draws, t takes."
|
||||
(cg-rummy-card-string card)))))))))
|
||||
|
||||
(cl-defmethod cg-gin--knock ((game cg-gin-game) knocker)
|
||||
"Resolve the hand when KNOCKER knocks; score and end the hand."
|
||||
(let* ((kpart (cg-rummy-best-partition (cg-rummy--hand game knocker)))
|
||||
(kmelds (plist-get kpart :melds))
|
||||
(kdw (plist-get kpart :count))
|
||||
(opp (- 1 knocker))
|
||||
(opart (cg-rummy-best-partition (cg-rummy--hand game opp)))
|
||||
(odead (plist-get opart :deadwood))
|
||||
(gin (= kdw 0)))
|
||||
;; opponent lays off onto the knocker's melds (not allowed on gin)
|
||||
(unless gin
|
||||
(let (remaining)
|
||||
(dolist (c odead)
|
||||
(let ((m (cg-rummy-layoff-p c kmelds)))
|
||||
(if m (setcdr (last m) (list c)) ; extend that meld in place
|
||||
(push c remaining))))
|
||||
(setq odead (nreverse remaining))))
|
||||
(let* ((odw (apply #'+ (mapcar #'cg-rummy-value odead)))
|
||||
(scores (cg-get game :scores))
|
||||
(winner knocker) (pts 0) (note ""))
|
||||
(cond
|
||||
(gin (setq pts (+ 25 odw) note "Gin!"))
|
||||
((< kdw odw) (setq pts (- odw kdw) note "Knock."))
|
||||
(t ;; undercut: defender wins
|
||||
(setq winner opp pts (+ 25 (- kdw odw)) note "Undercut!")))
|
||||
(aset scores winner (+ (aref scores winner) pts))
|
||||
(cg-put game :phase 'hand-over)
|
||||
(cg-put game :reveal t)
|
||||
(cg-put game :winner winner)
|
||||
(cg-put game :message
|
||||
(format "%s %s scores %d. %s (n: next hand)"
|
||||
note
|
||||
(if (= winner 0) "You" "Opponent") pts
|
||||
(if (>= (aref scores winner) cg-gin-target)
|
||||
(progn (cg-put game :phase 'game-over)
|
||||
(format "%s wins the game!"
|
||||
(if (= winner 0) "You" "Opponent")))
|
||||
(format "Score %d-%d."
|
||||
(aref scores 0) (aref scores 1))))))))
|
||||
|
||||
(cl-defmethod cg-gin--exhaust ((game cg-gin-game))
|
||||
"End a hand washed out because the stock ran dry."
|
||||
(cg-put game :phase 'hand-over)
|
||||
(cg-put game :reveal t)
|
||||
(cg-put game :message "Stock exhausted -- the hand is a wash. n: next hand."))
|
||||
|
||||
;;;; Gin UI
|
||||
|
||||
(defvar-local cg-gin--game nil "The Gin Rummy game in the current buffer.")
|
||||
|
||||
(defun cg-gin--svg (game)
|
||||
"Return an SVG board for the Gin GAME."
|
||||
(let* ((scores (cg-get game :scores)) (reveal (cg-get game :reveal))
|
||||
(hand (cg-rummy--hand game 0)) (infos '()))
|
||||
(push (format "Opponent: %d cards score %d"
|
||||
(length (cg-rummy--hand game 1)) (aref scores 1)) infos)
|
||||
(when reveal
|
||||
(let ((pp (cg-rummy-best-partition (cg-rummy--hand game 1))))
|
||||
(push (format " melds %s deadwood %s (%d)"
|
||||
(cg-rummy--melds-string (plist-get pp :melds))
|
||||
(mapconcat #'cg-rummy-card-string (plist-get pp :deadwood) " ")
|
||||
(plist-get pp :count))
|
||||
infos)))
|
||||
(push (format "You: deadwood %d score %d"
|
||||
(cg-gin--deadwood hand) (aref scores 0)) infos)
|
||||
(cg-rummy--board-svg
|
||||
:title (format "Gin Rummy (first to %d)" cg-gin-target)
|
||||
:infos (nreverse infos) :melds 'none
|
||||
:discard (cg-rummy--top game) :stock (length (cg-get game :stock))
|
||||
:hand hand :cursor (cg-get game :cursor)
|
||||
:message (cg-get game :message))))
|
||||
|
||||
(cl-defmethod cg-render ((game cg-gin-game))
|
||||
"Return a depiction of the Gin GAME: SVG board if graphical, else text."
|
||||
(if (and cg-rummy-svg-cards (display-graphic-p))
|
||||
(cg-gin--svg game)
|
||||
(cg-gin--render-text game)))
|
||||
|
||||
(defun cg-gin--render-text (game)
|
||||
"Return a plain-text depiction of the Gin GAME."
|
||||
(let* ((out '()) (scores (cg-get game :scores))
|
||||
(reveal (cg-get game :reveal))
|
||||
(hand (cg-rummy--hand game 0)) (cursor (cg-get game :cursor)))
|
||||
(push (format " Gin Rummy first to %d\n\n" cg-gin-target) out)
|
||||
(push (format " Opponent: %d cards score %d\n"
|
||||
(length (cg-rummy--hand game 1)) (aref scores 1)) out)
|
||||
(when reveal
|
||||
(let ((p (cg-rummy-best-partition (cg-rummy--hand game 1))))
|
||||
(push (format " melds: %s\n deadwood: %s (%d)\n"
|
||||
(cg-rummy--melds-string (plist-get p :melds))
|
||||
(mapconcat #'cg-rummy-card-string (plist-get p :deadwood) " ")
|
||||
(plist-get p :count))
|
||||
out)))
|
||||
(push (format "\n Discard: %s Stock: %d\n\n"
|
||||
(let ((cs (cg-rummy-card-string (cg-rummy--top game))))
|
||||
(if (and (cg-rummy--top game) (cg-red-suit-p (car (cg-rummy--top game))))
|
||||
(propertize cs 'face 'cg-red-suit) cs))
|
||||
(length (cg-get game :stock)))
|
||||
out)
|
||||
(push (format " Your hand (deadwood %d, score %d):\n "
|
||||
(cg-gin--deadwood hand) (aref scores 0)) out)
|
||||
(push (cg-rummy--render-cards hand cursor nil nil 'hand) out)
|
||||
(when reveal
|
||||
(let ((p (cg-rummy-best-partition hand)))
|
||||
(push (format "\n melds: %s\n deadwood: %s"
|
||||
(cg-rummy--melds-string (plist-get p :melds))
|
||||
(mapconcat #'cg-rummy-card-string (plist-get p :deadwood) " "))
|
||||
out)))
|
||||
(push (format "\n\n %s\n" (cg-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod cg-render-apply ((g cg-gin-game) action)
|
||||
"Apply a click ACTION on the hand to GAME G."
|
||||
(pcase action
|
||||
(`(hand . ,i) (cg-put g :cursor i))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun cg-gin--redisplay ()
|
||||
"Redraw the Gin Rummy buffer."
|
||||
(let ((game cg-gin--game) (inhibit-read-only t))
|
||||
(setq cg-current-game game cg-redisplay-function #'cg-gin--redisplay)
|
||||
(setq-local mode-line-process
|
||||
(format " [%s]" (or (cg-get game :step) (cg-get game :phase))))
|
||||
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
|
||||
|
||||
(defun cg-gin--cursor-card ()
|
||||
"Return the card under the cursor in your hand."
|
||||
(nth (cg-get cg-gin--game :cursor) (cg-rummy--hand cg-gin--game 0)))
|
||||
|
||||
(defun cg-gin-left ()
|
||||
"Move the hand cursor left."
|
||||
(interactive)
|
||||
(let* ((g cg-gin--game) (n (length (cg-rummy--hand g 0))))
|
||||
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n)))
|
||||
(cg-gin--redisplay)))
|
||||
|
||||
(defun cg-gin-right ()
|
||||
"Move the hand cursor right."
|
||||
(interactive)
|
||||
(let* ((g cg-gin--game) (n (length (cg-rummy--hand g 0))))
|
||||
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n)))
|
||||
(cg-gin--redisplay)))
|
||||
|
||||
(defun cg-gin--my-turn-p (g)
|
||||
"Return non-nil when it is your turn to act in G."
|
||||
(and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0)))
|
||||
|
||||
(defun cg-gin-draw-stock ()
|
||||
"Draw the top stock card into your hand."
|
||||
(interactive)
|
||||
(let ((g cg-gin--game))
|
||||
(cond
|
||||
((not (cg-gin--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((not (eq (cg-get g :step) 'draw)) (cg-put g :message "Discard first (RET)."))
|
||||
((cg-gin--draw g 0)
|
||||
(cg-put g :step 'discard)
|
||||
(cg-put g :cursor 0)
|
||||
(cg-put g :message "Choose a card and discard with RET, or knock with k."))
|
||||
(t (cg-gin--exhaust g)))
|
||||
(cg-gin--redisplay)))
|
||||
|
||||
(defun cg-gin-take-discard ()
|
||||
"Take the discard top into your hand."
|
||||
(interactive)
|
||||
(let ((g cg-gin--game))
|
||||
(cond
|
||||
((not (cg-gin--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((not (eq (cg-get g :step) 'draw)) (cg-put g :message "Discard first (RET)."))
|
||||
((null (cg-rummy--top g)) (cg-put g :message "The discard pile is empty."))
|
||||
(t (let ((c (cg-gin--take g 0)))
|
||||
(cg-put g :step 'discard)
|
||||
(cg-put g :cursor 0)
|
||||
(cg-put g :message
|
||||
(format "Took %s. Discard with RET, or knock with k."
|
||||
(cg-rummy-card-string c))))))
|
||||
(cg-gin--redisplay)))
|
||||
|
||||
(defun cg-gin--after-discard (g)
|
||||
"Hand control to the opponent after you discard in G."
|
||||
(cg-put g :turn 1)
|
||||
(cg-put g :step 'draw)
|
||||
(cg-gin--ai-turn g 1)
|
||||
(cg-gin--redisplay))
|
||||
|
||||
(defun cg-gin-discard ()
|
||||
"Discard the selected card and end your turn."
|
||||
(interactive)
|
||||
(let* ((g cg-gin--game) (card (cg-gin--cursor-card)))
|
||||
(cond
|
||||
((not (cg-gin--my-turn-p g)) (cg-put g :message "Not your turn.")
|
||||
(cg-gin--redisplay))
|
||||
((not (eq (cg-get g :step) 'discard))
|
||||
(cg-put g :message "Draw first (s or t).") (cg-gin--redisplay))
|
||||
((null card) (cg-put g :message "No card selected.") (cg-gin--redisplay))
|
||||
(t (cg-gin--discard g 0 card)
|
||||
(cg-put g :message (format "You discarded %s." (cg-rummy-card-string card)))
|
||||
(cg-gin--after-discard g)))))
|
||||
|
||||
(defun cg-gin-knock ()
|
||||
"Knock, discarding the selected card, if your deadwood allows."
|
||||
(interactive)
|
||||
(let* ((g cg-gin--game) (card (cg-gin--cursor-card)))
|
||||
(cond
|
||||
((not (cg-gin--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((not (eq (cg-get g :step) 'discard))
|
||||
(cg-put g :message "Draw first (s or t)."))
|
||||
((null card) (cg-put g :message "No card selected."))
|
||||
(t (let ((dw (cg-gin--deadwood (remove card (cg-rummy--hand g 0)))))
|
||||
(if (> dw 10)
|
||||
(cg-put g :message
|
||||
(format "Can't knock: that leaves %d deadwood (need <= 10)." dw))
|
||||
(cg-gin--discard g 0 card)
|
||||
(cg-gin--knock g 0)))))
|
||||
(cg-gin--redisplay)))
|
||||
|
||||
(defun cg-gin-new ()
|
||||
"Deal a fresh hand (or a new game when one is over)."
|
||||
(interactive)
|
||||
(let ((g cg-gin--game))
|
||||
(when (eq (cg-get g :phase) 'game-over) (cg-put g :scores (make-vector 2 0)))
|
||||
(cg-put g :reveal nil)
|
||||
(cg-gin--deal g)
|
||||
(cg-gin--redisplay)))
|
||||
|
||||
(defun cg-gin-redraw () "Redraw the board." (interactive) (cg-gin--redisplay))
|
||||
|
||||
(defun cg-gin-help ()
|
||||
"Describe the Gin Rummy controls."
|
||||
(interactive)
|
||||
(message "Arrows: choose s: draw stock t: take discard RET: discard k: knock n: new g: redraw"))
|
||||
|
||||
(defvar cg-gin-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'cg-card-click)
|
||||
(define-key map "+" #'cg-card-zoom-in)
|
||||
(define-key map "=" #'cg-card-zoom-in)
|
||||
(define-key map "-" #'cg-card-zoom-out)
|
||||
(define-key map "0" #'cg-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'cg-gin-left)
|
||||
(define-key map (kbd "<right>") #'cg-gin-right)
|
||||
(define-key map "s" #'cg-gin-draw-stock)
|
||||
(define-key map "t" #'cg-gin-take-discard)
|
||||
(define-key map (kbd "RET") #'cg-gin-discard)
|
||||
(define-key map "k" #'cg-gin-knock)
|
||||
(define-key map "n" #'cg-gin-new)
|
||||
(define-key map "g" #'cg-gin-redraw)
|
||||
(define-key map "?" #'cg-gin-help)
|
||||
(define-key map "q" #'cg-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `cg-gin-mode'.")
|
||||
|
||||
(define-derived-mode cg-gin-mode special-mode "Gin"
|
||||
"Major mode for Gin Rummy."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type cg-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-gin ()
|
||||
"Play Gin Rummy against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Gin Rummy*")))
|
||||
(with-current-buffer buf
|
||||
(cg-gin-mode)
|
||||
(setq cg-gin--game (cg-gin-game))
|
||||
(cg-gin--deal cg-gin--game)
|
||||
(cg-gin--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;###autoload
|
||||
(defalias 'cg-gin-rummy #'cg-gin)
|
||||
|
||||
(provide 'cg-rummy)
|
||||
;;; cg-rummy.el ends here
|
||||
439
cg-scopa.el
439
cg-scopa.el
|
|
@ -1,439 +0,0 @@
|
|||
;;; cg-scopa.el --- Scopa and Casino, capturing games -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Two capturing ("fishing") games on a shared engine. You play a card
|
||||
;; from your hand to capture cards from the table: either a single card of
|
||||
;; equal value or a combination that sums to it. Clear the whole table
|
||||
;; for a sweep.
|
||||
;;
|
||||
;; `cg-scopa' -- Scopa. The Italian classic on a 40-card deck; score
|
||||
;; for cards, coins (diamonds), the sette bello (seven of diamonds),
|
||||
;; primiera, and each sweep ("scopa"). Game to 11.
|
||||
;; `cg-casino' -- Casino. The English cousin on the full deck; score for
|
||||
;; cards, spades, big casino (ten of diamonds), little casino (two of
|
||||
;; spades), each ace, and each sweep. Game to 21.
|
||||
;;
|
||||
;; You are the first player against the computer. Captures are resolved
|
||||
;; automatically (a single equal card if there is one, otherwise the
|
||||
;; combination taking the most cards). This Casino omits builds and
|
||||
;; multiple captures from a single card. Cards use the package cons
|
||||
;; (SUIT . RANK), RANK 0 (Ace) .. 12 (King); suit 2 is diamonds.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'cg-core)
|
||||
(require 'cg-rummy)
|
||||
|
||||
(defclass cg-fish-game (cg-game)
|
||||
((nplayers :initarg :nplayers :initform 2)
|
||||
(hand-size :initarg :hand-size :initform 3)
|
||||
(target :initarg :target :initform 11))
|
||||
"Abstract base for the capturing games Scopa and Casino."
|
||||
:abstract t)
|
||||
|
||||
(cl-defgeneric cg-fish--value (game card)
|
||||
"Return CARD's capture value in GAME, or nil if it captures only by rank.")
|
||||
(cl-defgeneric cg-fish--deck (game)
|
||||
"Return a fresh shuffled deck for GAME.")
|
||||
(cl-defgeneric cg-fish--face-pair-p (game card)
|
||||
"Return non-nil when CARD captures only equal-rank cards (no sums).")
|
||||
(cl-defmethod cg-fish--face-pair-p ((_game cg-fish-game) _card) nil)
|
||||
(cl-defgeneric cg-fish--score-round (game)
|
||||
"Add this round's points to GAME's running scores.")
|
||||
|
||||
(defsubst cg-fish--hand (game s) (aref (cg-get game :hands) s))
|
||||
(defsubst cg-fish--set-hand (game s v) (aset (cg-get game :hands) s v))
|
||||
(defsubst cg-fish--captured (game s) (aref (cg-get game :captured) s))
|
||||
|
||||
(defun cg-fish--who (s) (if (= s 0) "You" "Computer"))
|
||||
|
||||
;;;; Capture search
|
||||
|
||||
(defun cg-fish--best-subset (cards target valfn)
|
||||
"Return the largest subset of CARDS whose values (via VALFN) sum to TARGET.
|
||||
Only subsets of two or more cards are considered. Return nil if none."
|
||||
(let ((best nil) (vec (vconcat cards)) (n (length cards)))
|
||||
(dotimes (mask (ash 1 n))
|
||||
(let ((sum 0) (sub '()) (cnt 0))
|
||||
(dotimes (i n)
|
||||
(when (/= 0 (logand mask (ash 1 i)))
|
||||
(let ((v (funcall valfn (aref vec i))))
|
||||
(when v (setq sum (+ sum v) sub (cons (aref vec i) sub) cnt (1+ cnt))))))
|
||||
(when (and (>= cnt 2) (= sum target) (> cnt (length best)))
|
||||
(setq best sub))))
|
||||
best))
|
||||
|
||||
(defun cg-fish--capture (game card)
|
||||
"Return the table cards CARD would capture in GAME, or nil."
|
||||
(let ((table (cg-get game :table)))
|
||||
(if (cg-fish--face-pair-p game card)
|
||||
(let ((same (cl-remove-if-not (lambda (c) (= (cdr c) (cdr card))) table)))
|
||||
(and same (list (car same))))
|
||||
(let ((v (cg-fish--value game card)))
|
||||
(and v (let ((single (cl-find-if (lambda (c) (eql (cg-fish--value game c) v))
|
||||
table)))
|
||||
(if single (list single)
|
||||
(cg-fish--best-subset table v
|
||||
(lambda (c) (cg-fish--value game c))))))))))
|
||||
|
||||
;;;; Flow
|
||||
|
||||
(cl-defmethod cg-fish--deal-round ((game cg-fish-game))
|
||||
"Start a fresh round: shuffle, deal the table and the first hands."
|
||||
(let* ((n (oref game nplayers)) (deck (cg-fish--deck game))
|
||||
(hands (make-vector n nil)) (table '()))
|
||||
(dotimes (_ 4) (push (pop deck) table))
|
||||
(dotimes (s n)
|
||||
(aset hands s (cg-rummy-sort-hand (cl-loop repeat (oref game hand-size)
|
||||
collect (pop deck)))))
|
||||
(cg-put game :hands hands)
|
||||
(cg-put game :table table)
|
||||
(cg-put game :deck deck)
|
||||
(cg-put game :captured (make-vector n nil))
|
||||
(cg-put game :sweeps (make-vector n 0))
|
||||
(cg-put game :nplayers n)
|
||||
(cg-put game :turn 0)
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :cursor 0)
|
||||
(cg-put game :last-capturer nil)
|
||||
(unless (cg-get game :scores) (cg-put game :scores (make-vector n 0)))
|
||||
(cg-put game :message "Play a card to capture by value, or trail it on the table.")
|
||||
game))
|
||||
|
||||
(defun cg-fish--refill (game)
|
||||
"Deal fresh hands from the deck when every hand is empty."
|
||||
(when (and (cl-every #'null (append (cg-get game :hands) nil)) (cg-get game :deck))
|
||||
(let ((deck (cg-get game :deck)))
|
||||
(dotimes (s (cg-get game :nplayers))
|
||||
(cg-fish--set-hand game s
|
||||
(cg-rummy-sort-hand
|
||||
(cl-loop repeat (oref game hand-size)
|
||||
while deck collect (pop deck)))))
|
||||
(cg-put game :deck deck))))
|
||||
|
||||
(defun cg-fish--round-over-p (game)
|
||||
(and (null (cg-get game :deck))
|
||||
(cl-every #'null (append (cg-get game :hands) nil))))
|
||||
|
||||
(cl-defmethod cg-fish--play ((game cg-fish-game) s card)
|
||||
"Seat S plays CARD: capture if possible, else trail it on the table."
|
||||
(cg-fish--set-hand game s (cl-remove card (cg-fish--hand game s) :test #'equal :count 1))
|
||||
(let ((cap (cg-fish--capture game card)))
|
||||
(if cap
|
||||
(progn
|
||||
(dolist (c cap)
|
||||
(cg-put game :table (cl-remove c (cg-get game :table) :test #'equal :count 1)))
|
||||
(aset (cg-get game :captured) s (append (cons card cap) (cg-fish--captured game s)))
|
||||
(cg-put game :last-capturer s)
|
||||
(when (and (null (cg-get game :table)) (not (cg-fish--round-over-p game)))
|
||||
(aset (cg-get game :sweeps) s (1+ (aref (cg-get game :sweeps) s))))
|
||||
(cg-put game :message
|
||||
(format "%s captured %d card%s with %s.%s" (cg-fish--who s)
|
||||
(length cap) (if (> (length cap) 1) "s" "")
|
||||
(cg-rummy-card-string card)
|
||||
(if (null (cg-get game :table)) " Sweep!" ""))))
|
||||
(cg-put game :table (cons card (cg-get game :table)))
|
||||
(cg-put game :message (format "%s trailed %s." (cg-fish--who s)
|
||||
(cg-rummy-card-string card))))
|
||||
(cg-put game :turn (mod (1+ s) (cg-get game :nplayers)))
|
||||
(cg-fish--refill game)
|
||||
(when (cg-fish--round-over-p game) (cg-fish--finish-round game))))
|
||||
|
||||
(cl-defmethod cg-fish--finish-round ((game cg-fish-game))
|
||||
"Award leftover table cards to the last capturer and score the round."
|
||||
(when (and (cg-get game :table) (cg-get game :last-capturer))
|
||||
(let ((s (cg-get game :last-capturer)))
|
||||
(aset (cg-get game :captured) s
|
||||
(append (cg-get game :table) (cg-fish--captured game s)))
|
||||
(cg-put game :table nil)))
|
||||
(cg-fish--score-round game)
|
||||
(let ((win nil) (n (cg-get game :nplayers)) (best most-negative-fixnum))
|
||||
(dotimes (s n)
|
||||
(when (and (>= (aref (cg-get game :scores) s) (oref game target))
|
||||
(> (aref (cg-get game :scores) s) best))
|
||||
(setq win s best (aref (cg-get game :scores) s))))
|
||||
(cg-put game :phase (if win 'game-over 'round-over))
|
||||
(cg-put game :winner win)
|
||||
(cg-put game :message
|
||||
(format "Round over. Scores: You %d, Computer %d. %s"
|
||||
(aref (cg-get game :scores) 0) (aref (cg-get game :scores) 1)
|
||||
(if win (format "%s wins! (n: new game)" (cg-fish--who win))
|
||||
"(n: next round)")))))
|
||||
|
||||
(defun cg-fish--award-most (game suit-pred pts)
|
||||
"Give PTS to whoever captured more cards satisfying SUIT-PRED."
|
||||
(let ((c0 (cl-count-if suit-pred (cg-fish--captured game 0)))
|
||||
(c1 (cl-count-if suit-pred (cg-fish--captured game 1))))
|
||||
(cond ((> c0 c1) (aset (cg-get game :scores) 0 (+ (aref (cg-get game :scores) 0) pts)))
|
||||
((> c1 c0) (aset (cg-get game :scores) 1 (+ (aref (cg-get game :scores) 1) pts))))))
|
||||
|
||||
(cl-defmethod cg-fish--ai-play ((game cg-fish-game) s)
|
||||
"Have AI seat S capture the most it can, else trail its lowest card."
|
||||
(let ((hand (cg-fish--hand game s)) (best nil) (bestn -1) (sweep nil))
|
||||
(dolist (c hand)
|
||||
(let* ((cap (cg-fish--capture game c))
|
||||
(nn (length cap))
|
||||
(sw (and cap (= nn (length (cg-get game :table))))))
|
||||
(when (or (and sw (not sweep))
|
||||
(and (eq (and sw t) (and sweep t)) (> nn bestn)))
|
||||
(setq best c bestn nn sweep sw))))
|
||||
(unless best ; nothing captures: trail the lowest-value card
|
||||
(setq best (car (sort (copy-sequence hand)
|
||||
(lambda (a b) (< (or (cg-fish--value game a) 99)
|
||||
(or (cg-fish--value game b) 99)))))))
|
||||
(cg-fish--play game s best)))
|
||||
|
||||
(defun cg-fish--run (game)
|
||||
"Advance AI seats until it is your turn or the round ends."
|
||||
(let ((guard 0))
|
||||
(while (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0) (< guard 200))
|
||||
(setq guard (1+ guard))
|
||||
(cg-fish--ai-play game (cg-get game :turn)))))
|
||||
|
||||
;;;; UI
|
||||
|
||||
(defvar-local cg-fish--game nil "The fishing game in the current buffer.")
|
||||
|
||||
(defun cg-fish--svg (game)
|
||||
"Return an SVG board for the fishing GAME."
|
||||
(cg-rummy--board-svg
|
||||
:title (format "%s (to %d)" (oref game vname) (oref game target))
|
||||
:infos (list (format "Computer: %d cards captured %d (score %d)"
|
||||
(length (cg-fish--hand game 1)) (length (cg-fish--captured game 1))
|
||||
(aref (cg-get game :scores) 1))
|
||||
(format "Your captured: %d (score %d)"
|
||||
(length (cg-fish--captured game 0)) (aref (cg-get game :scores) 0)))
|
||||
:stock-label "Deck" :stock (length (cg-get game :deck)) :discard 'none
|
||||
:melds (list (cons "Table" (cg-rummy-sort-hand (cg-get game :table))))
|
||||
:hand (cg-fish--hand game 0) :cursor (cg-get game :cursor)
|
||||
:message (cg-get game :message)))
|
||||
|
||||
(cl-defmethod cg-render ((game cg-fish-game))
|
||||
"Return a depiction of the fishing GAME: SVG board if graphical, else text."
|
||||
(if (and cg-rummy-svg-cards (display-graphic-p))
|
||||
(cg-fish--svg game)
|
||||
(cg-fish--render-text game)))
|
||||
|
||||
(defun cg-fish--render-text (game)
|
||||
"Return a plain-text depiction of the fishing GAME."
|
||||
(let* ((out '()) (cursor (cg-get game :cursor)))
|
||||
(push (format " %s to %d\n\n" (oref game vname) (oref game target)) out)
|
||||
(push (format " Computer: %d cards captured %d (score %d)\n"
|
||||
(length (cg-fish--hand game 1)) (length (cg-fish--captured game 1))
|
||||
(aref (cg-get game :scores) 1)) out)
|
||||
(push (format " Deck: %d Your captured: %d (score %d)\n\n"
|
||||
(length (cg-get game :deck)) (length (cg-fish--captured game 0))
|
||||
(aref (cg-get game :scores) 0)) out)
|
||||
(push " Table:\n " out)
|
||||
(push (if (cg-get game :table)
|
||||
(cg-rummy--render-cards (cg-rummy-sort-hand (cg-get game :table)) -1 nil)
|
||||
"(empty)")
|
||||
out)
|
||||
(push "\n\n Your hand:\n " out)
|
||||
(push (cg-rummy--render-cards (cg-fish--hand game 0) cursor nil nil 'hand) out)
|
||||
(push (format "\n\n %s\n" (cg-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod cg-render-apply ((g cg-fish-game) action)
|
||||
"Apply a click ACTION on the hand to GAME G."
|
||||
(pcase action
|
||||
(`(hand . ,i) (cg-put g :cursor i)
|
||||
(cg-fish-play))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun cg-fish--redisplay ()
|
||||
(let ((game cg-fish--game) (inhibit-read-only t))
|
||||
(setq cg-current-game game cg-redisplay-function #'cg-fish--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (cg-get game :phase)))
|
||||
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
|
||||
|
||||
(defun cg-fish-left ()
|
||||
"Move the hand cursor left."
|
||||
(interactive)
|
||||
(let* ((g cg-fish--game) (n (length (cg-fish--hand g 0))))
|
||||
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n)))
|
||||
(cg-fish--redisplay)))
|
||||
|
||||
(defun cg-fish-right ()
|
||||
"Move the hand cursor right."
|
||||
(interactive)
|
||||
(let* ((g cg-fish--game) (n (length (cg-fish--hand g 0))))
|
||||
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n)))
|
||||
(cg-fish--redisplay)))
|
||||
|
||||
(defun cg-fish-play ()
|
||||
"Play the card under the cursor."
|
||||
(interactive)
|
||||
(let* ((g cg-fish--game) (card (nth (cg-get g :cursor) (cg-fish--hand g 0))))
|
||||
(cond
|
||||
((not (eq (cg-get g :phase) 'play)) (cg-put g :message "Press n to continue."))
|
||||
((/= (cg-get g :turn) 0) (cg-put g :message "Not your turn."))
|
||||
((null card) (cg-put g :message "No card selected."))
|
||||
(t (cg-fish--play g 0 card)
|
||||
(cg-put g :cursor 0)
|
||||
(when (eq (cg-get g :phase) 'play) (cg-fish--run g))))
|
||||
(cg-fish--redisplay)))
|
||||
|
||||
(defun cg-fish-new ()
|
||||
"Start the next round, or a new game when one is over."
|
||||
(interactive)
|
||||
(let ((g cg-fish--game))
|
||||
(when (eq (cg-get g :phase) 'game-over)
|
||||
(cg-put g :scores (make-vector (oref g nplayers) 0)))
|
||||
(cg-fish--deal-round g)
|
||||
(cg-fish--run g)
|
||||
(cg-fish--redisplay)))
|
||||
|
||||
(defun cg-fish-redraw () "Redraw." (interactive) (cg-fish--redisplay))
|
||||
(defun cg-fish-help () "Describe the controls." (interactive)
|
||||
(message "Arrows: choose RET: play the card n: next round / new game g: redraw"))
|
||||
|
||||
(defvar cg-fish-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'cg-card-click)
|
||||
(define-key map "+" #'cg-card-zoom-in)
|
||||
(define-key map "=" #'cg-card-zoom-in)
|
||||
(define-key map "-" #'cg-card-zoom-out)
|
||||
(define-key map "0" #'cg-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'cg-fish-left)
|
||||
(define-key map (kbd "<right>") #'cg-fish-right)
|
||||
(define-key map (kbd "RET") #'cg-fish-play)
|
||||
(define-key map "n" #'cg-fish-new)
|
||||
(define-key map "g" #'cg-fish-redraw)
|
||||
(define-key map "?" #'cg-fish-help)
|
||||
(define-key map "q" #'cg-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `cg-fish-mode'.")
|
||||
|
||||
(define-derived-mode cg-fish-mode special-mode "Fish"
|
||||
"Major mode for the capturing games Scopa and Casino."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type cg-cursor-type))
|
||||
|
||||
(defun cg-fish--start (game buffer-name)
|
||||
"Start GAME in a buffer named BUFFER-NAME."
|
||||
(let ((buf (get-buffer-create buffer-name)))
|
||||
(with-current-buffer buf
|
||||
(cg-fish-mode)
|
||||
(setq cg-fish--game game)
|
||||
(cg-fish--deal-round game)
|
||||
(cg-fish--run game)
|
||||
(cg-fish--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;; Scopa
|
||||
|
||||
(defclass cg-scopa-game (cg-fish-game)
|
||||
((vname :initform "Scopa") (hand-size :initform 3) (target :initform 11))
|
||||
"A game of Scopa.")
|
||||
|
||||
(cl-defmethod cg-fish--value ((_game cg-scopa-game) card)
|
||||
"Return CARD's Scopa value (Ace 1 .. 7, Jack 8, Queen 9, King 10)."
|
||||
(let ((r (cdr card)))
|
||||
(cond ((<= r 6) (1+ r)) ((= r 10) 8) ((= r 11) 9) ((= r 12) 10))))
|
||||
|
||||
(cl-defmethod cg-fish--deck ((_game cg-scopa-game))
|
||||
"Return a shuffled 40-card Scopa deck (no eights, nines, or tens)."
|
||||
(random t)
|
||||
(cg-shuffle (cl-loop for s below 4 append
|
||||
(cl-loop for r below 13
|
||||
unless (memq r '(7 8 9)) collect (cons s r)))))
|
||||
|
||||
(defun cg-scopa--prime (card)
|
||||
"Return the primiera prime value of CARD."
|
||||
(pcase (cdr card)
|
||||
(6 21) (5 18) (0 16) (4 15) (3 14) (2 13) (1 12) (_ 10)))
|
||||
|
||||
(cl-defmethod cg-fish--score-round ((game cg-scopa-game))
|
||||
"Score a Scopa round: cards, coins, sette bello, primiera, sweeps."
|
||||
(let ((scores (cg-get game :scores)))
|
||||
(cg-fish--award-most game (lambda (_c) t) 1) ; most cards
|
||||
(cg-fish--award-most game (lambda (c) (= (car c) 2)) 1) ; most coins (diamonds)
|
||||
;; sette bello: 7 of diamonds
|
||||
(dotimes (s 2)
|
||||
(when (cl-find '(2 . 6) (cg-fish--captured game s) :test #'equal)
|
||||
(aset scores s (1+ (aref scores s)))))
|
||||
;; primiera: best prime total across suits
|
||||
(let ((p (vector 0 0)))
|
||||
(dotimes (s 2)
|
||||
(let ((bysuit (make-vector 4 0)))
|
||||
(dolist (c (cg-fish--captured game s))
|
||||
(aset bysuit (car c) (max (aref bysuit (car c)) (cg-scopa--prime c))))
|
||||
(aset p s (apply #'+ (append bysuit nil)))))
|
||||
(cond ((> (aref p 0) (aref p 1)) (aset scores 0 (1+ (aref scores 0))))
|
||||
((> (aref p 1) (aref p 0)) (aset scores 1 (1+ (aref scores 1))))))
|
||||
;; sweeps
|
||||
(dotimes (s 2) (aset scores s (+ (aref scores s) (aref (cg-get game :sweeps) s))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-scopa ()
|
||||
"Play Scopa against the computer."
|
||||
(interactive)
|
||||
(cg-fish--start (cg-scopa-game) "*Scopa*"))
|
||||
|
||||
;;;; Casino
|
||||
|
||||
(defclass cg-casino-game (cg-fish-game)
|
||||
((vname :initform "Casino") (hand-size :initform 4) (target :initform 21))
|
||||
"A game of Casino.")
|
||||
|
||||
(cl-defmethod cg-fish--value ((_game cg-casino-game) card)
|
||||
"Return CARD's Casino value (Ace 1, pips 2-10, faces nil)."
|
||||
(let ((r (cdr card)))
|
||||
(cond ((= r 0) 1) ((<= r 9) (1+ r)) (t nil))))
|
||||
|
||||
(cl-defmethod cg-fish--face-pair-p ((_game cg-casino-game) card)
|
||||
"Return non-nil when CARD is a face card (captures only by matching rank)."
|
||||
(>= (cdr card) 10))
|
||||
|
||||
(cl-defmethod cg-fish--deck ((_game cg-casino-game))
|
||||
"Return a shuffled 52-card deck for Casino."
|
||||
(cg-rummy-deck))
|
||||
|
||||
(cl-defmethod cg-fish--score-round ((game cg-casino-game))
|
||||
"Score a Casino round: cards, spades, casinos, aces, sweeps."
|
||||
(let ((scores (cg-get game :scores)))
|
||||
(cg-fish--award-most game (lambda (_c) t) 3) ; most cards
|
||||
(cg-fish--award-most game (lambda (c) (= (car c) 0)) 1) ; most spades
|
||||
(dotimes (s 2)
|
||||
(let ((caps (cg-fish--captured game s)))
|
||||
(when (cl-find '(2 . 9) caps :test #'equal) ; big casino 10D
|
||||
(aset scores s (+ (aref scores s) 2)))
|
||||
(when (cl-find '(0 . 1) caps :test #'equal) ; little casino 2S
|
||||
(aset scores s (+ (aref scores s) 1)))
|
||||
(aset scores s (+ (aref scores s) (cl-count 0 caps :key #'cdr))) ; aces
|
||||
(aset scores s (+ (aref scores s) (aref (cg-get game :sweeps) s)))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-casino ()
|
||||
"Play Casino against the computer."
|
||||
(interactive)
|
||||
(cg-fish--start (cg-casino-game) "*Casino*"))
|
||||
|
||||
(provide 'cg-scopa)
|
||||
;;; cg-scopa.el ends here
|
||||
1017
cg-solitaire.el
1017
cg-solitaire.el
File diff suppressed because it is too large
Load diff
507
cg-spite.el
507
cg-spite.el
|
|
@ -1,507 +0,0 @@
|
|||
;;; cg-spite.el --- Spite and Malice, a competitive patience -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Spite & Malice (also called Cat & Mouse): a race between you and the
|
||||
;; computer to empty a face-down goal pile. Play cards onto up to four
|
||||
;; shared centre piles, which build up from Ace to Queen regardless of
|
||||
;; suit; a pile that reaches a Queen is cleared away. Kings are wild and
|
||||
;; stand for whatever rank a pile needs next.
|
||||
;;
|
||||
;; On your turn, draw your hand up to five, then play from the top of your
|
||||
;; goal pile, your hand, or the tops of your four discard piles. Playing
|
||||
;; your goal card is how you win, so take every chance to. End your turn
|
||||
;; by discarding one card to a discard pile.
|
||||
;;
|
||||
;; Targets are chosen automatically (the first centre pile a card fits).
|
||||
;; Cards use the package cons (SUIT . RANK), RANK 0 (Ace) .. 12 (King);
|
||||
;; the build order runs Ace(0) up to Queen(11), and the King(12) is wild.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'cg-core)
|
||||
(require 'cg-rummy)
|
||||
|
||||
(defcustom cg-spite-goal-size 20
|
||||
"Number of cards in each player's goal pile."
|
||||
:type 'integer :group 'card-games)
|
||||
|
||||
(defclass cg-spite-game (cg-game)
|
||||
((vname :initform "Spite & Malice"))
|
||||
"A game of Spite & Malice.")
|
||||
|
||||
(defun cg-spite--wild-p (card) "Return non-nil when CARD (a King) is wild."
|
||||
(= (cdr card) 12))
|
||||
|
||||
(defun cg-spite--nat (card) "Return CARD's natural build rank, or nil if wild."
|
||||
(if (cg-spite--wild-p card) nil (cdr card)))
|
||||
|
||||
(defun cg-spite--deck ()
|
||||
"Return two shuffled standard decks (104 cards)."
|
||||
(random t)
|
||||
(cg-shuffle (cl-loop repeat 2 append
|
||||
(cl-loop for s below 4 append
|
||||
(cl-loop for r below 13 collect (cons s r))))))
|
||||
|
||||
;;;; Accessors
|
||||
|
||||
(defsubst cg-spite--goal (game s) (aref (cg-get game :goal) s))
|
||||
(defsubst cg-spite--set-goal (game s v) (aset (cg-get game :goal) s v))
|
||||
(defsubst cg-spite--hand (game s) (aref (cg-get game :hand) s))
|
||||
(defsubst cg-spite--set-hand (game s v) (aset (cg-get game :hand) s v))
|
||||
(defsubst cg-spite--disc (game s) (aref (cg-get game :disc) s)) ; vector of 4 lists
|
||||
|
||||
(defun cg-spite--who (s) (if (= s 0) "You" "Computer"))
|
||||
|
||||
(cl-defmethod cg-spite--deal ((game cg-spite-game))
|
||||
"Deal a fresh Spite & Malice game into GAME."
|
||||
(let ((deck (cg-spite--deck)) (goal (make-vector 2 nil))
|
||||
(hand (make-vector 2 nil)) (disc (vector nil nil)))
|
||||
(dotimes (s 2)
|
||||
(aset goal s (cl-loop repeat cg-spite-goal-size collect (pop deck)))
|
||||
(aset hand s (cg-rummy-sort-hand (cl-loop repeat 5 collect (pop deck))))
|
||||
(aset disc s (make-vector 4 nil)))
|
||||
(cg-put game :goal goal)
|
||||
(cg-put game :hand hand)
|
||||
(cg-put game :disc disc)
|
||||
(cg-put game :center (make-vector 4 nil)) ; each nil or (TOPRANK . CARDS)
|
||||
(cg-put game :muck nil)
|
||||
(cg-put game :stock deck)
|
||||
(cg-put game :turn 0)
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :cursor 0)
|
||||
(cg-put game :message "Your turn. RET plays a hand card; G plays your goal card.")
|
||||
game))
|
||||
|
||||
;;;; Stock and centre piles
|
||||
|
||||
(defun cg-spite--draw-stock (game)
|
||||
"Pop one card from the stock, recycling the muck when the stock is empty."
|
||||
(when (and (null (cg-get game :stock)) (cg-get game :muck))
|
||||
(cg-put game :stock (cg-shuffle (cg-get game :muck)))
|
||||
(cg-put game :muck nil))
|
||||
(let ((stock (cg-get game :stock)))
|
||||
(when stock (cg-put game :stock (cdr stock)) (car stock))))
|
||||
|
||||
(defun cg-spite--refill (game s)
|
||||
"Draw seat S's hand back up to five cards."
|
||||
(while (and (< (length (cg-spite--hand game s)) 5) (or (cg-get game :stock)
|
||||
(cg-get game :muck)))
|
||||
(let ((c (cg-spite--draw-stock game)))
|
||||
(when c (cg-spite--set-hand game s (cg-rummy-sort-hand
|
||||
(cons c (cg-spite--hand game s))))))))
|
||||
|
||||
(defun cg-spite--needed (game i)
|
||||
"Return the rank the centre pile I needs next (0 for an empty slot)."
|
||||
(let ((p (aref (cg-get game :center) i)))
|
||||
(if p (1+ (car p)) 0)))
|
||||
|
||||
(defun cg-spite--legal-center (game card)
|
||||
"Return the index of the first centre pile CARD may be played on, or nil."
|
||||
(let ((found nil))
|
||||
(dotimes (i 4)
|
||||
(let ((need (cg-spite--needed game i)))
|
||||
(when (and (null found) (<= need 11)
|
||||
(or (cg-spite--wild-p card) (eql (cg-spite--nat card) need)))
|
||||
(setq found i))))
|
||||
found))
|
||||
|
||||
(defun cg-spite--put-center (game card i)
|
||||
"Place CARD on centre pile I; clear the pile if it reaches a Queen."
|
||||
(let* ((need (cg-spite--needed game i))
|
||||
(p (aref (cg-get game :center) i))
|
||||
(cards (cons card (and p (cdr p)))))
|
||||
(if (= need 11) ; completed Ace..Queen
|
||||
(progn (cg-put game :muck (append cards (cg-get game :muck)))
|
||||
(aset (cg-get game :center) i nil))
|
||||
(aset (cg-get game :center) i (cons need cards)))))
|
||||
|
||||
;;;; Plays
|
||||
|
||||
(defun cg-spite--play-hand (game s card i)
|
||||
"Seat S plays hand CARD onto centre pile I."
|
||||
(cg-spite--set-hand game s (cl-remove card (cg-spite--hand game s) :test #'equal :count 1))
|
||||
(cg-spite--put-center game card i)
|
||||
(when (null (cg-spite--hand game s)) (cg-spite--refill game s)))
|
||||
|
||||
(defun cg-spite--play-goal (game s i)
|
||||
"Seat S plays the top of their goal pile onto centre pile I."
|
||||
(let ((card (car (cg-spite--goal game s))))
|
||||
(cg-spite--set-goal game s (cdr (cg-spite--goal game s)))
|
||||
(cg-spite--put-center game card i)
|
||||
(when (null (cg-spite--goal game s))
|
||||
(cg-put game :phase 'game-over) (cg-put game :winner s))))
|
||||
|
||||
(defun cg-spite--play-disc (game s d i)
|
||||
"Seat S plays the top of discard pile D onto centre pile I."
|
||||
(let* ((pile (aref (cg-spite--disc game s) d)) (card (car pile)))
|
||||
(aset (cg-spite--disc game s) d (cdr pile))
|
||||
(cg-spite--put-center game card i)))
|
||||
|
||||
(defun cg-spite--discard (game s card d)
|
||||
"Seat S discards CARD from hand onto discard pile D, ending the turn."
|
||||
(cg-spite--set-hand game s (cl-remove card (cg-spite--hand game s) :test #'equal :count 1))
|
||||
(aset (cg-spite--disc game s) d (cons card (aref (cg-spite--disc game s) d)))
|
||||
(cg-put game :turn (- 1 s)))
|
||||
|
||||
;;;; AI
|
||||
|
||||
(defun cg-spite--ai-one (game s)
|
||||
"Make one beneficial play for seat S; return non-nil if a play was made."
|
||||
(let ((goal (car (cg-spite--goal game s))) (done nil))
|
||||
(cond
|
||||
;; 1. advance the goal card (a wild goal card plays anywhere)
|
||||
((and goal (cg-spite--legal-center game goal))
|
||||
(cg-spite--play-goal game s (cg-spite--legal-center game goal)) (setq done t))
|
||||
;; 2. a non-wild hand card that fits
|
||||
((cl-find-if (lambda (c) (and (not (cg-spite--wild-p c))
|
||||
(cg-spite--legal-center game c)))
|
||||
(cg-spite--hand game s))
|
||||
(let ((card (cl-find-if (lambda (c) (and (not (cg-spite--wild-p c))
|
||||
(cg-spite--legal-center game c)))
|
||||
(cg-spite--hand game s))))
|
||||
(cg-spite--play-hand game s card (cg-spite--legal-center game card))
|
||||
(setq done t)))
|
||||
(t
|
||||
;; 3. a non-wild discard top that fits
|
||||
(catch 'hit
|
||||
(dotimes (d 4)
|
||||
(let ((top (car (aref (cg-spite--disc game s) d))))
|
||||
(when (and top (not (cg-spite--wild-p top)) (cg-spite--legal-center game top))
|
||||
(cg-spite--play-disc game s d (cg-spite--legal-center game top))
|
||||
(setq done t) (throw 'hit t))))
|
||||
;; 4. use a wild King: bridge to the goal card if possible, else
|
||||
;; advance the most-built pile to keep cards flowing
|
||||
(let ((king (cl-find-if #'cg-spite--wild-p (cg-spite--hand game s))))
|
||||
(when king
|
||||
(let* ((gr (and goal (cg-spite--nat goal))) (target nil))
|
||||
(when gr
|
||||
(dotimes (i 4)
|
||||
(let ((need (cg-spite--needed game i)))
|
||||
(when (and (null target) (<= need 11) (= need (1- gr)))
|
||||
(setq target i)))))
|
||||
(unless target
|
||||
(let ((bestneed -1))
|
||||
(dotimes (i 4)
|
||||
(let ((need (cg-spite--needed game i)))
|
||||
(when (and (<= need 11) (> need bestneed))
|
||||
(setq bestneed need target i))))))
|
||||
(when target
|
||||
(cg-spite--play-hand game s king target) (setq done t))))))))
|
||||
done))
|
||||
|
||||
(defun cg-spite--ai-turn (game s)
|
||||
"Take seat S's whole AI turn: play what helps, then discard."
|
||||
(cg-spite--refill game s)
|
||||
(let ((guard 0))
|
||||
(while (and (eq (cg-get game :phase) 'play) (< guard 300)
|
||||
(cg-spite--ai-one game s))
|
||||
(setq guard (1+ guard))))
|
||||
(when (eq (cg-get game :phase) 'play)
|
||||
(let ((hand (cg-spite--hand game s)))
|
||||
(if (null hand)
|
||||
(cg-put game :turn (- 1 s)) ; played out, nothing to discard
|
||||
;; discard the highest non-wild card; keep Kings (wild)
|
||||
(let* ((nonk (cl-remove-if #'cg-spite--wild-p hand))
|
||||
(card (car (sort (copy-sequence (or nonk hand))
|
||||
(lambda (a b) (> (cdr a) (cdr b))))))
|
||||
(d (cg-spite--ai-disc-pile game s card)))
|
||||
(cg-spite--discard game s card d))))))
|
||||
|
||||
(defun cg-spite--ai-disc-pile (game s card)
|
||||
"Choose a discard pile for CARD: an empty one, else the one topped just above."
|
||||
(let ((disc (cg-spite--disc game s)) (empty nil) (best nil) (bestv 99))
|
||||
(dotimes (d 4)
|
||||
(let ((top (car (aref disc d))))
|
||||
(cond ((null top) (unless empty (setq empty d)))
|
||||
((and (not (cg-spite--wild-p top)) (>= (cdr top) (cdr card))
|
||||
(< (- (cdr top) (cdr card)) bestv))
|
||||
(setq best d bestv (- (cdr top) (cdr card)))))))
|
||||
(or best empty 0)))
|
||||
|
||||
(defun cg-spite--run (game)
|
||||
"Let the computer (seat 1) take its turns until it is your turn or the game ends."
|
||||
(let ((guard 0))
|
||||
(while (and (eq (cg-get game :phase) 'play) (= (cg-get game :turn) 1) (< guard 200))
|
||||
(setq guard (1+ guard))
|
||||
(cg-spite--ai-turn game 1))))
|
||||
|
||||
;;;; UI
|
||||
|
||||
(defvar-local cg-spite--game nil "The Spite & Malice game in the current buffer.")
|
||||
|
||||
(defun cg-spite--center-string (game)
|
||||
"Return a one-line depiction of the centre piles."
|
||||
(let ((parts '()))
|
||||
(dotimes (i 4)
|
||||
(let ((p (aref (cg-get game :center) i)))
|
||||
(push (if p (format "[%s->%s]" (length (cdr p))
|
||||
(aref cg-rummy-ranks (car p)))
|
||||
"[ -- ]")
|
||||
parts)))
|
||||
(mapconcat #'identity (nreverse parts) " ")))
|
||||
|
||||
(defun cg-spite--disc-string (game s)
|
||||
"Return a depiction of seat S's four discard-pile tops."
|
||||
(let ((parts '()))
|
||||
(dotimes (d 4)
|
||||
(let ((top (car (aref (cg-spite--disc game s) d))))
|
||||
(push (format "%d:%s" (1+ d) (if top (cg-rummy-card-string top) "--")) parts)))
|
||||
(mapconcat #'identity (nreverse parts) " ")))
|
||||
|
||||
(defun cg-spite--board-svg (game)
|
||||
"Return an SVG board for the Spite & Malice GAME."
|
||||
(let* ((w cg-svg-card-width) (h cg-svg-card-height) (gap cg-svg-card-gap) (pad 16)
|
||||
(hand (cg-spite--hand game 0)) (n (length hand))
|
||||
(cursor (cg-get game :cursor)) (center (cg-get game :center))
|
||||
(overlap (cond ((> n 11) (- w 24)) ((> n 8) 20) (t 0)))
|
||||
(step (max 14 (- (+ w gap) overlap)))
|
||||
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
|
||||
(colstep (+ w 14))
|
||||
(y-title 6) (y-opp 26)
|
||||
(y-center (+ y-opp 16))
|
||||
(y-sm (+ y-center h 16))
|
||||
(y-ylabel (+ y-sm 12))
|
||||
(y-yours (+ y-ylabel 6))
|
||||
(y-hand (+ y-yours h 42))
|
||||
(height (+ y-hand h 30))
|
||||
(width (max (+ fanw (* 2 pad)) (+ (* 5 colstep) (* 2 pad)) 620))
|
||||
(svg (svg-create width height))
|
||||
(lc (cg-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels ((txt (str x y &optional sz bold)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family cg-svg-font-family (and bold '(:font-weight "bold"))))
|
||||
(pilecard (spec x y)
|
||||
(if spec (cg-svg-card svg x y :rank (car spec) :suit (cdr spec))
|
||||
(cg-svg-card svg x y :gap t))))
|
||||
(txt (format "Spite & Malice (goal %d)" cg-spite-goal-size) pad (+ y-title 12) 13 t)
|
||||
(txt (format "Computer: goal %d left hand %d discards %s"
|
||||
(length (cg-spite--goal game 1)) (length (cg-spite--hand game 1))
|
||||
(cg-spite--disc-string game 1))
|
||||
pad (+ y-opp 4) 12)
|
||||
(txt "Centre (build A..Q; King is wild)" pad (- y-center 4) 11)
|
||||
(dotimes (i 4)
|
||||
(let* ((x (+ pad (* i colstep))) (pp (aref center i))
|
||||
(spec (and pp (cons (aref cg-rummy-ranks (car pp)) (car (cadr pp))))))
|
||||
(pilecard spec x y-center)))
|
||||
(txt (format "Stock %d Muck %d"
|
||||
(length (cg-get game :stock)) (length (cg-get game :muck)))
|
||||
pad y-sm 11)
|
||||
(let* ((gtop (car (cg-spite--goal game 0)))
|
||||
(gspec (and gtop (cg-rummy--card-spec gtop))))
|
||||
(txt (format "Your goal (%d left)" (length (cg-spite--goal game 0)))
|
||||
pad y-ylabel 11)
|
||||
(txt "Discards" (+ pad colstep) y-ylabel 11)
|
||||
(pilecard gspec pad y-yours)
|
||||
(dotimes (d 4)
|
||||
(let* ((x (+ pad colstep (* d colstep)))
|
||||
(dtop (car (aref (cg-spite--disc game 0) d)))
|
||||
(dspec (and dtop (cg-rummy--card-spec dtop))))
|
||||
(pilecard dspec x y-yours))))
|
||||
(txt "Your hand" pad (- y-hand 6) 11)
|
||||
(let ((x (max pad (- (/ width 2) (/ fanw 2)))) (i 0))
|
||||
(dolist (c hand)
|
||||
(let ((sp (cg-rummy--card-spec c)) (curp (= i cursor)))
|
||||
(cg-svg-card svg x y-hand :rank (car sp) :suit (cdr sp) :highlight curp)
|
||||
(push (cons (list x y-hand (if (= i (1- n)) w step) h) (cons 'hand i)) regions))
|
||||
(setq x (+ x step) i (1+ i))))
|
||||
(txt (or (cg-get game :message) "") pad (- height 8) 12))
|
||||
(propertize "*" 'display (cg-svg-image svg (cg-scale)) 'cg-regions (nreverse regions))))
|
||||
|
||||
(cl-defmethod cg-render ((game cg-spite-game))
|
||||
"Return a depiction of the GAME: an SVG board if graphical, else text."
|
||||
(if (and cg-rummy-svg-cards (display-graphic-p))
|
||||
(cg-spite--board-svg game)
|
||||
(cg-spite--render-text game)))
|
||||
|
||||
(defun cg-spite--render-text (game)
|
||||
"Return a plain-text depiction of the Spite & Malice GAME."
|
||||
(let* ((out '()) (cursor (cg-get game :cursor)))
|
||||
(push " Spite & Malice\n\n" out)
|
||||
(push (format " Computer goal: %d left hand: %d discards: %s\n\n"
|
||||
(length (cg-spite--goal game 1)) (length (cg-spite--hand game 1))
|
||||
(cg-spite--disc-string game 1))
|
||||
out)
|
||||
(push (format " Centre: %s\n" (cg-spite--center-string game)) out)
|
||||
(push (format " Stock: %d Muck: %d\n\n"
|
||||
(length (cg-get game :stock)) (length (cg-get game :muck))) out)
|
||||
(push (format " Your goal: %s (%d left)\n"
|
||||
(let ((g (car (cg-spite--goal game 0))))
|
||||
(if g (cg-rummy-card-string g) "--"))
|
||||
(length (cg-spite--goal game 0)))
|
||||
out)
|
||||
(push (format " Your discards: %s\n\n" (cg-spite--disc-string game 0)) out)
|
||||
(push " Your hand:\n " out)
|
||||
(push (cg-rummy--render-cards (cg-spite--hand game 0) cursor nil nil 'hand) out)
|
||||
(push (format "\n\n %s\n" (cg-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod cg-render-apply ((g cg-spite-game) action)
|
||||
"Apply a click ACTION on the hand to GAME G."
|
||||
(pcase action
|
||||
(`(hand . ,i) (cg-put g :cursor i)
|
||||
(cg-spite-play))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun cg-spite--redisplay ()
|
||||
(let ((game cg-spite--game) (inhibit-read-only t))
|
||||
(setq cg-current-game game cg-redisplay-function #'cg-spite--redisplay)
|
||||
(setq-local mode-line-process (format " [%s]" (cg-get game :phase)))
|
||||
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
|
||||
|
||||
(defun cg-spite--my-turn-p (g)
|
||||
(and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0)))
|
||||
|
||||
(defun cg-spite-left ()
|
||||
"Move the hand cursor left."
|
||||
(interactive)
|
||||
(let* ((g cg-spite--game) (n (length (cg-spite--hand g 0))))
|
||||
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n)))
|
||||
(cg-spite--redisplay)))
|
||||
|
||||
(defun cg-spite-right ()
|
||||
"Move the hand cursor right."
|
||||
(interactive)
|
||||
(let* ((g cg-spite--game) (n (length (cg-spite--hand g 0))))
|
||||
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n)))
|
||||
(cg-spite--redisplay)))
|
||||
|
||||
(defun cg-spite--ensure-hand (g)
|
||||
"Draw your hand up to five at the start of your turn."
|
||||
(cg-spite--refill g 0))
|
||||
|
||||
(defun cg-spite-play ()
|
||||
"Play the cursor hand card onto the first centre pile it fits."
|
||||
(interactive)
|
||||
(let* ((g cg-spite--game) (card (nth (cg-get g :cursor) (cg-spite--hand g 0))))
|
||||
(cond
|
||||
((not (cg-spite--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((null card) (cg-put g :message "No card selected."))
|
||||
(t (let ((i (cg-spite--legal-center g card)))
|
||||
(if (null i) (cg-put g :message "That card fits no centre pile.")
|
||||
(cg-spite--play-hand g 0 card i)
|
||||
(cg-put g :cursor 0)
|
||||
(cg-put g :message "Played. Keep going, or d to discard and end turn.")))))
|
||||
(cg-spite--redisplay)))
|
||||
|
||||
(defun cg-spite-goal ()
|
||||
"Play your goal-pile top onto the first centre pile it fits."
|
||||
(interactive)
|
||||
(let* ((g cg-spite--game) (card (car (cg-spite--goal g 0))))
|
||||
(cond
|
||||
((not (cg-spite--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((null card) (cg-put g :message "Your goal pile is empty."))
|
||||
(t (let ((i (cg-spite--legal-center g card)))
|
||||
(if (null i) (cg-put g :message "Your goal card fits no centre pile.")
|
||||
(cg-spite--play-goal g 0 i)
|
||||
(if (eq (cg-get g :phase) 'game-over)
|
||||
(cg-put g :message "You emptied your goal -- you win! (n: new game)")
|
||||
(cg-put g :message "Goal card played!"))))))
|
||||
(cg-spite--redisplay)))
|
||||
|
||||
(defun cg-spite-play-disc ()
|
||||
"Play the top of the discard pile whose number you pressed."
|
||||
(interactive)
|
||||
(let* ((g cg-spite--game) (d (- last-command-event ?1))
|
||||
(top (and (>= d 0) (< d 4) (car (aref (cg-spite--disc g 0) d)))))
|
||||
(cond
|
||||
((not (cg-spite--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((null top) (cg-put g :message "That discard pile is empty."))
|
||||
(t (let ((i (cg-spite--legal-center g top)))
|
||||
(if (null i) (cg-put g :message "That card fits no centre pile.")
|
||||
(cg-spite--play-disc g 0 d i)
|
||||
(cg-put g :message "Played from a discard pile.")))))
|
||||
(cg-spite--redisplay)))
|
||||
|
||||
(defun cg-spite-discard ()
|
||||
"Discard the cursor card to a discard pile and end your turn."
|
||||
(interactive)
|
||||
(let* ((g cg-spite--game) (card (nth (cg-get g :cursor) (cg-spite--hand g 0))))
|
||||
(cond
|
||||
((not (cg-spite--my-turn-p g)) (cg-put g :message "Not your turn."))
|
||||
((null card) (cg-put g :message "No card to discard."))
|
||||
(t (cg-spite--discard g 0 card (cg-spite--ai-disc-pile g 0 card))
|
||||
(cg-put g :cursor 0)
|
||||
(cg-spite--run g)
|
||||
(when (eq (cg-get g :phase) 'play)
|
||||
(cg-spite--ensure-hand g)
|
||||
(cg-put g :message "Your turn."))))
|
||||
(cg-spite--redisplay)))
|
||||
|
||||
(defun cg-spite-new ()
|
||||
"Deal a fresh game."
|
||||
(interactive)
|
||||
(cg-spite--deal cg-spite--game)
|
||||
(cg-spite--redisplay))
|
||||
|
||||
(defun cg-spite-redraw () "Redraw." (interactive) (cg-spite--redisplay))
|
||||
(defun cg-spite-help () "Describe the controls." (interactive)
|
||||
(message "Arrows: choose RET: play hand card G: play goal 1-4: play discard top d: discard/end n: new"))
|
||||
|
||||
(defvar cg-spite-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'cg-card-click)
|
||||
(define-key map "+" #'cg-card-zoom-in)
|
||||
(define-key map "=" #'cg-card-zoom-in)
|
||||
(define-key map "-" #'cg-card-zoom-out)
|
||||
(define-key map "0" #'cg-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'cg-spite-left)
|
||||
(define-key map (kbd "<right>") #'cg-spite-right)
|
||||
(define-key map (kbd "RET") #'cg-spite-play)
|
||||
(define-key map "G" #'cg-spite-goal)
|
||||
(dolist (k '("1" "2" "3" "4")) (define-key map k #'cg-spite-play-disc))
|
||||
(define-key map "d" #'cg-spite-discard)
|
||||
(define-key map "n" #'cg-spite-new)
|
||||
(define-key map "g" #'cg-spite-redraw)
|
||||
(define-key map "?" #'cg-spite-help)
|
||||
(define-key map "q" #'cg-quit-to-menu)
|
||||
map)
|
||||
"Keymap for `cg-spite-mode'.")
|
||||
|
||||
(define-derived-mode cg-spite-mode special-mode "Spite"
|
||||
"Major mode for Spite & Malice."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type cg-cursor-type))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-spite ()
|
||||
"Play Spite & Malice against the computer."
|
||||
(interactive)
|
||||
(let ((buf (get-buffer-create "*Spite & Malice*")))
|
||||
(with-current-buffer buf
|
||||
(cg-spite-mode)
|
||||
(setq cg-spite--game (cg-spite-game))
|
||||
(cg-spite--deal cg-spite--game)
|
||||
(cg-spite--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;###autoload
|
||||
(defalias 'cg-cat-and-mouse #'cg-spite)
|
||||
|
||||
(provide 'cg-spite)
|
||||
;;; cg-spite.el ends here
|
||||
501
cg-trick-ext.el
501
cg-trick-ext.el
|
|
@ -1,501 +0,0 @@
|
|||
;;; cg-trick-ext.el --- Euchre, Pitch and Briscola -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Three more trick-taking games built on the engine in cg-trick.el, each
|
||||
;; a four-handed game against three AI opponents (you are South).
|
||||
;;
|
||||
;; `cg-euchre' -- Euchre. A 24-card deck, the Jack of trump (right
|
||||
;; bower) and its same-colour Jack (left bower) outranking everything;
|
||||
;; order up or call trump, then take three tricks. Partnership to 10.
|
||||
;; `cg-pitch' -- Auction Pitch (All Fours). Bid for the privilege of
|
||||
;; pitching; the first card led sets trump. Score High, Low, Jack and
|
||||
;; Game. First to 7.
|
||||
;; `cg-briscola' -- Briscola. A 40-card deck, a fixed trump turned from
|
||||
;; the deal, and no need to follow suit; capture the Aces and Threes.
|
||||
;; Partnership race to 61 of the 120 points.
|
||||
;;
|
||||
;; Cards use the package cons (SUIT . RANK), RANK 0 (Two) .. 12 (Ace) as
|
||||
;; in cg-trick.el.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'cg-core)
|
||||
(require 'cg-trick)
|
||||
|
||||
;;;; Shared helpers
|
||||
|
||||
(defun cg-tx--deck (ranks)
|
||||
"Return a shuffled deck holding only the RANKS (a list of rank indices)."
|
||||
(random t)
|
||||
(cg-shuffle (cl-loop for s below 4 append
|
||||
(cl-loop for r in ranks collect (cons s r)))))
|
||||
|
||||
(defun cg-tx--deal (game deck hs)
|
||||
"Deal HS cards each from DECK into GAME, in the cg-trick layout."
|
||||
(let ((hands (make-vector 4 nil)) (last nil) (d deck))
|
||||
(dotimes (s 4)
|
||||
(let ((h nil))
|
||||
(dotimes (_ hs) (setq last (pop d)) (push last h))
|
||||
(aset hands s (cg-trick--sort h))))
|
||||
(cg-put game :hands hands)
|
||||
(cg-put game :deck d)
|
||||
(cg-put game :last-card last)
|
||||
(cg-put game :trick nil)
|
||||
(cg-put game :tricks (make-vector 4 0))
|
||||
(cg-put game :taken (make-vector 4 nil))
|
||||
(cg-put game :broken t)
|
||||
(cg-put game :trick-no 0)
|
||||
game))
|
||||
|
||||
(defun cg-tx--winner (plays trump powerfn ledfn)
|
||||
"Return the winning seat of PLAYS (a list of (SEAT . CARD), play order).
|
||||
TRUMP is the trump suit; POWERFN and LEDFN rank cards for this game."
|
||||
(let* ((led (funcall ledfn (cdr (car plays)) trump))
|
||||
(best (car plays))
|
||||
(bestp (funcall powerfn (cdr (car plays)) trump led)))
|
||||
(dolist (p (cdr plays))
|
||||
(let ((pp (funcall powerfn (cdr p) trump led)))
|
||||
(when (> pp bestp) (setq best p bestp pp))))
|
||||
(car best)))
|
||||
|
||||
(defun cg-tx--ai (game seat powerfn ledfn valuefn)
|
||||
"Pick a card for SEAT: win cheaply if leading, else shed the cheapest.
|
||||
POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
|
||||
(let* ((legal (cg-trick--legal-moves game seat))
|
||||
(trick (cg-get game :trick)) (trump (oref game trump)))
|
||||
(if (null trick)
|
||||
(car (sort (copy-sequence legal)
|
||||
(lambda (a b) (< (funcall valuefn a) (funcall valuefn b)))))
|
||||
(let* ((order (reverse trick))
|
||||
(led (funcall ledfn (cdr (car order)) trump))
|
||||
(winners '()) (losers '()))
|
||||
(dolist (c legal)
|
||||
(if (= seat (cg-tx--winner (append order (list (cons seat c)))
|
||||
trump powerfn ledfn))
|
||||
(push c winners) (push c losers)))
|
||||
(if winners
|
||||
(car (sort winners (lambda (a b) (< (funcall powerfn a trump led)
|
||||
(funcall powerfn b trump led)))))
|
||||
(car (sort (or losers legal)
|
||||
(lambda (a b) (< (funcall valuefn a) (funcall valuefn b))))))))))
|
||||
|
||||
(defun cg-tx--plain-led (card _trump) (car card))
|
||||
|
||||
|
||||
;;;; Briscola
|
||||
|
||||
(defconst cg-briscola--ranks '(0 1 2 3 4 5 9 10 11 12)
|
||||
"Rank indices in a 40-card Briscola deck (no 8, 9, or 10).")
|
||||
|
||||
(defclass cg-briscola-game (cg-trick-game)
|
||||
((trump :initform nil) (target :initform 61) (hand-size :initform 10)
|
||||
(vname :initform "Briscola"))
|
||||
"Briscola: fixed trump, no follow, capture the points.")
|
||||
|
||||
(defun cg-bris--power (card _trump _led)
|
||||
"Return CARD's rank power within its suit for Briscola."
|
||||
(- 10 (or (cl-position (cdr card) '(12 1 11 10 9 5 4 3 2 0)) 10)))
|
||||
|
||||
(defun cg-bris--points (card)
|
||||
"Return CARD's Briscola point value."
|
||||
(pcase (cdr card) (12 11) (1 10) (11 4) (10 3) (9 2) (_ 0)))
|
||||
|
||||
(defun cg-bris--win-power (card trump led)
|
||||
"Power with trump dominance, for resolving a Briscola trick."
|
||||
(cond ((= (car card) trump) (+ 200 (cg-bris--power card trump led)))
|
||||
((= (car card) led) (+ 100 (cg-bris--power card trump led)))
|
||||
(t 0)))
|
||||
|
||||
(cl-defmethod cg-trick--legal-p ((game cg-briscola-game) seat card)
|
||||
"Briscola has no obligation to follow suit."
|
||||
(and (member card (cg-trick--hand game seat)) t))
|
||||
|
||||
(cl-defmethod cg-trick--winner ((game cg-briscola-game))
|
||||
(cg-tx--winner (reverse (cg-get game :trick)) (oref game trump)
|
||||
#'cg-bris--win-power #'cg-tx--plain-led))
|
||||
|
||||
(cl-defmethod cg-trick--ai-play ((game cg-briscola-game) seat)
|
||||
(cg-tx--ai game seat #'cg-bris--win-power #'cg-tx--plain-led #'cg-bris--points))
|
||||
|
||||
(cl-defmethod cg-trick--begin-hand ((game cg-briscola-game))
|
||||
(cg-tx--deal game (cg-tx--deck cg-briscola--ranks) 10)
|
||||
(cg-put game :dealer (mod (1+ (or (cg-get game :dealer) 3)) 4))
|
||||
(oset game trump (car (cg-get game :last-card)))
|
||||
(cg-put game :cursor 0)
|
||||
(let ((lead (mod (1+ (cg-get game :dealer)) 4)))
|
||||
(cg-put game :leader lead) (cg-put game :turn lead))
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :message
|
||||
(format "Trump is %s. No need to follow suit."
|
||||
(cg-suit-glyph (oref game trump))))
|
||||
(cg-trick--run game))
|
||||
|
||||
(cl-defmethod cg-trick--score-hand ((game cg-briscola-game))
|
||||
(let ((scores (cg-get game :scores)) (tp (make-vector 2 0)))
|
||||
(dotimes (s 4)
|
||||
(aset tp (cg-trick--team s)
|
||||
(+ (aref tp (cg-trick--team s))
|
||||
(apply #'+ (mapcar #'cg-bris--points (aref (cg-get game :taken) s))))))
|
||||
(dotimes (s 4) (aset scores s (+ (aref scores s) (aref tp (cg-trick--team s)))))))
|
||||
|
||||
(cl-defmethod cg-trick--game-over-p ((game cg-briscola-game))
|
||||
(or (>= (aref (cg-get game :scores) 0) (oref game target))
|
||||
(>= (aref (cg-get game :scores) 1) (oref game target))))
|
||||
|
||||
(cl-defmethod cg-trick--winner-seat ((game cg-briscola-game))
|
||||
(if (>= (aref (cg-get game :scores) 0) (aref (cg-get game :scores) 1)) 0 1))
|
||||
|
||||
(cl-defmethod cg-trick--result-string ((game cg-briscola-game))
|
||||
(let ((w (cg-trick--winner-seat game)))
|
||||
(format "%s win (%d points)" (if (= w 0) "You and North" "West and East")
|
||||
(aref (cg-get game :scores) w))))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-briscola ()
|
||||
"Play Briscola against three AI opponents."
|
||||
(interactive)
|
||||
(cg-trick--play-game 'cg-briscola-game))
|
||||
|
||||
|
||||
;;;; Auction Pitch
|
||||
|
||||
(defclass cg-pitch-game (cg-trick-game)
|
||||
((trump :initform nil) (target :initform 7) (hand-size :initform 6)
|
||||
(vname :initform "Pitch"))
|
||||
"Auction Pitch: bid, pitch to set trump, score High/Low/Jack/Game.")
|
||||
|
||||
(defun cg-pitch--pip (rank)
|
||||
"Return the Game-point pip value of RANK."
|
||||
(pcase rank (12 4) (11 3) (10 2) (9 1) (8 10) (_ 0)))
|
||||
|
||||
(defun cg-pitch--power (card trump led)
|
||||
"Rank CARD for a Pitch trick under TRUMP given the LED suit."
|
||||
(cond ((and trump (= (car card) trump)) (+ 100 (cdr card)))
|
||||
((= (car card) led) (+ 50 (cdr card)))
|
||||
(t (cdr card))))
|
||||
|
||||
(cl-defmethod cg-trick--legal-p ((game cg-pitch-game) seat card)
|
||||
"Pitch: follow the led suit if able, but you may always trump."
|
||||
(let ((hand (cg-trick--hand game seat)) (trick (cg-get game :trick))
|
||||
(trump (oref game trump)))
|
||||
(and (member card hand)
|
||||
(or (null trick)
|
||||
(let ((led (cg-trick--led-suit game)))
|
||||
(cond ((= (car card) led) t)
|
||||
((and trump (= (car card) trump)) t)
|
||||
((cl-some (lambda (c) (= (car c) led)) hand) nil)
|
||||
(t t)))))))
|
||||
|
||||
(cl-defmethod cg-trick--play ((game cg-pitch-game) seat card)
|
||||
"Set trump from the pitcher's first lead, then play normally."
|
||||
(when (and (null (oref game trump)) (null (cg-get game :trick)))
|
||||
(oset game trump (car card))
|
||||
(cg-put game :message
|
||||
(format "%s leads %s -- %s is trump."
|
||||
(aref cg-trick-seat-names seat) (cg-trick-card-string card)
|
||||
(cg-suit-glyph (car card)))))
|
||||
(cl-call-next-method))
|
||||
|
||||
(cl-defmethod cg-trick--ai-play ((game cg-pitch-game) seat)
|
||||
(if (and (null (oref game trump)) (= seat (cg-get game :leader)))
|
||||
;; pitcher's opening lead: lead high from the strongest suit
|
||||
(let ((best nil) (bestv -1))
|
||||
(dotimes (s 4)
|
||||
(let ((v (cg-pitch--suit-strength game seat s)))
|
||||
(when (> v bestv) (setq bestv v best s))))
|
||||
(car (sort (cl-remove-if-not (lambda (c) (= (car c) best))
|
||||
(cg-trick--hand game seat))
|
||||
(lambda (a b) (> (cdr a) (cdr b))))))
|
||||
(cg-tx--ai game seat #'cg-pitch--power #'cg-tx--plain-led
|
||||
(lambda (c) (cg-pitch--pip (cdr c))))))
|
||||
|
||||
(defun cg-pitch--suit-strength (game seat suit)
|
||||
"Estimate SEAT's strength if SUIT were trump."
|
||||
(let ((v 0))
|
||||
(dolist (c (cg-trick--hand game seat))
|
||||
(when (= (car c) suit)
|
||||
(setq v (+ v 2 (pcase (cdr c) (12 4) (11 3) (9 3) (_ 1))))))
|
||||
v))
|
||||
|
||||
(cl-defmethod cg-trick--ai-bid ((game cg-pitch-game) seat)
|
||||
"Return SEAT's Pitch bid (0 to pass, else 2..4), bidding only what is makeable."
|
||||
(let ((bid 0))
|
||||
(dotimes (s 4)
|
||||
(let* ((cards (cl-remove-if-not (lambda (c) (= (car c) s))
|
||||
(cg-trick--hand game seat)))
|
||||
(n (length cards))
|
||||
(hasa (cl-find 12 cards :key #'cdr))
|
||||
(hask (cl-find 11 cards :key #'cdr))
|
||||
(hasj (cl-find 9 cards :key #'cdr))
|
||||
(b (cond ((and (>= n 4) hasa hasj) 4)
|
||||
((and (>= n 3) hasa (or hask hasj)) 3)
|
||||
((and (>= n 3) hasa) 2)
|
||||
((and (>= n 2) hasa hask) 2)
|
||||
(t 0))))
|
||||
(setq bid (max bid b))))
|
||||
bid))
|
||||
|
||||
(defun cg-pitch--read-bid (game high)
|
||||
"Prompt you for a Pitch bid that must beat HIGH (or 0 to pass)."
|
||||
(let ((sug (cg-trick--ai-bid game 0)))
|
||||
(max 0 (min 4 (read-number
|
||||
(format "Your bid (0 pass, else %d-4) [suggest %d]: "
|
||||
(max 2 (1+ high)) sug)
|
||||
sug)))))
|
||||
|
||||
(cl-defmethod cg-trick--begin-hand ((game cg-pitch-game))
|
||||
(cg-tx--deal game (cg-tx--deck (number-sequence 0 12)) 6)
|
||||
(oset game trump nil)
|
||||
(cg-put game :dealer (mod (1+ (or (cg-get game :dealer) 3)) 4))
|
||||
(cg-put game :cursor 0)
|
||||
(let ((high 0) (bidder nil))
|
||||
(dotimes (k 4)
|
||||
(let* ((s (mod (+ (cg-get game :dealer) 1 k) 4))
|
||||
(b (if (= s 0)
|
||||
(if noninteractive (cg-trick--ai-bid game 0) (cg-pitch--read-bid game high))
|
||||
(cg-trick--ai-bid game s))))
|
||||
(when (and (>= b 2) (> b high)) (setq high b bidder s))))
|
||||
(unless bidder (setq bidder (cg-get game :dealer) high 2)) ; stuck dealer pitches 2
|
||||
(cg-put game :bidder bidder) (cg-put game :bid high)
|
||||
(cg-put game :leader bidder) (cg-put game :turn bidder)
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :message
|
||||
(format "%s pitches (bid %d). Their first card sets trump."
|
||||
(aref cg-trick-seat-names bidder) high))
|
||||
(cg-trick--run game)))
|
||||
|
||||
(cl-defmethod cg-trick--score-hand ((game cg-pitch-game))
|
||||
(let* ((trump (oref game trump)) (scores (cg-get game :scores))
|
||||
(earned (make-vector 4 0)) (game-pts (make-vector 4 0))
|
||||
(bidder (cg-get game :bidder)) (bid (cg-get game :bid))
|
||||
(hi nil) (hiseat nil) (lo nil) (loseat nil) (jackseat nil))
|
||||
(dotimes (s 4)
|
||||
(dolist (c (aref (cg-get game :taken) s))
|
||||
(when (= (car c) trump)
|
||||
(when (or (null hi) (> (cdr c) hi)) (setq hi (cdr c) hiseat s))
|
||||
(when (or (null lo) (< (cdr c) lo)) (setq lo (cdr c) loseat s))
|
||||
(when (= (cdr c) 9) (setq jackseat s)))
|
||||
(aset game-pts s (+ (aref game-pts s) (cg-pitch--pip (cdr c))))))
|
||||
(when hiseat (aset earned hiseat (1+ (aref earned hiseat))))
|
||||
(when loseat (aset earned loseat (1+ (aref earned loseat))))
|
||||
(when jackseat (aset earned jackseat (1+ (aref earned jackseat))))
|
||||
(let ((best -1) (bs nil) (tie nil))
|
||||
(dotimes (s 4)
|
||||
(cond ((> (aref game-pts s) best) (setq best (aref game-pts s) bs s tie nil))
|
||||
((= (aref game-pts s) best) (setq tie t))))
|
||||
(when (and bs (not tie) (> best 0)) (aset earned bs (1+ (aref earned bs)))))
|
||||
(dotimes (s 4)
|
||||
(if (= s bidder)
|
||||
(if (>= (aref earned s) bid)
|
||||
(aset scores s (+ (aref scores s) (aref earned s)))
|
||||
(aset scores s (- (aref scores s) bid)))
|
||||
(aset scores s (+ (aref scores s) (aref earned s)))))
|
||||
(cg-put game :last-earned earned)))
|
||||
|
||||
(cl-defmethod cg-trick--game-over-p ((game cg-pitch-game))
|
||||
(cl-some (lambda (s) (>= s (oref game target))) (append (cg-get game :scores) nil)))
|
||||
|
||||
(cl-defmethod cg-trick--winner-seat ((game cg-pitch-game))
|
||||
(let ((best 0)) (dotimes (s 4)
|
||||
(when (> (aref (cg-get game :scores) s)
|
||||
(aref (cg-get game :scores) best)) (setq best s)))
|
||||
best))
|
||||
|
||||
(cl-defmethod cg-trick--result-string ((game cg-pitch-game))
|
||||
(format "%s wins" (aref cg-trick-seat-names (cg-trick--winner-seat game))))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-pitch ()
|
||||
"Play Auction Pitch against three AI opponents."
|
||||
(interactive)
|
||||
(cg-trick--play-game 'cg-pitch-game))
|
||||
|
||||
|
||||
;;;; Euchre
|
||||
|
||||
(defclass cg-euchre-game (cg-trick-game)
|
||||
((trump :initform nil) (target :initform 10) (hand-size :initform 5)
|
||||
(vname :initform "Euchre"))
|
||||
"Euchre: 24 cards, bowers, order up or call trump, partnership to 10.")
|
||||
|
||||
(defun cg-euchre--right-bower-p (card trump)
|
||||
(and (= (cdr card) 9) (= (car card) trump)))
|
||||
|
||||
(defun cg-euchre--left-bower-p (card trump)
|
||||
(and (= (cdr card) 9) (= (car card) (cg-sister-suit trump))))
|
||||
|
||||
(defun cg-euchre--eff-suit (card trump)
|
||||
"Return CARD's effective suit (the left bower belongs to TRUMP)."
|
||||
(if (cg-euchre--left-bower-p card trump) trump (car card)))
|
||||
|
||||
(defun cg-euchre--power (card trump led)
|
||||
"Rank CARD for a Euchre trick under TRUMP given the effective LED suit."
|
||||
(cond ((cg-euchre--right-bower-p card trump) 1000)
|
||||
((cg-euchre--left-bower-p card trump) 999)
|
||||
((= (cg-euchre--eff-suit card trump) trump) (+ 900 (cdr card)))
|
||||
((= (cg-euchre--eff-suit card trump) led) (+ 100 (cdr card)))
|
||||
(t (cdr card))))
|
||||
|
||||
(defun cg-euchre--eff-led (card trump) (cg-euchre--eff-suit card trump))
|
||||
|
||||
(cl-defmethod cg-trick--legal-p ((game cg-euchre-game) seat card)
|
||||
"Euchre: follow the effective led suit if able (left bower is trump)."
|
||||
(let ((hand (cg-trick--hand game seat)) (trick (cg-get game :trick))
|
||||
(trump (oref game trump)))
|
||||
(and (member card hand)
|
||||
(or (null trick)
|
||||
(let ((led (cg-euchre--eff-suit (cdr (cg-trick--first-play game)) trump)))
|
||||
(if (cl-some (lambda (c) (= (cg-euchre--eff-suit c trump) led)) hand)
|
||||
(= (cg-euchre--eff-suit card trump) led)
|
||||
t))))))
|
||||
|
||||
(cl-defmethod cg-trick--winner ((game cg-euchre-game))
|
||||
(cg-tx--winner (reverse (cg-get game :trick)) (oref game trump)
|
||||
#'cg-euchre--power #'cg-euchre--eff-led))
|
||||
|
||||
(cl-defmethod cg-trick--ai-play ((game cg-euchre-game) seat)
|
||||
(cg-tx--ai game seat #'cg-euchre--power #'cg-euchre--eff-led
|
||||
(lambda (c) (cg-euchre--power c (oref game trump) -1))))
|
||||
|
||||
(defun cg-euchre--strength (game seat suit)
|
||||
"Estimate SEAT's trump strength if SUIT were trump."
|
||||
(let ((v 0))
|
||||
(dolist (c (cg-trick--hand game seat))
|
||||
(cond ((cg-euchre--right-bower-p c suit) (setq v (+ v 4)))
|
||||
((cg-euchre--left-bower-p c suit) (setq v (+ v 3)))
|
||||
((= (cg-euchre--eff-suit c suit) suit) (setq v (+ v 2)))
|
||||
((= (cdr c) 12) (setq v (+ v 1))))) ; off-ace
|
||||
v))
|
||||
|
||||
(defun cg-euchre--ai-order (game seat upsuit)
|
||||
"Return non-nil if SEAT orders up the UPSUIT."
|
||||
(>= (cg-euchre--strength game seat upsuit) 6))
|
||||
|
||||
(defun cg-euchre--ai-call (game seat upsuit)
|
||||
"Return a suit SEAT calls in round two, or nil to pass."
|
||||
(let ((best nil) (bestv 0))
|
||||
(dotimes (s 4)
|
||||
(unless (= s upsuit)
|
||||
(let ((v (cg-euchre--strength game seat s)))
|
||||
(when (> v bestv) (setq bestv v best s)))))
|
||||
(and (>= bestv 6) best)))
|
||||
|
||||
(defun cg-euchre--best-suit (game seat upsuit)
|
||||
"Return SEAT's strongest suit other than UPSUIT (for a stuck dealer)."
|
||||
(let ((best (mod (1+ upsuit) 4)) (bestv -1))
|
||||
(dotimes (s 4)
|
||||
(unless (= s upsuit)
|
||||
(let ((v (cg-euchre--strength game seat s)))
|
||||
(when (> v bestv) (setq bestv v best s)))))
|
||||
best))
|
||||
|
||||
(defun cg-euchre--dealer-pickup (game up)
|
||||
"Dealer takes the UP card and discards their weakest card."
|
||||
(let* ((d (cg-get game :dealer)) (trump (car up))
|
||||
(hand (cons up (cg-trick--hand game d)))
|
||||
(worst (car (sort (copy-sequence hand)
|
||||
(lambda (a b) (< (cg-euchre--power a trump -1)
|
||||
(cg-euchre--power b trump -1)))))))
|
||||
(cg-trick--set-hand game d (cg-trick--sort (remove worst hand)))))
|
||||
|
||||
(cl-defmethod cg-trick--begin-hand ((game cg-euchre-game))
|
||||
(cg-tx--deal game (cg-tx--deck '(7 8 9 10 11 12)) 5)
|
||||
(oset game trump nil)
|
||||
(cg-put game :dealer (mod (1+ (or (cg-get game :dealer) 3)) 4))
|
||||
(cg-put game :cursor 0)
|
||||
(let* ((up (car (cg-get game :deck))) (upsuit (car up))
|
||||
(dealer (cg-get game :dealer)) (maker nil) (chosen nil))
|
||||
(cg-put game :up up)
|
||||
(cl-block bid
|
||||
(dotimes (k 4)
|
||||
(let ((s (mod (+ dealer 1 k) 4)))
|
||||
(when (if (= s 0)
|
||||
(if noninteractive (cg-euchre--ai-order game 0 upsuit)
|
||||
(y-or-n-p (format "Order up %s as trump? " (cg-suit-glyph upsuit))))
|
||||
(cg-euchre--ai-order game s upsuit))
|
||||
(setq maker s chosen upsuit)
|
||||
(cg-euchre--dealer-pickup game up)
|
||||
(cl-return-from bid))))
|
||||
(dotimes (k 4)
|
||||
(let* ((s (mod (+ dealer 1 k) 4))
|
||||
(suit (if (= s 0)
|
||||
(if noninteractive (cg-euchre--ai-call game 0 upsuit)
|
||||
(cg-euchre--human-call upsuit))
|
||||
(cg-euchre--ai-call game s upsuit))))
|
||||
(when suit (setq maker s chosen suit) (cl-return-from bid)))))
|
||||
(unless chosen
|
||||
(setq maker dealer chosen (cg-euchre--best-suit game dealer upsuit)))
|
||||
(oset game trump chosen)
|
||||
(cg-put game :maker maker)
|
||||
(let ((lead (mod (1+ dealer) 4)))
|
||||
(cg-put game :leader lead) (cg-put game :turn lead))
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :message
|
||||
(format "%s makes %s trump." (aref cg-trick-seat-names maker)
|
||||
(cg-suit-glyph chosen)))
|
||||
(cg-trick--run game)))
|
||||
|
||||
(defun cg-euchre--human-call (upsuit)
|
||||
"Prompt you to name a trump suit other than UPSUIT, or pass."
|
||||
(let* ((choices (cl-loop for s below 4 unless (= s upsuit)
|
||||
collect (cons (aref cg-suit-names s) s)))
|
||||
(pick (completing-read "Call trump (or RET to pass): "
|
||||
(mapcar #'car choices) nil t)))
|
||||
(cdr (assoc pick choices))))
|
||||
|
||||
(cl-defmethod cg-trick--score-hand ((game cg-euchre-game))
|
||||
(let* ((scores (cg-get game :scores))
|
||||
(mteam (cg-trick--team (cg-get game :maker)))
|
||||
(mt (+ (aref (cg-get game :tricks) mteam)
|
||||
(aref (cg-get game :tricks) (+ mteam 2))))
|
||||
(oteam (- 1 mteam)))
|
||||
(cl-flet ((award (team n) (dolist (s (list team (+ team 2)))
|
||||
(aset scores s (+ (aref scores s) n)))))
|
||||
(cond ((>= mt 5) (award mteam 2))
|
||||
((>= mt 3) (award mteam 1))
|
||||
(t (award oteam 2))))))
|
||||
|
||||
(cl-defmethod cg-trick--game-over-p ((game cg-euchre-game))
|
||||
(or (>= (aref (cg-get game :scores) 0) (oref game target))
|
||||
(>= (aref (cg-get game :scores) 1) (oref game target))))
|
||||
|
||||
(cl-defmethod cg-trick--winner-seat ((game cg-euchre-game))
|
||||
(if (>= (aref (cg-get game :scores) 0) (aref (cg-get game :scores) 1)) 0 1))
|
||||
|
||||
(cl-defmethod cg-trick--result-string ((game cg-euchre-game))
|
||||
(let ((w (cg-trick--winner-seat game)))
|
||||
(format "%s win" (if (= w 0) "You and North" "West and East"))))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-euchre ()
|
||||
"Play Euchre against three AI opponents."
|
||||
(interactive)
|
||||
(cg-trick--play-game 'cg-euchre-game))
|
||||
|
||||
(provide 'cg-trick-ext)
|
||||
;;; cg-trick-ext.el ends here
|
||||
941
cg-trick.el
941
cg-trick.el
|
|
@ -1,941 +0,0 @@
|
|||
;;; cg-trick.el --- Four-hand trick-taking games (Hearts, Spades) -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2026 Corwin Brust
|
||||
|
||||
;; Author: Corwin Brust <corwin@bru.st>
|
||||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||||
;; Version: 1.0.91
|
||||
;; Package-Requires: ((emacs "26.1"))
|
||||
;; Keywords: games
|
||||
;; URL: https://code.bru.st/corwin/card-game.el
|
||||
|
||||
;; This program is free software; you can redistribute it and/or modify
|
||||
;; it under the terms of the GNU General Public License as published by
|
||||
;; the Free Software Foundation, either version 3 of the License, or
|
||||
;; (at your option) any later version.
|
||||
|
||||
;; This program is distributed in the hope that it will be useful,
|
||||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;; GNU General Public License for more details.
|
||||
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; A small four-handed trick-taking engine and two games built on it:
|
||||
;;
|
||||
;; `cg-hearts' -- the classic avoidance game; dodge every heart and the
|
||||
;; Queen of Spades, or take them all to "shoot the moon".
|
||||
;; `cg-spades' -- partnership bidding; spades are always trump; make your
|
||||
;; side's combined bid, beware of bags, and dare a nil.
|
||||
;;
|
||||
;; You sit South (seat 0); the other three seats are played by simple but
|
||||
;; legal AI. Cards are the package-standard cons (SUIT . RANK) with SUIT
|
||||
;; 0 spades, 1 clubs, 2 diamonds, 3 hearts and RANK 0 (the Two) .. 12 (the
|
||||
;; Ace); within a suit the higher rank wins, with the trump suit beating
|
||||
;; every plain suit.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'eieio)
|
||||
(require 'cg-core)
|
||||
(require 'cg-svg)
|
||||
|
||||
;;;; Cards
|
||||
|
||||
(defconst cg-trick-ranks
|
||||
["2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K" "A"]
|
||||
"Rank labels indexed 0 (Two) .. 12 (Ace).")
|
||||
|
||||
(defconst cg-trick-seat-names ["South" "West" "North" "East"]
|
||||
"Seat names indexed 0..3, going clockwise from the human player.")
|
||||
|
||||
(defun cg-trick-card-string (card)
|
||||
"Return a short string for CARD."
|
||||
(if (null card) "·"
|
||||
(concat (aref cg-trick-ranks (cdr card)) (cg-suit-glyph (car card)))))
|
||||
|
||||
(defsubst cg-trick-red-p (card) (and card (cg-red-suit-p (car card))))
|
||||
|
||||
(defun cg-trick--full-deck ()
|
||||
"Return a fresh shuffled 52-card deck."
|
||||
(random t)
|
||||
(cg-shuffle (cl-loop for s below 4 append
|
||||
(cl-loop for r below 13 collect (cons s r)))))
|
||||
|
||||
(defun cg-trick--sort (cards)
|
||||
"Return CARDS sorted by suit then rank for display."
|
||||
(sort (copy-sequence cards)
|
||||
(lambda (a b) (if (= (car a) (car b)) (< (cdr a) (cdr b))
|
||||
(< (car a) (car b))))))
|
||||
|
||||
;;;; Classes
|
||||
|
||||
(defclass cg-trick-game (cg-game)
|
||||
((trump :initform nil :documentation "Trump suit index, or nil for none.")
|
||||
(restricted :initform 3 :documentation "Suit that cannot be led until broken.")
|
||||
(target :initform 100 :documentation "Score that ends the game.")
|
||||
(hand-size :initform 13 :documentation "Cards dealt to each seat per hand.")
|
||||
(vname :initform "Trick game"))
|
||||
"Abstract base for four-handed trick-taking games."
|
||||
:abstract t)
|
||||
|
||||
(defclass cg-hearts-game (cg-trick-game)
|
||||
((trump :initform nil) (restricted :initform 3) (target :initform 100)
|
||||
(vname :initform "Hearts"))
|
||||
"Hearts: no trump; avoid hearts and the Queen of Spades.")
|
||||
|
||||
(defclass cg-spades-game (cg-trick-game)
|
||||
((trump :initform 0) (restricted :initform 0) (target :initform 500)
|
||||
(vname :initform "Spades"))
|
||||
"Spades: spades are trump; partnership bidding to 500.")
|
||||
|
||||
;;;; Dealing
|
||||
|
||||
(cl-defmethod cg-trick--deal ((game cg-trick-game))
|
||||
"Deal a fresh hand into GAME."
|
||||
(let ((deck (cg-trick--full-deck))
|
||||
(hands (make-vector 4 nil))
|
||||
(hs (oref game hand-size))
|
||||
(last nil))
|
||||
(dotimes (s 4)
|
||||
(let ((h nil))
|
||||
(dotimes (_ hs) (setq last (pop deck)) (push last h))
|
||||
(aset hands s (cg-trick--sort h))))
|
||||
(cg-put game :hands hands)
|
||||
(cg-put game :deck deck)
|
||||
(cg-put game :last-card last)
|
||||
(cg-put game :trick nil)
|
||||
(cg-put game :tricks (make-vector 4 0))
|
||||
(cg-put game :taken (make-vector 4 nil))
|
||||
(cg-put game :broken nil)
|
||||
(cg-put game :trick-no 0)
|
||||
game))
|
||||
|
||||
(defsubst cg-trick--hand (game s) (aref (cg-get game :hands) s))
|
||||
(defsubst cg-trick--set-hand (game s v) (aset (cg-get game :hands) s v))
|
||||
(defsubst cg-trick--partner (s) (mod (+ s 2) 4))
|
||||
(defsubst cg-trick--team (s) (mod s 2))
|
||||
|
||||
;;;; Trick mechanics
|
||||
|
||||
(defun cg-trick--led-suit (game)
|
||||
"Return the suit led to the current trick, or nil if none yet."
|
||||
(let ((tr (cg-get game :trick)))
|
||||
(and tr (car (cdr (car (last tr))))))) ; first entry played
|
||||
|
||||
(defun cg-trick--first-play (game)
|
||||
"Return the (SEAT . CARD) led to the current trick, or nil."
|
||||
(car (last (cg-get game :trick))))
|
||||
|
||||
(cl-defmethod cg-trick--has-points-only-p ((_ cg-trick-game) _hand) nil)
|
||||
|
||||
(cl-defmethod cg-trick--legal-p ((game cg-trick-game) seat card)
|
||||
"Return non-nil when SEAT may legally play CARD now."
|
||||
(let* ((hand (cg-trick--hand game seat))
|
||||
(trick (cg-get game :trick))
|
||||
(restricted (oref game restricted))
|
||||
(broken (cg-get game :broken)))
|
||||
(and (member card hand)
|
||||
(if trick
|
||||
;; following: must follow the led suit if able
|
||||
(let ((led (cg-trick--led-suit game)))
|
||||
(if (cl-some (lambda (c) (= (car c) led)) hand)
|
||||
(= (car card) led)
|
||||
t))
|
||||
;; leading: cannot lead the restricted suit until broken,
|
||||
;; unless the hand holds nothing else
|
||||
(if (and (= (car card) restricted) (not broken))
|
||||
(cl-every (lambda (c) (= (car c) restricted)) hand)
|
||||
t)))))
|
||||
|
||||
(defun cg-trick--legal-moves (game seat)
|
||||
"Return the list of cards SEAT may legally play now."
|
||||
(cl-remove-if-not (lambda (c) (cg-trick--legal-p game seat c))
|
||||
(cg-trick--hand game seat)))
|
||||
|
||||
(cl-defmethod cg-trick--winner ((game cg-trick-game))
|
||||
"Return the seat that wins the now-complete current trick."
|
||||
(let* ((trick (reverse (cg-get game :trick))) ; play order
|
||||
(led (car (cdr (car trick))))
|
||||
(trump (oref game trump))
|
||||
(best (car trick)))
|
||||
(dolist (play (cdr trick))
|
||||
(let ((bc (cdr best)) (pc (cdr play)))
|
||||
(cond
|
||||
((and trump (= (car pc) trump) (not (= (car bc) trump)))
|
||||
(setq best play))
|
||||
((and (= (car pc) (car bc)) (> (cdr pc) (cdr bc)))
|
||||
(setq best play))
|
||||
((and trump (not (= (car bc) trump)) (= (car pc) led)
|
||||
(> (cdr pc) (cdr bc)))
|
||||
(setq best play)))))
|
||||
(car best)))
|
||||
|
||||
(cl-defmethod cg-trick--play ((game cg-trick-game) seat card)
|
||||
"Have SEAT play CARD, resolving the trick when it completes."
|
||||
(cg-trick--set-hand game seat (remove card (cg-trick--hand game seat)))
|
||||
(when (= (car card) (oref game restricted)) (cg-put game :broken t))
|
||||
(cg-put game :trick (cons (cons seat card) (cg-get game :trick)))
|
||||
(if (= 4 (length (cg-get game :trick)))
|
||||
(let* ((w (cg-trick--winner game))
|
||||
(cards (mapcar #'cdr (cg-get game :trick))))
|
||||
(aset (cg-get game :tricks) w (1+ (aref (cg-get game :tricks) w)))
|
||||
(aset (cg-get game :taken) w (append cards (aref (cg-get game :taken) w)))
|
||||
(cg-put game :trick nil)
|
||||
(cg-put game :trick-no (1+ (cg-get game :trick-no)))
|
||||
(cg-put game :leader w)
|
||||
(cg-put game :turn w)
|
||||
w)
|
||||
(cg-put game :turn (mod (1+ seat) 4))
|
||||
nil))
|
||||
|
||||
(defun cg-trick--hand-over-p (game)
|
||||
"Return non-nil when all 13 tricks of the hand have been played."
|
||||
(and (null (cg-get game :trick))
|
||||
(cl-every #'null (append (cg-get game :hands) nil))))
|
||||
|
||||
;;;; Hearts specifics
|
||||
|
||||
(defun cg-hearts--card-points (card)
|
||||
"Return the penalty points for CARD in Hearts."
|
||||
(cond ((equal card '(0 . 10)) 13) ; Queen of Spades
|
||||
((= (car card) 3) 1) ; any heart
|
||||
(t 0)))
|
||||
|
||||
(cl-defmethod cg-trick--legal-p ((game cg-hearts-game) seat card)
|
||||
"Hearts legality, adding the first-trick rules to the base."
|
||||
(and (cl-call-next-method)
|
||||
(let ((trick (cg-get game :trick))
|
||||
(hand (cg-trick--hand game seat))
|
||||
(first (= 0 (cg-get game :trick-no))))
|
||||
(cond
|
||||
;; the very first card of the hand must be the Two of Clubs
|
||||
((and first (null trick))
|
||||
(equal card '(1 . 0)))
|
||||
;; no points on the first trick unless that is all one holds
|
||||
((and first trick (> (cg-hearts--card-points card) 0))
|
||||
(cl-every (lambda (c) (> (cg-hearts--card-points c) 0)) hand))
|
||||
(t t)))))
|
||||
|
||||
(cl-defmethod cg-trick--leader-init ((game cg-hearts-game))
|
||||
"Hearts: the holder of the Two of Clubs leads first."
|
||||
(let (seat)
|
||||
(dotimes (s 4)
|
||||
(when (member '(1 . 0) (cg-trick--hand game s)) (setq seat s)))
|
||||
(cg-put game :leader seat) (cg-put game :turn seat)))
|
||||
|
||||
(cl-defmethod cg-trick--leader-init ((game cg-spades-game))
|
||||
"Spades: the player left of the dealer leads first."
|
||||
(let ((s (mod (1+ (or (cg-get game :dealer) 3)) 4)))
|
||||
(cg-put game :leader s) (cg-put game :turn s)))
|
||||
|
||||
(cl-defmethod cg-trick--score-hand ((game cg-hearts-game))
|
||||
"Score a finished Hearts hand into the cumulative scores."
|
||||
(let ((pts (make-vector 4 0)) (scores (cg-get game :scores)))
|
||||
(dotimes (s 4)
|
||||
(aset pts s (apply #'+ (mapcar #'cg-hearts--card-points
|
||||
(aref (cg-get game :taken) s)))))
|
||||
;; shooting the moon
|
||||
(let ((moon (cl-position 26 (append pts nil))))
|
||||
(if moon
|
||||
(dotimes (s 4) (unless (= s moon)
|
||||
(aset scores s (+ (aref scores s) 26))))
|
||||
(dotimes (s 4) (aset scores s (+ (aref scores s) (aref pts s))))))
|
||||
(cg-put game :last-points pts)))
|
||||
|
||||
(cl-defmethod cg-trick--game-over-p ((game cg-hearts-game))
|
||||
"Hearts ends when any score reaches the target."
|
||||
(cl-some (lambda (s) (>= s (oref game target))) (append (cg-get game :scores) nil)))
|
||||
|
||||
(cl-defmethod cg-trick--winner-seat ((game cg-hearts-game))
|
||||
"Return the winning seat (lowest score) for a finished Hearts game."
|
||||
(let ((best 0))
|
||||
(dotimes (s 4) (when (< (aref (cg-get game :scores) s)
|
||||
(aref (cg-get game :scores) best))
|
||||
(setq best s)))
|
||||
best))
|
||||
|
||||
;;;; Spades specifics
|
||||
|
||||
(cl-defmethod cg-trick--score-hand ((game cg-spades-game))
|
||||
"Score a finished Spades hand into the cumulative team scores."
|
||||
(let ((scores (cg-get game :scores))
|
||||
(bags (cg-get game :bags))
|
||||
(bids (cg-get game :bids))
|
||||
(tricks (cg-get game :tricks)))
|
||||
(dotimes (team 2)
|
||||
(let* ((a team) (b (+ team 2))
|
||||
(teambid 0) (teamtricks (+ (aref tricks a) (aref tricks b)))
|
||||
(delta 0))
|
||||
;; nil bids handled per player
|
||||
(dolist (s (list a b))
|
||||
(if (= (aref bids s) 0)
|
||||
(setq delta (+ delta (if (= (aref tricks s) 0) 100 -100)))
|
||||
(setq teambid (+ teambid (aref bids s)))))
|
||||
(if (>= teamtricks teambid)
|
||||
(let ((over (- teamtricks teambid)))
|
||||
;; overtricks beyond nil winners count as bags
|
||||
(setq delta (+ delta (* 10 teambid) over))
|
||||
(aset bags team (+ (aref bags team) over))
|
||||
(when (>= (aref bags team) 10)
|
||||
(setq delta (- delta 100))
|
||||
(aset bags team (- (aref bags team) 10))))
|
||||
(setq delta (- delta (* 10 teambid))))
|
||||
(aset scores a (+ (aref scores a) delta))
|
||||
(aset scores b (aref scores a))))
|
||||
(cg-put game :scores scores)))
|
||||
|
||||
(cl-defmethod cg-trick--game-over-p ((game cg-spades-game))
|
||||
"Spades ends when a team reaches the target (or falls badly behind)."
|
||||
(cl-some (lambda (s) (>= s (oref game target))) (append (cg-get game :scores) nil)))
|
||||
|
||||
(cl-defmethod cg-trick--winner-seat ((game cg-spades-game))
|
||||
"Return a member seat of the winning team for a finished Spades game."
|
||||
(if (>= (aref (cg-get game :scores) 0) (aref (cg-get game :scores) 1)) 0 1))
|
||||
|
||||
;;;; AI
|
||||
|
||||
(cl-defmethod cg-trick--ai-bid ((game cg-spades-game) seat)
|
||||
"Return a simple trick estimate (bid) for SEAT in Spades."
|
||||
(let ((hand (cg-trick--hand game seat)) (bid 0))
|
||||
(dolist (c hand)
|
||||
(cond
|
||||
((= (cdr c) 12) (setq bid (1+ bid))) ; aces
|
||||
((and (= (cdr c) 11)) (setq bid (1+ bid))) ; kings
|
||||
((and (= (car c) 0) (>= (cdr c) 9)) (setq bid (1+ bid))))) ; high spades
|
||||
;; long spades add tricks
|
||||
(let ((nsp (cl-count-if (lambda (c) (= (car c) 0)) hand)))
|
||||
(when (> nsp 4) (setq bid (+ bid (- nsp 4)))))
|
||||
(max 1 (min 13 bid))))
|
||||
|
||||
(cl-defmethod cg-trick--ai-play ((game cg-hearts-game) seat)
|
||||
"Choose a legal Hearts card for SEAT, avoiding points."
|
||||
(let* ((moves (cg-trick--legal-moves game seat))
|
||||
(trick (cg-get game :trick)))
|
||||
(or
|
||||
(if (null trick)
|
||||
;; leading: play a low non-point card
|
||||
(car (sort (copy-sequence moves)
|
||||
(lambda (a b) (< (+ (* 4 (cg-hearts--card-points a)) (cdr a))
|
||||
(+ (* 4 (cg-hearts--card-points b)) (cdr b))))))
|
||||
;; following: if we can duck under the current winner, play highest
|
||||
;; safe card; else dump the most dangerous card
|
||||
(let* ((led (cg-trick--led-suit game))
|
||||
(winrank (apply #'max (cons -1 (mapcar (lambda (p) (if (= (car (cdr p)) led)
|
||||
(cdr (cdr p)) -1))
|
||||
trick))))
|
||||
(under (cl-remove-if-not (lambda (c) (and (= (car c) led)
|
||||
(< (cdr c) winrank)))
|
||||
moves)))
|
||||
(cond
|
||||
(under (car (last (cg-trick--sort under)))) ; highest still safe
|
||||
((cl-some (lambda (c) (/= (car c) led)) moves) ; void: dump worst
|
||||
(car (sort (copy-sequence moves)
|
||||
(lambda (a b) (> (+ (* 4 (cg-hearts--card-points a)) (cdr a))
|
||||
(+ (* 4 (cg-hearts--card-points b)) (cdr b)))))))
|
||||
(t (car (sort (copy-sequence moves) ; must follow & take: lowest
|
||||
(lambda (a b) (< (cdr a) (cdr b)))))))))
|
||||
(car moves))))
|
||||
|
||||
(cl-defmethod cg-trick--ai-play ((game cg-spades-game) seat)
|
||||
"Choose a legal Spades card for SEAT."
|
||||
(let* ((moves (cg-trick--legal-moves game seat))
|
||||
(trick (cg-get game :trick))
|
||||
(trump (oref game trump)))
|
||||
(or
|
||||
(if (null trick)
|
||||
;; lead a high non-spade if possible, else lowest
|
||||
(let ((non (cl-remove-if (lambda (c) (= (car c) trump)) moves)))
|
||||
(if non (car (last (cg-trick--sort non)))
|
||||
(car (cg-trick--sort moves))))
|
||||
(let* ((led (cg-trick--led-suit game))
|
||||
(cur (cg-get game :trick))
|
||||
;; current winning play
|
||||
(winner (cg-trick--winner-of game cur))
|
||||
(partner-winning (and winner (= (cg-trick--team winner)
|
||||
(cg-trick--team seat)))))
|
||||
(if partner-winning
|
||||
(car (cg-trick--sort moves)) ; let partner have it: play low
|
||||
;; try to win cheaply
|
||||
(let* ((followers (cl-remove-if-not (lambda (c) (= (car c) led)) moves)))
|
||||
(or (car (cg-trick--sort followers))
|
||||
(car (cg-trick--sort moves)))))))
|
||||
(car moves))))
|
||||
|
||||
(defun cg-trick--winner-of (game trick)
|
||||
"Return the seat currently winning the partial TRICK of GAME."
|
||||
(when trick
|
||||
(let* ((order (reverse trick))
|
||||
(led (car (cdr (car order))))
|
||||
(trump (oref game trump))
|
||||
(best (car order)))
|
||||
(dolist (play (cdr order))
|
||||
(let ((bc (cdr best)) (pc (cdr play)))
|
||||
(cond
|
||||
((and trump (= (car pc) trump) (not (= (car bc) trump))) (setq best play))
|
||||
((and (= (car pc) (car bc)) (> (cdr pc) (cdr bc))) (setq best play))
|
||||
((and trump (not (= (car bc) trump)) (= (car pc) led)
|
||||
(> (cdr pc) (cdr bc))) (setq best play)))))
|
||||
(car best))))
|
||||
|
||||
;;;; Game driver (logic; UI layered on top)
|
||||
|
||||
(cl-defmethod cg-trick--start-hand ((game cg-trick-game))
|
||||
"Deal and prepare a new hand, leaving GAME ready for the first lead."
|
||||
(cg-trick--deal game)
|
||||
(cg-trick--leader-init game)
|
||||
game)
|
||||
|
||||
(defun cg-trick--simulate-hand (game)
|
||||
"Play a whole hand with AI for every seat (used by tests)."
|
||||
(while (not (cg-trick--hand-over-p game))
|
||||
(let ((seat (cg-get game :turn)))
|
||||
(cg-trick--play game seat
|
||||
(if (eq cg-ai-level 'easy)
|
||||
(let ((moves (cg-trick--legal-moves game seat)))
|
||||
(nth (random (length moves)) moves))
|
||||
(cg-trick--ai-play game seat)))))
|
||||
(cg-trick--score-hand game))
|
||||
|
||||
;;;; New-game / hand lifecycle
|
||||
|
||||
(defvar-local cg-trick--game nil "The trick-taking game in the current buffer.")
|
||||
|
||||
(defconst cg-trick--pass-dirs [1 3 2 0]
|
||||
"Pass directions by hand: left, right, across, hold (then repeat).")
|
||||
|
||||
(defun cg-trick--dir-name (dir)
|
||||
"Return a human label for pass direction DIR."
|
||||
(pcase dir (1 "left") (3 "right") (2 "across") (_ "hold")))
|
||||
|
||||
(cl-defgeneric cg-trick--begin-hand (game)
|
||||
"Deal and set up a new hand of GAME, then run AI up to the human's turn.")
|
||||
|
||||
(cl-defmethod cg-trick--begin-hand ((game cg-hearts-game))
|
||||
(cg-trick--deal game)
|
||||
(cg-put game :hand-no (1+ (or (cg-get game :hand-no) 0)))
|
||||
(cg-put game :cursor 0) (cg-put game :marks nil)
|
||||
(let ((dir (aref cg-trick--pass-dirs (mod (1- (cg-get game :hand-no)) 4))))
|
||||
(cg-put game :pass-dir dir)
|
||||
(if (= dir 0)
|
||||
(progn (cg-trick--leader-init game)
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :message "No passing this hand. Play begins.")
|
||||
(cg-trick--run game))
|
||||
(cg-put game :phase 'pass)
|
||||
(cg-put game :message
|
||||
(format "Pass three cards %s. RET marks a card; p sends them."
|
||||
(cg-trick--dir-name dir))))))
|
||||
|
||||
(cl-defmethod cg-trick--begin-hand ((game cg-spades-game))
|
||||
(cg-trick--deal game)
|
||||
(cg-put game :dealer (mod (1+ (or (cg-get game :dealer) 3)) 4))
|
||||
(cg-put game :cursor 0)
|
||||
(let ((bids (make-vector 4 0)))
|
||||
(dotimes (s 4) (unless (= s 0) (aset bids s (cg-trick--ai-bid game s))))
|
||||
(aset bids 0 (if noninteractive (cg-trick--ai-bid game 0)
|
||||
(let ((sug (cg-trick--ai-bid game 0)))
|
||||
(max 0 (min 13 (read-number
|
||||
(format "Your bid (0 = nil) [suggest %d]: " sug)
|
||||
sug))))))
|
||||
(cg-put game :bids bids))
|
||||
(cg-trick--leader-init game)
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :message
|
||||
(format "You bid %d. Make your side's combined bid."
|
||||
(aref (cg-get game :bids) 0)))
|
||||
(cg-trick--run game))
|
||||
|
||||
(defun cg-trick--new (game)
|
||||
"Initialise GAME for a fresh match and deal the first hand."
|
||||
(cg-put game :scores (make-vector 4 0))
|
||||
(cg-put game :bags (make-vector 2 0))
|
||||
(cg-put game :dealer 3)
|
||||
(cg-put game :hand-no 0)
|
||||
(cg-put game :round 0)
|
||||
(cg-trick--begin-hand game)
|
||||
game)
|
||||
|
||||
(defun cg-trick--run (game)
|
||||
"Advance AI seats until it is the human's turn or the hand ends."
|
||||
(while (and (eq (cg-get game :phase) 'play)
|
||||
(not (cg-trick--hand-over-p game))
|
||||
(/= (cg-get game :turn) 0))
|
||||
(let ((s (cg-get game :turn)))
|
||||
(cg-trick--play game s (cg-trick--ai-play game s))))
|
||||
(when (and (eq (cg-get game :phase) 'play) (cg-trick--hand-over-p game))
|
||||
(cg-trick--finish-hand game)))
|
||||
|
||||
(defun cg-trick--finish-hand (game)
|
||||
"Score the finished hand of GAME and start the next, or end the match."
|
||||
(cg-trick--score-hand game)
|
||||
(if (cg-trick--game-over-p game)
|
||||
(progn (cg-put game :phase 'game-over)
|
||||
(cg-put game :message
|
||||
(format "Game over. %s. Press n for a new match."
|
||||
(cg-trick--result-string game))))
|
||||
(cg-trick--begin-hand game)))
|
||||
|
||||
(cl-defmethod cg-trick--result-string ((game cg-hearts-game))
|
||||
(format "%s wins with the lowest score"
|
||||
(aref cg-trick-seat-names (cg-trick--winner-seat game))))
|
||||
|
||||
(cl-defmethod cg-trick--result-string ((game cg-spades-game))
|
||||
(let ((w (cg-trick--winner-seat game)))
|
||||
(format "%s win" (if (= w 0) "You and North" "West and East"))))
|
||||
|
||||
;;;; AI passing
|
||||
|
||||
(cl-defmethod cg-trick--ai-pass ((_ cg-hearts-game) hand)
|
||||
"Return three cards to pass from HAND (shed the most dangerous)."
|
||||
(let ((danger (lambda (c) (+ (* 6 (cg-hearts--card-points c))
|
||||
(if (and (= (car c) 0) (>= (cdr c) 10)) 5 0)
|
||||
(cdr c)))))
|
||||
(cl-subseq (sort (copy-sequence hand)
|
||||
(lambda (a b) (> (funcall danger a) (funcall danger b))))
|
||||
0 3)))
|
||||
|
||||
(defun cg-trick--do-pass (game)
|
||||
"Exchange the chosen passing cards among the four seats of GAME."
|
||||
(let* ((dir (cg-get game :pass-dir))
|
||||
(sel (make-vector 4 nil))
|
||||
(kept (make-vector 4 nil)))
|
||||
(aset sel 0 (copy-sequence (cg-get game :marks)))
|
||||
(dotimes (s 4)
|
||||
(unless (= s 0)
|
||||
(aset sel s (copy-sequence (cg-trick--ai-pass game (cg-trick--hand game s))))))
|
||||
;; what each seat keeps (its hand minus the cards it gives away)
|
||||
(dotimes (s 4)
|
||||
(aset kept s (cl-remove-if (lambda (c) (member c (aref sel s)))
|
||||
(cg-trick--hand game s))))
|
||||
;; deal each seat's three cards to the seat DIR places along
|
||||
(dotimes (s 4)
|
||||
(let ((r (mod (+ s dir) 4)))
|
||||
(aset kept r (append (aref kept r) (aref sel s)))))
|
||||
(dotimes (s 4)
|
||||
(cg-trick--set-hand game s (cg-trick--sort (aref kept s))))
|
||||
(cg-trick--leader-init game)
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :marks nil)
|
||||
(cg-put game :message "Cards passed. Play begins.")
|
||||
(cg-trick--run game)))
|
||||
|
||||
(defun cg-trick--seat-line (game s)
|
||||
"Return a status line for opponent seat S of GAME."
|
||||
(let* ((n (length (cg-trick--hand game s)))
|
||||
(bid (and (cg-get game :bids) (aref (cg-get game :bids) s)))
|
||||
(won (and (cg-get game :tricks) (aref (cg-get game :tricks) s))))
|
||||
(format " %-6s %2d cards%s%s\n" (aref cg-trick-seat-names s) n
|
||||
(if bid (format " bid %d" bid) "")
|
||||
(if won (format " won %d" won) ""))))
|
||||
|
||||
(defcustom cg-trick-svg-cards t
|
||||
"When non-nil, draw cards as SVG images on a graphical display."
|
||||
:type 'boolean :group 'card-games)
|
||||
|
||||
(defun cg-trick--spec (card)
|
||||
"Return the cg-svg display spec (RANK-STRING . SUIT) for CARD."
|
||||
(cons (aref cg-trick-ranks (cdr card)) (car card)))
|
||||
|
||||
(cl-defun cg-trick--svg-row (cards &key cursor marks hints region-tag)
|
||||
"Return a one-image SVG row for CARDS (clickable + sliderful when REGION-TAG)."
|
||||
(cg-svg-hand-image (mapcar #'cg-trick--spec cards)
|
||||
:cursor cursor :marks marks :hints hints
|
||||
:overlap (if (> (length cards) 11)
|
||||
(max 0 (- cg-svg-card-width 24)) 0)
|
||||
:region-tag region-tag))
|
||||
|
||||
(defun cg-trick--draw-backs (svg x y n)
|
||||
"Draw up to three overlapped face-down backs at X, Y for a hand of N cards."
|
||||
(let ((k (min (max n 0) 3)) (xx x))
|
||||
(dotimes (_ k)
|
||||
(cg-svg-card svg xx y :down t)
|
||||
(setq xx (+ xx 16)))))
|
||||
|
||||
(defun cg-trick--svg (game)
|
||||
"Return a propertized full-table SVG depiction of trick GAME.
|
||||
The South hand carries clickable (hand . INDEX) regions."
|
||||
(let* ((w cg-svg-card-width) (h cg-svg-card-height) (gap cg-svg-card-gap)
|
||||
(pad 16)
|
||||
(hand (cg-trick--sort (cg-trick--hand game 0)))
|
||||
(n (length hand))
|
||||
(overlap (cond ((> n 11) (- w 24)) ((> n 8) 20) (t 0)))
|
||||
(step (max 14 (- (+ w gap) overlap)))
|
||||
(fanw (if (> n 0) (+ (* (1- n) step) w) w))
|
||||
(width (max (+ fanw (* 2 pad)) 720))
|
||||
(cx (/ width 2))
|
||||
(scores (cg-get game :scores))
|
||||
(trick (cg-get game :trick))
|
||||
(turn (cg-get game :turn))
|
||||
(phase (cg-get game :phase))
|
||||
(marks (cg-get game :marks))
|
||||
(cursor (cg-get game :cursor))
|
||||
(bids (cg-get game :bids))
|
||||
(tks (cg-get game :tricks))
|
||||
(y-title 6) (y-north 26)
|
||||
(y-tn (+ y-north h 22))
|
||||
(cy (+ y-tn (round (* h 0.55))))
|
||||
(y-ts (+ cy (round (* h 0.15))))
|
||||
(y-south (+ y-ts h 34))
|
||||
(height (+ y-south h 30))
|
||||
(svg (svg-create width height))
|
||||
(lc (cg-color 'shadow :foreground "gray50"))
|
||||
(regions '()))
|
||||
(cl-labels
|
||||
((txt (str x y &optional sz bold anchor)
|
||||
(apply #'svg-text svg str :x x :y y :font-size (or sz 12) :fill lc
|
||||
:font-family cg-svg-font-family
|
||||
(append (and bold '(:font-weight "bold"))
|
||||
(and anchor (list :text-anchor anchor)))))
|
||||
(seat (s x y)
|
||||
(cg-trick--draw-backs svg x (+ y 6) (length (cg-trick--hand game s)))
|
||||
(txt (format "%s%s%s%s" (aref cg-trick-seat-names s)
|
||||
(if (and bids (aref bids s)) (format " bid %d" (aref bids s)) "")
|
||||
(if (and tks (> (aref tks s) 0)) (format " won %d" (aref tks s)) "")
|
||||
(if (= turn s) " <-" ""))
|
||||
x y 11))
|
||||
(trick-card (s x y)
|
||||
(let ((play (assq s trick)))
|
||||
(when play
|
||||
(let ((sp (cg-trick--spec (cdr play))))
|
||||
(cg-svg-card svg x y :rank (car sp) :suit (cdr sp)))))))
|
||||
(txt (format "%s -- %s" (oref game vname)
|
||||
(pcase phase
|
||||
('pass "pass three cards") ('bid "bidding")
|
||||
('play (if (= turn 0) "your turn" "opponents playing"))
|
||||
(_ "play")))
|
||||
pad (+ y-title 12) 13 t)
|
||||
(when scores
|
||||
(txt (format "S %d W %d N %d E %d"
|
||||
(aref scores 0) (aref scores 1) (aref scores 2) (aref scores 3))
|
||||
(- width pad) (+ y-title 12) 12 nil "end"))
|
||||
(seat 2 (- cx 40) y-north)
|
||||
(seat 1 pad cy)
|
||||
(seat 3 (- width pad 100) cy)
|
||||
(trick-card 2 (- cx (/ w 2)) y-tn)
|
||||
(trick-card 0 (- cx (/ w 2)) y-ts)
|
||||
(trick-card 1 (- cx w (round (* w 0.4))) (round (- cy (* h 0.25))))
|
||||
(trick-card 3 (+ cx (round (* w 0.4))) (round (- cy (* h 0.25))))
|
||||
(txt (format "Your hand (South)%s"
|
||||
(if (eq phase 'pass) (format " -- marked %d/3" (length marks)) ""))
|
||||
pad (- y-south 6) 11)
|
||||
(let ((x (- cx (/ fanw 2))) (i 0)
|
||||
(legalp (and (eq phase 'play) (= turn 0))))
|
||||
(dolist (c hand)
|
||||
(let ((sp (cg-trick--spec c))
|
||||
(curp (= i cursor))
|
||||
(markp (member c marks))
|
||||
(hintp (and legalp (cg-trick--legal-p game 0 c))))
|
||||
(cg-svg-card svg x y-south :rank (car sp) :suit (cdr sp)
|
||||
:highlight curp :hint hintp)
|
||||
(when markp
|
||||
(svg-rectangle svg (- x 3) (- y-south 3) (+ w 6) (+ h 6)
|
||||
:rx 8 :fill "none" :stroke "#4a90d9" :stroke-width 3))
|
||||
(push (cons (list x y-south (if (= i (1- n)) w step) h) (cons 'hand i)) regions))
|
||||
(setq x (+ x step) i (1+ i))))
|
||||
(txt (or (cg-get game :message) "") pad (- height 8) 12))
|
||||
(propertize "*" 'display (cg-svg-image svg (cg-scale))
|
||||
'cg-regions (nreverse regions))))
|
||||
|
||||
(defun cg-trick--render-text (game)
|
||||
"Return a plain-text depiction of trick GAME."
|
||||
(let* ((out (list))
|
||||
(scores (cg-get game :scores))
|
||||
(marks (cg-get game :marks))
|
||||
(cursor (cg-get game :cursor))
|
||||
(hand (cg-trick--sort (cg-trick--hand game 0))))
|
||||
(push (format " %s\n" (oref game vname)) out)
|
||||
(when scores
|
||||
(push (format " Scores: South %d West %d North %d East %d\n\n"
|
||||
(aref scores 0) (aref scores 1) (aref scores 2) (aref scores 3))
|
||||
out))
|
||||
(dolist (s '(2 1 3))
|
||||
(push (cg-trick--seat-line game s) out))
|
||||
(push "\n Trick: " out)
|
||||
(if (null (cg-get game :trick))
|
||||
(push "(empty)" out)
|
||||
(dolist (play (reverse (cg-get game :trick)))
|
||||
(push (format "%s:%s " (aref cg-trick-seat-names (car play))
|
||||
(let ((cs (cg-trick-card-string (cdr play))))
|
||||
(if (cg-trick-red-p (cdr play))
|
||||
(propertize cs 'face 'cg-red-suit) cs)))
|
||||
out)))
|
||||
(push "\n\n Your hand (South):\n " out)
|
||||
(let ((i 0))
|
||||
(dolist (c hand)
|
||||
(let ((cs (cg-trick-card-string c)) (faces nil))
|
||||
(when (cg-trick-red-p c) (push 'cg-red-suit faces))
|
||||
(when (member c marks) (push 'cg-hint faces))
|
||||
(when (= i cursor) (push 'cg-cursor faces))
|
||||
(push (propertize (format "%4s" cs) 'face (or faces 'default)) out))
|
||||
(setq i (1+ i))))
|
||||
(push (format "\n\n %s\n" (cg-get game :message)) out)
|
||||
(apply #'concat (nreverse out))))
|
||||
|
||||
(cl-defmethod cg-render ((game cg-trick-game))
|
||||
"Return a depiction of GAME: a full SVG table on a graphical display,
|
||||
else a plain-text board."
|
||||
(if (and cg-trick-svg-cards (display-graphic-p))
|
||||
(cg-trick--svg game)
|
||||
(cg-trick--render-text game)))
|
||||
|
||||
(cl-defmethod cg-render-apply ((g cg-trick-game) action)
|
||||
"Apply a click ACTION on the hand: select that card and play it."
|
||||
(pcase action
|
||||
(`(hand . ,i) (cg-put g :cursor i) (cg-trick-act))
|
||||
(_ (cl-call-next-method))))
|
||||
|
||||
(defun cg-trick--redisplay ()
|
||||
"Redraw the current trick-game buffer."
|
||||
(let ((game cg-trick--game) (inhibit-read-only t))
|
||||
(setq cg-current-game game cg-redisplay-function #'cg-trick--redisplay)
|
||||
(setq-local mode-line-process
|
||||
(format " [%s]" (or (cg-get game :phase) "play")))
|
||||
(erase-buffer)
|
||||
(insert (cg-render game))
|
||||
(goto-char (point-min))))
|
||||
|
||||
;;;; Commands
|
||||
|
||||
(defun cg-trick--cursor-card (game)
|
||||
"Return the South card currently under the cursor."
|
||||
(nth (cg-get game :cursor) (cg-trick--sort (cg-trick--hand game 0))))
|
||||
|
||||
(defun cg-trick-left ()
|
||||
"Move the hand cursor left."
|
||||
(interactive)
|
||||
(let* ((game cg-trick--game) (n (length (cg-trick--hand game 0))))
|
||||
(when (> n 0) (cg-put game :cursor (mod (1- (cg-get game :cursor)) n)))
|
||||
(cg-trick--redisplay)))
|
||||
|
||||
(defun cg-trick-right ()
|
||||
"Move the hand cursor right."
|
||||
(interactive)
|
||||
(let* ((game cg-trick--game) (n (length (cg-trick--hand game 0))))
|
||||
(when (> n 0) (cg-put game :cursor (mod (1+ (cg-get game :cursor)) n)))
|
||||
(cg-trick--redisplay)))
|
||||
|
||||
(defun cg-trick-act ()
|
||||
"Play, or (during the Hearts pass) mark, the selected card."
|
||||
(interactive)
|
||||
(let* ((game cg-trick--game)
|
||||
(phase (cg-get game :phase))
|
||||
(card (cg-trick--cursor-card game)))
|
||||
(pcase phase
|
||||
('play
|
||||
(cond
|
||||
((/= (cg-get game :turn) 0) (cg-put game :message "Not your turn."))
|
||||
((not (cg-trick--legal-p game 0 card))
|
||||
(cg-put game :message "Illegal play — you must follow suit."))
|
||||
(t (cg-trick--play game 0 card)
|
||||
(cg-put game :cursor (max 0 (min (cg-get game :cursor)
|
||||
(1- (length (cg-trick--hand game 0))))))
|
||||
(cg-trick--run game))))
|
||||
('pass
|
||||
(if (member card (cg-get game :marks))
|
||||
(cg-put game :marks (remove card (cg-get game :marks)))
|
||||
(if (>= (length (cg-get game :marks)) 3)
|
||||
(cg-put game :message "Three already marked — press p to pass.")
|
||||
(cg-put game :marks (cons card (cg-get game :marks))))))
|
||||
(_ (cg-put game :message "Press n for a new match.")))
|
||||
(cg-trick--redisplay)))
|
||||
|
||||
(defun cg-trick-pass ()
|
||||
"Confirm the Hearts pass once three cards are marked."
|
||||
(interactive)
|
||||
(let ((game cg-trick--game))
|
||||
(if (and (eq (cg-get game :phase) 'pass) (= 3 (length (cg-get game :marks))))
|
||||
(cg-trick--do-pass game)
|
||||
(cg-put game :message "Mark exactly three cards first."))
|
||||
(cg-trick--redisplay)))
|
||||
|
||||
(defun cg-trick-new ()
|
||||
"Start a fresh match in this buffer."
|
||||
(interactive)
|
||||
(cg-trick--new cg-trick--game)
|
||||
(cg-trick--redisplay))
|
||||
|
||||
(defun cg-trick-redraw () "Redraw the table." (interactive) (cg-trick--redisplay))
|
||||
|
||||
(defun cg-trick-help ()
|
||||
"Describe the controls."
|
||||
(interactive)
|
||||
(message "Arrows: choose card RET: play/mark p: pass (Hearts) n: new g: redraw"))
|
||||
|
||||
(defvar cg-trick-mode-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] #'cg-card-click)
|
||||
(define-key map "+" #'cg-card-zoom-in)
|
||||
(define-key map "=" #'cg-card-zoom-in)
|
||||
(define-key map "-" #'cg-card-zoom-out)
|
||||
(define-key map "0" #'cg-card-zoom-reset)
|
||||
(define-key map (kbd "<left>") #'cg-trick-left)
|
||||
(define-key map (kbd "<right>") #'cg-trick-right)
|
||||
(define-key map (kbd "RET") #'cg-trick-act)
|
||||
(define-key map (kbd "SPC") #'cg-trick-act)
|
||||
(define-key map "p" #'cg-trick-pass)
|
||||
(define-key map "n" #'cg-trick-new)
|
||||
(define-key map "g" #'cg-trick-redraw)
|
||||
(define-key map "?" #'cg-trick-help)
|
||||
map)
|
||||
"Keymap for `cg-trick-mode'.")
|
||||
|
||||
(define-derived-mode cg-trick-mode special-mode "Trick"
|
||||
"Major mode for the four-handed trick-taking games."
|
||||
(setq-local truncate-lines t)
|
||||
(setq-local cursor-type cg-cursor-type))
|
||||
|
||||
(defun cg-trick--play-game (class)
|
||||
"Start a trick game of CLASS in its own buffer."
|
||||
(let* ((game (make-instance class))
|
||||
(buf (get-buffer-create (format "*%s*" (oref game vname)))))
|
||||
(with-current-buffer buf
|
||||
(cg-trick-mode)
|
||||
(setq cg-trick--game game)
|
||||
(cg-trick--new game)
|
||||
(cg-trick--redisplay))
|
||||
(switch-to-buffer buf)))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-hearts ()
|
||||
"Play Hearts against three computer opponents."
|
||||
(interactive) (cg-trick--play-game 'cg-hearts-game))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-spades ()
|
||||
"Play Spades (partnership) against three computer opponents."
|
||||
(interactive) (cg-trick--play-game 'cg-spades-game))
|
||||
|
||||
|
||||
;;;; Whist and Oh Hell
|
||||
|
||||
(defclass cg-whist-game (cg-trick-game)
|
||||
((restricted :initform -1) (target :initform 5) (vname :initform "Whist"))
|
||||
"Whist: trump set by the turned card, no bidding, score tricks over six.")
|
||||
|
||||
(defclass cg-ohhell-game (cg-trick-game)
|
||||
((restricted :initform -1) (target :initform 0) (vname :initform "Oh Hell"))
|
||||
"Oh Hell: hand size shrinks each round; bid the exact tricks you will take.")
|
||||
|
||||
(cl-defmethod cg-trick--leader-init ((game cg-whist-game))
|
||||
(let ((s (mod (1+ (or (cg-get game :dealer) 3)) 4)))
|
||||
(cg-put game :leader s) (cg-put game :turn s)))
|
||||
(cl-defmethod cg-trick--leader-init ((game cg-ohhell-game))
|
||||
(let ((s (mod (1+ (or (cg-get game :dealer) 3)) 4)))
|
||||
(cg-put game :leader s) (cg-put game :turn s)))
|
||||
|
||||
(defun cg-trick--ai-trump-play (game seat)
|
||||
"A generic legal trump-game play for SEAT: follow and win cheaply, else low."
|
||||
(let* ((moves (cg-trick--legal-moves game seat))
|
||||
(trick (cg-get game :trick)))
|
||||
(or
|
||||
(if (null trick)
|
||||
(car (last (cg-trick--sort moves)))
|
||||
(let* ((winner (cg-trick--winner-of game trick))
|
||||
(partner-winning (and winner (= (cg-trick--team winner)
|
||||
(cg-trick--team seat))))
|
||||
(led (cg-trick--led-suit game)))
|
||||
(if partner-winning
|
||||
(car (cg-trick--sort moves))
|
||||
(let ((follow (cl-remove-if-not (lambda (c) (= (car c) led)) moves)))
|
||||
(or (car (last (cg-trick--sort follow)))
|
||||
(car (cg-trick--sort moves)))))))
|
||||
(car moves))))
|
||||
|
||||
(cl-defmethod cg-trick--ai-play ((game cg-whist-game) seat)
|
||||
(cg-trick--ai-trump-play game seat))
|
||||
(cl-defmethod cg-trick--ai-play ((game cg-ohhell-game) seat)
|
||||
(cg-trick--ai-trump-play game seat))
|
||||
|
||||
;; Whist
|
||||
(cl-defmethod cg-trick--begin-hand ((game cg-whist-game))
|
||||
(cg-trick--deal game)
|
||||
(cg-put game :dealer (mod (1+ (or (cg-get game :dealer) 3)) 4))
|
||||
(oset game trump (car (cg-get game :last-card))) ; dealer's last card turns trump
|
||||
(cg-put game :cursor 0)
|
||||
(cg-trick--leader-init game)
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :message (format "Trump is %s. Take tricks past the book of six."
|
||||
(cg-suit-glyph (oref game trump))))
|
||||
(cg-trick--run game))
|
||||
|
||||
(cl-defmethod cg-trick--score-hand ((game cg-whist-game))
|
||||
(let ((scores (cg-get game :scores)) (tricks (cg-get game :tricks)))
|
||||
(dotimes (team 2)
|
||||
(let ((over (max 0 (- (+ (aref tricks team) (aref tricks (+ team 2))) 6))))
|
||||
(aset scores team (+ (aref scores team) over))
|
||||
(aset scores (+ team 2) (aref scores team))))
|
||||
(cg-put game :scores scores)))
|
||||
|
||||
(cl-defmethod cg-trick--game-over-p ((game cg-whist-game))
|
||||
(cl-some (lambda (s) (>= s (oref game target))) (append (cg-get game :scores) nil)))
|
||||
(cl-defmethod cg-trick--winner-seat ((game cg-whist-game))
|
||||
(if (>= (aref (cg-get game :scores) 0) (aref (cg-get game :scores) 1)) 0 1))
|
||||
(cl-defmethod cg-trick--result-string ((game cg-whist-game))
|
||||
(format "%s win" (if (= 0 (cg-trick--winner-seat game)) "You and North" "West and East")))
|
||||
|
||||
;; Oh Hell
|
||||
(defconst cg-ohhell--sizes [7 6 5 4 3 2 1]
|
||||
"Hand sizes dealt in successive Oh Hell rounds.")
|
||||
|
||||
(cl-defmethod cg-trick--ai-bid ((game cg-ohhell-game) seat)
|
||||
(let ((hand (cg-trick--hand game seat)) (trump (oref game trump)) (bid 0))
|
||||
(dolist (c hand)
|
||||
(cond ((= (cdr c) 12) (cl-incf bid))
|
||||
((and (= (car c) trump) (>= (cdr c) 9)) (cl-incf bid))))
|
||||
(min bid (length hand))))
|
||||
|
||||
(cl-defmethod cg-trick--begin-hand ((game cg-ohhell-game))
|
||||
(let* ((round (or (cg-get game :round) 0))
|
||||
(hs (aref cg-ohhell--sizes (min round (1- (length cg-ohhell--sizes))))))
|
||||
(oset game hand-size hs)
|
||||
(cg-trick--deal game)
|
||||
(cg-put game :dealer (mod (1+ (or (cg-get game :dealer) 3)) 4))
|
||||
(let ((up (car (cg-get game :deck))))
|
||||
(oset game trump (if up (car up) 0)))
|
||||
(cg-put game :cursor 0)
|
||||
(let ((bids (make-vector 4 0)))
|
||||
(dotimes (s 4) (unless (= s 0) (aset bids s (cg-trick--ai-bid game s))))
|
||||
(aset bids 0 (if noninteractive (cg-trick--ai-bid game 0)
|
||||
(max 0 (min hs (read-number
|
||||
(format "Round %d (trump %s) -- your bid (0-%d): "
|
||||
(1+ round) (cg-suit-glyph (oref game trump)) hs)
|
||||
(cg-trick--ai-bid game 0))))))
|
||||
(cg-put game :bids bids))
|
||||
(cg-trick--leader-init game)
|
||||
(cg-put game :phase 'play)
|
||||
(cg-put game :message (format "Round %d: make EXACTLY your bid (trump %s)."
|
||||
(1+ round) (cg-suit-glyph (oref game trump))))
|
||||
(cg-trick--run game)))
|
||||
|
||||
(cl-defmethod cg-trick--score-hand ((game cg-ohhell-game))
|
||||
(let ((scores (cg-get game :scores)) (bids (cg-get game :bids))
|
||||
(tricks (cg-get game :tricks)))
|
||||
(dotimes (s 4)
|
||||
(when (= (aref tricks s) (aref bids s))
|
||||
(aset scores s (+ (aref scores s) 10 (aref bids s)))))
|
||||
(cg-put game :scores scores)
|
||||
(cg-put game :round (1+ (or (cg-get game :round) 0)))))
|
||||
|
||||
(cl-defmethod cg-trick--game-over-p ((game cg-ohhell-game))
|
||||
(>= (or (cg-get game :round) 0) (length cg-ohhell--sizes)))
|
||||
(cl-defmethod cg-trick--winner-seat ((game cg-ohhell-game))
|
||||
(let ((best 0)) (dotimes (s 4) (when (> (aref (cg-get game :scores) s)
|
||||
(aref (cg-get game :scores) best)) (setq best s)))
|
||||
best))
|
||||
(cl-defmethod cg-trick--result-string ((game cg-ohhell-game))
|
||||
(format "%s wins" (aref cg-trick-seat-names (cg-trick--winner-seat game))))
|
||||
|
||||
;;;###autoload
|
||||
(defun cg-whist () "Play Whist against three computer opponents."
|
||||
(interactive) (cg-trick--play-game 'cg-whist-game))
|
||||
;;;###autoload
|
||||
(defun cg-ohhell () "Play Oh Hell against three computer opponents."
|
||||
(interactive) (cg-trick--play-game 'cg-ohhell-game))
|
||||
|
||||
(provide 'cg-trick)
|
||||
;;; cg-trick.el ends here
|
||||
|
|
@ -120,7 +120,7 @@ The competitive duel, Crapette, against the computer. @xref{Russian
|
|||
Bank}.
|
||||
@end table
|
||||
|
||||
To start, type @kbd{M-x card-game}.
|
||||
To start, type @kbd{M-x card-games}.
|
||||
|
||||
@node Installation
|
||||
@chapter Installation
|
||||
|
|
@ -143,7 +143,7 @@ graphical Emacs has it); in a terminal the games fall back to text.
|
|||
@cindex ELPA
|
||||
When the package is available from a package archive, install it the
|
||||
usual way with @kbd{M-x package-install @key{RET} card-games @key{RET}}.
|
||||
The autoloads let you run @kbd{M-x card-game} straight away.
|
||||
The autoloads let you run @kbd{M-x card-games} straight away.
|
||||
|
||||
@node From source
|
||||
@section From source
|
||||
|
|
@ -158,7 +158,7 @@ add it to your @code{load-path}, and load the umbrella file:
|
|||
@end example
|
||||
|
||||
@noindent
|
||||
Then @kbd{M-x card-game}. You can also build an installable tarball with
|
||||
Then @kbd{M-x card-games}. You can also build an installable tarball with
|
||||
@kbd{make package} and install it with @kbd{M-x package-install-file}.
|
||||
|
||||
@node Building
|
||||
|
|
@ -182,11 +182,11 @@ Build the installable @file{.tar}.
|
|||
@node The Game Menu
|
||||
@chapter The Game Menu
|
||||
|
||||
@findex card-game
|
||||
@findex card-games
|
||||
@findex card-games
|
||||
@cindex chooser
|
||||
@cindex menu
|
||||
@kbd{M-x card-game} (also available as @code{card-games}) opens the
|
||||
@kbd{M-x card-games} (also available as @code{card-games}) opens the
|
||||
chooser: a buffer listing every game with a one-line description. Move
|
||||
between games with @key{TAB} and @kbd{S-@key{TAB}}, or @kbd{n} and
|
||||
@kbd{p}, and press @key{RET} --- or click a game's name --- to start it.
|
||||
|
|
@ -196,7 +196,7 @@ Two controls sit at the top of the list.
|
|||
|
||||
@table @asis
|
||||
@item AI opponents
|
||||
@vindex cg-ai-level
|
||||
@vindex card-games-ai-level
|
||||
Sets how hard the computer plays: @code{easy}, @code{normal}, or
|
||||
@code{hard}. Click it to cycle, or use @kbd{M-x card-games-set-ai-level}.
|
||||
@xref{Opponents}.
|
||||
|
|
@ -241,7 +241,7 @@ Leave the game and return to the menu (@pxref{The Game Menu}).
|
|||
@end table
|
||||
|
||||
@cindex zoom
|
||||
@vindex cg-card-scale
|
||||
@vindex card-games-card-scale
|
||||
On a graphical display, @kbd{+} and @kbd{-} (and @kbd{=}) make the cards
|
||||
larger and smaller, and @kbd{0} resets the size. Emacs's own
|
||||
@code{text-scale-adjust} works too. Many boards show a one-line legend
|
||||
|
|
@ -275,32 +275,32 @@ that have one (Gaps and 500). You can also cycle it from the menu
|
|||
(@pxref{The Game Menu}). A change takes effect the next time a game is
|
||||
drawn; press @kbd{g} to redraw an open game.
|
||||
|
||||
@vindex cg-card-scale
|
||||
The card size follows @code{cg-card-scale} and the zoom keys
|
||||
@vindex card-games-card-scale
|
||||
The card size follows @code{card-games-card-scale} and the zoom keys
|
||||
(@pxref{Playing}).
|
||||
|
||||
@node Cards and colours
|
||||
@section Cards and colours
|
||||
|
||||
@vindex cg-svg-card-back
|
||||
@findex cg-svg-shuffle-card-back
|
||||
@vindex card-games-svg-card-back
|
||||
@findex card-games-svg-shuffle-card-back
|
||||
@cindex card backs
|
||||
The pattern on a face-down card is @code{cg-svg-card-back}. Besides
|
||||
The pattern on a face-down card is @code{card-games-svg-card-back}. Besides
|
||||
@code{dots}, @code{rings}, and @code{solid} there are the drawn patterns
|
||||
@code{lattice}, @code{waves}, and @code{diamond}, and four backs stamped
|
||||
with an Emacs logo: @code{emacs}, @code{emacs-classic}, @code{gnu}, and
|
||||
@code{splash}. The default, @code{random}, chooses a back for the
|
||||
session; @kbd{M-x cg-svg-shuffle-card-back} rolls a new one, and
|
||||
session; @kbd{M-x card-games-svg-shuffle-card-back} rolls a new one, and
|
||||
reopening the menu also re-rolls.
|
||||
|
||||
@vindex cg-svg-four-color
|
||||
@vindex card-games-svg-four-color
|
||||
@cindex four-colour deck
|
||||
With @code{cg-svg-four-color} non-@code{nil}, clubs are drawn green and
|
||||
With @code{card-games-svg-four-color} non-@code{nil}, clubs are drawn green and
|
||||
diamonds blue, so all four suits are told apart by colour.
|
||||
|
||||
@vindex cg-symbols
|
||||
@vindex card-games-symbols
|
||||
@cindex suit glyphs
|
||||
@code{cg-symbols} maps each suit to the glyph used for it, in both the
|
||||
@code{card-games-symbols} maps each suit to the glyph used for it, in both the
|
||||
text and the SVG cards; customize it to use the outlined suits
|
||||
@samp{♤ ♧ ♢ ♡}, say, instead of the filled ones.
|
||||
|
||||
|
|
@ -310,22 +310,22 @@ text and the SVG cards; customize it to use the outlined suits
|
|||
@kbd{M-x card-games-set-theme} applies a colour preset ---
|
||||
@code{classic}, @code{dark}, or @code{contrast} --- setting the felt
|
||||
colour, the card back, and the highlight together. The individual
|
||||
colours (@code{cg-svg-highlight-color}, @code{cg-bid-felt-color}, and the
|
||||
colours (@code{card-games-svg-highlight-color}, @code{card-games-bid-felt-color}, and the
|
||||
rest) can also be set on their own.
|
||||
|
||||
@vindex cg-cursor-type
|
||||
@vindex card-games-cursor-type
|
||||
@cindex cursor
|
||||
Card buffers hide the text cursor by default, since you act on the
|
||||
highlighted card rather than on point; @code{cg-cursor-type} can bring it
|
||||
highlighted card rather than on point; @code{card-games-cursor-type} can bring it
|
||||
back.
|
||||
|
||||
@node The Emacs emblem
|
||||
@section The Emacs emblem
|
||||
|
||||
@vindex cg-svg-emacs-logo
|
||||
@vindex card-games-svg-emacs-logo
|
||||
@cindex logo
|
||||
The full-window tables (500 and Gaps) show an Emacs emblem in a corner.
|
||||
@code{cg-svg-emacs-logo} chooses it: @code{modern} (the current Emacs
|
||||
@code{card-games-svg-emacs-logo} chooses it: @code{modern} (the current Emacs
|
||||
icon, the default), @code{classic} (the older icon), @code{gnu} (a GNU
|
||||
head), @code{splash} (the startup image), @code{drawn} (a small built-in
|
||||
emblem), or @code{none}. The image choices embed a logo that ships with
|
||||
|
|
@ -334,9 +334,9 @@ your Emacs, falling back to the drawn emblem when it cannot be found.
|
|||
@node Keys
|
||||
@section Keys
|
||||
|
||||
@vindex cg-keys
|
||||
@vindex card-games-keys
|
||||
@cindex key scheme
|
||||
@code{cg-keys} selects a movement scheme. @code{emacs} (the default)
|
||||
@code{card-games-keys} selects a movement scheme. @code{emacs} (the default)
|
||||
follows Emacs conventions --- the arrow keys move and @key{RET} acts.
|
||||
@code{classic} additionally enables @kbd{h} @kbd{j} @kbd{k} @kbd{l} and
|
||||
@key{SPC}. A change takes effect the next time a game starts.
|
||||
|
|
@ -344,10 +344,10 @@ follows Emacs conventions --- the arrow keys move and @key{RET} acts.
|
|||
@node Opponents
|
||||
@section Opponents
|
||||
|
||||
@vindex cg-ai-level
|
||||
@vindex card-games-ai-level
|
||||
@findex card-games-set-ai-level
|
||||
@cindex difficulty
|
||||
@code{cg-ai-level} sets how hard the computer plays: @code{easy},
|
||||
@code{card-games-ai-level} sets how hard the computer plays: @code{easy},
|
||||
@code{normal}, or @code{hard}. Russian Bank plays all three levels; the
|
||||
trick-taking games play a random legal card on @code{easy} and their
|
||||
usual game otherwise. Other games do not yet consult it. Set it with
|
||||
|
|
@ -384,7 +384,7 @@ New deal, redraw, describe the keys, and return to the menu.
|
|||
@end table
|
||||
|
||||
@noindent
|
||||
With @code{cg-keys} set to @code{classic} the vi keys @kbd{h} @kbd{j}
|
||||
With @code{card-games-keys} set to @code{classic} the vi keys @kbd{h} @kbd{j}
|
||||
@kbd{k} @kbd{l} move as well (@pxref{Keys}).
|
||||
|
||||
@menu
|
||||
|
|
@ -406,7 +406,7 @@ With @code{cg-keys} set to @code{classic} the vi keys @kbd{h} @kbd{j}
|
|||
@node Klondike
|
||||
@section Klondike
|
||||
|
||||
@findex cg-klondike
|
||||
@findex card-games-klondike
|
||||
@cindex Klondike
|
||||
The classic. Build the four foundations up in suit, Ace to King. Seven
|
||||
columns hold a descending, alternating-colour tableau; move a card or an
|
||||
|
|
@ -415,8 +415,8 @@ empty column with a King (or a King-headed run). Turn cards from the
|
|||
stock to the waste --- one at a time by default --- and recycle the
|
||||
waste when the stock runs out.
|
||||
|
||||
@vindex cg-sol-klondike-draw
|
||||
Set @code{cg-sol-klondike-draw} to @code{3} for the harder
|
||||
@vindex card-games-sol-klondike-draw
|
||||
Set @code{card-games-sol-klondike-draw} to @code{3} for the harder
|
||||
turn-three variant.
|
||||
|
||||
@cindex strategy, Klondike
|
||||
|
|
@ -427,7 +427,7 @@ if you may still need them to receive tableau cards.
|
|||
@node FreeCell
|
||||
@section FreeCell
|
||||
|
||||
@findex cg-freecell
|
||||
@findex card-games-freecell
|
||||
@cindex FreeCell
|
||||
Every card is dealt face up into eight columns, and four @dfn{free cells}
|
||||
each hold a single card. Build the tableau down in alternating colour
|
||||
|
|
@ -442,7 +442,7 @@ cell.
|
|||
@node Spider
|
||||
@section Spider
|
||||
|
||||
@findex cg-spider
|
||||
@findex card-games-spider
|
||||
@cindex Spider
|
||||
Two decks, ten columns, no separate foundations. Build down regardless
|
||||
of suit, but only a same-suit run moves as a block. Complete a
|
||||
|
|
@ -456,7 +456,7 @@ a column as soon as you can: it is the key to untangling the rest.
|
|||
@node Yukon
|
||||
@section Yukon
|
||||
|
||||
@findex cg-yukon
|
||||
@findex card-games-yukon
|
||||
@cindex Yukon
|
||||
Klondike's layout, dealt mostly face up, with one liberating difference:
|
||||
you may move @emph{any} face-up card, together with everything piled on
|
||||
|
|
@ -469,7 +469,7 @@ buried groups wins many deals that Klondike would lose.
|
|||
@node Canfield
|
||||
@section Canfield
|
||||
|
||||
@findex cg-canfield
|
||||
@findex card-games-canfield
|
||||
@cindex Canfield
|
||||
A thirteen-card @dfn{reserve}, four tableau columns, and a stock dealt
|
||||
three at a time. The first card sets the base rank for the foundations,
|
||||
|
|
@ -483,7 +483,7 @@ keep the wrapping base rank in mind when you choose what to bank.
|
|||
@node Forty Thieves
|
||||
@section Forty Thieves
|
||||
|
||||
@findex cg-forty-thieves
|
||||
@findex card-games-forty-thieves
|
||||
@cindex Forty Thieves
|
||||
Two decks, ten columns, eight foundations. The tableau builds down
|
||||
@emph{in suit} and moves one card at a time; the foundations build up in
|
||||
|
|
@ -495,7 +495,7 @@ the low cards you will need.
|
|||
@node Scorpion
|
||||
@section Scorpion
|
||||
|
||||
@findex cg-scorpion
|
||||
@findex card-games-scorpion
|
||||
@cindex Scorpion
|
||||
Seven columns, built down in suit. As in Yukon you may move any card
|
||||
with everything on top of it, ordered or not. Free four King-to-Ace runs
|
||||
|
|
@ -507,7 +507,7 @@ which King you can afford to complete first.
|
|||
@node Russian Bank Solitaire
|
||||
@section Russian Bank
|
||||
|
||||
@findex cg-russian-bank
|
||||
@findex card-games-russian-bank
|
||||
@cindex Russian Bank, solitaire
|
||||
The one-player patience: eight @dfn{houses} built down in alternating
|
||||
colour, four foundations built up in suit from the Ace, and a
|
||||
|
|
@ -520,7 +520,7 @@ the houses are just working space.
|
|||
@node Golf
|
||||
@section Golf
|
||||
|
||||
@findex cg-golf
|
||||
@findex card-games-golf
|
||||
@cindex Golf
|
||||
A layout of thirty-five cards over a single waste pile. Play any exposed
|
||||
card onto the waste when it is one rank above @emph{or} below the waste's
|
||||
|
|
@ -538,7 +538,7 @@ card from the stock.
|
|||
@node TriPeaks
|
||||
@section TriPeaks
|
||||
|
||||
@findex cg-tripeaks
|
||||
@findex card-games-tripeaks
|
||||
@cindex TriPeaks
|
||||
Golf played over three overlapping peaks, with one change: the sequence
|
||||
@emph{wraps}, so an Ace follows a King and a King follows an Ace. That
|
||||
|
|
@ -551,7 +551,7 @@ the stock in reserve for when the board truly stalls.
|
|||
@node Pyramid
|
||||
@section Pyramid
|
||||
|
||||
@findex cg-pyramid
|
||||
@findex card-games-pyramid
|
||||
@cindex Pyramid
|
||||
A twenty-eight-card pyramid. Remove pairs of exposed cards whose ranks
|
||||
sum to thirteen --- Ace counts 1, Jack 11, Queen 12, and a King is 13, so
|
||||
|
|
@ -565,8 +565,8 @@ not strand a card whose only partner is already gone.
|
|||
@node Gaps
|
||||
@section Gaps
|
||||
|
||||
@findex cg-montana
|
||||
@findex cg-gaps
|
||||
@findex card-games-montana
|
||||
@findex card-games-gaps
|
||||
@cindex Gaps
|
||||
@cindex Montana
|
||||
Also called Montana. The pack is dealt into four rows with gaps between
|
||||
|
|
@ -586,7 +586,7 @@ each row, and spend redeals only when you are truly stuck.
|
|||
@node Hell's Half-Acre
|
||||
@section Hell's Half-Acre
|
||||
|
||||
@findex cg-hells-half-acre
|
||||
@findex card-games-hells-half-acre
|
||||
@cindex Hell's Half-Acre
|
||||
The same game as Gaps, built the other way: a King anchors the head of
|
||||
each row and the rows descend King, Queen, @dots{}, down to the Two. The
|
||||
|
|
@ -640,7 +640,7 @@ have richer boards and a few keys of their own, noted below.
|
|||
@node 500
|
||||
@section 500
|
||||
|
||||
@findex cg-bid
|
||||
@findex card-games-bid
|
||||
@cindex 500
|
||||
Australia's national card game, and the flagship of this collection. You
|
||||
and North play against East and West. After the deal there is an
|
||||
|
|
@ -680,7 +680,7 @@ Misère for a hand too weak to win a single trick.
|
|||
@node Hearts
|
||||
@section Hearts
|
||||
|
||||
@findex cg-hearts
|
||||
@findex card-games-hearts
|
||||
@cindex Hearts
|
||||
An avoidance game with no trump. Every heart costs one point and the
|
||||
Queen of Spades costs thirteen, and you want as few as possible. Before
|
||||
|
|
@ -699,7 +699,7 @@ hand that cannot be stopped.
|
|||
@node Spades
|
||||
@section Spades
|
||||
|
||||
@findex cg-spades
|
||||
@findex card-games-spades
|
||||
@cindex Spades
|
||||
Spades are always trump. Each player bids the number of tricks they
|
||||
expect to win, and the two partners' bids are added: your side must make
|
||||
|
|
@ -714,7 +714,7 @@ partner's Nil when you can.
|
|||
@node Whist
|
||||
@section Whist
|
||||
|
||||
@findex cg-whist
|
||||
@findex card-games-whist
|
||||
@cindex Whist
|
||||
The old English ancestor of Bridge, with no bidding. The dealer's last
|
||||
card is turned for trump. Follow the suit led if you can; trumps beat the
|
||||
|
|
@ -727,7 +727,7 @@ trumps, and remember the cards that have gone.
|
|||
@node Oh Hell
|
||||
@section Oh Hell
|
||||
|
||||
@findex cg-ohhell
|
||||
@findex card-games-ohhell
|
||||
@cindex Oh Hell
|
||||
The hand shrinks every deal, from seven cards down to one, and a card is
|
||||
turned for trump. Each player bids the @emph{exact} number of tricks
|
||||
|
|
@ -741,7 +741,7 @@ low one a sure miss; do not be afraid to bid zero and duck everything.
|
|||
@node Euchre
|
||||
@section Euchre
|
||||
|
||||
@findex cg-euchre
|
||||
@findex card-games-euchre
|
||||
@cindex Euchre
|
||||
A brisk 24-card game (Nine to Ace). The Jack of the trump suit (the
|
||||
@dfn{right bower}) and the other Jack of the same colour (the @dfn{left
|
||||
|
|
@ -759,7 +759,7 @@ score.
|
|||
@node Pitch
|
||||
@section Pitch
|
||||
|
||||
@findex cg-pitch
|
||||
@findex card-games-pitch
|
||||
@cindex Pitch
|
||||
Auction Pitch. Players bid for the right to @dfn{pitch}, and the
|
||||
pitcher's first lead sets the trump suit. Thereafter follow the led suit
|
||||
|
|
@ -772,7 +772,7 @@ Jack or with both the highest and lowest trumps.
|
|||
@node Briscola
|
||||
@section Briscola
|
||||
|
||||
@findex cg-briscola
|
||||
@findex card-games-briscola
|
||||
@cindex Briscola
|
||||
A 40-card Italian game. One card is turned to fix the trump, the
|
||||
@dfn{briscola}, and --- unusually --- there is no need to follow suit: you
|
||||
|
|
@ -786,7 +786,7 @@ lead worthless cards to coax points out of them.
|
|||
@node Contract Bridge
|
||||
@section Bridge
|
||||
|
||||
@findex cg-bridge
|
||||
@findex card-games-bridge
|
||||
@cindex Bridge
|
||||
@cindex Contract Bridge
|
||||
The full game: the auction, then the play with the dummy exposed, and
|
||||
|
|
@ -832,7 +832,7 @@ a kind, and @dfn{runs} of three or more cards in one suit.
|
|||
@node Gin Rummy
|
||||
@section Gin Rummy
|
||||
|
||||
@findex cg-gin
|
||||
@findex card-games-gin
|
||||
@cindex Gin Rummy
|
||||
@cindex deadwood
|
||||
@cindex knock
|
||||
|
|
@ -849,7 +849,7 @@ early against a slow hand, and note which cards your opponent takes.
|
|||
@node Rummy
|
||||
@section Rummy
|
||||
|
||||
@findex cg-rummy-basic
|
||||
@findex card-games-rummy-basic
|
||||
@cindex Rummy
|
||||
Draw and discard, and lay your melds down on the table. Mark the cards
|
||||
of a meld with @key{SPC} and lay it down with @kbd{m}; add a single card
|
||||
|
|
@ -869,7 +869,7 @@ rearranged, and they tell your opponents what you hold.
|
|||
@node Rummy 500
|
||||
@section Rummy 500
|
||||
|
||||
@findex cg-rum500
|
||||
@findex card-games-rum500
|
||||
@cindex Rummy 500
|
||||
Rummy played for points over many hands, first past 500. You score the
|
||||
cards you lay down and lose the ones left in your hand. Besides the top
|
||||
|
|
@ -883,7 +883,7 @@ pile when the reward outweighs the cards it puts in your hand.
|
|||
@node Hand & Foot
|
||||
@section Hand & Foot
|
||||
|
||||
@findex cg-handfoot
|
||||
@findex card-games-handfoot
|
||||
@cindex Hand and Foot
|
||||
A partnership cousin of Canasta. You are dealt a @dfn{hand} and a
|
||||
@dfn{foot}; play out the hand, then take up the foot. Build @dfn{books}
|
||||
|
|
@ -911,7 +911,7 @@ Two light games of collecting and shedding, good for a quick sit-down.
|
|||
@node Go Fish
|
||||
@section Go Fish
|
||||
|
||||
@findex cg-go-fish
|
||||
@findex card-games-go-fish
|
||||
@cindex Go Fish
|
||||
@cindex books
|
||||
Collect @dfn{books} of four of a kind. On your turn pick a rank you hold
|
||||
|
|
@ -927,7 +927,7 @@ who holds what.
|
|||
@node Old Maid
|
||||
@section Old Maid
|
||||
|
||||
@findex cg-old-maid
|
||||
@findex card-games-old-maid
|
||||
@cindex Old Maid
|
||||
One Queen is set aside, so a single Queen is left without a partner.
|
||||
Throw out every pair in your hand, then draw a card, unseen, from the next
|
||||
|
|
@ -954,7 +954,7 @@ under the cursor.
|
|||
@node Scopa
|
||||
@section Scopa
|
||||
|
||||
@findex cg-scopa
|
||||
@findex card-games-scopa
|
||||
@cindex Scopa
|
||||
A 40-card Italian game. The card you play captures a single table card of
|
||||
the same value, or a set of table cards that add up to its value.
|
||||
|
|
@ -969,7 +969,7 @@ your opponent unable to make the capture that would sweep it.
|
|||
@node Casino
|
||||
@section Casino
|
||||
|
||||
@findex cg-casino
|
||||
@findex card-games-casino
|
||||
@cindex Casino
|
||||
The 52-card cousin of Scopa. Number cards capture by value as in Scopa;
|
||||
face cards capture only by matching rank. Score the @dfn{big casino}
|
||||
|
|
@ -995,7 +995,7 @@ what is already on the table.
|
|||
@node President
|
||||
@section President
|
||||
|
||||
@findex cg-president
|
||||
@findex card-games-president
|
||||
@cindex President
|
||||
@cindex Scum
|
||||
Also called Scum. The leader plays one to four cards of a rank; the next
|
||||
|
|
@ -1013,7 +1013,7 @@ your Twos and your pairs to grab the lead back when it matters.
|
|||
@node Spite & Malice
|
||||
@section Spite & Malice
|
||||
|
||||
@findex cg-spite
|
||||
@findex card-games-spite
|
||||
@cindex Spite and Malice
|
||||
@cindex Cat and Mouse
|
||||
Race to empty your @dfn{goal} pile. Four shared centre piles are built up
|
||||
|
|
@ -1029,7 +1029,7 @@ keep your discard piles in order so you can unload them in turn.
|
|||
@node Cribbage
|
||||
@chapter Cribbage
|
||||
|
||||
@findex cg-cribbage
|
||||
@findex card-games-cribbage
|
||||
@cindex Cribbage
|
||||
@cindex pegging
|
||||
@cindex the crib
|
||||
|
|
@ -1049,8 +1049,8 @@ crib, and always be counting toward the next fifteen and thirty-one.
|
|||
@node Russian Bank
|
||||
@chapter Russian Bank
|
||||
|
||||
@findex cg-crapette
|
||||
@findex cg-russian-bank-duel
|
||||
@findex card-games-crapette
|
||||
@findex card-games-russian-bank-duel
|
||||
@cindex Russian Bank
|
||||
@cindex Crapette
|
||||
Russian Bank, also called Crapette, is the competitive two-player
|
||||
|
|
@ -1080,13 +1080,13 @@ or waste, when it is the same suit and one rank higher or lower.
|
|||
@end itemize
|
||||
|
||||
@cindex stop rule
|
||||
@vindex cg-crapette-stops
|
||||
@vindex card-games-crapette-stops
|
||||
@strong{Foundation priority and ``Stop''.} A card that can go to a
|
||||
foundation must be played there before anything else. If you build a
|
||||
house, load your opponent, turn a card, or end your turn while a
|
||||
foundation play is waiting, your opponent calls ``Stop!'' and your turn
|
||||
ends at once --- the piles that owe a foundation play are ringed to warn
|
||||
you. Set @code{cg-crapette-stops} to @code{nil} for a gentler mode that
|
||||
you. Set @code{card-games-crapette-stops} to @code{nil} for a gentler mode that
|
||||
simply blocks the slip instead of ending your turn.
|
||||
|
||||
When you can do no more, turn the top of your hand: if it fits somewhere
|
||||
|
|
@ -1111,7 +1111,7 @@ Undo, new game, and the menu.
|
|||
@end table
|
||||
|
||||
@noindent
|
||||
@code{cg-ai-level} sets how hard North plays (@pxref{Opponents}): on
|
||||
@code{card-games-ai-level} sets how hard North plays (@pxref{Opponents}): on
|
||||
@code{hard} it even looks a move ahead to rearrange the houses.
|
||||
|
||||
@strong{Strategy.} Play to the foundations first, and empty your reserve
|
||||
|
|
@ -1122,18 +1122,18 @@ a sequence.
|
|||
@node Networked Play
|
||||
@chapter Networked Play
|
||||
|
||||
@findex cg-bid-host
|
||||
@findex cg-bid-join
|
||||
@findex card-games-bid-host
|
||||
@findex card-games-bid-join
|
||||
@cindex networked play
|
||||
@cindex multiplayer
|
||||
500 can be played live against other people over a TCP connection. One
|
||||
player hosts the game and the others join it.
|
||||
|
||||
@table @kbd
|
||||
@item M-x cg-bid-host @key{RET} @var{port} @key{RET}
|
||||
@item M-x card-games-bid-host @key{RET} @var{port} @key{RET}
|
||||
Start a game as the host. You take the South seat and wait for others to
|
||||
connect.
|
||||
@item M-x cg-bid-join @key{RET} @var{host} @key{RET} @var{port} @key{RET} @var{name} @key{RET}
|
||||
@item M-x card-games-bid-join @key{RET} @var{host} @key{RET} @var{port} @key{RET} @var{name} @key{RET}
|
||||
Connect to a host at @var{host} and @var{port} under a display
|
||||
@var{name}.
|
||||
@end table
|
||||
|
|
@ -1143,8 +1143,8 @@ The game starts automatically once four people have joined. The host may
|
|||
also press @kbd{s} to start early, with the computer filling any empty
|
||||
seats.
|
||||
|
||||
@vindex cg-bid-shuffle-partners
|
||||
With @code{cg-bid-shuffle-partners} non-@code{nil}, the joining players
|
||||
@vindex card-games-bid-shuffle-partners
|
||||
With @code{card-games-bid-shuffle-partners} non-@code{nil}, the joining players
|
||||
are dealt randomly among the seats. Each player's view is rotated so
|
||||
they sit South, so the ordinary controls (@pxref{500}) work unchanged.
|
||||
Play is turn-based and the host is authoritative; a client can join from
|
||||
|
|
@ -1158,7 +1158,7 @@ anywhere Emacs can open a network connection.
|
|||
Card Games for Emacs was written by Corwin Brust.
|
||||
|
||||
The rules of the trickier games were checked against public references,
|
||||
chiefly Wikipedia and John McLeod's card-game site, Pagat
|
||||
chiefly Wikipedia and John McLeod's card-games site, Pagat
|
||||
(@url{https://www.pagat.com/}). Thanks are due to the playtesters whose
|
||||
feedback shaped the controls and the display.
|
||||
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
Loading…
Add table
Add a link
Reference in a new issue