From 209ebdc02a515c5564d863bcad4c03c969ca8f55 Mon Sep 17 00:00:00 2001 From: Corwin Brust Date: Mon, 3 Aug 2026 23:21:57 -0500 Subject: [PATCH] card-games: rename cg- prefix to card-games- for MELPA --- Makefile | 4 +- README.md | 120 +- README.org | 120 +- card-games-bid-net.el | 428 ++++++ card-games-bid-ui.el | 1257 ++++++++++++++++ card-games-bid.el | 843 +++++++++++ card-games-bridge.el | 874 ++++++++++++ cg-core.el => card-games-core.el | 187 ++- card-games-crapette.el | 902 ++++++++++++ card-games-cribbage.el | 525 +++++++ card-games-eights.el | 443 ++++++ card-games-gaps.el | 867 +++++++++++ card-games-handfoot.el | 795 +++++++++++ card-games-match.el | 607 ++++++++ cg-net.el => card-games-net.el | 239 ++-- card-games-patience.el | 448 ++++++ card-games-president.el | 425 ++++++ cg-render.el => card-games-render.el | 83 +- card-games-rum500.el | 665 +++++++++ cg-rummy.el => card-games-rummy.el | 575 ++++---- card-games-scopa.el | 438 ++++++ card-games-solitaire.el | 1016 +++++++++++++ card-games-spite.el | 506 +++++++ cg-svg.el => card-games-svg.el | 407 +++--- card-games-trick-ext.el | 500 +++++++ card-games-trick.el | 940 ++++++++++++ card-games.el | 186 ++- cg-bid-net.el | 429 ------ cg-bid-ui.el | 1258 ---------------- cg-bid.el | 844 ----------- cg-bridge.el | 875 ------------ cg-crapette.el | 903 ------------ cg-cribbage.el | 526 ------- cg-eights.el | 444 ------ cg-gaps.el | 868 ----------- cg-handfoot.el | 796 ----------- cg-match.el | 608 -------- cg-patience.el | 449 ------ cg-president.el | 426 ------ cg-rum500.el | 666 --------- cg-scopa.el | 439 ------ cg-solitaire.el | 1017 ------------- cg-spite.el | 507 ------- cg-trick-ext.el | 501 ------- cg-trick.el | 941 ------------ doc/card-games.texi | 150 +- test/card-games-tests.el | 1978 +++++++++++++------------- 47 files changed, 14499 insertions(+), 14526 deletions(-) create mode 100644 card-games-bid-net.el create mode 100644 card-games-bid-ui.el create mode 100644 card-games-bid.el create mode 100644 card-games-bridge.el rename cg-core.el => card-games-core.el (65%) create mode 100644 card-games-crapette.el create mode 100644 card-games-cribbage.el create mode 100644 card-games-eights.el create mode 100644 card-games-gaps.el create mode 100644 card-games-handfoot.el create mode 100644 card-games-match.el rename cg-net.el => card-games-net.el (55%) create mode 100644 card-games-patience.el create mode 100644 card-games-president.el rename cg-render.el => card-games-render.el (54%) create mode 100644 card-games-rum500.el rename cg-rummy.el => card-games-rummy.el (52%) create mode 100644 card-games-scopa.el create mode 100644 card-games-solitaire.el create mode 100644 card-games-spite.el rename cg-svg.el => card-games-svg.el (58%) create mode 100644 card-games-trick-ext.el create mode 100644 card-games-trick.el delete mode 100644 cg-bid-net.el delete mode 100644 cg-bid-ui.el delete mode 100644 cg-bid.el delete mode 100644 cg-bridge.el delete mode 100644 cg-crapette.el delete mode 100644 cg-cribbage.el delete mode 100644 cg-eights.el delete mode 100644 cg-gaps.el delete mode 100644 cg-handfoot.el delete mode 100644 cg-match.el delete mode 100644 cg-patience.el delete mode 100644 cg-president.el delete mode 100644 cg-rum500.el delete mode 100644 cg-scopa.el delete mode 100644 cg-solitaire.el delete mode 100644 cg-spite.el delete mode 100644 cg-trick-ext.el delete mode 100644 cg-trick.el diff --git a/Makefile b/Makefile index 68bd964..7928785 100644 --- a/Makefile +++ b/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) diff --git a/README.md b/README.md index 3644c7d..123a038 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ mouse on a graphical display. ![img](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`. @@ -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). diff --git a/README.org b/README.org index 900cd84..f3ee790 100644 --- a/README.org +++ b/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). diff --git a/card-games-bid-net.el b/card-games-bid-net.el new file mode 100644 index 0000000..657b77e --- /dev/null +++ b/card-games-bid-net.el @@ -0,0 +1,428 @@ +;;; card-games-bid-net.el --- Networked live 500 (Bid) -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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 diff --git a/card-games-bid-ui.el b/card-games-bid-ui.el new file mode 100644 index 0000000..87b4fe9 --- /dev/null +++ b/card-games-bid-ui.el @@ -0,0 +1,1257 @@ +;;; card-games-bid-ui.el --- 500 (Bid) — console UI and commands -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; Commentary: + +;; The console (UNICODE) interface and interactive commands for 500. +;; The rules engine lives in card-games-bid.el. Play with `M-x card-games-bid'. + +;;; Code: + +(require 'cl-lib) +(require 'card-games-core) +(require 'card-games-bid) +(require 'card-games-svg) +(require 'card-games-render) +(require 'svg) +(require 'color) + + +;;;; Rendering + +(defun card-games-bid--trick-card-for (game seat) + "Return the card SEAT has played to the current (or last) trick, or nil." + (let ((tr (or (card-games-get game :trick) (card-games-get game :last-trick)))) + (cdr (assq seat tr)))) + +(cl-defmethod card-games-render ((game card-games-bid-game)) + "Return a propertized string depicting GAME." + (let* ((contract (card-games-get game :contract)) + (trump (and contract (card-games-bid-trump contract))) + (scores (card-games-get game :scores)) + (tricks (card-games-get game :tricks)) + (turn (card-games-get game :turn)) + (phase (card-games-get game :phase)) + (out (list))) + (push (format " 500 Bid Hand %d\n" (card-games-get game :hand-no)) out) + (push (format " Score — You/North: %d West/East: %d\n" + (car scores) (cdr scores)) + out) + (when (eq phase 'gameover) + (push (propertize + (format " *** GAME OVER — %s WIN ***\n" + (if (= (card-games-get game :game-over) 0) "YOU/NORTH" "WEST/EAST")) + 'face 'card-games-cursor) + out)) + (push (format " Contract: %s\n\n" + (if contract + (format "%s (%s) by %s" + (card-games-bid-label contract) (card-games-bid-name contract) + (aref card-games-bid-seat-names (card-games-get game :contractor))) + "— (auction in progress)")) + out) + ;; opponents and partner: name, hand size (or exposed/sitting), played card + (cl-flet ((seatline + (seat indent) + (let ((sit (eql seat (card-games-bid--sitter game))) + (exp (eql seat (card-games-get game :exposed)))) + (format "%s%s%s %s played: %s\n" + indent + (aref card-games-bid-seat-names seat) + (if (and (eq phase 'play) (= seat turn)) "*" " ") + (cond + (sit "(sitting out)") + (exp (format "[%s]" + (mapconcat #'card-games-bid-card-string + (card-games-bid-sort-hand + (card-games-bid--hand game seat) trump) + " "))) + (t (format "[%d cards]" + (length (card-games-bid--hand game seat))))) + (card-games-bid-card-string (card-games-bid--trick-card-for game seat)))))) + (push (seatline 2 " ") out) ; North (partner) + (push (seatline 1 " ") out) ; West + (push (seatline 3 " ") out)) ; East + (push (format "\n Tricks — You/North: %d West/East: %d\n\n" + (+ (aref tricks 0) (aref tricks 2)) + (+ (aref tricks 1) (aref tricks 3))) + out) + ;; human hand + (push " Your hand (South):\n " out) + (let* ((hand (card-games-bid-sort-display (card-games-bid--hand game 0) trump)) + (cursor (card-games-get game :cursor)) + (marks (card-games-get game :marks)) + (led (card-games-get game :led)) + (legal (and (eq phase 'play) + (= turn 0) + (card-games-bid-legal-cards (card-games-bid--hand game 0) led trump)))) + (card-games-put game :sorted-hand hand) + (if (null hand) + (push "(empty)" out) + (cl-loop for c in hand for i from 0 do + (let ((faces nil) + (str (card-games-bid-card-string c))) + (when (card-games-red-suit-p (car c)) (push 'card-games-red-suit faces)) + (when (member c marks) (setq str (concat "^" str))) + (when (and legal (not (member c legal))) + (push 'card-games-gap faces)) ; dim illegal plays + (when (= i cursor) (push 'card-games-cursor faces)) + (push (propertize (format " %-4s" str) + 'face (or faces 'default) + 'card-games-card i 'mouse-face 'highlight) + out)))) + (push "\n" out)) + (push (format "\n %s\n" (card-games-get game :message)) out) + (push (card-games-bid--key-help game) out) + (apply #'concat (nreverse out)))) + +(defun card-games-bid--key-help (game) + "Return a context-sensitive key-help line for GAME." + (pcase (card-games-get game :phase) + ('auction " [b]id [p]ass [n]ew hand [q]uit ? help\n") + ('kitty " [←/→] move [RET] mark/unmark [x] discard the 5 marked [q]uit\n") + ('play " [←/→] move [RET] play card [n]ew hand [q]uit ? help\n") + ('done " [n]ext hand [q]uit ? help\n") + ('gameover " [n]ew game [q]uit ? help\n") + (_ " [n]ew hand [q]uit ? help\n"))) + + +;;;; Graphical (SVG) table + +(defconst card-games-bid--tw 44 "Table card width.") +(defconst card-games-bid--th 62 "Table card height.") +(defconst card-games-bid--canvas-w 600 "Table canvas width.") +(defconst card-games-bid--canvas-h 460 "Table canvas height.") + +(defcustom card-games-bid-felt-color "#15692f" + "Base felt colour for the 500 table. +Set to a theme-derived colour (see `card-games-color') for a table that +matches your Emacs theme." + :type 'color :group 'card-games-svg) + +(defcustom card-games-bid-animate t + "When non-nil, pace AI turns so play is watchable." + :type 'boolean :group 'card-games-svg) + +(defcustom card-games-bid-ai-delay 0.45 + "Seconds to pause after each AI action when `card-games-bid-animate' is on." + :type 'number :group 'card-games-svg) + +(defcustom card-games-bid-trick-pause 1.1 + "Seconds to leave a completed trick on the table before it is swept." + :type 'number :group 'card-games-svg) + +(defcustom card-games-bid-svg-ui nil + "When non-nil (and on a graphical display), render 500 as a single +full-buffer SVG: the table in the centre, a status/compass/bid panel on +the left, and a scrollable message log on the right." + :type 'boolean :group 'card-games-svg) + +(defcustom card-games-bid-svg-fill t + "When non-nil, size the full-SVG UI to fill the window and enlarge the +South hand, re-fitting on window changes. Only used when `card-games-bid-svg-ui'." + :type 'boolean :group 'card-games-svg) + +(defcustom card-games-bid-card-scale 1.0 + "Card-size multiplier for the South hand in the full-SVG 500 UI. +Driven by the on-screen card-size slider and the +/-/0 keys." + :type 'number :group 'card-games-svg) + + +(defun card-games-bid--header-text (game) + "Return the header lines (scores, contract, tricks) for GAME." + (let ((scores (card-games-get game :scores)) + (contract (card-games-get game :contract)) + (tricks (card-games-get game :tricks))) + (concat + (format " 500 Bid Hand %d\n" (card-games-get game :hand-no)) + (format " Score - You/North: %d West/East: %d\n" + (car scores) (cdr scores)) + (if (eq (card-games-get game :phase) 'gameover) + (format " *** GAME OVER - %s WIN ***\n" + (if (= (card-games-get game :game-over) 0) "YOU/NORTH" "WEST/EAST")) + "") + (format " Contract: %s\n" + (if contract + (format "%s (%s) by %s" (card-games-bid-label contract) + (card-games-bid-name contract) + (aref card-games-bid-seat-names (card-games-get game :contractor))) + "- (auction in progress)")) + (format " Tricks - You/North: %d West/East: %d\n" + (+ (aref tricks 0) (aref tricks 2)) + (+ (aref tricks 1) (aref tricks 3)))))) + +(defun card-games-bid--footer-text (game) + "Return the footer (message and key help) for GAME." + (concat (format "\n %s\n" (card-games-get game :message)) + (card-games-bid--key-help game))) + +(defun card-games-bid--spec (card) + "Return the card-games-svg card spec for a 500 CARD, or nil for none." + (cond ((null card) nil) + ((card-games-bid-joker-p card) (cons nil 'joker)) + (t (cons (aref card-games-bid-ranks (cdr card)) (car card))))) + +(defun card-games-bid--south-layout (n) + "Return (X0 STEP Y) for laying N South-hand cards across the canvas." + (let* ((w card-games-bid--tw) + (maxw (- card-games-bid--canvas-w 24)) + (step (if (<= n 1) 0 (min (+ w 6) (/ (- maxw w) (1- n))))) + (total (+ w (* (max 0 (1- n)) step))) + (x0 (/ (- card-games-bid--canvas-w total) 2)) + (y (- card-games-bid--canvas-h card-games-bid--th 8))) + (list x0 step y))) + +(defun card-games-bid--draw-backs (svg cx top n) + "Draw a small fan of up to N face-down cards centred at CX, TOP on SVG. +Card size and fan step follow the dynamic `card-games-svg-card-width'." + (let* ((cw card-games-svg-card-width) + (k (min (max n 0) 6)) + (step (max 12 (round (* cw 0.42)))) + (total (if (> k 0) (+ cw (* (1- k) step)) 0)) + (x0 (- cx (/ total 2)))) + (dotimes (i k) (card-games-svg-card svg (+ x0 (* i step)) top :down t)))) + +(defun card-games-bid--draw-opponent (svg game seat cx top &optional fs) + "Draw opponent SEAT (label, backs, turn marker) on SVG centred at CX, TOP. +FS scales the name pill and its fonts." + (let* ((fs (or fs 1.0)) + (n (length (card-games-bid--hand game seat))) + (sitter (eql seat (card-games-bid--sitter game))) + (lw (round (* 104 fs))) (lh (round (* 18 fs))) + (fsz (max 11 (round (* 13 fs))))) + (svg-rectangle svg (- cx (/ lw 2)) (- top lh 3) lw lh :rx (round (* 9 fs)) + :fill "#0b3d1d" :fill-opacity 0.55) + (svg-text svg (format "%s%s" (aref card-games-bid-seat-names seat) + (if sitter " (sitting out)" (format " (%d)" n))) + :x cx :y (- top (round (* 8 fs))) :font-size fsz :fill "#eaffea" + :text-anchor "middle" :font-family "sans-serif") + (when (and (eq (card-games-get game :phase) 'play) (= seat (card-games-get game :turn))) + (svg-text svg "*" :x cx :y (- top (round (* 22 fs))) + :font-size (round (* 18 fs)) :fill "#f1c40f" + :text-anchor "middle" :font-family "sans-serif")) + (unless sitter (card-games-bid--draw-backs svg cx top n)))) + +(defun card-games-bid--draw-trick (svg game) + "Draw the cards played to the current trick around the centre of SVG." + (let* ((W card-games-bid--canvas-w) (H card-games-bid--canvas-h) + (w card-games-bid--tw) (h card-games-bid--th) + (cx (/ W 2)) (cy (/ H 2)) + (spots (list (list 0 (- cx (/ w 2)) (+ cy 22)) + (list 1 (- cx 70 w) (- cy (/ h 2))) + (list 2 (- cx (/ w 2)) (- cy 22 h)) + (list 3 (+ cx 70) (- cy (/ h 2)))))) + (dolist (s spots) + (let* ((card (card-games-bid--trick-card-for game (nth 0 s))) + (spec (card-games-bid--spec card))) + (when spec + (card-games-svg-card svg (nth 1 s) (nth 2 s) + :rank (car spec) :suit (cdr spec))))))) + +(defun card-games-bid--draw-south (svg game) + "Draw South's hand face-up along the bottom of SVG; record sort order." + (let* ((trump (and (card-games-get game :contract) + (card-games-bid-trump (card-games-get game :contract)))) + (hand (card-games-bid-sort-display (card-games-bid--hand game 0) trump))) + (card-games-put game :sorted-hand hand) + (let* ((n (length hand)) (lay (card-games-bid--south-layout n)) + (x0 (nth 0 lay)) (step (nth 1 lay)) (y (nth 2 lay)) + (cursor (card-games-get game :cursor)) (marks (card-games-get game :marks)) (i 0)) + (svg-text svg "Your hand (South)" :x (/ card-games-bid--canvas-w 2) + :y (+ y card-games-bid--th 14) + :font-size 12 :fill "#cfeccf" :text-anchor "middle" + :font-family "sans-serif") + (dolist (card hand) + (let* ((spec (card-games-bid--spec card)) + (marked (and (member card marks) t)) + (hl (or (and (eq (card-games-get game :phase) 'play) (= i cursor)) + marked)) + ;; selected cards pop up out of the hand + (cy (if marked (- y (round (* card-games-bid--th 0.17))) y))) + (card-games-svg-card svg (+ x0 (* i step)) cy + :rank (car spec) :suit (cdr spec) :highlight hl)) + (setq i (1+ i)))))) + +(defun card-games-bid--table-svg (game) + "Return an svg object depicting the whole 500 table for GAME." + (let* ((W card-games-bid--canvas-w) (H card-games-bid--canvas-h) + (svg (svg-create W H))) + (let* ((base (or card-games-bid-felt-color "#15692f")) + (lite (or (ignore-errors (color-lighten-name base 12)) base)) + (dark (or (ignore-errors (color-darken-name base 16)) base))) + (svg-gradient svg "card-games-felt" 'radial (list (cons 0 lite) (cons 100 dark))) + (svg-rectangle svg 0 0 W H :rx 14 :gradient "card-games-felt") + (svg-ellipse svg (/ W 2) (/ H 2) 132 88 :fill "black" :fill-opacity 0.10)) + (let ((card-games-svg-card-width card-games-bid--tw) + (card-games-svg-card-height card-games-bid--th) + (card-games-svg-card-gap 4)) + (card-games-bid--draw-opponent svg game 2 (/ W 2) 34) + (card-games-bid--draw-opponent svg game 1 80 (/ H 2)) + (card-games-bid--draw-opponent svg game 3 (- W 80) (/ H 2)) + (card-games-bid--draw-trick svg game) + (card-games-bid--draw-south svg game)) + svg)) + +(defun card-games-bid--insert-graphical (game) + "Insert the GUI (SVG) depiction of GAME into the current buffer. +Folds the controls into the single action-button row (see +`card-games-bid--insert-buttons'); only the status line precedes it." + (insert (card-games-bid--header-text game)) + (insert-image (card-games-svg-image (card-games-bid--table-svg game) (card-games-scale))) + (insert (format "\n %s\n" (card-games-get game :message)))) + +(defun card-games-bid--south-hit (px py n) + "Map a click at PX, PY to a South-hand index (0..N-1), or nil." + (let* ((lay (card-games-bid--south-layout n)) + (x0 (nth 0 lay)) (step (nth 1 lay)) (y (nth 2 lay))) + (when (and (> n 0) (>= py (- y (round (* card-games-bid--th 0.17)) 4)) + (<= py (+ y card-games-bid--th 8)) (>= px x0)) + (let ((i (if (<= step 0) 0 (/ (- px x0) step)))) + (when (< i n) i))))) + + + +;;;; Interaction + +(defvar-local card-games-bid--game nil "The `card-games-bid-game' in the current buffer.") + +(defun card-games-bid--mode-line (game) + "Return a mode-line status string for GAME." + (pcase (card-games-get game :phase) + ('auction (if (= (card-games-get game :bidder) 0) " [Your bid]" + (format " [%s bidding]" (aref card-games-bid-seat-names (card-games-get game :bidder))))) + ('kitty (if (card-games-bid--human-p (card-games-get game :contractor)) " [Discard 5]" + (format " [%s: kitty]" + (aref card-games-bid-seat-names (card-games-get game :contractor))))) + ('play (if (= (card-games-get game :turn) 0) " [Your turn]" + (format " [%s to play]" (aref card-games-bid-seat-names (card-games-get game :turn))))) + ('done " [Hand over — n]") + ('gameover " [Game over — n]") + (_ ""))) + +(defun card-games-bid--phase-text (game) + "Return a short prompt describing what to do now in GAME." + (pcase (card-games-get game :phase) + ('auction (if (= (card-games-get game :bidder) 0) + "Your turn to bid — click a bid, or Pass." + (format "Waiting for %s to bid..." + (aref card-games-bid-seat-names (card-games-get game :bidder))))) + ('kitty (if (card-games-bid--human-p (card-games-get game :contractor)) + "Click 5 cards to discard, then Discard." + (format "%s is exchanging the kitty..." + (aref card-games-bid-seat-names (card-games-get game :contractor))))) + ('play (if (= (card-games-get game :turn) 0) + "Your turn — click a card to play." + (format "Waiting for %s to play..." + (aref card-games-bid-seat-names (card-games-get game :turn))))) + ('done (or (card-games-get game :hand-result) (card-games-get game :message))) + ('gameover (or (card-games-get game :message) "Game over — click New game.")) + (_ (card-games-get game :message)))) + +(defun card-games-bid--announce (game) + "Echo a prompt or status describing what to do now in GAME." + (message "%s" (card-games-bid--phase-text game))) + +(defun card-games-bid--button (label cmd help) + "Insert a clickable button LABEL running CMD with tooltip HELP." + (insert-text-button label 'action (lambda (_) (call-interactively cmd)) + 'help-echo help 'follow-link t 'face 'link) + (insert " ")) + +(defun card-games-bid--insert-buttons (game) + "Insert clickable buttons for the actions available now in GAME." + (insert " ") + (pcase (card-games-get game :phase) + ('auction (when (= (card-games-get game :bidder) 0) + (card-games-bid--button "[Bid]" #'card-games-bid-make-bid "Make a bid") + (card-games-bid--button "[Pass]" #'card-games-bid-pass "Pass"))) + ('kitty (when (card-games-bid--human-p (card-games-get game :contractor)) + (card-games-bid--button "[Discard 5]" #'card-games-bid-discard-marked + "Discard the five marked cards"))) + ('play (when (= (card-games-get game :turn) 0) + (card-games-bid--button "[Play]" #'card-games-bid-select + "Play the highlighted card")))) + (when (memq (card-games-get game :phase) '(done gameover)) + (card-games-bid--button (if (eq (card-games-get game :phase) 'gameover) "[New game]" "[Next hand]") + #'card-games-bid-new "Deal the next hand / start a new game")) + (card-games-bid--button "[Help]" #'card-games-bid-help "Show help") + (insert "\n")) + +(cl-defmethod card-games-renderer-draw ((_renderer card-games-text-renderer) (game card-games-bid-game)) + "Draw the 500 GAME as UNICODE text with the action buttons." + (insert (card-games-render game)) + (card-games-bid--insert-buttons game)) + +(cl-defmethod card-games-renderer-draw ((_renderer card-games-svg-renderer) (game card-games-bid-game)) + "Draw the 500 GAME as an SVG table with the action buttons." + (card-games-bid--insert-graphical game) + (card-games-bid--insert-buttons game)) + +(cl-defmethod card-games-renderer-draw ((_renderer card-games-svg-fill-renderer) (game card-games-bid-game)) + "Draw the 500 GAME as a frameless full-window SVG table." + (card-games-bid--insert-svg-ui game)) + +(defun card-games-bid--treatment () + "Return the display treatment symbol for the current 500 buffer. +Honours `card-games-bid-svg-ui' and whether the display is graphical." + (cond ((and card-games-bid-svg-ui (display-graphic-p)) 'svg-fill) + ((display-graphic-p) 'svg) + (t 'text))) + +(defun card-games-bid--redisplay () + "Redraw the current 500 buffer through its renderer. +The treatment is chosen by `card-games-bid--treatment' and dispatched with +`card-games-renderer-draw'." + (let* ((inhibit-read-only t) + (game card-games-bid--game) + (renderer (card-games-render-set-treatment game (card-games-bid--treatment)))) + (setq-local mode-line-process (card-games-bid--mode-line game)) + (erase-buffer) + (card-games-renderer-draw renderer game) + (goto-char (point-min)))) + +(defun card-games-bid--refresh () + "Advance AI to the next human action, animating turns if enabled." + (let ((game card-games-bid--game)) + (if (or (not card-games-bid-animate) (<= card-games-bid-ai-delay 0)) + (progn (card-games-bid--run game) (card-games-bid--redisplay)) + (card-games-bid--redisplay) + (let ((guard 0)) + (while (and (< (cl-incf guard) 400) + (let ((before (card-games-get game :ntricks))) + (when (card-games-bid--ai-step game) + (card-games-bid--redisplay) + (message "%s" (card-games-get game :message)) + (sit-for (if (> (card-games-get game :ntricks) before) + card-games-bid-trick-pause + card-games-bid-ai-delay)) + t))))) + (card-games-bid--redisplay)) + (card-games-bid--announce game))) + +(defun card-games-bid-left () + "Move the hand cursor left." + (interactive) + (card-games-put card-games-bid--game :cursor (max 0 (1- (card-games-get card-games-bid--game :cursor)))) + (card-games-bid--redisplay)) + +(defun card-games-bid-right () + "Move the hand cursor right." + (interactive) + (let ((n (length (card-games-get card-games-bid--game :sorted-hand)))) + (card-games-put card-games-bid--game :cursor (min (1- n) (1+ (card-games-get card-games-bid--game :cursor)))) + (card-games-bid--redisplay))) + +(defun card-games-bid--current-card () + "Return the card under the hand cursor." + (nth (card-games-get card-games-bid--game :cursor) (card-games-get card-games-bid--game :sorted-hand))) + +(defun card-games-bid-select () + "Play (in play phase) or mark/unmark (in kitty phase) the current card." + (interactive) + (let* ((game card-games-bid--game) + (phase (card-games-get game :phase)) + (card (card-games-bid--current-card))) + (pcase phase + ('kitty + (when (card-games-bid--human-p (card-games-get game :contractor)) + (let ((marks (card-games-get game :marks))) + (cond + ((member card marks) + (card-games-put game :marks (remove card marks)) + (card-games-put game :message + (format "%d of 5 marked for discard." (length (card-games-get game :marks))))) + ((>= (length marks) 5) + (card-games-put game :message + "Five already marked — click a marked card to unmark first.")) + (t (card-games-put game :marks (cons card marks)) + (card-games-put game :message + (let ((np (length (card-games-get game :marks)))) + (if (= np 5) "5 of 5 marked — press Discard." + (format "%d of 5 marked for discard." np)))))) + (card-games-bid--redisplay)))) + ('play + (if (/= (card-games-get game :turn) 0) + (progn (card-games-put game :message "Not your turn.") (card-games-bid--redisplay)) + (let ((legal (card-games-bid-legal-cards (card-games-bid--hand game 0) + (card-games-get game :led) + (card-games-bid-trump (card-games-get game :contract))))) + (if (not (member card legal)) + (progn (card-games-put game :message "Illegal — you must follow suit.") + (card-games-bid--redisplay)) + (card-games-bid--play game 0 card) + (card-games-bid--refresh))))) + (_ (card-games-bid--redisplay))))) + +(defun card-games-bid-discard-marked () + "Discard the five marked kitty cards." + (interactive) + (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-bid--discard game (card-games-get game :contractor) marks) + (card-games-put game :marks nil) + (card-games-bid--refresh))))) + +(defun card-games-bid--code (bid) + "Return a short ASCII code for BID, e.g. \"7H\", \"8NT\", \"NL\"." + (let ((trump (card-games-bid-trump bid)) (tricks (card-games-bid-tricks bid))) + (cond ((card-games-bid-nullo-p bid) (card-games-bid-label bid)) + ((eq trump 'nt) (format "%dNT" tricks)) + (t (format "%d%c" tricks (aref "SCDH" trump)))))) + +(defun card-games-bid-make-bid () + "Prompt the human for a bid. +Type a short code such as 7H, 8NT, NL (case-insensitive)." + (interactive) + (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-bid--auction-act game 0 (if (eq sel 'pass) nil sel)) + (card-games-bid--refresh))))) + +(defun card-games-bid-pass () + "Pass during the auction." + (interactive) + (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-bid--auction-act game 0 nil) + (card-games-bid--refresh)))) + +(defun card-games-bid-new () + "Advance to the next hand once a hand is over, or start a fresh game at +game over. 500 is a multi-hand game with no mid-hand redeal, so a hand in +progress must be played out (unlike the solitaire games)." + (interactive) + (let* ((game card-games-bid--game) (phase (card-games-get game :phase))) + (cond + ((eq phase 'gameover) + (card-games-put game :scores (cons 0 0)) + (card-games-put game :hand-no 0) + (card-games-put game :game-over nil) + (card-games-bid--deal game 3) + (card-games-bid--refresh)) + ((eq phase 'done) + (card-games-bid--deal game (mod (1+ (card-games-get game :dealer)) 4)) + (card-games-bid--refresh)) + (t (card-games-put game :message "Play the hand out — 500 has no mid-hand redeal.") + (card-games-bid--redisplay))))) + +(defun card-games-bid-mouse (event) + "Handle a click in the 500 buffer (SVG-UI panels, table, or text)." + (interactive "e") + (let ((start (event-start event)) (game card-games-bid--game)) + (if (and card-games-bid-svg-ui (display-graphic-p) (posn-image start)) + (card-games-bid--svg-ui-click start) + (let ((i (if (and (display-graphic-p) (posn-image start)) + (let ((xy (posn-object-x-y start)) (s (card-games-scale))) + (and xy (card-games-bid--south-hit (round (/ (car xy) s)) + (round (/ (cdr xy) s)) + (length (card-games-get game :sorted-hand))))) + (let ((pos (posn-point start))) + (and pos (get-text-property pos 'card-games-card)))))) + (when i (card-games-put game :cursor i) (card-games-bid-select)))))) + +(defun card-games-bid-help () + "Show brief help." + (interactive) + (message "%s" (concat "500: win the auction, exchange the kitty, take your bid " + "in tricks. Click the ? Help button (SVG UI) for the rules."))) + +(defun card-games-bid-zoom-in () + "Enlarge the cards." + (interactive) + (if (and card-games-bid-svg-ui (display-graphic-p)) + (progn (setq card-games-bid-card-scale (min 2.2 (+ (or card-games-bid-card-scale 1.0) 0.2))) + (card-games-bid--redisplay)) + (text-scale-increase 1) (card-games-bid--redisplay))) +(defun card-games-bid-zoom-out () + "Shrink the cards." + (interactive) + (if (and card-games-bid-svg-ui (display-graphic-p)) + (progn (setq card-games-bid-card-scale (max 0.6 (- (or card-games-bid-card-scale 1.0) 0.2))) + (card-games-bid--redisplay)) + (text-scale-decrease 1) (card-games-bid--redisplay))) +(defun card-games-bid-zoom-reset () + "Reset the card size." + (interactive) + (if (and card-games-bid-svg-ui (display-graphic-p)) + (progn (setq card-games-bid-card-scale 1.0) (card-games-bid--redisplay)) + (text-scale-set 0) (card-games-bid--redisplay))) + +(defun card-games-bid-redraw () + "Redraw the table (e.g. after a theme or frame change)." + (interactive) + (card-games-bid--redisplay)) + +(defvar card-games-bid-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "") #'card-games-bid-left) + (define-key map (kbd "") #'card-games-bid-right) + (define-key map (kbd "RET") #'card-games-bid-select) + (define-key map "b" #'card-games-bid-make-bid) + (define-key map "p" #'card-games-bid-pass) + (define-key map "x" #'card-games-bid-discard-marked) + (define-key map "g" #'card-games-bid-redraw) + (define-key map "n" #'card-games-bid-new) + (define-key map "?" #'card-games-bid-help) + (define-key map "+" #'card-games-bid-zoom-in) + (define-key map "=" #'card-games-bid-zoom-in) + (define-key map "-" #'card-games-bid-zoom-out) + (define-key map "0" #'card-games-bid-zoom-reset) + (define-key map (kbd "M-") #'card-games-bid-log-up) + (define-key map (kbd "M-") #'card-games-bid-log-down) + (define-key map [wheel-up] #'card-games-bid-wheel) + (define-key map [wheel-down] #'card-games-bid-wheel) + (define-key map [mouse-4] #'card-games-bid-wheel) + (define-key map [mouse-5] #'card-games-bid-wheel) + (define-key map "v" #'card-games-bid-toggle-svg-ui) + (define-key map [mouse-1] #'card-games-bid-mouse) + (define-key map "q" #'card-games-quit-to-menu) + map) + "Keymap for `card-games-bid-mode' (Emacs style; see `card-games-keys').") + +(defun card-games-bid--classic-keymap () + "Return a copy of `card-games-bid-mode-map' with vi-style h/l and SPC added." + (let ((map (copy-keymap card-games-bid-mode-map))) + (define-key map "h" #'card-games-bid-left) + (define-key map "l" #'card-games-bid-right) + (define-key map (kbd "SPC") #'card-games-bid-select) + map)) + +(define-derived-mode card-games-bid-mode special-mode "500" + "Major mode for playing 500 (Bid)." + (setq-local truncate-lines t) + (setq-local cursor-type card-games-cursor-type) + (add-hook 'window-configuration-change-hook #'card-games-bid--fit nil t) + (when (eq card-games-keys 'classic) + (use-local-map (card-games-bid--classic-keymap)))) + +;;;###autoload +(defun card-games-bid () + "Play 500 (Bid) against three computer opponents." + (interactive) + (let ((buf (get-buffer-create "*500 Bid*"))) + (with-current-buffer buf + (card-games-bid-mode) + (setq card-games-bid--game (card-games-bid--deal (make-instance 'card-games-bid-game))) + (card-games-bid--refresh)) + (switch-to-buffer buf))) + + +;;;; Frameless full-SVG UI (opt-in; see `card-games-bid-svg-ui') + +(defconst card-games-bid--ui-w 860 "Default SVG-UI canvas width.") +(defconst card-games-bid--ui-h 540 "Default SVG-UI canvas height.") +(defconst card-games-bid--ui-tx 210 "Left edge of the table area.") +(defconst card-games-bid--ui-tw 440 "Default width of the table area.") +(defconst card-games-bid--sw 58 "South-hand card width (larger, for readability).") +(defconst card-games-bid--sh 82 "South-hand card height.") + +(defconst card-games-bid--south-minfrac 0.30 + "Minimum South-card step as a fraction of card width. +The smallest gutter that still keeps each card's rank/suit index visible.") + +(defun card-games-bid--south-size (w h) + "Return (SW . SH) South-card size for a canvas W by H. +The player's cards grow with the window; height grows about twice as +fast as the window widens, so the hand compresses (cards overlap) as the +table enlarges. Capped at 42% of canvas height; width is capped later, +per-deal, so the hand always fits the table." + (let* ((wf (- w card-games-bid--ui-w)) (hf (- h card-games-bid--ui-h)) + (base (max 76 (min (round (* h 0.42)) + (round (+ 92 (* hf 0.20) (* wf 0.40)))))) + (sh (max 50 (min (round (* h 0.60)) + (round (* base (or card-games-bid-card-scale 1.0)))))) + (sw (round (* sh 0.70)))) + (cons sw sh))) + +(defvar-local card-games-bid--regions nil + "Plist of clickable SVG-UI regions for hit-testing.") +(defvar-local card-games-bid--last-size nil + "Last window pixel size used to render the SVG-UI.") + +(defun card-games-bid--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-bid--text-left (svg str x y size color &optional bold) + "Draw left-anchored text STR on SVG." + (let ((a (list :x (round x) :y (round y) :font-size (round size) + :fill color :text-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-bid--ui-label (svg str x y &optional size) + "Draw an all-caps, letter-spaced section label on SVG (font SIZE, default 10)." + (svg-text svg (upcase str) :x (round x) :y (round y) :font-size (round (or size 10)) + :fill "#8fc79b" :text-anchor "start" :font-family card-games-svg-font-family + :font-weight "bold" :letter-spacing "2")) + +(defun card-games-bid--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 card-games-bid--active-seat (game) + "Return the seat whose action is pending, or nil." + (pcase (card-games-get game :phase) + ('auction (card-games-get game :bidder)) + ('kitty (card-games-get game :contractor)) + ('play (card-games-get game :turn)) + (_ nil))) + +(defun card-games-bid--hand-layout (n width xoff ybottom &optional cardw cardh) + "Return (X0 STEP Y) for N cards across WIDTH from XOFF, bottom YBOTTOM. +CARDW/CARDH default to the table card size. Cards overlap to fit but +keep a minimum gutter so each rank index stays visible." + (let* ((w (or cardw card-games-bid--tw)) + (hgt (or cardh card-games-bid--th)) + (maxw (- width 24)) + (minstep (max 14 (round (* w card-games-bid--south-minfrac)))) + (fit (if (<= n 1) 0 (/ (- maxw w) (1- n)))) + (step (if (<= n 1) 0 (max minstep (min (+ w 7) fit)))) + (total (+ w (* (max 0 (1- n)) step))) + (x0 (+ xoff (/ (- width total) 2))) + (y (- ybottom hgt 8))) + (list x0 step y))) + +(defun card-games-bid--draw-trick-at (svg game cx cy &optional fs) + "Draw the current trick centred at CX, CY on SVG, on a faint drop-zone. +FS scales the drop-zone, the played cards, and their spread." + (let* ((fs (or fs 1.0)) + (r (round (* 80 fs))) + (w (round (* card-games-bid--tw fs))) (h (round (* card-games-bid--th fs))) + (off (round (* 70 fs))) (gap (round (* 22 fs))) + (spots (list (list 0 (- cx (/ w 2)) (+ cy gap)) + (list 1 (- cx off w) (- cy (/ h 2))) + (list 2 (- cx (/ w 2)) (- cy gap h)) + (list 3 (+ cx off) (- cy (/ h 2)))))) + (svg-circle svg cx cy r :fill "#000000" :fill-opacity 0.08) + (svg-circle svg cx cy r :fill "none" :stroke "#0e5226" :stroke-width 2) + (let ((card-games-svg-card-width w) (card-games-svg-card-height h)) + (dolist (s spots) + (let* ((card (card-games-bid--trick-card-for game (nth 0 s))) (spec (card-games-bid--spec card))) + (when spec + (card-games-svg-card svg (nth 1 s) (nth 2 s) :rank (car spec) :suit (cdr spec)))))))) + +(defun card-games-bid--draw-south-region (svg game tx tw ybottom sw sh) + "Draw South's hand (cards SW by SH) within TX width TW bottom YBOTTOM. +Return (:hand (X0 STEP Y N SH))." + (let* ((trump (and (card-games-get game :contract) (card-games-bid-trump (card-games-get game :contract)))) + (hand (card-games-bid-sort-display (card-games-bid--hand game 0) trump))) + (card-games-put game :sorted-hand hand) + (let* ((n (length hand)) + ;; Cap card width so N cards fit the table at the index-safe + ;; gutter; tall cards shrink only when the table is too narrow. + (maxsw (if (<= n 1) sw + (/ (- tw 24.0) (+ 1.0 (* (1- n) card-games-bid--south-minfrac))))) + (capped (and (> n 1) (> sw maxsw))) + (sw (if capped (max 40 (round maxsw)) sw)) + (sh (if capped (round (/ sw 0.70)) sh)) + (lay (card-games-bid--hand-layout n tw tx ybottom sw sh)) + (x0 (nth 0 lay)) (step (nth 1 lay)) (y (nth 2 lay)) + (cursor (card-games-get game :cursor)) (marks (card-games-get game :marks)) (i 0)) + (svg-rectangle svg tx (- y 6) tw (+ sh 14) :rx 10 + :fill "#ffffff" :fill-opacity 0.05) + (let ((card-games-svg-card-width sw) (card-games-svg-card-height sh) + (legal (and (eq (card-games-get game :phase) 'play) (= (card-games-get game :turn) 0) + (card-games-bid-legal-cards + (card-games-bid--hand game 0) (card-games-get game :led) + (and (card-games-get game :contract) + (card-games-bid-trump (card-games-get game :contract))))))) + (dolist (card hand) + (let* ((spec (card-games-bid--spec card)) (marked (and (member card marks) t)) + (illegal (and legal (not (member card legal)))) + (hl (or (and (eq (card-games-get game :phase) 'play) (= i cursor)) marked)) + (cxc (+ x0 (* i step))) + (cy (if marked (- y (round (* sh 0.17))) y))) + (card-games-svg-card svg cxc cy :rank (car spec) :suit (cdr spec) :highlight hl) + (when illegal + (svg-rectangle svg cxc cy sw sh :rx 6 :fill "#0a1a0c" :fill-opacity 0.55))) + (setq i (1+ i)))) + (list :hand (list x0 step y n sh))))) + +(defun card-games-bid--draw-compass (svg game cx cy r &optional fs) + "Draw a compass turn indicator centred at CX, CY radius R on SVG. +FS scales the N/S/E/W label fonts." + (let ((active (card-games-bid--active-seat game)) + (lsz (max 12 (round (* 13 (or fs 1.0)))))) + (svg-circle svg cx cy r :fill "#0d4a22" :stroke "#0a3a1a" :stroke-width 2) + (svg-circle svg cx cy (- r 7) :fill "none" :stroke "#1b6b35" :stroke-width 1) + (cl-flet ((lab (seat lx ly s) + (card-games-svg--text svg s lx ly lsz + (if (eql seat active) "#f6e27a" "#bfe0bf") + (eql seat active)))) + (lab 2 cx (- cy r -15) "N") + (lab 0 cx (+ cy r -5) "S") + (lab 1 (- cx r -11) (+ cy 5) "W") + (lab 3 (+ cx r -11) (+ cy 5) "E")) + (when active + (let* ((tip (pcase active + (2 (cons cx (- cy (- r 16)))) + (0 (cons cx (+ cy (- r 16)))) + (1 (cons (- cx (- r 16)) cy)) + (3 (cons (+ cx (- r 16)) cy))))) + (svg-line svg cx cy (car tip) (cdr tip) :stroke "#f1c40f" :stroke-width 2) + (svg-circle svg (car tip) (cdr tip) 3 :fill "#f1c40f"))) + (svg-circle svg cx cy 3 :fill "#cfeccf"))) + +(defun card-games-bid--draw-logo (svg cx cy &optional fs) + "Draw the configured Emacs emblem centred at CX, CY on SVG, scaled by FS. +The emblem is chosen with `card-games-svg-emacs-logo'." + (card-games-svg-draw-logo svg cx cy fs)) + +(defun card-games-bid--grid-cell (bid gx gy cw ch g) + "Return (X Y W H) for BID in a grid at GX,GY with cells CW by CH, gutter G. +Suit/NT bids occupy rows by trick count (6-10) and columns by suit; +nullo bids share the bottom row." + (if (card-games-bid-nullo-p bid) + (let ((col (pcase (card-games-bid-label bid) ("ON" 1) ("GN" 2) (_ 0)))) + (list (+ gx (* col (+ cw g))) (+ gy (* 5 (+ ch g))) cw ch)) + (let ((col (if (eq (card-games-bid-trump bid) 'nt) 4 (card-games-bid-trump bid))) + (row (- (card-games-bid-tricks bid) 6))) + (list (+ gx (* col (+ cw g))) (+ gy (* row (+ ch g))) cw ch)))) + +(defun card-games-bid--grid-pass-cell (gx gy cw ch g) + "Return (X Y W H) for the double-width Pass button (bottom row, cols 3-4)." + (list (+ gx (* 3 (+ cw g))) (+ gy (* 5 (+ ch g))) (+ (* 2 cw) g) ch)) + +(defun card-games-bid--draw-left-panel (svg game h lpw fs ccy) + "Draw the full-height left status panel; return its clickable regions. +LPW is the panel width, FS the font/element scale, CCY the compass centre +Y (also the North reference line). All metrics scale with FS so the +panel content grows with the window." + (let* ((scores (card-games-get game :scores)) + (contract (card-games-get game :contract)) + (regions nil) + (F (lambda (n) (round (* n fs)))) + (px0 (funcall F 16)) (pxr (- lpw (funcall F 12))) + (dl (funcall F 8)) (dr (- lpw (funcall F 8))) + (cxp (/ lpw 2)) + (cr (funcall F 44)) + (y 0)) + (svg-rectangle svg 6 6 (- lpw 8) (- h 12) :rx 10 :fill "#0d4a22" :fill-opacity 0.9 + :stroke "#0a3a1a" :stroke-width 1) + (card-games-bid--draw-compass svg game cxp ccy cr fs) + (setq y (+ ccy cr (funcall F 12))) + (card-games-bid--ui-divider svg dl dr y) + (setq y (+ y (funcall F 18))) + (card-games-bid--ui-label svg "Scores" px0 y (funcall F 10)) + (setq y (+ y (funcall F 22))) + (card-games-bid--text-left svg "You / North" px0 y (funcall F 13) "#eaffea") + (svg-text svg (number-to-string (car scores)) :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-bid--text-left svg "West / East" px0 y (funcall F 13) "#eaffea") + (svg-text svg (number-to-string (cdr scores)) :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-bid--ui-divider svg dl dr y) + (setq y (+ y (funcall F 18))) + (card-games-bid--ui-label svg "Contract" px0 y (funcall F 10)) + (setq y (+ y (funcall F 32))) + (card-games-svg--text svg (if contract (card-games-bid-label contract) "Auction…") + cxp y (funcall F 24) "#f1c40f" t) + (setq y (+ y (funcall F 20))) + (if contract + (let ((tr (card-games-get game :tricks))) + (card-games-bid--text-left svg + (format "%s — tricks %d:%d" + (aref card-games-bid-seat-names (card-games-get game :contractor)) + (+ (aref tr 0) (aref tr 2)) (+ (aref tr 1) (aref tr 3))) + px0 y (funcall F 12) "#cfeccf")) + (card-games-bid--text-left svg "Bidding in progress" px0 y (funcall F 12) "#9fd0a8")) + (setq y (+ y (funcall F 14))) + (card-games-bid--ui-divider svg dl dr y) + (when (and (eq (card-games-get game :phase) 'auction) (= (card-games-get game :bidder) 0)) + (setq y (+ y (funcall F 18))) + (card-games-bid--ui-label svg "Your bid" px0 y (funcall F 10)) + ;; extra breathing room between the label and the grid + (setq y (+ y (funcall F 16))) + (let* ((gx px0) (gy y) + (g (funcall F 5)) + (cw (max 24 (/ (- lpw px0 (funcall F 12) (* 4 g)) 5))) + ;; full height when the panel is tall; shrink to fit on short windows + (ch (min (funcall F 26) + (max (funcall F 10) + (- (/ (- (- h (funcall F 14)) gy) 6) g)))) + (legal (card-games-bid--legal-bids game)) (bids nil)) + (dolist (b card-games-bid-schedule) + (when (memq b legal) + (let* ((cell (card-games-bid--grid-cell b gx gy cw ch g)) + (x (nth 0 cell)) (cy2 (nth 1 cell)) (w (nth 2 cell)) (h2 (nth 3 cell)) + (color (card-games-svg--suit-color (pcase (card-games-bid-trump b) + ('nt 0) ('nullo 'joker) (n n))))) + (svg-rectangle svg x cy2 w h2 :rx 5 :fill "#fdfdfb" + :stroke color :stroke-width 1) + (card-games-svg--text svg (card-games-bid-label b) (+ x (/ w 2)) (+ cy2 (round (* h2 0.66))) + (funcall F 12) color t) + (push (cons b cell) bids)))) + (setq regions (plist-put regions :bids bids)) + (let ((pr (card-games-bid--grid-pass-cell gx gy cw ch g))) + (svg-rectangle svg (nth 0 pr) (nth 1 pr) (nth 2 pr) (nth 3 pr) + :rx 5 :fill "#7f8c8d" :stroke "#566573" :stroke-width 1) + (card-games-svg--text svg "Pass" (+ (nth 0 pr) (/ (nth 2 pr) 2)) + (+ (nth 1 pr) (round (* ch 0.66))) + (funcall F 12) "#ffffff" t) + (setq regions (plist-put regions :pass pr))))) + ;; kitty: a Discard button for the human contractor (mouse-only path) + (when (and (eq (card-games-get game :phase) 'kitty) + (card-games-bid--human-p (card-games-get game :contractor))) + (setq y (+ y (funcall F 18))) + (card-games-bid--ui-label svg "Kitty" px0 y (funcall F 10)) + (setq y (+ y (funcall F 14))) + (let* ((nmk (length (card-games-get game :marks))) (ready (= nmk 5)) + (bx px0) (by y) (bw (- lpw px0 (funcall F 12))) (bh (funcall F 30))) + (svg-rectangle svg bx by bw bh :rx 6 + :fill (if ready "#2e7d32" "#14401f") + :fill-opacity (if ready 1.0 0.6) + :stroke "#0a3a1a" :stroke-width 1) + (card-games-svg--text svg (format "Discard %d / 5" nmk) + (+ bx (/ bw 2)) (+ by (round (* bh 0.64))) + (funcall F 13) (if ready "#ffffff" "#9fd0a8") t) + (setq regions (plist-put regions :discard (list bx by bw bh))))) + regions)) + +(defun card-games-bid--draw-log (svg game x w h fs ccy) + "Draw the full-height right log panel (emblem + scrolling story); return regions. +FS scales the emblem and fonts; CCY aligns the divider with the compass." + (let* ((F (lambda (n) (round (* n fs)))) + (y 6) (bottom (- h 6 (funcall F 64))) ; reserve a control strip + (logtop (+ ccy (funcall F 44) (funcall F 12))) ; align with left divider + (lh (funcall F 16)) + (list-top (+ logtop (funcall F 24))) + (tw (funcall F 5)) (tx (+ x w (- (funcall F 10)))) + (log (card-games-get game :log)) (total (max 1 (length log))) + (scroll (or (card-games-get game :log-scroll) 0)) + (vis (max 1 (/ (- bottom list-top) lh))) + (maxch (max 12 (round (/ (- w (funcall F 22)) (* 0.62 (funcall F 11))))))) + (svg-rectangle svg x y w (- (- h 6) y) :rx 10 :fill "#0d4a22" :fill-opacity 0.9 + :stroke "#0a3a1a" :stroke-width 1) + ;; emblem in the open top area, divider aligned with the left compass divider + (card-games-bid--draw-logo svg (+ x (/ w 2)) ccy fs) + (card-games-bid--ui-divider svg (+ x (funcall F 10)) (- (+ x w) (funcall F 10)) logtop) + (card-games-bid--ui-label svg "Log" (+ x (funcall F 12)) (+ logtop (funcall F 16)) (funcall F 10)) + ;; scrollbar track + proportional thumb + delicate arrows + (svg-rectangle svg tx list-top tw (- bottom list-top) :rx 2 :fill "#0a3a1a") + (let* ((th2 (max 16 (round (* (- bottom list-top) (min 1.0 (/ (float vis) total)))))) + (room (- (- bottom list-top) th2)) + (ty2 (+ list-top (round (* room (/ (float scroll) (max 1 (- total 1))))))) + (up (list tx (- list-top 11) tw 9)) (dn (list tx (+ bottom 2) tw 9))) + (svg-rectangle svg tx ty2 tw th2 :rx 2 :fill "#7fae8a") + (svg-polygon svg (list (cons (+ tx 2) (nth 1 up)) (cons (- tx 1) (+ (nth 1 up) 7)) + (cons (+ tx 5) (+ (nth 1 up) 7))) :fill "#9fd0a8") + (svg-polygon svg (list (cons (- tx 1) (nth 1 dn)) (cons (+ tx 5) (nth 1 dn)) + (cons (+ tx 2) (+ (nth 1 dn) 7))) :fill "#9fd0a8") + ;; entries: newest first; top item gets ceremony; alternating stripes + (let ((yy (+ list-top (funcall F 12))) (ents (nthcdr scroll log)) (k 0)) + (while (and ents (< k vis)) + (let* ((sline (car ents)) (top? (= k 0))) + (when (cl-oddp k) + (svg-rectangle svg (+ x (funcall F 6)) (- yy (funcall F 12)) + (- w (funcall F 22)) lh :fill "#ffffff" :fill-opacity 0.05)) + (when (> (length sline) maxch) + (setq sline (concat (substring sline 0 (1- maxch)) "…"))) + (card-games-bid--text-left svg sline (+ x (funcall F 10)) yy + (if top? (funcall F 13) (funcall F 11)) + (if top? "#f4faf4" "#cfe3cf") top?) + (setq yy (+ yy (if top? (funcall F 22) lh)))) + (setq ents (cdr ents) k (1+ k)))) + ;; global controls (Help, card size) in the reserved bottom strip + (card-games-bid--ui-divider svg (+ x (funcall F 10)) (- (+ x w) (funcall F 10)) + (+ bottom (funcall F 4))) + (let* ((cz (+ bottom (funcall F 12))) + (hx (+ x (funcall F 12))) (hw (- w (funcall F 24))) (hh (funcall F 24)) + (sy (+ cz hh (funcall F 14))) + (lx (+ x (funcall F 36))) (rx2 (- (+ x w) (funcall F 14))) + (stops card-games-svg-slider-stops) + (segw (/ (float (- rx2 lx)) (max 1 (1- (length stops))))) + (srs nil) (k 0)) + (svg-rectangle svg hx cz hw hh :rx (funcall F 6) + :fill "#14401f" :stroke "#2e7d32" :stroke-width 1) + (card-games-svg--text svg "? Help / Rules" (+ hx (/ hw 2)) (+ cz (round (* hh 0.66))) + (funcall F 12) "#cfe3cf" t) + (card-games-bid--ui-label svg "Size" (+ x (funcall F 12)) (+ sy (funcall F 4)) (funcall F 9)) + (svg-line svg lx sy rx2 sy :stroke "#1b6b35" :stroke-width 2) + (dolist (v stops) + (let* ((cxk (round (+ lx (* k segw)))) + (near (< (abs (- v (or card-games-bid-card-scale 1.0))) 0.08))) + (svg-circle svg cxk sy (if near 7 4) + :fill (if near "#f1c40f" "#eaffea") + :stroke "#0a3a1a" :stroke-width 1) + (push (cons (list (- cxk (round (/ segw 2))) (- sy 10) + (max 12 (round segw)) 20) (cons 'scale v)) srs)) + (setq k (1+ k))) + (list :scroll-up up :scroll-down dn :log-region (list x y w (- bottom y)) + :help (list hx cz hw hh) :sizer (nreverse srs)))))) + +(defun card-games-bid--draw-banner (svg game tx tw ty fs) + "Draw the phase-prompt banner across the top of the table." + (let* ((txt (card-games-bid--phase-text game)) + (by (+ ty (round (* 6 fs)))) (bh (round (* 30 fs))) + (bw (min (- tw (round (* 90 fs))) + (max (round (* 240 fs)) (* (length txt) (round (* 8 fs)))))) + (bx (+ tx (/ (- tw bw) 2)))) + (svg-rectangle svg bx by bw bh :rx (round (* 15 fs)) + :fill "#0d2c17" :fill-opacity 0.88 :stroke "#2e7d32" :stroke-width 1) + (card-games-svg--text svg txt (+ bx (/ bw 2)) (+ by (round (* bh 0.66))) + (round (* 14 fs)) "#f4faf4" t))) + +(defun card-games-bid--draw-help-overlay (svg _game tx ty tw th fs) + "Draw the rules/legend overlay over the table; return its regions." + (let* ((F (lambda (n) (round (* n fs)))) + (m (funcall F 26)) + (ox (+ tx m)) (oy (+ ty m)) (ow (- tw (* 2 m))) (oh (- th (* 2 m))) + (lx (+ ox (funcall F 22))) (y (+ oy (funcall F 36))) + (lines '("How to play 500" + "" + "You (South) + North are partners vs West + East." + "1. AUCTION — bid how many tricks your side will take," + " or Pass. Click a bid in the left panel; high bid wins." + "2. KITTY — the winner takes 5 hidden cards, then clicks" + " 5 to throw away (the Discard button turns green at 5)." + "3. PLAY — take turns clicking a card; follow the led suit." + " Take at least as many tricks as you bid to score." + "" + "Bids: 7♠ = take 7 tricks, spades trump. NT = no-trump." + " NL / ON / GN = misère bids (try to take none)." + "Trump rank: Joker, right & left bowers, A K Q 10 9 ... 4.")) + (regions nil)) + (svg-rectangle svg ox oy ow oh :rx (funcall F 14) + :fill "#08200f" :fill-opacity 0.97 :stroke "#2e7d32" :stroke-width 2) + (dolist (ln lines) + (let ((title (string-prefix-p "How to" ln))) + (card-games-bid--text-left svg ln lx y (if title (funcall F 18) (funcall F 13)) + (if title "#f1c40f" "#eaffea") title)) + (setq y (+ y (funcall F 22)))) + (let* ((by (- (+ oy oh) (funcall F 44))) + (bw (funcall F 130)) (bh (funcall F 30)) (g (funcall F 14)) (bx lx)) + (cl-flet ((btn (label key fill) + (svg-rectangle svg bx by bw bh :rx (funcall F 6) :fill fill + :stroke "#0a3a1a" :stroke-width 1) + (card-games-svg--text svg label (+ bx (/ bw 2)) (+ by (round (* bh 0.64))) + (funcall F 13) "#ffffff" t) + (setq regions (plist-put regions key (list bx by bw bh))) + (setq bx (+ bx bw g)))) + (btn "Close" :help-close "#2e7d32") + (btn "Classic view" :help-classic "#34495e") + (btn "Quit" :help-quit "#7f3b3b"))) + regions)) + +(defun card-games-bid--ui-svg (game &optional w h) + "Return (SVG . REGIONS) for the full-buffer SVG-UI of GAME (W by H). +Everything scales proportionally with the canvas: FS drives fonts and +table cards, PSCALE the side-panel widths." + (let* ((W (or w card-games-bid--ui-w)) (H (or h card-games-bid--ui-h)) + (svg (svg-create W H)) (regions nil) + ;; master scales relative to the base 860x540 canvas + (fs (max 1.0 (min 2.0 (/ (+ (/ (float W) card-games-bid--ui-w) + (/ (float H) card-games-bid--ui-h)) 2.0)))) + (pscale (max 1.0 (min 1.7 (/ (float W) card-games-bid--ui-w)))) + (lpw (round (* 196 pscale))) + (rp-w (round (* 206 pscale))) + (rp-x (- W rp-w)) + (tx (+ lpw 14)) (tw (max 320 (- rp-x tx 8))) + (ty 8) (th (- H 16)) + (cx (+ tx (/ tw 2))) (cy (+ ty (/ th 2))) + ;; opponent/trick card size grows up to ~2x + (otw (round (* card-games-bid--tw fs))) (oth (round (* card-games-bid--th fs))) + ;; compass-centre line; North sits just below it, its name just above + (ccy (max 56 (round (* H 0.12))))) + (let* ((base (or card-games-bid-felt-color "#15692f")) + (lite (or (ignore-errors (color-lighten-name base 12)) base)) + (dark (or (ignore-errors (color-darken-name base 18)) base))) + (svg-gradient svg "card-games-felt2" 'radial (list (cons 0 lite) (cons 100 dark))) + (svg-rectangle svg 0 0 W H :rx 14 :gradient "card-games-felt2") + (svg-rectangle svg (- tx 6) 8 (+ tw 12) (- H 16) :rx 12 + :fill "none" :stroke "#0e5226" :stroke-width 2)) + (let ((card-games-svg-card-width otw) (card-games-svg-card-height oth) + (card-games-svg-card-gap (max 2 (round (* 4 fs)))) + (inset (round (* 70 fs)))) + ;; North: cards just below the compass line, name just above it + (card-games-bid--draw-opponent svg game 2 cx (+ ccy (round (* 4 fs))) fs) + ;; West/East: vertically centred on the table midline + (card-games-bid--draw-opponent svg game 1 (+ tx inset) (- cy (/ oth 2)) fs) + (card-games-bid--draw-opponent svg game 3 (- (+ tx tw) inset) (- cy (/ oth 2)) fs) + (card-games-bid--draw-trick-at svg game cx (- cy 24) fs)) + (let ((ss (card-games-bid--south-size W H))) + (setq regions (append regions + (card-games-bid--draw-south-region svg game tx tw (+ ty th) + (car ss) (cdr ss))))) + (when (memq (card-games-get game :phase) '(done gameover)) + (let* ((hy (nth 2 (plist-get regions :hand))) + (bw (round (* 120 fs))) (bh (round (* 26 fs))) + (bx (- cx (/ bw 2))) (by (- hy bh (round (* 8 fs))))) + (svg-rectangle svg bx by bw bh :rx 6 :fill "#2e7d32" + :stroke "#0a3a1a" :stroke-width 1) + (card-games-svg--text svg "Next hand" (+ bx (/ bw 2)) (+ by (round (* bh 0.66))) + (round (* 14 fs)) "#ffffff" t) + (setq regions (plist-put regions :next (list bx by bw bh))))) + (setq regions (append regions (card-games-bid--draw-left-panel svg game H lpw fs ccy))) + (setq regions (append regions (card-games-bid--draw-log svg game rp-x rp-w H fs ccy))) + (card-games-bid--draw-banner svg game tx tw ty fs) + (when (card-games-get game :help-open) + (setq regions (append regions + (card-games-bid--draw-help-overlay svg game tx ty tw th fs)))) + (cons svg regions))) + +(defun card-games-bid--insert-svg-ui (game) + "Insert the full-buffer SVG-UI for GAME and record its regions. +When `card-games-bid-svg-fill', size the canvas to fill the window." + (let* ((win (get-buffer-window (current-buffer))) + (fill (and card-games-bid-svg-fill win)) + (w (if fill (max 720 (window-body-width win t)) card-games-bid--ui-w)) + (h (if fill (max 470 (- (window-body-height win t) 4)) card-games-bid--ui-h)) + (sr (card-games-bid--ui-svg game w h))) + (when fill (setq card-games-bid--last-size (cons (window-body-width win t) + (window-body-height win t)))) + (setq card-games-bid--regions (cdr sr)) + (insert-image (card-games-svg-image (car sr) (if fill 1.0 (card-games-scale)))) + (put-text-property (point-min) (point-max) 'pointer 'hand))) + +(defun card-games-bid--fit (&rest _) + "Re-render the SVG-UI to fit the window after a configuration change." + (when (and card-games-bid--game card-games-bid-svg-ui card-games-bid-svg-fill + (eq major-mode 'card-games-bid-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-bid--last-size) + (setq card-games-bid--last-size sz) + (card-games-bid--redisplay))))))) + +(defun card-games-bid-log-up () + "Scroll the SVG-UI message log towards older entries." + (interactive) + (let* ((game card-games-bid--game) (max (max 0 (1- (length (card-games-get game :log)))))) + (card-games-put game :log-scroll (min max (1+ (or (card-games-get game :log-scroll) 0)))) + (card-games-bid--redisplay))) + +(defun card-games-bid-log-down () + "Scroll the SVG-UI message log towards newer entries." + (interactive) + (let ((game card-games-bid--game)) + (card-games-put game :log-scroll (max 0 (1- (or (card-games-get game :log-scroll) 0)))) + (card-games-bid--redisplay))) + +(defun card-games-bid-wheel (event) + "Scroll the message log when the wheel turns over the log area. +Elsewhere, fall back to normal buffer scrolling." + (interactive "e") + (let ((start (event-start event)) (rg card-games-bid--regions) (handled nil)) + (when (and card-games-bid-svg-ui (display-graphic-p) (posn-image start)) + (let* ((xy (posn-object-x-y start)) (s (card-games-scale)) + (px (round (/ (car xy) s))) (py (round (/ (cdr xy) s)))) + (when (card-games-bid--in-rect px py (plist-get rg :log-region)) + (setq handled t) + (pcase (event-basic-type event) + ((or 'wheel-up 'mouse-4) (card-games-bid-log-up)) + ((or 'wheel-down 'mouse-5) (card-games-bid-log-down)))))) + (unless handled + (ignore-errors (require 'mwheel) (mwheel-scroll event))))) + +(defun card-games-bid--region-bid (px py rg) + "Return the bid whose button rect contains PX,PY in REGIONS RG, or nil." + (cl-some (lambda (e) (and (card-games-bid--in-rect px py (cdr e)) (car e))) + (plist-get rg :bids))) + +(defun card-games-bid--region-hand (px py hl) + "Return the South-hand index at PX,PY given hand layout HL, or nil." + (when hl + (let ((x0 (nth 0 hl)) (step (nth 1 hl)) (y (nth 2 hl)) (n (nth 3 hl)) + (sh (or (nth 4 hl) card-games-bid--sh))) + (when (and (> n 0) (>= py (- y (round (* sh 0.17)) 4)) + (<= py (+ y sh 8)) (>= px x0)) + (let ((i (if (<= step 0) 0 (/ (- px x0) step)))) (when (< i n) i)))))) + +(defun card-games-bid--sizer-hit (px py rg) + "If PX,PY lands on a card-size slider stop in RG, apply it; return non-nil." + (let ((hit (cl-some (lambda (e) (and (card-games-bid--in-rect px py (car e)) (cdr e))) + (plist-get rg :sizer)))) + (when (and (consp hit) (eq (car hit) 'scale)) + (setq card-games-bid-card-scale (cdr hit)) + (card-games-bid--refresh) + t))) + +(defun card-games-bid--svg-ui-click (start) + "Dispatch a click at posn START within the SVG-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-bid--game) (rg card-games-bid--regions) bid) + (if (card-games-get game :help-open) + (cond + ((card-games-bid--in-rect px py (plist-get rg :help-classic)) (card-games-bid-toggle-svg-ui)) + ((card-games-bid--in-rect px py (plist-get rg :help-quit)) (quit-window)) + (t (card-games-put game :help-open nil) (card-games-bid--redisplay))) + (cond + ((card-games-bid--in-rect px py (plist-get rg :help)) + (card-games-put game :help-open t) (card-games-bid--redisplay)) + ((card-games-bid--in-rect px py (plist-get rg :scroll-up)) (card-games-bid-log-up)) + ((card-games-bid--in-rect px py (plist-get rg :scroll-down)) (card-games-bid-log-down)) + ((card-games-bid--in-rect px py (plist-get rg :next)) (card-games-bid-new)) + ((card-games-bid--in-rect px py (plist-get rg :discard)) (card-games-bid-discard-marked)) + ((card-games-bid--sizer-hit px py rg)) + ((and (card-games-bid--in-rect px py (plist-get rg :pass)) + (eq (card-games-get game :phase) 'auction) (= (card-games-get game :bidder) 0)) + (card-games-bid--auction-act game 0 nil) (card-games-bid--refresh)) + ((setq bid (card-games-bid--region-bid px py rg)) + (card-games-bid--auction-act game 0 bid) (card-games-bid--refresh)) + (t (let ((i (card-games-bid--region-hand px py (plist-get rg :hand)))) + (when i (card-games-put game :cursor i) (card-games-bid-select)))))))) + +(defun card-games-bid-toggle-svg-ui () + "Toggle the full-buffer SVG UI for 500." + (interactive) + (setq card-games-bid-svg-ui (not card-games-bid-svg-ui)) + (setq card-games-bid--last-size nil) + (card-games-bid--redisplay) + (message "Full-SVG UI %s" (if card-games-bid-svg-ui "enabled" "disabled"))) + +(provide 'card-games-bid-ui) +;;; card-games-bid-ui.el ends here diff --git a/card-games-bid.el b/card-games-bid.el new file mode 100644 index 0000000..a739f56 --- /dev/null +++ b/card-games-bid.el @@ -0,0 +1,843 @@ +;;; card-games-bid.el --- 500 (Bid) — game logic -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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) (nth 0 bid)) +(defsubst card-games-bid-name (bid) (nth 1 bid)) +(defsubst card-games-bid-value (bid) (nth 2 bid)) +(defsubst card-games-bid-tricks (bid) (nth 3 bid)) +(defsubst card-games-bid-trump (bid) (nth 4 bid)) +(defsubst card-games-bid-open-p (bid) (nth 5 bid)) +(defsubst card-games-bid-nullo-p (bid) (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: trumps first (by power), 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 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 + ((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) (mod (+ seat 2) 4)) +(defsubst card-games-bid--team (seat) (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) (aref (card-games-get game :hands) seat)) +(defun card-games-bid--set-hand (game seat cards) (aset (card-games-get game :hands) seat cards)) + + +;;;; Auction + +(defun card-games-bid--legal-bids (game) + "Return the 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 the 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 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 (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 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 the 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 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 the 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 the 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 the current hand's play." + (not (eql seat (card-games-bid--sitter game)))) + +(defun card-games-bid--num-players (game) + "Return the number of 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 the 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 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 nominated 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 the 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 the 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 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 (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 the cards of HAND that are trumps under TRUMP (incl. Joker, bowers)." + (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 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 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 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 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) + "Discard to keep trumps and aces and to void short side 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 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 (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 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 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 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 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 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 diff --git a/card-games-bridge.el b/card-games-bridge.el new file mode 100644 index 0000000..f119667 --- /dev/null +++ b/card-games-bridge.el @@ -0,0 +1,874 @@ +;;; card-games-bridge.el --- Contract Bridge with rubber scoring -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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 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 (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) (aref (card-games-get game :hands) s)) +(defsubst card-games-bridge--set-hand (game s v) (aset (card-games-get game :hands) s v)) +(defsubst card-games-bridge--side (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 the 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 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 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 the 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 the contract, declarer, and start of play from the finished 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 the 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 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 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 ((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 card-games-bridge--play-card (game seat card) + "Have SEAT play CARD; resolve and score the trick when it completes." + (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 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 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 list of 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 AI plays until a human-controlled 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 the 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 the 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 a one-image SVG row for CARDS (clickable + sliderful when 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 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 a click ACTION on the 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 () + (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 end-of-auction and run AI after South calls 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 the 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 "") #'card-games-bridge-left) + (define-key map (kbd "") #'card-games-bridge-right) + (define-key map (kbd "") #'card-games-bridge-up) + (define-key map (kbd "") #'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 diff --git a/cg-core.el b/card-games-core.el similarity index 65% rename from cg-core.el rename to card-games-core.el index 1675c26..6d77b39 100644 --- a/cg-core.el +++ b/card-games-core.el @@ -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 ;; Maintainer: Corwin Brust ;; 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,35 +195,35 @@ 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))) -(defvar cg-shuffle-seed nil - "When non-nil, `cg-shuffle' is deterministic, seeded by this value. +(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 cg-shuffle--seeded-index (seed i limit) +(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 @@ -235,19 +234,19 @@ Emacs, so no bignum or overflow behaviour can vary the result." 16))) (mod r limit))) -(defun cg-shuffle (seq &optional seed) +(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 `cg-shuffle-seed', the shuffle is +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 `cg-shuffle-seed'. The seed may be a number or a string. +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)) - (seed (or seed cg-shuffle-seed))) + (seed (or seed card-games-shuffle-seed))) (dotimes (i n) (let ((j (+ i (if seed - (cg-shuffle--seeded-index seed i (- n i)) + (card-games-shuffle--seeded-index seed i (- n i)) (random (- n i)))))) (cl-rotatef (aref v i) (aref v j)))) (append v nil))) @@ -255,19 +254,19 @@ With no seed the order is unpredictable (system `random')." ;;;; Shared faces -(defface cg-red-suit '((t :foreground "red3")) +(defface card-games-red-suit '((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 '((t :foreground "gray50")) "Face for an empty slot." :group 'card-games) -(defface cg-hint '((t :foreground "green3" :weight bold)) +(defface card-games-hint '((t :foreground "green3" :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." @@ -278,74 +277,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 diff --git a/card-games-crapette.el b/card-games-crapette.el new file mode 100644 index 0000000..75766ad --- /dev/null +++ b/card-games-crapette.el @@ -0,0 +1,902 @@ +;;; card-games-crapette.el --- Russian Bank (Crapette), two-player vs AI -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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 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 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 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 spot FROM to spot TO." + (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 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 the source spots of GAME 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 any legal destination 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 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 the 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 foundation priority: call \"stop\" or block, per `card-games-crapette-stops'. +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, 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 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 (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 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 -- 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 the 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 a click 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 (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 "") #'card-games-crap-left) + (define-key map (kbd "") #'card-games-crap-right) + (define-key map (kbd "") #'card-games-crap-left) + (define-key map (kbd "") #'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 diff --git a/card-games-cribbage.el b/card-games-cribbage.el new file mode 100644 index 0000000..f8f10b6 --- /dev/null +++ b/card-games-cribbage.el @@ -0,0 +1,525 @@ +;;; card-games-cribbage.el --- Cribbage, with pegging and the show -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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 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 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 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 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) (aref (card-games-get game :hands) s)) +(defsubst card-games-crib--set-hand (game s v) (aset (card-games-get game :hands) s v)) +(defsubst card-games-crib--play (game s) (aref (card-games-get game :play) s)) +(defsubst card-games-crib--set-play (game s v) (aset (card-games-get game :play) s v)) + +(defun card-games-crib--who (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 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 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 the 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 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) + "Seat S plays CARD into the pegging round and pegs 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 the 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 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 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 AI seat S either 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 AI pegging turns until it is 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 the hands and the 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 () + (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) + (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 "") #'card-games-crib-left) + (define-key map (kbd "") #'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 diff --git a/card-games-eights.el b/card-games-eights.el new file mode 100644 index 0000000..49187cd --- /dev/null +++ b/card-games-eights.el @@ -0,0 +1,443 @@ +;;; card-games-eights.el --- Crazy Eights, a shedding card game -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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) (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) (aref (card-games-get game :hands) s)) +(defsubst card-games-eights--set-hand (game s v) (aset (card-games-get game :hands) s v)) +(defsubst card-games-eights--top (game) (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 the 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 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 seat S holds most of (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 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 the 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 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 seat S's whole turn: play if able, otherwise 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 AI seats until it is 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 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) + (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." + (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 "") #'card-games-eights-left) + (define-key map (kbd "") #'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 diff --git a/card-games-gaps.el b/card-games-gaps.el new file mode 100644 index 0000000..e485b8b --- /dev/null +++ b/card-games-gaps.el @@ -0,0 +1,867 @@ +;;; card-games-gaps.el --- Gaps-style row solitaires (Montana, Hell's Half-Acre) -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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.") +(cl-defgeneric card-games-gaps--step (game) + "Return the 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)) 0) +(cl-defmethod card-games-gaps--step ((_ card-games-montana-game)) 1) +(cl-defmethod card-games-gaps--vname ((_ card-games-montana-game)) "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)) 11) +(cl-defmethod card-games-gaps--step ((_ card-games-acre-game)) -1) +(cl-defmethod card-games-gaps--vname ((_ card-games-acre-game)) "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 the 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 + "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 'card-games-svg) + +(defcustom card-games-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 `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 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 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." + (svg-line svg x1 y x2 y :stroke "#1b6b35" :stroke-width 1)) + +(defun card-games-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)) + (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 "") #'card-games-gaps-left) + (define-key map (kbd "") #'card-games-gaps-right) + (define-key map (kbd "") #'card-games-gaps-up) + (define-key map (kbd "") #'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 diff --git a/card-games-handfoot.el b/card-games-handfoot.el new file mode 100644 index 0000000..53b744c --- /dev/null +++ b/card-games-handfoot.el @@ -0,0 +1,795 @@ +;;; card-games-handfoot.el --- Hand and Foot, a partnership rummy -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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) (>= (length cards) 7)) +(defun card-games-hf--book-clean-p (cards) (not (cl-some #'card-games-hf--wild-p cards))) + +;;;; Setup + +(defun card-games-hf--team (game s) (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) (aref (card-games-get game :books) team)) +(defun card-games-hf--set-books (game team v) (aset (card-games-get game :books) team v)) + +(defun card-games-hf--down-p (game team) + "Return non-nil when 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 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 seat S onto its foot, collecting any red threes it holds." + (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 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) + "Seat S picks 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 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 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 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 stock cards into seat S's hand. Return nil if stock runs out." + (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 seat S lay CARDS as a new book for their team. Return 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 onto a team book it fits. Return 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, 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 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 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 the 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 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 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 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 AI seats until it is 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 marks." + (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) + (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 "") #'card-games-hf-left) + (define-key map (kbd "") #'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 diff --git a/card-games-match.el b/card-games-match.el new file mode 100644 index 0000000..5c85956 --- /dev/null +++ b/card-games-match.el @@ -0,0 +1,607 @@ +;;; card-games-match.el --- Go Fish and Old Maid -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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) (aref (card-games-get game :hands) s)) +(defsubst card-games-gf--set-hand (game s v) (aset (card-games-get game :hands) s v)) + +(defun card-games-gf--books (game s) (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 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 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) + (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 the 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) (if (= s 0) "You" (format "Player %d" s))) + +(cl-defmethod card-games-gf--ask ((game card-games-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)) (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 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 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 (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 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 AI seats until it is 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 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 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 (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 () + (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 "") #'card-games-gf-left) + (define-key map (kbd "") #'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) (aref (card-games-get game :hands) s)) +(defsubst card-games-om--set-hand (game s 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 the list of 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 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 the 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) + (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) + "DRAWER takes card IDX from the next active 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 the game; whoever holds 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 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 AI seats until it is 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 a click ACTION: 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 () + (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 "") #'card-games-om-left) + (define-key map (kbd "") #'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 diff --git a/cg-net.el b/card-games-net.el similarity index 55% rename from cg-net.el rename to card-games-net.el index b322772..1928263 100644 --- a/cg-net.el +++ b/card-games-net.el @@ -1,11 +1,10 @@ -;;; cg-net.el --- Networked multiplayer for card games -*- lexical-binding: t; -*- +;;; card-games-net.el --- Networked multiplayer for card games -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Corwin Brust ;; Author: Corwin Brust ;; Maintainer: Corwin Brust ;; Version: 1.0.91 -;; Package-Requires: ((emacs "26.1")) ;; Keywords: games ;; URL: https://code.bru.st/corwin/card-game.el @@ -42,25 +41,25 @@ ;; host -> client: (:type welcome :seat N) ;; (:type state :state SEXP) ;; -;; A game plugs in by defining methods on `cg-net-apply-move' (host +;; 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 -;; `cg-net-game-state' / `cg-net-set-game-state'. Clients add a -;; redraw function to `cg-net-state-functions'. +;; `card-games-net-game-state' / `card-games-net-set-game-state'. Clients add a +;; redraw function to `card-games-net-state-functions'. ;;; Code: -(require 'cg-core) +(require 'card-games-core) -(defgroup cg-net nil +(defgroup card-games-net nil "Networked play for card games." :group 'card-games - :prefix "cg-net-") + :prefix "card-games-net-") -(defcustom cg-net-port 7500 +(defcustom card-games-net-port 7500 "Default TCP port used to host or join a game." - :type 'integer :group 'cg-net) + :type 'integer :group 'card-games-net) -(defcustom cg-net-host-address "127.0.0.1" +(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 @@ -75,62 +74,62 @@ 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 'cg-net) + :group 'card-games-net) -(defcustom cg-net-max-line 65536 +(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 'cg-net) + :type 'integer :group 'card-games-net) -(defcustom cg-net-max-connections 8 +(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 'cg-net) + :type 'integer :group 'card-games-net) -(defvar cg-net-state-functions nil +(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 cg-net-connect-functions nil +(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 `cg-net-host' struct and +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 cg-net-apply-move (game seat move) +(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 cg-net-game-state (game &optional seat) +(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 cg-net-game-state ((game cg-game) &optional _seat) +(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 cg-net-set-game-state (game state) +(cl-defgeneric card-games-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) +(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 cg-net--send (proc msg) +(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 cg-net--scrub (x) +(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 @@ -157,15 +156,15 @@ redisplay, and there is never a reason to honour a remote peer's." (t v)))) (walk x)))) -(defconst cg-net-max-nodes 20000 +(defconst card-games-net-max-nodes 20000 "Upper bound on the number of nodes accepted in one wire message.") -(defun cg-net--valid-p (msg types) +(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 `cg-net-max-nodes' nodes. Accept what +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." @@ -173,7 +172,7 @@ impersonate internal record types." (nodes 0)) (cl-labels ((clean-p (v) (cond - ((> (cl-incf nodes) cg-net-max-nodes) nil) + ((> (cl-incf nodes) card-games-net-max-nodes) nil) ((consp v) (and (not (gethash v seen)) (progn (puthash v t seen) @@ -190,14 +189,14 @@ impersonate internal record types." (cl-evenp (length msg)) ; of key/value pairs (memq (plist-get msg :type) types))))) -(defun cg-net--filter (handler 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 (`cg-net--valid-p') whose type is in TYPES; +well-shaped message (`card-games-net--valid-p') whose type is in TYPES; strings inside MSG have their text properties stripped first, by -`cg-net--scrub'. Anything else is dropped where it lands." +`card-games-net--scrub'. Anything else is dropped where it lands." (lambda (proc string) - (let ((buf (concat (or (process-get proc 'cg-net-buf) "") 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))) @@ -205,148 +204,148 @@ strings inside MSG have their text properties stripped first, by (unless (string-empty-p line) (condition-case err (let ((msg (car (read-from-string line)))) - (if (cg-net--valid-p msg types) - (funcall handler proc (cg-net--scrub msg)) - (message "cg-net: dropped malformed message"))) - (error (message "cg-net: bad message: %S" err)))))) + (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) cg-net-max-line) + (if (> (length rest) card-games-net-max-line) (progn - (process-put proc 'cg-net-buf nil) - (message "cg-net: dropping %s (line over %d bytes)" - (process-name proc) cg-net-max-line) + (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 'cg-net-buf rest)))))) + (process-put proc 'card-games-net-buf rest)))))) ;;;; Host -(cl-defstruct (cg-net-host (:constructor cg-net--host-make)) +(cl-defstruct (card-games-net-host (:constructor card-games-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.") +(defvar card-games-net--host nil + "The running `card-games-net-host', or nil when not hosting.") -(defun cg-net-hosting-p () +(defun card-games-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)))) + (and card-games-net--host (process-live-p (card-games-net-host-server card-games-net--host)))) -(defun cg-net-host-start (game &optional port) - "Begin hosting GAME on PORT (default `cg-net-port'). Return the server process. -The socket binds `cg-net-host-address' -- by default, this machine only." - (let* ((port (or port cg-net-port)) +(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 "cg-host" :server t :service port - :host cg-net-host-address :family 'ipv4 :coding 'utf-8 - :log #'cg-net--host-accept))) - (setq cg-net--host (cg-net--host-make :server server :game game)) + :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 cg-net-host-stop () +(defun card-games-net-host-stop () "Stop hosting and close all client connections." - (when cg-net--host - (dolist (c (cg-net-host-clients cg-net--host)) + (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 (cg-net-host-server cg-net--host)) - (delete-process (cg-net-host-server cg-net--host))) - (setq cg-net--host nil))) + (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 cg-net--host-sentinel (proc _event) +(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 cg-net--host - (setf (cg-net-host-clients cg-net--host) - (delq proc (cg-net-host-clients cg-net--host)))))) + (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 cg-net--host-accept (_server connection _message) +(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 `cg-net-max-connections' is closed instead." +A connection arriving past `card-games-net-max-connections' is closed instead." (if (>= (length (cl-remove-if-not #'process-live-p - (cg-net-host-clients cg-net--host))) - cg-net-max-connections) + (card-games-net-host-clients card-games-net--host))) + card-games-net-max-connections) (progn - (message "cg-net: refusing connection (table is at %d)" - cg-net-max-connections) + (message "card-games-net: refusing connection (table is at %d)" + card-games-net-max-connections) (delete-process connection)) - (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) + (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 #'cg-net--host-sentinel) + (set-process-sentinel connection #'card-games-net--host-sentinel) (set-process-filter connection - (cg-net--filter #'cg-net--host-handle '(hello move))) - (cg-net--send connection (list :type 'welcome :seat seat)) - (cg-net--send 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 (cg-net-game-state (cg-net-host-game cg-net--host) seat))) - (run-hook-with-args 'cg-net-connect-functions cg-net--host seat)))) + :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 cg-net--host-handle (proc msg) +(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 'cg-net-name (plist-get msg :name))) + ('hello (process-put proc 'card-games-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)))))) + (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 cg-net-host-broadcast () +(defun card-games-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)))))))) + (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 (cg-net-client (:constructor cg-net--client-make)) +(cl-defstruct (card-games-net-client (:constructor card-games-net--client-make)) proc game (seat nil)) -(defvar cg-net--client nil - "The active `cg-net-client', or nil when not connected.") +(defvar card-games-net--client nil + "The active `card-games-net-client', or nil when not connected.") -(defun cg-net-connected-p () +(defun card-games-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)))) + (and card-games-net--client (process-live-p (card-games-net-client-proc card-games-net--client)))) -(defun cg-net-connect (host port name game) +(defun card-games-net-connect (host port name game) "Connect to HOST on PORT as NAME, syncing into the local GAME. -Return the new `cg-net-client'." +Return the new `card-games-net-client'." (let ((proc (make-network-process - :name "cg-client" :host host :service port + :name "card-games-client" :host host :service port :family 'ipv4 :coding 'utf-8))) - (setq cg-net--client (cg-net--client-make :proc proc :game game)) + (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 - (cg-net--filter #'cg-net--client-handle + (card-games-net--filter #'card-games-net--client-handle '(welcome state full))) - (cg-net--send proc (list :type 'hello :name name)) - cg-net--client)) + (card-games-net--send proc (list :type 'hello :name name)) + card-games-net--client)) -(defun cg-net-disconnect () +(defun card-games-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)) + (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 cg-net--client-handle (_proc msg) +(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 (cg-net-client-seat cg-net--client) (plist-get msg :seat))) + ('welcome (setf (card-games-net-client-seat card-games-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))))) + (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 cg-net-send-move (move) +(defun card-games-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))) + (card-games-net--send (card-games-net-client-proc card-games-net--client) (list :type 'move :move move))) -(provide 'cg-net) -;;; cg-net.el ends here +(provide 'card-games-net) +;;; card-games-net.el ends here diff --git a/card-games-patience.el b/card-games-patience.el new file mode 100644 index 0000000..0b6f572 --- /dev/null +++ b/card-games-patience.el @@ -0,0 +1,448 @@ +;;; card-games-patience.el --- Pile solitaires (Golf, TriPeaks, Pyramid) -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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) (and card (card-games-red-suit-p (car card)))) + +(defun card-games-pat--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) + (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) + (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) + (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 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 the 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." + (append (mapcar (lambda (i) (cons 'slot i)) (card-games-pat--exposed game)) + '((waste . 0) (stock . 0)))) + +(defun card-games-pat--waste-top (game) (car (last (card-games-get game :waste)))) + +(defun card-games-pat--board-empty-p (game) + "Return non-nil when every 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 the 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 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 card from the stock 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 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) + (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 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 mark M; when two marks 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) + (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) + (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 () + (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 "") #'card-games-pat-left) + (define-key map (kbd "") #'card-games-pat-right) + (define-key map (kbd "") #'card-games-pat-left) + (define-key map (kbd "") #'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) + (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 diff --git a/card-games-president.el b/card-games-president.el new file mode 100644 index 0000000..41d15cf --- /dev/null +++ b/card-games-president.el @@ -0,0 +1,425 @@ +;;; card-games-president.el --- President (Scum), a climbing card game -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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) + (if (null card) "·" + (concat (aref card-games-pres-ranks (cdr card)) (card-games-suit-glyph (car card))))) + +(defsubst card-games-pres-red-p (card) (and card (card-games-red-suit-p (car card)))) + +(defun card-games-pres--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) (aref (card-games-get game :hands) s)) +(defsubst card-games-pres--set-hand (game s v) (aset (card-games-get game :hands) s v)) +(defsubst card-games-pres--name (_game 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)) + (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 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 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 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 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) + "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) + "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) + "Next seat after FROM that is 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 the pile; the last player to play leads (or 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 the game when only one player still holds 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 the 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) + "Seat SEAT plays 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) + "Seat SEAT passes for 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 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." + (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 AI seats until it is 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) + "Distinct ranks in 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 the 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 () + (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 "") #'card-games-pres-left) + (define-key map (kbd "") #'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 diff --git a/cg-render.el b/card-games-render.el similarity index 54% rename from cg-render.el rename to card-games-render.el index d031d93..8499958 100644 --- a/cg-render.el +++ b/card-games-render.el @@ -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 ;; Maintainer: Corwin Brust ;; 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 diff --git a/card-games-rum500.el b/card-games-rum500.el new file mode 100644 index 0000000..fb8f93e --- /dev/null +++ b/card-games-rum500.el @@ -0,0 +1,665 @@ +;;; card-games-rum500.el --- Basic Rummy and Rummy 500 -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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) (oref game ace-high)) +(defun card-games-tm--ace-15 (game) (oref game ace-15)) +(defun card-games-tm--deep-pickup (game) (oref game deep-pickup)) + +(defun card-games-tm--draw (game s) + "Move one stock card to seat S's hand; return it or nil if stock 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 the 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 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 seat S lay CARD off onto a matching table meld. Return 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 the 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) (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 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 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 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 seat S, keeping a card back 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 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 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 (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) + "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 (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 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 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 AI seats until it is 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 marks." + (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) + (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 "") #'card-games-tm-left) + (define-key map (kbd "") #'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 diff --git a/cg-rummy.el b/card-games-rummy.el similarity index 52% rename from cg-rummy.el rename to card-games-rummy.el index 98c42bf..60f39f5 100644 --- a/cg-rummy.el +++ b/card-games-rummy.el @@ -1,11 +1,10 @@ -;;; cg-rummy.el --- Rummy meld engine and Gin Rummy -*- lexical-binding: t; -*- +;;; card-games-rummy.el --- Rummy meld engine and Gin Rummy -*- lexical-binding: t; -*- ;; Copyright (C) 2026 Corwin Brust ;; Author: Corwin Brust ;; Maintainer: Corwin Brust ;; Version: 1.0.91 -;; Package-Requires: ((emacs "26.1")) ;; Keywords: games ;; URL: https://code.bru.st/corwin/card-game.el @@ -40,40 +39,40 @@ ;; 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). +;; `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 'cg-core) -(require 'cg-svg) +(require 'card-games-core) +(require 'card-games-svg) -(defconst cg-rummy-ranks +(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 cg-rummy-mark '((t :background "steelblue" :foreground "white")) +(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 cg-rummy-card-string (card) +(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) (cg-suit-glyph 'joker)) - (t (concat (aref cg-rummy-ranks (cdr card)) (cg-suit-glyph (car 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 cg-rummy-joker-p (card) +(defun card-games-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) +(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) (cg-rummy-joker-p card)) 0) + (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)) @@ -82,18 +81,18 @@ jokers value them separately." ;;;; Meld predicates -(defun cg-rummy--consec-p (ranks) +(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 cg-rummy-set-p (cards &key (min 3) distinct-suits) +(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 #'cg-rummy-joker-p cards)) + (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) @@ -101,38 +100,38 @@ With DISTINCT-SUITS, every suit must differ (a single-deck rule)." (= (length suits) (length (delete-dups (copy-sequence suits)))))))) -(cl-defun cg-rummy-run-p (cards &key (min 3) ace-high) +(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 #'cg-rummy-joker-p cards)) + (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 (cg-rummy--consec-p ranks) + (or (card-games-rummy--consec-p ranks) (and ace-high (eql (car ranks) 0) - (cg-rummy--consec-p (sort (cons 13 (cdr ranks)) #'<)))))))) + (card-games-rummy--consec-p (sort (cons 13 (cdr ranks)) #'<)))))))) -(cl-defun cg-rummy-meld-p (cards &key (min 3) ace-high distinct-suits) +(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 (cg-rummy-set-p cards :min min :distinct-suits distinct-suits) - (cg-rummy-run-p cards :min min :ace-high ace-high))) + (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 cg-rummy--combinations (lst k) +(defun card-games-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))))) + (card-games-rummy--combinations (cdr lst) (1- k))) + (card-games-rummy--combinations (cdr lst) k))))) -(defun cg-rummy--runs-in (pairs) +(defun card-games-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))) @@ -149,7 +148,7 @@ PAIRS is a list of (RANK . INDEX) sorted ascending by RANK." (setq j (1+ j)))))) res)) -(cl-defun cg-rummy--candidate-melds (cards &key ace-high) +(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." @@ -158,14 +157,14 @@ ending in an Ace are also generated." (let ((byrank (make-hash-table :test 'eql))) (dotimes (i n) (let ((c (aref vec i))) - (unless (cg-rummy-joker-p c) + (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 (cg-rummy--combinations idxs k)) - (when (cg-rummy-set-p (mapcar (lambda (i) (aref vec i)) combo) + (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)) @@ -173,28 +172,28 @@ ending in an Ace are also generated." (let ((bysuit (make-hash-table :test 'eql))) (dotimes (i n) (let ((c (aref vec i))) - (unless (cg-rummy-joker-p c) + (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 (cg-rummy--runs-in sorted)) (push (sort m #'<) melds))) + (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 (cg-rummy--runs-in sh)) (push (sort m #'<) melds))))) + (dolist (m (card-games-rummy--runs-in sh)) (push (sort m #'<) melds))))) bysuit)) (delete-dups melds))) -(cl-defun cg-rummy-best-partition (cards &key ace-high ace-15) +(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 (cg-rummy--candidate-melds cards :ace-high ace-high)) + (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)) @@ -202,7 +201,7 @@ sum. ACE-HIGH allows Q-K-A runs; ACE-15 scores Aces at 15." (memo (make-hash-table :test 'eql)) (full (1- (ash 1 n)))) (cl-labels - ((cval (i) (cg-rummy-value (aref vec i) ace-15)) + ((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) @@ -237,23 +236,23 @@ sum. ACE-HIGH allows Q-K-A runs; ACE-15 scores Aces at 15." (nreverse dl)) :count (car res)))))) -(defun cg-rummy-deadwood (cards &optional ace-high ace-15) +(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 `cg-rummy-best-partition'." - (plist-get (cg-rummy-best-partition cards :ace-high ace-high :ace-15 ace-15) +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 cg-rummy-layoff-p (card melds &optional ace-high) +(defun card-games-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)) + (card-games-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) +(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) @@ -261,35 +260,35 @@ NDECKS defaults to 1 and JOKERS to 0." (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))) + (card-games-shuffle cards))) -(defclass cg-rummy-game (cg-game) () +(defclass card-games-rummy-game (card-games-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))) +(defsubst card-games-rummy--hand (game s) (aref (card-games-get game :hands) s)) +(defsubst card-games-rummy--set-hand (game s v) (aset (card-games-get game :hands) s v)) +(defsubst card-games-rummy--top (game) (car (card-games-get game :discard))) -(defun cg-rummy-sort-hand (cards) +(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 (cg-rummy-joker-p a) 99 (car a))) - (sb (if (cg-rummy-joker-p b) 99 (car 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 cg-rummy-svg-cards t +(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 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 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 cg-rummy--svg-row (cards cursor marks hint-fn &optional region-tag) +(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). HINT-FN is an optional predicate marking playable cards." (let ((hints (when hint-fn @@ -297,35 +296,35 @@ HINT-FN is an optional predicate marking playable cards." (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) + (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 (- cg-svg-card-width 24)) 0) + (max 0 (- card-games-svg-card-width 24)) 0) :region-tag region-tag))) -(defun cg-rummy--render-cards (cards cursor marks &optional hint-fn 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 `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) +\(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 (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)) + (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 cg-rummy--board-svg (&rest args) +(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 @@ -345,7 +344,7 @@ Keyword ARGS: :title :infos :melds :discard :stock :hand :cursor :marks (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) + (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))) @@ -370,29 +369,29 @@ Keyword ARGS: :title :infos :melds :discard :stock :hand :cursor :marks 0)) (width (max (+ fanw (* 2 pad)) (+ meld-maxw (* 2 pad)) 640)) (svg (svg-create width height)) - (lc (cg-color 'shadow :foreground "gray50")) + (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 cg-svg-font-family + :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 (cg-svg-card svg xx y :rank (car sp) :suit (cdr sp)) - (cg-svg-card svg xx y :gap t)) + (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)))) - (cg-svg-card svg pad y-sd :down (> stock 0) :gap (= stock 0)) + (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 (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)) + (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) @@ -401,16 +400,16 @@ Keyword ARGS: :title :infos :melds :discard :stock :hand :cursor :marks (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) + (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 (cg-rummy--card-spec c)) + (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)))) - (cg-svg-card svg x y-hand :rank (car sp) :suit (cdr sp) + (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) @@ -418,118 +417,118 @@ Keyword ARGS: :title :infos :melds :discard :stock :hand :cursor :marks (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)))) + (propertize "*" 'display (card-games-svg-image svg (card-games-scale)) + 'card-games-regions (nreverse regions)))) -(defun cg-rummy--melds-string (melds) +(defun card-games-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 " ")) + (mapconcat (lambda (m) (mapconcat #'card-games-rummy-card-string m " ")) melds " | ")) ;;;; Gin Rummy -(defcustom cg-gin-target 100 +(defcustom card-games-gin-target 100 "Points needed to win a game of Gin Rummy." :type 'integer :group 'card-games) -(defclass cg-gin-game (cg-rummy-game) +(defclass card-games-gin-game (card-games-rummy-game) ((vname :initform "Gin Rummy")) "A two-handed game of Gin Rummy.") -(cl-defmethod cg-gin--deal ((game cg-gin-game)) +(cl-defmethod card-games-gin--deal ((game card-games-gin-game)) "Deal a fresh Gin hand into GAME." - (let ((deck (cg-rummy-deck)) (hands (make-vector 2 nil))) + (let ((deck (card-games-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 + (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 cg-gin--deadwood (cards) (cg-rummy-deadwood cards)) +(defun card-games-gin--deadwood (cards) (card-games-rummy-deadwood cards)) -(defun cg-gin--draw (game s) +(defun card-games-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))) + (let ((stock (card-games-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))) + (card-games-put game :stock stock) + (card-games-rummy--set-hand game s (cons c (card-games-rummy--hand game s))) c)))) -(defun cg-gin--take (game s) +(defun card-games-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))) + (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 cg-gin--discard (game s card) +(defun card-games-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)))) + (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 cg-gin--ai-best-discard (game s) +(defun card-games-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)) + (let ((hand (card-games-rummy--hand game s)) (best nil) (bestv most-positive-fixnum)) (dolist (c hand best) - (let ((d (cg-gin--deadwood (remove c hand)))) + (let ((d (card-games-gin--deadwood (remove c hand)))) (when (or (< d bestv) (and (= d bestv) best - (> (cg-rummy-value c) (cg-rummy-value best)))) + (> (card-games-rummy-value c) (card-games-rummy-value best)))) (setq best c bestv d)))))) -(cl-defmethod cg-gin--ai-turn ((game cg-gin-game) s) +(cl-defmethod card-games-gin--ai-turn ((game card-games-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)))) + (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)) - (cg-gin--take game s) - (cg-gin--draw game s)))) + (card-games-gin--take game s) + (card-games-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)))) + (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) - (cg-gin--knock game s) - (cg-put game :turn 0) - (cg-put game :step 'draw) - (cg-put game :message + (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." - (cg-rummy-card-string card))))))))) + (card-games-rummy-card-string card))))))))) -(cl-defmethod cg-gin--knock ((game cg-gin-game) knocker) +(cl-defmethod card-games-gin--knock ((game card-games-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))) + (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 (cg-rummy-best-partition (cg-rummy--hand game opp))) + (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 (cg-rummy-layoff-p c kmelds))) + (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 #'cg-rummy-value odead))) - (scores (cg-get game :scores)) + (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!")) @@ -537,250 +536,250 @@ Keyword ARGS: :title :infos :melds :discard :stock :hand :cursor :marks (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 + (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) cg-gin-target) - (progn (cg-put game :phase 'game-over) + (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 cg-gin--exhaust ((game cg-gin-game)) +(cl-defmethod card-games-gin--exhaust ((game card-games-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.")) + (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 cg-gin--game nil "The Gin Rummy game in the current buffer.") +(defvar-local card-games-gin--game nil "The Gin Rummy game in the current buffer.") -(defun cg-gin--svg (game) +(defun card-games-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 '())) + (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 (cg-rummy--hand game 1)) (aref scores 1)) infos) + (length (card-games-rummy--hand game 1)) (aref scores 1)) infos) (when reveal - (let ((pp (cg-rummy-best-partition (cg-rummy--hand game 1)))) + (let ((pp (card-games-rummy-best-partition (card-games-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) " ") + (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" - (cg-gin--deadwood hand) (aref scores 0)) infos) - (cg-rummy--board-svg - :title (format "Gin Rummy (first to %d)" cg-gin-target) + (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 (cg-rummy--top game) :stock (length (cg-get game :stock)) - :hand hand :cursor (cg-get game :cursor) - :message (cg-get game :message)))) + :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 cg-render ((game cg-gin-game)) +(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 cg-rummy-svg-cards (display-graphic-p)) - (cg-gin--svg game) - (cg-gin--render-text game))) + (if (and card-games-rummy-svg-cards (display-graphic-p)) + (card-games-gin--svg game) + (card-games-gin--render-text game))) -(defun cg-gin--render-text (game) +(defun card-games-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) + (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 (cg-rummy--hand game 1)) (aref scores 1)) out) + (length (card-games-rummy--hand game 1)) (aref scores 1)) out) (when reveal - (let ((p (cg-rummy-best-partition (cg-rummy--hand game 1)))) + (let ((p (card-games-rummy-best-partition (card-games-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) " ") + (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 (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))) + (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 " - (cg-gin--deadwood hand) (aref scores 0)) out) - (push (cg-rummy--render-cards hand cursor nil nil 'hand) out) + (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 (cg-rummy-best-partition hand))) + (let ((p (card-games-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) " ")) + (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" (cg-get game :message)) out) + (push (format "\n\n %s\n" (card-games-get game :message)) out) (apply #'concat (nreverse out)))) -(cl-defmethod cg-render-apply ((g cg-gin-game) action) +(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) (cg-put g :cursor i)) + (`(hand . ,i) (card-games-put g :cursor i)) (_ (cl-call-next-method)))) -(defun cg-gin--redisplay () +(defun card-games-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) + (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 (cg-get game :step) (cg-get game :phase)))) - (erase-buffer) (insert (cg-render game)) (goto-char (point-min)))) + (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 cg-gin--cursor-card () +(defun card-games-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))) + (nth (card-games-get card-games-gin--game :cursor) (card-games-rummy--hand card-games-gin--game 0))) -(defun cg-gin-left () +(defun card-games-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))) + (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 cg-gin-right () +(defun card-games-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))) + (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 cg-gin--my-turn-p (g) +(defun card-games-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))) + (and (eq (card-games-get g :phase) 'play) (= (card-games-get g :turn) 0))) -(defun cg-gin-draw-stock () +(defun card-games-gin-draw-stock () "Draw the top stock card into your hand." (interactive) - (let ((g cg-gin--game)) + (let ((g card-games-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))) + ((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 cg-gin-take-discard () +(defun card-games-gin-take-discard () "Take the discard top into your hand." (interactive) - (let ((g cg-gin--game)) + (let ((g card-games-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 + ((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." - (cg-rummy-card-string c)))))) - (cg-gin--redisplay))) + (card-games-rummy-card-string c)))))) + (card-games-gin--redisplay))) -(defun cg-gin--after-discard (g) +(defun card-games-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)) + (card-games-put g :turn 1) + (card-games-put g :step 'draw) + (card-games-gin--ai-turn g 1) + (card-games-gin--redisplay)) -(defun cg-gin-discard () +(defun card-games-gin-discard () "Discard the selected card and end your turn." (interactive) - (let* ((g cg-gin--game) (card (cg-gin--cursor-card))) + (let* ((g card-games-gin--game) (card (card-games-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))))) + ((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 cg-gin-knock () +(defun card-games-gin-knock () "Knock, discarding the selected card, if your deadwood allows." (interactive) - (let* ((g cg-gin--game) (card (cg-gin--cursor-card))) + (let* ((g card-games-gin--game) (card (card-games-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))))) + ((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) - (cg-put g :message + (card-games-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))) + (card-games-gin--discard g 0 card) + (card-games-gin--knock g 0))))) + (card-games-gin--redisplay))) -(defun cg-gin-new () +(defun card-games-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))) + (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 cg-gin-redraw () "Redraw the board." (interactive) (cg-gin--redisplay)) +(defun card-games-gin-redraw () "Redraw the board." (interactive) (card-games-gin--redisplay)) -(defun cg-gin-help () +(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 cg-gin-mode-map +(defvar card-games-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 "") #'cg-gin-left) - (define-key map (kbd "") #'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) + (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 "") #'card-games-gin-left) + (define-key map (kbd "") #'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 `cg-gin-mode'.") + "Keymap for `card-games-gin-mode'.") -(define-derived-mode cg-gin-mode special-mode "Gin" +(define-derived-mode card-games-gin-mode special-mode "Gin" "Major mode for Gin Rummy." (setq-local truncate-lines t) - (setq-local cursor-type cg-cursor-type)) + (setq-local cursor-type card-games-cursor-type)) ;;;###autoload -(defun cg-gin () +(defun card-games-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)) + (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 'cg-gin-rummy #'cg-gin) +(defalias 'card-games-gin-rummy #'card-games-gin) -(provide 'cg-rummy) -;;; cg-rummy.el ends here +(provide 'card-games-rummy) +;;; card-games-rummy.el ends here diff --git a/card-games-scopa.el b/card-games-scopa.el new file mode 100644 index 0000000..7a58438 --- /dev/null +++ b/card-games-scopa.el @@ -0,0 +1,438 @@ +;;; card-games-scopa.el --- Scopa and Casino, capturing games -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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 captures only equal-rank cards (no sums).") +(cl-defmethod card-games-fish--face-pair-p ((_game card-games-fish-game) _card) 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) (aref (card-games-get game :hands) s)) +(defsubst card-games-fish--set-hand (game s v) (aset (card-games-get game :hands) s v)) +(defsubst card-games-fish--captured (game s) (aref (card-games-get game :captured) s)) + +(defun card-games-fish--who (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: shuffle, deal the table and the 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 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) + (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) + "Seat S plays CARD: capture if possible, else trail it on the table." + (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 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 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 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 AI seats until it is 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 () + (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 "") #'card-games-fish-left) + (define-key map (kbd "") #'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: 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: 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 diff --git a/card-games-solitaire.el b/card-games-solitaire.el new file mode 100644 index 0000000..7cfa79e --- /dev/null +++ b/card-games-solitaire.el @@ -0,0 +1,1016 @@ +;;; card-games-solitaire.el --- Tableau solitaires (Klondike, FreeCell, Spider, Yukon) -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; Commentary: + +;; A shared engine for tableau solitaires, with four games built on it: +;; +;; `card-games-klondike' -- the classic "Solitaire": seven columns, a stock and +;; waste, build the foundations up by suit from the Ace. +;; `card-games-freecell' -- all cards dealt face up, four free cells, no stock; +;; a game of nearly pure skill. +;; `card-games-spider' -- two decks, ten columns; build down regardless of suit +;; but only same-suit runs move; clear eight K..A runs. +;; `card-games-yukon' -- Klondike's layout, all face up, move any buried group. +;; +;; Cards are the package-standard cons (SUIT . RANK) with SUIT 0 spades, +;; 1 clubs, 2 diamonds, 3 hearts and RANK 0 Ace .. 12 King. Each tableau +;; column is a list ordered bottom (screen top) to top (the accessible +;; card); a per-column face-down count tracks the hidden prefix. +;; +;; Play is by keyboard: move the cursor between piles with the arrow keys +;; and press RET to pick up the movable run from a pile, then RET again on +;; a destination to drop it. `f' sends a card to a foundation, `a' auto- +;; plays everything it can, and the stock pile deals or recycles on RET. + +;;; Code: + +(require 'cl-lib) +(require 'eieio) +(require 'card-games-core) +(require 'card-games-svg) +(require 'card-games-render) + +;;;; Cards + +(defconst card-games-sol-ranks + ["A" "2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K"] + "Rank labels indexed 0..12 (Ace through King).") + +(defun card-games-sol-card-string (card &optional down) + "Return a short string for CARD. +With DOWN non-nil, draw a face-down back instead. A nil CARD draws an +empty-slot dot." + (cond (down "##") + ((null card) "·") + (t (concat (aref card-games-sol-ranks (cdr card)) (card-games-suit-glyph (car card)))))) + +(defsubst card-games-sol-red-p (card) + "Return non-nil when CARD is a red suit." + (and card (card-games-red-suit-p (car card)))) + +(defun card-games-sol--make-deck (ndecks) + "Return a shuffled list of NDECKS standard 52-card decks." + (random t) + (let ((cards nil)) + (dotimes (_ ndecks) + (dotimes (s 4) + (dotimes (r 13) + (push (cons s r) cards)))) + (card-games-shuffle cards))) + +;;;; Game classes + +(defclass card-games-solitaire-game (card-games-game) + ((ncols :initform 7 :documentation "Number of tableau columns.") + (ndecks :initform 1 :documentation "Number of 52-card decks used.") + (nfound :initform 4 :documentation "Number of foundation piles.") + (nfree :initform 0 :documentation "Number of free cells.") + (has-stock :initform nil :documentation "Whether a stock pile exists.") + (has-waste :initform nil :documentation "Whether a waste pile exists.") + (build :initform 'alt :documentation "Tableau placement rule: alt, suit, any.") + (run-rule :initform 'alt :documentation "Movable-run cohesion: alt, suit, any.") + (empty-rule :initform 'king :documentation "Empty-column rule: king or any.") + (redeal :initform t :documentation "Whether an empty stock recycles the waste.") + (draw :initform 1 :documentation "Cards turned from the stock to the waste.") + (target-sets :initform 8 :documentation "Completed runs to win when NFOUND is 0.") + (base :initform 0 :documentation "Foundation base rank (0 = Ace).") + (wrap :initform nil :documentation "Whether foundations wrap King to Ace.") + (has-reserve :initform nil :documentation "Whether a reserve pile exists (Canfield).") + (vname :initform "Solitaire" :documentation "Display name.")) + "Abstract base for tableau solitaires." + :abstract t) + +(defclass card-games-klondike-game (card-games-solitaire-game) + ((has-stock :initform t) (has-waste :initform t) + (vname :initform "Klondike")) + "Klondike: seven columns, stock and waste, foundations up by suit.") + +(defclass card-games-freecell-game (card-games-solitaire-game) + ((ncols :initform 8) (nfree :initform 4) (empty-rule :initform 'any) + (vname :initform "FreeCell")) + "FreeCell: eight columns dealt face up, four free cells, no stock.") + +(defclass card-games-yukon-game (card-games-solitaire-game) + ((run-rule :initform 'any) (vname :initform "Yukon")) + "Yukon: Klondike layout dealt mostly face up; move any buried group.") + +(defclass card-games-spider-game (card-games-solitaire-game) + ((ncols :initform 10) (ndecks :initform 2) (nfound :initform 0) + (has-stock :initform t) (build :initform 'any) (run-rule :initform 'suit) + (empty-rule :initform 'any) (vname :initform "Spider")) + "Spider: two decks, ten columns; clear eight K..A same-suit runs.") + +;;;; Rules (predicates) + +(defun card-games-sol--diff-color-p (a b) + "Return non-nil when cards A and B are of opposite colours." + (not (eq (card-games-red-suit-p (car a)) (card-games-red-suit-p (car b))))) + +(cl-defmethod card-games-sol--link-p ((game card-games-solitaire-game) upper lower) + "Return non-nil when LOWER may rest directly on UPPER within a run." + (pcase (oref game run-rule) + ('any t) + ('suit (and (= (cdr lower) (1- (cdr upper))) (= (car lower) (car upper)))) + (_ (and (= (cdr lower) (1- (cdr upper))) (card-games-sol--diff-color-p upper lower))))) + +(cl-defmethod card-games-sol--place-p ((game card-games-solitaire-game) top card) + "Return non-nil when CARD may be placed on a column whose top is TOP." + (pcase (oref game build) + ('any (= (cdr card) (1- (cdr top)))) + ('suit (and (= (cdr card) (1- (cdr top))) (= (car card) (car top)))) + (_ (and (= (cdr card) (1- (cdr top))) (card-games-sol--diff-color-p top card))))) + +(cl-defmethod card-games-sol--empty-accepts ((game card-games-solitaire-game) card) + "Return non-nil when CARD may be placed on an empty column." + (pcase (oref game empty-rule) + ('king (= (cdr card) 12)) + (_ t))) + +;;;; Layout and dealing + +(cl-defgeneric card-games-sol--layout (game) + "Return a list of (DOWN . UP) card counts, one per tableau column.") + +(cl-defmethod card-games-sol--layout ((_ card-games-klondike-game)) + (cl-loop for i below 7 collect (cons i 1))) +(cl-defmethod card-games-sol--layout ((_ card-games-yukon-game)) + (cons (cons 0 1) (cl-loop for i from 1 below 7 collect (cons i 5)))) +(cl-defmethod card-games-sol--layout ((_ card-games-freecell-game)) + (append (make-list 4 (cons 0 7)) (make-list 4 (cons 0 6)))) +(cl-defmethod card-games-sol--layout ((_ card-games-spider-game)) + (append (make-list 4 (cons 5 1)) (make-list 6 (cons 4 1)))) + +(cl-defmethod card-games-sol--deal ((game card-games-solitaire-game)) + "Deal a fresh layout into GAME and initialise its environment." + (let* ((deck (card-games-sol--make-deck (oref game ndecks))) + (nc (oref game ncols)) + (layout (card-games-sol--layout game)) + (tableau (make-vector nc nil)) + (down (make-vector nc 0))) + (dotimes (c nc) + (let* ((spec (nth c layout)) + (col nil)) + (dotimes (_ (+ (car spec) (cdr spec))) + (push (pop deck) col)) + (aset tableau c (nreverse col)) + (aset down c (car spec)))) + (card-games-put game :tableau tableau) + (card-games-put game :down down) + (card-games-put game :found (make-vector (oref game nfound) nil)) + (card-games-put game :free (make-vector (oref game nfree) nil)) + (card-games-put game :stock deck) + (card-games-put game :waste nil) + (card-games-put game :sets 0) + (card-games-put game :moves 0) + (card-games-put game :cursor 0) + (card-games-put game :sel nil) + (card-games-put game :sel-n 0) + (card-games-put game :history nil) + (card-games-put game :message + (format "%s. Arrows move; RET picks up/drops; f=foundation; a=auto; ?=help." + (oref game vname))) + game)) + +;;;; Spots (the cursor visits piles) + +(cl-defmethod card-games-sol--spots ((game card-games-solitaire-game)) + "Return the ordered list of (TYPE . INDEX) piles the cursor can visit." + (append + (when (oref game has-stock) '((stock . 0))) + (when (oref game has-waste) '((waste . 0))) + (when (oref game has-reserve) '((reserve . 0))) + (cl-loop for i below (oref game nfree) collect (cons 'free i)) + (cl-loop for i below (oref game nfound) collect (cons 'found i)) + (cl-loop for i below (oref game ncols) collect (cons 'col i)))) + +(defun card-games-sol--cur-spot (game) + "Return the (TYPE . INDEX) spot currently under the cursor." + (nth (card-games-get game :cursor) (card-games-sol--spots game))) + +;;;; Pile access helpers + +(defun card-games-sol--col (game c) "Column C of GAME (a list)." (aref (card-games-get game :tableau) c)) +(defun card-games-sol--set-col (game c v) (aset (card-games-get game :tableau) c v)) +(defun card-games-sol--down (game c) "Face-down count of column C." (aref (card-games-get game :down) c)) +(defun card-games-sol--set-down (game c v) (aset (card-games-get game :down) c v)) + +(defun card-games-sol--col-top (game c) + "Return the top (accessible) card of column C, or nil." + (car (last (card-games-sol--col game c)))) + +(defun card-games-sol--exposed (game c) + "Return the face-up cards of column C (bottom..top order)." + (nthcdr (card-games-sol--down game c) (card-games-sol--col game c))) + +(cl-defmethod card-games-sol--top-run ((game card-games-solitaire-game) c) + "Return the longest movable run from the top of column C (bottom..top)." + (let ((top->bottom (reverse (card-games-sol--exposed game c)))) + (if (null top->bottom) + nil + (let ((run (list (car top->bottom))) + (prev (car top->bottom))) + (catch 'done + (dolist (card (cdr top->bottom)) + (if (card-games-sol--link-p game card prev) + (progn (push card run) (setq prev card)) + (throw 'done nil)))) + run)))) + +(defun card-games-sol--spot-top (game spot) + "Return the top card available at SPOT, or nil." + (pcase (car spot) + ('col (card-games-sol--col-top game (cdr spot))) + ('waste (car (last (card-games-get game :waste)))) + ('free (aref (card-games-get game :free) (cdr spot))) + ('found (car (last (aref (card-games-get game :found) (cdr spot))))) + ('reserve (car (last (card-games-get game :reserve)))) + (_ nil))) + +;;;; Foundations + +(defun card-games-sol--found-accepts (game i card) + "Return non-nil when CARD may go onto foundation I of GAME." + (and card + (let ((f (aref (card-games-get game :found) i))) + (if (null f) + (= (cdr card) (oref game base)) ; empty foundation takes the base rank + (let* ((top (car (last f))) + (need (if (oref game wrap) (mod (1+ (cdr top)) 13) (1+ (cdr top))))) + (and (= (car card) (car top)) + (= (cdr card) need))))))) + +(defun card-games-sol--found-for (game card) + "Return the index of a foundation that would accept CARD, or nil." + (cl-loop for i below (oref game nfound) + when (card-games-sol--found-accepts game i card) return i)) + +;;;; Move primitives + +(defun card-games-sol--snapshot (game) + "Push a deep-ish copy of GAME's mutable state onto the undo history." + (let ((tab (card-games-get game :tableau)) + (frv (card-games-get game :found)) + (fre (card-games-get game :free))) + (card-games-put game :history + (cons (list (vconcat (mapcar #'copy-sequence tab)) + (copy-sequence (card-games-get game :down)) + (vconcat (mapcar #'copy-sequence frv)) + (copy-sequence fre) + (copy-sequence (card-games-get game :stock)) + (copy-sequence (card-games-get game :waste)) + (card-games-get game :sets) + (card-games-get game :moves) + (copy-sequence (card-games-get game :reserve))) + (card-games-get game :history))))) + +(defun card-games-sol--restore (game) + "Pop and restore the most recent undo snapshot of GAME, if any." + (let ((h (card-games-get game :history))) + (when h + (cl-destructuring-bind (tab down frv fre stock waste sets moves reserve) (car h) + (card-games-put game :tableau tab) + (card-games-put game :down down) + (card-games-put game :found frv) + (card-games-put game :free fre) + (card-games-put game :stock stock) + (card-games-put game :waste waste) + (card-games-put game :sets sets) + (card-games-put game :moves moves) + (card-games-put game :reserve reserve)) + (card-games-put game :history (cdr h)) + (card-games-put game :sel nil) + t))) + +(defun card-games-sol--flip (game c) + "Flip the top of column C face up if it is face down." + (let ((len (length (card-games-sol--col game c))) + (d (card-games-sol--down game c))) + (when (and (> len 0) (>= d len)) + (card-games-sol--set-down game c (1- len))))) + +(defun card-games-sol--take (game spot n) + "Remove and return the top N cards (bottom..top order) from SPOT." + (pcase (car spot) + ('col (let* ((c (cdr spot)) (col (card-games-sol--col game c)) + (run (last col n))) + (card-games-sol--set-col game c (butlast col n)) + (let ((len (length (card-games-sol--col game c)))) + (when (> (card-games-sol--down game c) len) + (card-games-sol--set-down game c len))) + (card-games-sol--flip game c) + run)) + ('waste (let ((w (card-games-get game :waste))) + (card-games-put game :waste (butlast w 1)) (last w 1))) + ('free (let ((card (aref (card-games-get game :free) (cdr spot)))) + (aset (card-games-get game :free) (cdr spot) nil) (list card))) + ('found (let* ((i (cdr spot)) (f (aref (card-games-get game :found) i))) + (aset (card-games-get game :found) i (butlast f 1)) (last f 1))) + ('reserve (let ((r (card-games-get game :reserve))) + (card-games-put game :reserve (butlast r 1)) (last r 1))) + (_ nil))) + +(defun card-games-sol--can-drop (game spot cards) + "Return non-nil when the run CARDS (bottom..top) may drop on SPOT." + (and cards + (pcase (car spot) + ('col (let* ((c (cdr spot)) (top (card-games-sol--col-top game c))) + (if top + (card-games-sol--place-p game top (car cards)) + (card-games-sol--empty-accepts game (car cards))))) + ('found (and (= 1 (length cards)) + (card-games-sol--found-accepts game (cdr spot) (car cards)))) + ('free (and (= 1 (length cards)) + (null (aref (card-games-get game :free) (cdr spot))))) + (_ nil)))) + +(defun card-games-sol--drop (game spot cards) + "Place the run CARDS (bottom..top) onto SPOT." + (pcase (car spot) + ('col (let ((c (cdr spot))) + (card-games-sol--set-col game c (append (card-games-sol--col game c) cards)))) + ('found (let ((i (cdr spot))) + (aset (card-games-get game :found) i + (append (aref (card-games-get game :found) i) cards)))) + ('free (aset (card-games-get game :free) (cdr spot) (car cards))))) + +;;;; Spider: complete-run removal + +(cl-defmethod card-games-sol--harvest ((game card-games-solitaire-game)) + "Remove any complete K..A same-suit run from a column top; bump :sets. +Only games without foundations (NFOUND 0: Spider, Scorpion) harvest runs." + (when (= 0 (oref game nfound)) + (dotimes (c (oref game ncols)) + (let* ((col (card-games-sol--col game c)) + (exp (card-games-sol--exposed game c))) + (when (>= (length exp) 13) + (let ((run (last exp 13)) (ok t) (suit (car (nth 0 (last exp 13))))) + (cl-loop for k below 13 + for card = (nth k run) + unless (and (= (car card) suit) (= (cdr card) (- 12 k))) + do (setq ok nil)) + (when ok + (card-games-sol--set-col game c (butlast col 13)) + (let ((len (length (card-games-sol--col game c)))) + (when (> (card-games-sol--down game c) len) (card-games-sol--set-down game c len))) + (card-games-sol--flip game c) + (card-games-put game :sets (1+ (card-games-get game :sets)))))))))) + +;;;; Stock action + +(defcustom card-games-sol-klondike-draw 1 + "Number of cards turned from the stock to the waste in Klondike." + :type '(choice (const :tag "Draw one" 1) (const :tag "Draw three" 3)) + :group 'card-games) + +(cl-defmethod card-games-sol--stock-action ((game card-games-solitaire-game)) + "Deal `draw' cards to the waste, recycling the waste when `redeal'." + (if (not (oref game has-waste)) + (card-games-put game :message "No stock to deal.") + (card-games-sol--snapshot game) + (let ((stock (card-games-get game :stock)) (waste (card-games-get game :waste))) + (if stock + (let ((n (min (oref game draw) (length stock)))) + (dotimes (_ n) + (setq waste (append waste (last stock 1))) + (setq stock (butlast stock 1))) + (card-games-put game :stock stock) (card-games-put game :waste waste) + (card-games-put game :message "Dealt from stock.")) + (if (and (oref game redeal) waste) + (progn (card-games-put game :stock (reverse waste)) (card-games-put game :waste nil) + (card-games-put game :message "Recycled the waste into the stock.")) + (card-games-put game :message "The stock is empty.")))))) + +(cl-defmethod card-games-sol--stock-action ((game card-games-klondike-game)) + (card-games-sol--snapshot game) + (let ((stock (card-games-get game :stock)) (waste (card-games-get game :waste))) + (if stock + (let ((n (min card-games-sol-klondike-draw (length stock)))) + (dotimes (_ n) + (setq waste (append waste (last stock 1))) + (setq stock (butlast stock 1))) + (card-games-put game :stock stock) (card-games-put game :waste waste) + (card-games-put game :message "Dealt from stock.")) + (if waste + (progn (card-games-put game :stock (reverse waste)) (card-games-put game :waste nil) + (card-games-put game :message "Recycled the waste into the stock.")) + (card-games-put game :message "Stock and waste are both empty."))))) + +(cl-defmethod card-games-sol--stock-action ((game card-games-spider-game)) + (let ((stock (card-games-get game :stock))) + (cond + ((null stock) (card-games-put game :message "The stock is empty.")) + ((cl-loop for c below (oref game ncols) + thereis (null (card-games-sol--col game c))) + (card-games-put game :message "Fill every column before dealing from the stock.")) + (t (card-games-sol--snapshot game) + (dotimes (c (oref game ncols)) + (card-games-sol--set-col game c (append (card-games-sol--col game c) (last stock 1))) + (setq stock (butlast stock 1))) + (card-games-put game :stock stock) + (card-games-sol--harvest game) + (card-games-put game :message "Dealt a row from the stock."))))) + +;;;; Win + +(cl-defmethod card-games-won-p ((game card-games-solitaire-game)) + "Return non-nil when GAME is solved." + (if (= 0 (oref game nfound)) + (>= (card-games-get game :sets) (oref game target-sets)) + (cl-every (lambda (f) (= 13 (length f))) + (append (card-games-get game :found) nil)))) + +;;;; Interaction + +(defvar-local card-games-sol--game nil "The solitaire game in the current buffer.") + +(cl-defmethod card-games-sol--selectable ((game card-games-solitaire-game) spot) + "Return the run (bottom..top) GAME would pick up from SPOT, or nil." + (pcase (car spot) + ('col (card-games-sol--top-run game (cdr spot))) + ('waste (let ((c (card-games-sol--spot-top game spot))) (and c (list c)))) + ('free (let ((c (card-games-sol--spot-top game spot))) (and c (list c)))) + ('found (let ((c (card-games-sol--spot-top game spot))) (and c (list c)))) + ('reserve (let ((c (card-games-sol--spot-top game spot))) (and c (list c)))) + (_ nil))) + +(defun card-games-sol-act (&optional count) + "Pick up from, or drop onto, the pile under the cursor. +With prefix COUNT, pick up exactly COUNT cards from a column." + (interactive "P") + (let* ((game card-games-sol--game) + (spot (card-games-sol--cur-spot game)) + (sel (card-games-get game :sel))) + (cond + ((eq (car spot) 'stock) + (card-games-put game :sel nil) + (card-games-sol--stock-action game)) + ((null sel) + (let ((run (card-games-sol--selectable game spot))) + (cond + ((null run) (card-games-put game :message "Nothing to pick up there.")) + (t (when (and count (eq (car spot) 'col)) + (setq run (last run (min (prefix-numeric-value count) (length run))))) + (card-games-put game :sel spot) + (card-games-put game :sel-n (length run)) + (card-games-put game :message + (format "Picked up %d card%s. RET on a destination." + (length run) (if (= 1 (length run)) "" "s"))))))) + ((equal sel spot) + (card-games-put game :sel nil) (card-games-put game :message "Cancelled.")) + (t + (let* ((n (card-games-get game :sel-n)) + (cards (last (pcase (car sel) + ('col (card-games-sol--col game (cdr sel))) + ('waste (card-games-get game :waste)) + ('found (aref (card-games-get game :found) (cdr sel))) + ('free (list (aref (card-games-get game :free) (cdr sel))))) + n))) + (if (card-games-sol--can-drop game spot cards) + (progn (card-games-sol--snapshot game) + (card-games-sol--take game sel n) + (card-games-sol--drop game spot cards) + (card-games-put game :moves (1+ (card-games-get game :moves))) + (card-games-sol--harvest game) + (card-games-put game :sel nil) + (card-games-put game :message "Moved.")) + (card-games-put game :sel nil) + (card-games-put game :message "That move is not allowed.")))))) + (card-games-sol--after card-games-sol--game)) + +(defun card-games-sol-to-foundation () + "Send the top card of the pile under the cursor to a foundation." + (interactive) + (let* ((game card-games-sol--game) + (spot (card-games-sol--cur-spot game)) + (card (card-games-sol--spot-top game spot))) + (if (and card (memq (car spot) '(col waste free reserve))) + (let ((i (card-games-sol--found-for game card))) + (if i + (progn (card-games-sol--snapshot game) + (card-games-sol--take game spot 1) + (card-games-sol--drop game (cons 'found i) (list card)) + (card-games-put game :moves (1+ (card-games-get game :moves))) + (card-games-put game :sel nil) + (card-games-put game :message "To the foundation.")) + (card-games-put game :message "No foundation will take that card."))) + (card-games-put game :message "Nothing to send to a foundation."))) + (card-games-sol--after card-games-sol--game)) + +(defun card-games-sol-auto () + "Repeatedly send any eligible card to the foundations." + (interactive) + (let ((game card-games-sol--game) (moved 0)) + (when (> (oref game nfound) 0) + (card-games-sol--snapshot game) + (let (again) + (cl-loop + do (setq again nil) + (dolist (spot (card-games-sol--spots game)) + (when (memq (car spot) '(col waste free reserve)) + (let* ((card (card-games-sol--spot-top game spot)) + (i (and card (card-games-sol--found-for game card)))) + (when i + (card-games-sol--take game spot 1) + (card-games-sol--drop game (cons 'found i) (list card)) + (setq moved (1+ moved) again t))))) + while again)) + (if (> moved 0) + (progn (card-games-put game :moves (+ moved (card-games-get game :moves))) + (card-games-put game :sel nil) + (card-games-put game :message (format "Auto-played %d card%s." + moved (if (= 1 moved) "" "s")))) + (card-games-put game :history (cdr (card-games-get game :history))) + (card-games-put game :message "Nothing to auto-play.")))) + (card-games-sol--after card-games-sol--game)) + +(defun card-games-sol-undo () + "Undo the last move." + (interactive) + (let ((game card-games-sol--game)) + (if (card-games-sol--restore game) + (card-games-put game :message "Undid a move.") + (card-games-put game :message "Nothing to undo.")) + (card-games-sol--redisplay))) + +(defun card-games-sol--move (delta) + "Move the cursor by DELTA spots." + (let* ((game card-games-sol--game) + (n (length (card-games-sol--spots game))) + (cur (card-games-get game :cursor))) + (card-games-put game :cursor (mod (+ cur delta) n)) + (card-games-sol--redisplay))) + +(defun card-games-sol-left () "Move cursor left." (interactive) (card-games-sol--move -1)) +(defun card-games-sol-right () "Move cursor right." (interactive) (card-games-sol--move 1)) +(defun card-games-sol-up () "Move cursor left (previous pile)." (interactive) (card-games-sol--move -1)) +(defun card-games-sol-down () "Move cursor right (next pile)." (interactive) (card-games-sol--move 1)) + +(defun card-games-sol--after (game) + "Fill empty columns from the reserve, redisplay GAME, and announce a win." + (card-games-sol--autofill game) + (card-games-sol--redisplay) + (when (card-games-won-p game) + (card-games-put game :message "You won! Press n for a new game.") + (card-games-sol--redisplay) + (message "Solved! Well played."))) + +(defun card-games-sol-new () + "Start a fresh deal of the same game." + (interactive) + (let ((game card-games-sol--game)) + (card-games-sol--deal game) + (card-games-sol--redisplay))) + +(defun card-games-sol-help () + "Describe the controls." + (interactive) + (message "Arrows: move RET: pick up/drop f: to foundation a: auto u: undo n: new g: redraw")) + +(defun card-games-sol-redraw () "Redraw the board." (interactive) (card-games-sol--redisplay)) + +;;;; Rendering (console) + +(defun card-games-sol--render-card (card down sel cursor) + "Return a propertized 3-column cell for CARD (DOWN, SEL, CURSOR flags)." + (let* ((s (card-games-sol-card-string card down)) + (faces nil)) + (when (and card (not down) (card-games-sol-red-p card)) (push 'card-games-red-suit faces)) + (when down (push 'card-games-gap faces)) + (when sel (push 'card-games-hint faces)) + (when cursor (push 'card-games-cursor faces)) + (propertize (format "%3s " s) 'face (or faces 'default)))) + +(defcustom card-games-sol-svg-cards t + "When non-nil, draw the solitaire board as SVG on a graphical display." + :type 'boolean :group 'card-games) + +(defun card-games-sol--spec (card) + "Return the card-games-svg display spec (RANK-STRING . SUIT) for CARD, or nil." + (and card (cons (aref card-games-sol-ranks (cdr card)) (car card)))) + +(defun card-games-sol--svg (game) + "Return (DISPLAY . REGIONS) for an SVG board of solitaire GAME. +DISPLAY is a propertized one-image string; REGIONS is a click map of +\(RECT . SPOT) entries, RECT being (X Y W H) in unscaled image pixels." + (let* ((w card-games-svg-card-width) (h card-games-svg-card-height) + (pad 12) (gap card-games-svg-card-gap) (colgap 8) (vdown 12) (vup 26) + (ncols (oref game ncols)) + (cur-spot (card-games-sol--cur-spot game)) + (sel (card-games-get game :sel)) (sel-n (or (card-games-get game :sel-n) 0)) + (lc (card-games-color 'shadow :foreground "gray40")) + (regions '()) (slots '())) + (when (oref game has-stock) + (push (list (format "Stock(%d)" (length (card-games-get game :stock))) + nil (and (card-games-get game :stock) t) (equal cur-spot '(stock . 0)) + '(stock . 0)) slots)) + (when (oref game has-waste) + (push (list "Waste" (card-games-sol--spec (car (last (card-games-get game :waste)))) nil + (equal cur-spot '(waste . 0)) '(waste . 0)) slots)) + (when (oref game has-reserve) + (push (list (format "Resv(%d)" (length (card-games-get game :reserve))) + (card-games-sol--spec (car (last (card-games-get game :reserve)))) nil + (equal cur-spot '(reserve . 0)) '(reserve . 0)) slots)) + (dotimes (i (oref game nfree)) + (push (list (format "F%d" (1+ i)) (card-games-sol--spec (aref (card-games-get game :free) i)) nil + (equal cur-spot (cons 'free i)) (cons 'free i)) slots)) + (dotimes (i (oref game nfound)) + (push (list (format "%d" (1+ i)) + (card-games-sol--spec (car (last (aref (card-games-get game :found) i)))) nil + (equal cur-spot (cons 'found i)) (cons 'found i)) slots)) + (setq slots (nreverse slots)) + (let* ((ntop (length slots)) + (topw (+ (* 2 pad) (* ntop (+ w gap)))) + (colsw (+ (* 2 pad) (* ncols (+ w colgap)))) + (width (max topw colsw)) + (top-y (+ pad 14)) (col-label-y (+ top-y h 18)) (col-y (+ col-label-y 6)) + (tab (card-games-get game :tableau)) + (maxext (let ((m h)) + (dotimes (c ncols) + (let* ((col (aref tab c)) (d (card-games-sol--down game c)) + (nu (- (length col) d)) + (ext (+ (* d vdown) (* (max 0 (1- nu)) vup) h))) + (setq m (max m ext)))) + m)) + (height (+ col-y maxext pad)) + (svg (svg-create width height))) + (let ((x pad)) + (dolist (sl slots) + (cl-destructuring-bind (label spec downp cursorp spot) sl + (svg-text svg label :x (+ x 1) :y (- top-y 3) :font-size 11 :fill lc + :font-family card-games-svg-font-family) + (cond (downp (card-games-svg-card svg x top-y :down t :highlight cursorp)) + (spec (card-games-svg-card svg x top-y :rank (car spec) :suit (cdr spec) + :highlight cursorp)) + (t (card-games-svg-card svg x top-y :gap t :highlight cursorp))) + (push (cons (list x top-y w h) spot) regions)) + (setq x (+ x w gap)))) + (dotimes (c ncols) + (let* ((x (+ pad (* c (+ w colgap)))) (col (aref tab c)) (len (length col)) + (d (card-games-sol--down game c)) (y col-y) (r 0) + (cursorp (equal cur-spot (cons 'col c)))) + (svg-text svg (format "%d" (1+ c)) :x (+ x 1) :y col-label-y + :font-size 11 :fill lc :font-family card-games-svg-font-family) + (push (cons (list x col-y w maxext) (cons 'col c)) regions) + (if (= len 0) + (card-games-svg-card svg x y :gap t :highlight cursorp) + (dolist (card col) + (let* ((downp (< r d)) (top-card (= r (1- len))) + (selp (and (equal sel (cons 'col c)) (>= r (- len sel-n))))) + (if downp (card-games-svg-card svg x y :down t) + (card-games-svg-card svg x y :rank (car (card-games-sol--spec card)) + :suit (cdr (card-games-sol--spec card)) + :highlight (and top-card cursorp) :hint selp)) + (setq y (+ y (if downp vdown vup)) r (1+ r))))))) + (cons (propertize "*" 'display (card-games-svg-image svg (card-games-scale))) + (nreverse regions))))) + +(cl-defmethod card-games-render ((game card-games-solitaire-game)) + "Return a propertized depiction of GAME (SVG on a graphical display)." + (if (and card-games-sol-svg-cards (display-graphic-p)) + (car (card-games-sol--svg game)) + (card-games-sol--render-text game))) + +(cl-defmethod card-games-render-text ((game card-games-solitaire-game)) + (card-games-sol--render-text game)) + +(cl-defmethod card-games-render-svg ((game card-games-solitaire-game)) + (if card-games-sol-svg-cards (card-games-sol--svg game) + (cons (card-games-sol--render-text game) nil))) + +(cl-defmethod card-games-render-apply ((game card-games-solitaire-game) action) + "Apply a click ACTION (a cursor spot) by selecting it and acting." + (let ((idx (cl-position action (card-games-sol--spots game) :test #'equal))) + (when idx (card-games-put game :cursor idx) (card-games-sol-act)))) + +(defun card-games-sol--render-text (game) + "Return a plain-text depiction of solitaire GAME." + (let* ((spots (card-games-sol--spots game)) + (cur (card-games-get game :cursor)) + (cur-spot (nth cur spots)) + (sel (card-games-get game :sel)) + (sel-n (card-games-get game :sel-n)) + (out (list))) + (push (format " %s Moves: %d%s\n\n" + (oref game vname) (card-games-get game :moves) + (if (> (oref game nfound) 0) "" + (format " Sets: %d/%d" (card-games-get game :sets) (oref game target-sets)))) + out) + ;; Top line: stock / waste / free cells / foundations. + (let ((line " ")) + (when (oref game has-stock) + (let ((on (equal cur-spot '(stock . 0)))) + (setq line (concat line "Stock:" + (propertize (format "%-4s" + (if (card-games-get game :stock) "##" "·")) + 'face (if on 'card-games-cursor 'default)) + (format "(%d) " (length (card-games-get game :stock))))) )) + (when (oref game has-waste) + (let ((on (equal cur-spot '(waste . 0))) (w (car (last (card-games-get game :waste))))) + (setq line (concat line "Waste:" + (card-games-sol--render-card w nil nil on))))) + (when (oref game has-reserve) + (let ((on (equal cur-spot '(reserve . 0))) (r (car (last (card-games-get game :reserve))))) + (setq line (concat line "Reserve:" + (card-games-sol--render-card r nil nil on) + (format "(%d) " (length (card-games-get game :reserve))))))) + (dotimes (i (oref game nfree)) + (let ((on (equal cur-spot (cons 'free i))) (c (aref (card-games-get game :free) i))) + (setq line (concat line (format "F%d:" (1+ i)) + (card-games-sol--render-card c nil nil on))))) + (dotimes (i (oref game nfound)) + (let ((on (equal cur-spot (cons 'found i))) + (c (car (last (aref (card-games-get game :found) i))))) + (setq line (concat line (format "%d:" (1+ i)) + (card-games-sol--render-card c nil nil on))))) + (push (concat line "\n\n") out)) + ;; Column headers. + (let ((hdr " ")) + (dotimes (c (oref game ncols)) + (let ((on (equal cur-spot (cons 'col c)))) + (setq hdr (concat hdr (propertize (format "%2d " (1+ c)) + 'face (if on 'card-games-cursor 'default)))))) + (push (concat hdr "\n") out)) + ;; Column bodies, row by row. + (let* ((tab (card-games-get game :tableau)) + (maxlen (apply #'max 1 (mapcar #'length (append tab nil))))) + (dotimes (r maxlen) + (let ((row " ")) + (dotimes (c (oref game ncols)) + (let* ((col (aref tab c)) + (len (length col)) + (card (and (< r len) (nth r col))) + (down (and card (< r (card-games-sol--down game c)))) + (selp (and (equal sel (cons 'col c)) + card (>= r (- len sel-n)))) + (cursorp (and (equal cur-spot (cons 'col c)) (= r (1- len))))) + (setq row (concat row + (if (< r len) + (card-games-sol--render-card card down selp cursorp) + " "))))) + (push (concat row "\n") out)))) + (push (format "\n %s\n" (card-games-get game :message)) out) + (apply #'concat (nreverse out)))) + +(defun card-games-sol--redisplay () + "Redraw the current solitaire buffer." + (let ((game card-games-sol--game) + (inhibit-read-only t)) + (setq-local mode-line-process + (format " [%s]" (if (card-games-won-p game) "solved" + (let ((s (card-games-get game :sel))) + (if s "carrying" "playing"))))) + (erase-buffer) + (card-games-render-game game) + (insert "\n") + (card-games-insert-legend + "arrows move · RET pick up/drop · f foundation · a auto · u undo · n new · q menu · ? help") + (goto-char (point-min)))) + +;;;; Mode and commands + +(defun card-games-sol-mouse (event) + "Handle a mouse click on the solitaire board: select that pile and act." + (interactive "e") + (let* ((game card-games-sol--game) + (r (and game (oref game renderer))) + (action (and r (card-games-renderer-hit r game (event-start event))))) + (when action (card-games-render-apply game action)))) + +(defvar card-games-sol-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] #'card-games-sol-mouse) + (define-key map (kbd "") #'card-games-sol-left) + (define-key map (kbd "") #'card-games-sol-right) + (define-key map (kbd "") #'card-games-sol-up) + (define-key map (kbd "") #'card-games-sol-down) + (define-key map (kbd "RET") #'card-games-sol-act) + (define-key map (kbd "SPC") #'card-games-sol-act) + (define-key map "f" #'card-games-sol-to-foundation) + (define-key map "a" #'card-games-sol-auto) + (define-key map "u" #'card-games-sol-undo) + (define-key map "n" #'card-games-sol-new) + (define-key map "g" #'card-games-sol-redraw) + (define-key map "?" #'card-games-sol-help) + (define-key map "q" #'card-games-quit-to-menu) + map) + "Keymap for `card-games-sol-mode'.") + +(defun card-games-sol--classic-keymap () + "Return a copy of `card-games-sol-mode-map' with vi-style hjkl added." + (let ((map (copy-keymap card-games-sol-mode-map))) + (define-key map "h" #'card-games-sol-left) + (define-key map "l" #'card-games-sol-right) + (define-key map "j" #'card-games-sol-down) + (define-key map "k" #'card-games-sol-up) + map)) + +(define-derived-mode card-games-sol-mode special-mode "Solitaire" + "Major mode for the tableau solitaires." + (setq-local truncate-lines t) + (setq-local cursor-type card-games-cursor-type) + (when (eq card-games-keys 'classic) + (use-local-map (card-games-sol--classic-keymap)))) + +(defun card-games-sol--play (class) + "Start a solitaire game of CLASS in its own buffer." + (let* ((game (card-games-sol--deal (make-instance class))) + (buf (get-buffer-create (format "*%s*" (oref game vname))))) + (with-current-buffer buf + (card-games-sol-mode) + (setq card-games-sol--game game) + (card-games-sol--redisplay)) + (switch-to-buffer buf))) + +;;;###autoload +(defun card-games-klondike () + "Play Klondike, the classic solitaire." + (interactive) (card-games-sol--play 'card-games-klondike-game)) + +;;;###autoload +(defun card-games-freecell () + "Play FreeCell solitaire." + (interactive) (card-games-sol--play 'card-games-freecell-game)) + +;;;###autoload +(defun card-games-spider () + "Play Spider solitaire (two decks)." + (interactive) (card-games-sol--play 'card-games-spider-game)) + +;;;###autoload +(defun card-games-yukon () + "Play Yukon solitaire." + (interactive) (card-games-sol--play 'card-games-yukon-game)) + + +;;;; More games: Forty Thieves, Scorpion, Canfield + +(defclass card-games-forty-game (card-games-solitaire-game) + ((ncols :initform 10) (ndecks :initform 2) (nfound :initform 8) + (has-stock :initform t) (has-waste :initform t) (redeal :initform nil) + (build :initform 'suit) (run-rule :initform 'suit) (empty-rule :initform 'any) + (vname :initform "Forty Thieves")) + "Forty Thieves: two decks, ten columns, eight foundations, no redeal.") + +(cl-defmethod card-games-sol--layout ((_ card-games-forty-game)) + (make-list 10 (cons 0 4))) + +(defclass card-games-scorpion-game (card-games-solitaire-game) + ((ncols :initform 7) (nfound :initform 0) (has-stock :initform t) + (build :initform 'suit) (run-rule :initform 'any) (empty-rule :initform 'king) + (target-sets :initform 4) (vname :initform "Scorpion")) + "Scorpion: build down by suit, move any buried group, clear four runs.") + +(cl-defmethod card-games-sol--layout ((_ card-games-scorpion-game)) + (append (make-list 4 (cons 3 4)) (make-list 3 (cons 0 7)))) + +(cl-defmethod card-games-sol--stock-action ((game card-games-scorpion-game)) + "Deal the three stock cards onto the first three columns." + (let ((stock (card-games-get game :stock))) + (if (null stock) + (card-games-put game :message "The stock is empty.") + (card-games-sol--snapshot game) + (dotimes (c (min 3 (length stock))) + (card-games-sol--set-col game c (append (card-games-sol--col game c) (last stock 1))) + (setq stock (butlast stock 1))) + (card-games-put game :stock stock) + (card-games-sol--harvest game) + (card-games-put game :message "Dealt the stock onto the first columns.")))) + +(defclass card-games-canfield-game (card-games-solitaire-game) + ((ncols :initform 4) (nfound :initform 4) (has-stock :initform t) + (has-waste :initform t) (has-reserve :initform t) (draw :initform 3) + (redeal :initform t) (build :initform 'alt) (run-rule :initform 'alt) + (empty-rule :initform 'any) (wrap :initform t) (vname :initform "Canfield")) + "Canfield: a 13-card reserve and a variable foundation base rank.") + +(cl-defmethod card-games-sol--deal ((game card-games-canfield-game)) + "Deal a Canfield layout: reserve, base foundation, four columns, stock." + (let* ((deck (card-games-sol--make-deck 1)) + (reserve (cl-loop repeat 13 collect (pop deck))) + (first (pop deck)) + (found (make-vector 4 nil)) + (tableau (make-vector 4 nil)) + (down (make-vector 4 0))) + (oset game base (cdr first)) + (aset found 0 (list first)) + (dotimes (c 4) (aset tableau c (list (pop deck)))) + (card-games-put game :reserve reserve) + (card-games-put game :tableau tableau) + (card-games-put game :down down) + (card-games-put game :found found) + (card-games-put game :free (make-vector 0 nil)) + (card-games-put game :stock deck) + (card-games-put game :waste nil) + (card-games-put game :sets 0) + (card-games-put game :moves 0) + (card-games-put game :cursor 0) + (card-games-put game :sel nil) + (card-games-put game :sel-n 0) + (card-games-put game :history nil) + (card-games-put game :message + (format "Canfield. Foundations build up from %s (wrapping). RET deals three." + (aref card-games-sol-ranks (cdr first)))) + game)) + +(cl-defmethod card-games-sol--autofill ((_ card-games-solitaire-game)) nil) +(cl-defmethod card-games-sol--autofill ((game card-games-canfield-game)) + "Fill empty columns from the reserve, as Canfield requires." + (dotimes (c (oref game ncols)) + (when (and (null (card-games-sol--col game c)) (card-games-get game :reserve)) + (let ((card (car (last (card-games-get game :reserve))))) + (card-games-put game :reserve (butlast (card-games-get game :reserve) 1)) + (card-games-sol--set-col game c (list card)))))) + + +;;;; Russian Bank (single-player patience) + +;; A one-deck patience in the spirit of Russian Bank (Crapette): eight +;; "houses" build down in alternating colours, the four foundations build +;; up by suit from the Ace, and a thirteen-card reserve feeds the houses. +;; The competitive two-player game (with its "stops" and loading rules) +;; is a separate, larger build; this is the solitaire adaptation. + +(defclass card-games-russian-bank-game (card-games-solitaire-game) + ((ncols :initform 8) (nfound :initform 4) (has-stock :initform t) + (has-waste :initform t) (has-reserve :initform t) (draw :initform 1) + (redeal :initform t) (build :initform 'alt) (run-rule :initform 'alt) + (empty-rule :initform 'any) (base :initform 0) (wrap :initform nil) + (vname :initform "Russian Bank")) + "Russian Bank patience: eight houses down by alternating colour, four +foundations up by suit from the Ace, and a thirteen-card reserve.") + +(cl-defmethod card-games-sol--deal ((game card-games-russian-bank-game)) + "Deal a Russian Bank patience layout: reserve, eight houses, and a stock." + (let* ((deck (card-games-sol--make-deck 1)) + (reserve (cl-loop repeat 13 collect (pop deck))) + (tableau (make-vector 8 nil)) + (down (make-vector 8 0))) + (dotimes (c 8) (aset tableau c (list (pop deck)))) + (card-games-put game :reserve reserve) + (card-games-put game :tableau tableau) + (card-games-put game :down down) + (card-games-put game :found (make-vector 4 nil)) + (card-games-put game :free (make-vector 0 nil)) + (card-games-put game :stock deck) + (card-games-put game :waste nil) + (card-games-put game :sets 0) + (card-games-put game :moves 0) + (card-games-put game :cursor 0) + (card-games-put game :sel nil) + (card-games-put game :sel-n 0) + (card-games-put game :history nil) + (card-games-put game :message + "Russian Bank. Houses build down in alternating colours; foundations up by suit from the Ace.") + game)) + +(cl-defmethod card-games-sol--autofill ((game card-games-russian-bank-game)) + "Fill an empty house from the reserve, as Russian Bank does." + (dotimes (c (oref game ncols)) + (when (and (null (card-games-sol--col game c)) (card-games-get game :reserve)) + (let ((card (car (last (card-games-get game :reserve))))) + (card-games-put game :reserve (butlast (card-games-get game :reserve) 1)) + (card-games-sol--set-col game c (list card)))))) + +;;;###autoload +(defun card-games-forty-thieves () + "Play Forty Thieves solitaire (two decks)." + (interactive) (card-games-sol--play 'card-games-forty-game)) + +;;;###autoload +(defun card-games-scorpion () + "Play Scorpion solitaire." + (interactive) (card-games-sol--play 'card-games-scorpion-game)) + +;;;###autoload +(defun card-games-canfield () + "Play Canfield solitaire." + (interactive) (card-games-sol--play 'card-games-canfield-game)) + +;;;###autoload +(defun card-games-russian-bank () + "Play Russian Bank, the single-player patience adaptation." + (interactive) (card-games-sol--play 'card-games-russian-bank-game)) + +(provide 'card-games-solitaire) +;;; card-games-solitaire.el ends here diff --git a/card-games-spite.el b/card-games-spite.el new file mode 100644 index 0000000..6a611d9 --- /dev/null +++ b/card-games-spite.el @@ -0,0 +1,506 @@ +;;; card-games-spite.el --- Spite and Malice, a competitive patience -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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) (aref (card-games-get game :goal) s)) +(defsubst card-games-spite--set-goal (game s v) (aset (card-games-get game :goal) s v)) +(defsubst card-games-spite--hand (game s) (aref (card-games-get game :hand) s)) +(defsubst card-games-spite--set-hand (game s v) (aset (card-games-get game :hand) s v)) +(defsubst card-games-spite--disc (game s) (aref (card-games-get game :disc) s)) ; vector of 4 lists + +(defun card-games-spite--who (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 the stock, recycling the muck when the stock 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 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 the 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 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 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) + "Seat S plays 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) + "Seat S plays 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) + "Seat S plays 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) + "Seat S discards CARD from hand onto discard 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 seat S; return non-nil if a play 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 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 a discard pile for CARD: an empty one, else the one 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) take its turns until it is 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 the 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 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 () + (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) + (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 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 "") #'card-games-spite-left) + (define-key map (kbd "") #'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 diff --git a/cg-svg.el b/card-games-svg.el similarity index 58% rename from cg-svg.el rename to card-games-svg.el index d549af0..95ccf74 100644 --- a/cg-svg.el +++ b/card-games-svg.el @@ -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 ;; Maintainer: Corwin Brust ;; 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 "#1a8a3c" "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 "#95a5a6" "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 "#27ae60" "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,176 @@ 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) +(defun card-games-svg--back-dots (svg x y w h) "Draw the dotted-medallion back pattern." (let ((gy (+ y 10))) (while (< gy (- (+ y h) 8)) (let ((gx (+ x 10))) (while (< gx (- (+ x w) 8)) - (svg-circle svg gx gy 1.1 :fill cg-svg-back-trim) + (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) +(defun card-games-svg--back-lattice (svg x y w h) "Draw a small-cross lattice back pattern." (let ((gy (+ y 13))) (while (< gy (- (+ y h) 10)) (let ((gx (+ x 13))) (while (< gx (- (+ x w) 10)) (svg-line svg (- gx 2) (- gy 2) (+ gx 2) (+ gy 2) - :stroke cg-svg-back-trim :stroke-width 1) + :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) +(defun card-games-svg--back-waves (svg x y w h) "Draw a staggered-dash (brickwork) back pattern." (let ((gy (+ y 12)) (row 0)) (while (< gy (- (+ y h) 9)) (let ((gx (+ x (if (cl-evenp row) 9 15)))) (while (< gx (- (+ x w) 9)) - (svg-line svg gx gy (+ gx 6) gy :stroke cg-svg-back-trim :stroke-width 1.4) + (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) +(defun card-games-svg--back-diamond (svg x y w h) "Draw concentric diamonds as the back pattern." (let ((cx (+ x (/ w 2.0))) (cy (+ y (/ h 2.0)))) (dolist (f '(0.40 0.28 0.16)) (let ((dw (* w f)) (dh (* h f))) (svg-polygon svg (list (cons cx (- cy dh)) (cons (+ cx dw) cy) (cons cx (+ cy dh)) (cons (- cx dw) cy)) - :fill "none" :stroke cg-svg-back-trim :stroke-width 1))))) + :fill "none" :stroke card-games-svg-back-trim :stroke-width 1))))) -(defun cg-svg--back-logo (svg x y w h back) +(defun card-games-svg--back-logo (svg x y w h back) "Stamp the Emacs logo for BACK centred on the card, or dots if unavailable." (let ((file (and (fboundp 'svg-embed) - (cg-svg--logo-file (cg-svg--back-logo-name back))))) + (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 (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))) + (let ((hl (card-games-svg--highlight))) (svg-rectangle svg (- x 4) (- y 4) (+ w 8) (+ h 8) :rx (+ r 3) :fill "none" :stroke hl :stroke-opacity 0.45 :stroke-width 6) (svg-rectangle svg (- x 3) (- y 3) (+ w 6) (+ h 6) :rx (+ r 2) :fill "none" :stroke hl :stroke-width 2.5))))) -(defun cg-svg--draw-spec (svg x y spec highlight &optional hint) +(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 +461,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 +572,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 +583,37 @@ 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) +(defun card-games-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" + (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. +(defun card-games-svg-draw-logo (svg cx cy &optional fs) + "Draw the configured Emacs emblem (`card-games-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)) + (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 diff --git a/card-games-trick-ext.el b/card-games-trick-ext.el new file mode 100644 index 0000000..369c11a --- /dev/null +++ b/card-games-trick-ext.el @@ -0,0 +1,500 @@ +;;; card-games-trick-ext.el --- Euchre, Pitch and Briscola -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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 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) (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) + "Power with trump dominance, for resolving a Briscola trick." + (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) + "Briscola has no obligation to follow suit." + (and (member card (card-games-trick--hand game seat)) t)) + +(cl-defmethod card-games-trick--winner ((game card-games-briscola-game)) + (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) + (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)) + (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)) + (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)) + (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)) + (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)) + (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) + "Pitch: follow the led suit if able, but you may always trump." + (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) + "Set trump from the pitcher's first lead, then play normally." + (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) + (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 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 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)) + (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 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)) + (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)) + (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)) + (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)) + (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)) + (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) + (and (= (cdr card) 9) (= (car card) trump))) + +(defun card-games-euchre--left-bower-p (card 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) (card-games-euchre--eff-suit card trump)) + +(cl-defmethod card-games-trick--legal-p ((game card-games-euchre-game) seat card) + "Euchre: follow the effective led suit if able (left bower is trump)." + (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)) + (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) + (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 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 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 SEAT calls in round two, 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 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) + "Dealer takes the UP card and discards their weakest card." + (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)) + (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)) + (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)) + (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)) + (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)) + (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 diff --git a/card-games-trick.el b/card-games-trick.el new file mode 100644 index 0000000..e19e4db --- /dev/null +++ b/card-games-trick.el @@ -0,0 +1,940 @@ +;;; card-games-trick.el --- Four-hand trick-taking games (Hearts, Spades) -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; 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 . + +;;; 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) (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) (aref (card-games-get game :hands) s)) +(defsubst card-games-trick--set-hand (game s v) (aset (card-games-get game :hands) s v)) +(defsubst card-games-trick--partner (s) (mod (+ s 2) 4)) +(defsubst card-games-trick--team (s) (mod s 2)) + +;;;; Trick mechanics + +(defun card-games-trick--led-suit (game) + "Return the suit led to the 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 the 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) nil) + +(cl-defmethod card-games-trick--legal-p ((game card-games-trick-game) seat card) + "Return non-nil when SEAT may legally play CARD 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 list of cards SEAT may legally play 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 the 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 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 the 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) + "Hearts legality, adding the first-trick rules to the base." + (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)) + "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)) + "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 a 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)) + "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 the 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 a 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)) + "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 member seat of the 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 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 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 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 hand with AI for every seat (used by tests)." + (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)) + (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)) + (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 AI seats until it is 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)) + (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)) + (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 a one-image SVG row for CARDS (clickable + sliderful when REGION-TAG)." + (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 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-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: 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 a click ACTION on the 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 the 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 "") #'card-games-trick-left) + (define-key map (kbd "") #'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)) + (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)) + (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 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) + (card-games-trick--ai-trump-play game seat)) +(cl-defmethod card-games-trick--ai-play ((game card-games-ohhell-game) seat) + (card-games-trick--ai-trump-play game seat)) + +;; Whist +(cl-defmethod card-games-trick--begin-hand ((game card-games-whist-game)) + (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)) + (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)) + (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)) + (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)) + (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) + (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)) + (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)) + (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)) + (>= (or (card-games-get game :round) 0) (length card-games-ohhell--sizes))) +(cl-defmethod card-games-trick--winner-seat ((game card-games-ohhell-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)) + (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 diff --git a/card-games.el b/card-games.el index 633144a..adbaf20 100644 --- a/card-games.el +++ b/card-games.el @@ -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 @@ -162,32 +162,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 +195,23 @@ open game. Gaps and 500 are always graphical on a window system." (define-key map (kbd "TAB") #'forward-button) (define-key map (kbd "") #'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 +220,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 +238,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 +262,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) diff --git a/cg-bid-net.el b/cg-bid-net.el deleted file mode 100644 index 4f8a145..0000000 --- a/cg-bid-net.el +++ /dev/null @@ -1,429 +0,0 @@ -;;; cg-bid-net.el --- Networked live 500 (Bid) -*- lexical-binding: t; -*- - -;; Copyright (C) 2026 Corwin Brust - -;; Author: Corwin Brust -;; Maintainer: Corwin Brust -;; 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 . - -;;; 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 - -(defun cg-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 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--net-holds-p (cg-bid--hand game seat) cards)) - (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 diff --git a/cg-bid-ui.el b/cg-bid-ui.el deleted file mode 100644 index 19412cf..0000000 --- a/cg-bid-ui.el +++ /dev/null @@ -1,1258 +0,0 @@ -;;; cg-bid-ui.el --- 500 (Bid) — console UI and commands -*- lexical-binding: t; -*- - -;; Copyright (C) 2026 Corwin Brust - -;; Author: Corwin Brust -;; Maintainer: Corwin Brust -;; 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 . - -;;; Commentary: - -;; The console (UNICODE) interface and interactive commands for 500. -;; The rules engine lives in cg-bid.el. Play with `M-x cg-bid'. - -;;; Code: - -(require 'cl-lib) -(require 'cg-core) -(require 'cg-bid) -(require 'cg-svg) -(require 'cg-render) -(require 'svg) -(require 'color) - - -;;;; Rendering - -(defun cg-bid--trick-card-for (game seat) - "Return the card SEAT has played to the current (or last) trick, or nil." - (let ((tr (or (cg-get game :trick) (cg-get game :last-trick)))) - (cdr (assq seat tr)))) - -(cl-defmethod cg-render ((game cg-bid-game)) - "Return a propertized string depicting GAME." - (let* ((contract (cg-get game :contract)) - (trump (and contract (cg-bid-trump contract))) - (scores (cg-get game :scores)) - (tricks (cg-get game :tricks)) - (turn (cg-get game :turn)) - (phase (cg-get game :phase)) - (out (list))) - (push (format " 500 Bid Hand %d\n" (cg-get game :hand-no)) out) - (push (format " Score — You/North: %d West/East: %d\n" - (car scores) (cdr scores)) - out) - (when (eq phase 'gameover) - (push (propertize - (format " *** GAME OVER — %s WIN ***\n" - (if (= (cg-get game :game-over) 0) "YOU/NORTH" "WEST/EAST")) - 'face 'cg-cursor) - out)) - (push (format " Contract: %s\n\n" - (if contract - (format "%s (%s) by %s" - (cg-bid-label contract) (cg-bid-name contract) - (aref cg-bid-seat-names (cg-get game :contractor))) - "— (auction in progress)")) - out) - ;; opponents and partner: name, hand size (or exposed/sitting), played card - (cl-flet ((seatline - (seat indent) - (let ((sit (eql seat (cg-bid--sitter game))) - (exp (eql seat (cg-get game :exposed)))) - (format "%s%s%s %s played: %s\n" - indent - (aref cg-bid-seat-names seat) - (if (and (eq phase 'play) (= seat turn)) "*" " ") - (cond - (sit "(sitting out)") - (exp (format "[%s]" - (mapconcat #'cg-bid-card-string - (cg-bid-sort-hand - (cg-bid--hand game seat) trump) - " "))) - (t (format "[%d cards]" - (length (cg-bid--hand game seat))))) - (cg-bid-card-string (cg-bid--trick-card-for game seat)))))) - (push (seatline 2 " ") out) ; North (partner) - (push (seatline 1 " ") out) ; West - (push (seatline 3 " ") out)) ; East - (push (format "\n Tricks — You/North: %d West/East: %d\n\n" - (+ (aref tricks 0) (aref tricks 2)) - (+ (aref tricks 1) (aref tricks 3))) - out) - ;; human hand - (push " Your hand (South):\n " out) - (let* ((hand (cg-bid-sort-display (cg-bid--hand game 0) trump)) - (cursor (cg-get game :cursor)) - (marks (cg-get game :marks)) - (led (cg-get game :led)) - (legal (and (eq phase 'play) - (= turn 0) - (cg-bid-legal-cards (cg-bid--hand game 0) led trump)))) - (cg-put game :sorted-hand hand) - (if (null hand) - (push "(empty)" out) - (cl-loop for c in hand for i from 0 do - (let ((faces nil) - (str (cg-bid-card-string c))) - (when (cg-red-suit-p (car c)) (push 'cg-red-suit faces)) - (when (member c marks) (setq str (concat "^" str))) - (when (and legal (not (member c legal))) - (push 'cg-gap faces)) ; dim illegal plays - (when (= i cursor) (push 'cg-cursor faces)) - (push (propertize (format " %-4s" str) - 'face (or faces 'default) - 'cg-card i 'mouse-face 'highlight) - out)))) - (push "\n" out)) - (push (format "\n %s\n" (cg-get game :message)) out) - (push (cg-bid--key-help game) out) - (apply #'concat (nreverse out)))) - -(defun cg-bid--key-help (game) - "Return a context-sensitive key-help line for GAME." - (pcase (cg-get game :phase) - ('auction " [b]id [p]ass [n]ew hand [q]uit ? help\n") - ('kitty " [←/→] move [RET] mark/unmark [x] discard the 5 marked [q]uit\n") - ('play " [←/→] move [RET] play card [n]ew hand [q]uit ? help\n") - ('done " [n]ext hand [q]uit ? help\n") - ('gameover " [n]ew game [q]uit ? help\n") - (_ " [n]ew hand [q]uit ? help\n"))) - - -;;;; Graphical (SVG) table - -(defconst cg-bid--tw 44 "Table card width.") -(defconst cg-bid--th 62 "Table card height.") -(defconst cg-bid--canvas-w 600 "Table canvas width.") -(defconst cg-bid--canvas-h 460 "Table canvas height.") - -(defcustom cg-bid-felt-color "#15692f" - "Base felt colour for the 500 table. -Set to a theme-derived colour (see `cg-color') for a table that -matches your Emacs theme." - :type 'color :group 'cg-svg) - -(defcustom cg-bid-animate t - "When non-nil, pace AI turns so play is watchable." - :type 'boolean :group 'cg-svg) - -(defcustom cg-bid-ai-delay 0.45 - "Seconds to pause after each AI action when `cg-bid-animate' is on." - :type 'number :group 'cg-svg) - -(defcustom cg-bid-trick-pause 1.1 - "Seconds to leave a completed trick on the table before it is swept." - :type 'number :group 'cg-svg) - -(defcustom cg-bid-svg-ui nil - "When non-nil (and on a graphical display), render 500 as a single -full-buffer SVG: the table in the centre, a status/compass/bid panel on -the left, and a scrollable message log on the right." - :type 'boolean :group 'cg-svg) - -(defcustom cg-bid-svg-fill t - "When non-nil, size the full-SVG UI to fill the window and enlarge the -South hand, re-fitting on window changes. Only used when `cg-bid-svg-ui'." - :type 'boolean :group 'cg-svg) - -(defcustom cg-bid-card-scale 1.0 - "Card-size multiplier for the South hand in the full-SVG 500 UI. -Driven by the on-screen card-size slider and the +/-/0 keys." - :type 'number :group 'cg-svg) - - -(defun cg-bid--header-text (game) - "Return the header lines (scores, contract, tricks) for GAME." - (let ((scores (cg-get game :scores)) - (contract (cg-get game :contract)) - (tricks (cg-get game :tricks))) - (concat - (format " 500 Bid Hand %d\n" (cg-get game :hand-no)) - (format " Score - You/North: %d West/East: %d\n" - (car scores) (cdr scores)) - (if (eq (cg-get game :phase) 'gameover) - (format " *** GAME OVER - %s WIN ***\n" - (if (= (cg-get game :game-over) 0) "YOU/NORTH" "WEST/EAST")) - "") - (format " Contract: %s\n" - (if contract - (format "%s (%s) by %s" (cg-bid-label contract) - (cg-bid-name contract) - (aref cg-bid-seat-names (cg-get game :contractor))) - "- (auction in progress)")) - (format " Tricks - You/North: %d West/East: %d\n" - (+ (aref tricks 0) (aref tricks 2)) - (+ (aref tricks 1) (aref tricks 3)))))) - -(defun cg-bid--footer-text (game) - "Return the footer (message and key help) for GAME." - (concat (format "\n %s\n" (cg-get game :message)) - (cg-bid--key-help game))) - -(defun cg-bid--spec (card) - "Return the cg-svg card spec for a 500 CARD, or nil for none." - (cond ((null card) nil) - ((cg-bid-joker-p card) (cons nil 'joker)) - (t (cons (aref cg-bid-ranks (cdr card)) (car card))))) - -(defun cg-bid--south-layout (n) - "Return (X0 STEP Y) for laying N South-hand cards across the canvas." - (let* ((w cg-bid--tw) - (maxw (- cg-bid--canvas-w 24)) - (step (if (<= n 1) 0 (min (+ w 6) (/ (- maxw w) (1- n))))) - (total (+ w (* (max 0 (1- n)) step))) - (x0 (/ (- cg-bid--canvas-w total) 2)) - (y (- cg-bid--canvas-h cg-bid--th 8))) - (list x0 step y))) - -(defun cg-bid--draw-backs (svg cx top n) - "Draw a small fan of up to N face-down cards centred at CX, TOP on SVG. -Card size and fan step follow the dynamic `cg-svg-card-width'." - (let* ((cw cg-svg-card-width) - (k (min (max n 0) 6)) - (step (max 12 (round (* cw 0.42)))) - (total (if (> k 0) (+ cw (* (1- k) step)) 0)) - (x0 (- cx (/ total 2)))) - (dotimes (i k) (cg-svg-card svg (+ x0 (* i step)) top :down t)))) - -(defun cg-bid--draw-opponent (svg game seat cx top &optional fs) - "Draw opponent SEAT (label, backs, turn marker) on SVG centred at CX, TOP. -FS scales the name pill and its fonts." - (let* ((fs (or fs 1.0)) - (n (length (cg-bid--hand game seat))) - (sitter (eql seat (cg-bid--sitter game))) - (lw (round (* 104 fs))) (lh (round (* 18 fs))) - (fsz (max 11 (round (* 13 fs))))) - (svg-rectangle svg (- cx (/ lw 2)) (- top lh 3) lw lh :rx (round (* 9 fs)) - :fill "#0b3d1d" :fill-opacity 0.55) - (svg-text svg (format "%s%s" (aref cg-bid-seat-names seat) - (if sitter " (sitting out)" (format " (%d)" n))) - :x cx :y (- top (round (* 8 fs))) :font-size fsz :fill "#eaffea" - :text-anchor "middle" :font-family "sans-serif") - (when (and (eq (cg-get game :phase) 'play) (= seat (cg-get game :turn))) - (svg-text svg "*" :x cx :y (- top (round (* 22 fs))) - :font-size (round (* 18 fs)) :fill "#f1c40f" - :text-anchor "middle" :font-family "sans-serif")) - (unless sitter (cg-bid--draw-backs svg cx top n)))) - -(defun cg-bid--draw-trick (svg game) - "Draw the cards played to the current trick around the centre of SVG." - (let* ((W cg-bid--canvas-w) (H cg-bid--canvas-h) - (w cg-bid--tw) (h cg-bid--th) - (cx (/ W 2)) (cy (/ H 2)) - (spots (list (list 0 (- cx (/ w 2)) (+ cy 22)) - (list 1 (- cx 70 w) (- cy (/ h 2))) - (list 2 (- cx (/ w 2)) (- cy 22 h)) - (list 3 (+ cx 70) (- cy (/ h 2)))))) - (dolist (s spots) - (let* ((card (cg-bid--trick-card-for game (nth 0 s))) - (spec (cg-bid--spec card))) - (when spec - (cg-svg-card svg (nth 1 s) (nth 2 s) - :rank (car spec) :suit (cdr spec))))))) - -(defun cg-bid--draw-south (svg game) - "Draw South's hand face-up along the bottom of SVG; record sort order." - (let* ((trump (and (cg-get game :contract) - (cg-bid-trump (cg-get game :contract)))) - (hand (cg-bid-sort-display (cg-bid--hand game 0) trump))) - (cg-put game :sorted-hand hand) - (let* ((n (length hand)) (lay (cg-bid--south-layout n)) - (x0 (nth 0 lay)) (step (nth 1 lay)) (y (nth 2 lay)) - (cursor (cg-get game :cursor)) (marks (cg-get game :marks)) (i 0)) - (svg-text svg "Your hand (South)" :x (/ cg-bid--canvas-w 2) - :y (+ y cg-bid--th 14) - :font-size 12 :fill "#cfeccf" :text-anchor "middle" - :font-family "sans-serif") - (dolist (card hand) - (let* ((spec (cg-bid--spec card)) - (marked (and (member card marks) t)) - (hl (or (and (eq (cg-get game :phase) 'play) (= i cursor)) - marked)) - ;; selected cards pop up out of the hand - (cy (if marked (- y (round (* cg-bid--th 0.17))) y))) - (cg-svg-card svg (+ x0 (* i step)) cy - :rank (car spec) :suit (cdr spec) :highlight hl)) - (setq i (1+ i)))))) - -(defun cg-bid--table-svg (game) - "Return an svg object depicting the whole 500 table for GAME." - (let* ((W cg-bid--canvas-w) (H cg-bid--canvas-h) - (svg (svg-create W H))) - (let* ((base (or cg-bid-felt-color "#15692f")) - (lite (or (ignore-errors (color-lighten-name base 12)) base)) - (dark (or (ignore-errors (color-darken-name base 16)) base))) - (svg-gradient svg "cg-felt" 'radial (list (cons 0 lite) (cons 100 dark))) - (svg-rectangle svg 0 0 W H :rx 14 :gradient "cg-felt") - (svg-ellipse svg (/ W 2) (/ H 2) 132 88 :fill "black" :fill-opacity 0.10)) - (let ((cg-svg-card-width cg-bid--tw) - (cg-svg-card-height cg-bid--th) - (cg-svg-card-gap 4)) - (cg-bid--draw-opponent svg game 2 (/ W 2) 34) - (cg-bid--draw-opponent svg game 1 80 (/ H 2)) - (cg-bid--draw-opponent svg game 3 (- W 80) (/ H 2)) - (cg-bid--draw-trick svg game) - (cg-bid--draw-south svg game)) - svg)) - -(defun cg-bid--insert-graphical (game) - "Insert the GUI (SVG) depiction of GAME into the current buffer. -Folds the controls into the single action-button row (see -`cg-bid--insert-buttons'); only the status line precedes it." - (insert (cg-bid--header-text game)) - (insert-image (cg-svg-image (cg-bid--table-svg game) (cg-scale))) - (insert (format "\n %s\n" (cg-get game :message)))) - -(defun cg-bid--south-hit (px py n) - "Map a click at PX, PY to a South-hand index (0..N-1), or nil." - (let* ((lay (cg-bid--south-layout n)) - (x0 (nth 0 lay)) (step (nth 1 lay)) (y (nth 2 lay))) - (when (and (> n 0) (>= py (- y (round (* cg-bid--th 0.17)) 4)) - (<= py (+ y cg-bid--th 8)) (>= px x0)) - (let ((i (if (<= step 0) 0 (/ (- px x0) step)))) - (when (< i n) i))))) - - - -;;;; Interaction - -(defvar-local cg-bid--game nil "The `cg-bid-game' in the current buffer.") - -(defun cg-bid--mode-line (game) - "Return a mode-line status string for GAME." - (pcase (cg-get game :phase) - ('auction (if (= (cg-get game :bidder) 0) " [Your bid]" - (format " [%s bidding]" (aref cg-bid-seat-names (cg-get game :bidder))))) - ('kitty (if (cg-bid--human-p (cg-get game :contractor)) " [Discard 5]" - (format " [%s: kitty]" - (aref cg-bid-seat-names (cg-get game :contractor))))) - ('play (if (= (cg-get game :turn) 0) " [Your turn]" - (format " [%s to play]" (aref cg-bid-seat-names (cg-get game :turn))))) - ('done " [Hand over — n]") - ('gameover " [Game over — n]") - (_ ""))) - -(defun cg-bid--phase-text (game) - "Return a short prompt describing what to do now in GAME." - (pcase (cg-get game :phase) - ('auction (if (= (cg-get game :bidder) 0) - "Your turn to bid — click a bid, or Pass." - (format "Waiting for %s to bid..." - (aref cg-bid-seat-names (cg-get game :bidder))))) - ('kitty (if (cg-bid--human-p (cg-get game :contractor)) - "Click 5 cards to discard, then Discard." - (format "%s is exchanging the kitty..." - (aref cg-bid-seat-names (cg-get game :contractor))))) - ('play (if (= (cg-get game :turn) 0) - "Your turn — click a card to play." - (format "Waiting for %s to play..." - (aref cg-bid-seat-names (cg-get game :turn))))) - ('done (or (cg-get game :hand-result) (cg-get game :message))) - ('gameover (or (cg-get game :message) "Game over — click New game.")) - (_ (cg-get game :message)))) - -(defun cg-bid--announce (game) - "Echo a prompt or status describing what to do now in GAME." - (message "%s" (cg-bid--phase-text game))) - -(defun cg-bid--button (label cmd help) - "Insert a clickable button LABEL running CMD with tooltip HELP." - (insert-text-button label 'action (lambda (_) (call-interactively cmd)) - 'help-echo help 'follow-link t 'face 'link) - (insert " ")) - -(defun cg-bid--insert-buttons (game) - "Insert clickable buttons for the actions available now in GAME." - (insert " ") - (pcase (cg-get game :phase) - ('auction (when (= (cg-get game :bidder) 0) - (cg-bid--button "[Bid]" #'cg-bid-make-bid "Make a bid") - (cg-bid--button "[Pass]" #'cg-bid-pass "Pass"))) - ('kitty (when (cg-bid--human-p (cg-get game :contractor)) - (cg-bid--button "[Discard 5]" #'cg-bid-discard-marked - "Discard the five marked cards"))) - ('play (when (= (cg-get game :turn) 0) - (cg-bid--button "[Play]" #'cg-bid-select - "Play the highlighted card")))) - (when (memq (cg-get game :phase) '(done gameover)) - (cg-bid--button (if (eq (cg-get game :phase) 'gameover) "[New game]" "[Next hand]") - #'cg-bid-new "Deal the next hand / start a new game")) - (cg-bid--button "[Help]" #'cg-bid-help "Show help") - (insert "\n")) - -(cl-defmethod cg-renderer-draw ((_renderer cg-text-renderer) (game cg-bid-game)) - "Draw the 500 GAME as UNICODE text with the action buttons." - (insert (cg-render game)) - (cg-bid--insert-buttons game)) - -(cl-defmethod cg-renderer-draw ((_renderer cg-svg-renderer) (game cg-bid-game)) - "Draw the 500 GAME as an SVG table with the action buttons." - (cg-bid--insert-graphical game) - (cg-bid--insert-buttons game)) - -(cl-defmethod cg-renderer-draw ((_renderer cg-svg-fill-renderer) (game cg-bid-game)) - "Draw the 500 GAME as a frameless full-window SVG table." - (cg-bid--insert-svg-ui game)) - -(defun cg-bid--treatment () - "Return the display treatment symbol for the current 500 buffer. -Honours `cg-bid-svg-ui' and whether the display is graphical." - (cond ((and cg-bid-svg-ui (display-graphic-p)) 'svg-fill) - ((display-graphic-p) 'svg) - (t 'text))) - -(defun cg-bid--redisplay () - "Redraw the current 500 buffer through its renderer. -The treatment is chosen by `cg-bid--treatment' and dispatched with -`cg-renderer-draw'." - (let* ((inhibit-read-only t) - (game cg-bid--game) - (renderer (cg-render-set-treatment game (cg-bid--treatment)))) - (setq-local mode-line-process (cg-bid--mode-line game)) - (erase-buffer) - (cg-renderer-draw renderer game) - (goto-char (point-min)))) - -(defun cg-bid--refresh () - "Advance AI to the next human action, animating turns if enabled." - (let ((game cg-bid--game)) - (if (or (not cg-bid-animate) (<= cg-bid-ai-delay 0)) - (progn (cg-bid--run game) (cg-bid--redisplay)) - (cg-bid--redisplay) - (let ((guard 0)) - (while (and (< (cl-incf guard) 400) - (let ((before (cg-get game :ntricks))) - (when (cg-bid--ai-step game) - (cg-bid--redisplay) - (message "%s" (cg-get game :message)) - (sit-for (if (> (cg-get game :ntricks) before) - cg-bid-trick-pause - cg-bid-ai-delay)) - t))))) - (cg-bid--redisplay)) - (cg-bid--announce game))) - -(defun cg-bid-left () - "Move the hand cursor left." - (interactive) - (cg-put cg-bid--game :cursor (max 0 (1- (cg-get cg-bid--game :cursor)))) - (cg-bid--redisplay)) - -(defun cg-bid-right () - "Move the hand cursor right." - (interactive) - (let ((n (length (cg-get cg-bid--game :sorted-hand)))) - (cg-put cg-bid--game :cursor (min (1- n) (1+ (cg-get cg-bid--game :cursor)))) - (cg-bid--redisplay))) - -(defun cg-bid--current-card () - "Return the card under the hand cursor." - (nth (cg-get cg-bid--game :cursor) (cg-get cg-bid--game :sorted-hand))) - -(defun cg-bid-select () - "Play (in play phase) or mark/unmark (in kitty phase) the current card." - (interactive) - (let* ((game cg-bid--game) - (phase (cg-get game :phase)) - (card (cg-bid--current-card))) - (pcase phase - ('kitty - (when (cg-bid--human-p (cg-get game :contractor)) - (let ((marks (cg-get game :marks))) - (cond - ((member card marks) - (cg-put game :marks (remove card marks)) - (cg-put game :message - (format "%d of 5 marked for discard." (length (cg-get game :marks))))) - ((>= (length marks) 5) - (cg-put game :message - "Five already marked — click a marked card to unmark first.")) - (t (cg-put game :marks (cons card marks)) - (cg-put game :message - (let ((np (length (cg-get game :marks)))) - (if (= np 5) "5 of 5 marked — press Discard." - (format "%d of 5 marked for discard." np)))))) - (cg-bid--redisplay)))) - ('play - (if (/= (cg-get game :turn) 0) - (progn (cg-put game :message "Not your turn.") (cg-bid--redisplay)) - (let ((legal (cg-bid-legal-cards (cg-bid--hand game 0) - (cg-get game :led) - (cg-bid-trump (cg-get game :contract))))) - (if (not (member card legal)) - (progn (cg-put game :message "Illegal — you must follow suit.") - (cg-bid--redisplay)) - (cg-bid--play game 0 card) - (cg-bid--refresh))))) - (_ (cg-bid--redisplay))))) - -(defun cg-bid-discard-marked () - "Discard the five marked kitty cards." - (interactive) - (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-bid--discard game (cg-get game :contractor) marks) - (cg-put game :marks nil) - (cg-bid--refresh))))) - -(defun cg-bid--code (bid) - "Return a short ASCII code for BID, e.g. \"7H\", \"8NT\", \"NL\"." - (let ((trump (cg-bid-trump bid)) (tricks (cg-bid-tricks bid))) - (cond ((cg-bid-nullo-p bid) (cg-bid-label bid)) - ((eq trump 'nt) (format "%dNT" tricks)) - (t (format "%d%c" tricks (aref "SCDH" trump)))))) - -(defun cg-bid-make-bid () - "Prompt the human for a bid. -Type a short code such as 7H, 8NT, NL (case-insensitive)." - (interactive) - (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-bid--auction-act game 0 (if (eq sel 'pass) nil sel)) - (cg-bid--refresh))))) - -(defun cg-bid-pass () - "Pass during the auction." - (interactive) - (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-bid--auction-act game 0 nil) - (cg-bid--refresh)))) - -(defun cg-bid-new () - "Advance to the next hand once a hand is over, or start a fresh game at -game over. 500 is a multi-hand game with no mid-hand redeal, so a hand in -progress must be played out (unlike the solitaire games)." - (interactive) - (let* ((game cg-bid--game) (phase (cg-get game :phase))) - (cond - ((eq phase 'gameover) - (cg-put game :scores (cons 0 0)) - (cg-put game :hand-no 0) - (cg-put game :game-over nil) - (cg-bid--deal game 3) - (cg-bid--refresh)) - ((eq phase 'done) - (cg-bid--deal game (mod (1+ (cg-get game :dealer)) 4)) - (cg-bid--refresh)) - (t (cg-put game :message "Play the hand out — 500 has no mid-hand redeal.") - (cg-bid--redisplay))))) - -(defun cg-bid-mouse (event) - "Handle a click in the 500 buffer (SVG-UI panels, table, or text)." - (interactive "e") - (let ((start (event-start event)) (game cg-bid--game)) - (if (and cg-bid-svg-ui (display-graphic-p) (posn-image start)) - (cg-bid--svg-ui-click start) - (let ((i (if (and (display-graphic-p) (posn-image start)) - (let ((xy (posn-object-x-y start)) (s (cg-scale))) - (and xy (cg-bid--south-hit (round (/ (car xy) s)) - (round (/ (cdr xy) s)) - (length (cg-get game :sorted-hand))))) - (let ((pos (posn-point start))) - (and pos (get-text-property pos 'cg-card)))))) - (when i (cg-put game :cursor i) (cg-bid-select)))))) - -(defun cg-bid-help () - "Show brief help." - (interactive) - (message "%s" (concat "500: win the auction, exchange the kitty, take your bid " - "in tricks. Click the ? Help button (SVG UI) for the rules."))) - -(defun cg-bid-zoom-in () - "Enlarge the cards." - (interactive) - (if (and cg-bid-svg-ui (display-graphic-p)) - (progn (setq cg-bid-card-scale (min 2.2 (+ (or cg-bid-card-scale 1.0) 0.2))) - (cg-bid--redisplay)) - (text-scale-increase 1) (cg-bid--redisplay))) -(defun cg-bid-zoom-out () - "Shrink the cards." - (interactive) - (if (and cg-bid-svg-ui (display-graphic-p)) - (progn (setq cg-bid-card-scale (max 0.6 (- (or cg-bid-card-scale 1.0) 0.2))) - (cg-bid--redisplay)) - (text-scale-decrease 1) (cg-bid--redisplay))) -(defun cg-bid-zoom-reset () - "Reset the card size." - (interactive) - (if (and cg-bid-svg-ui (display-graphic-p)) - (progn (setq cg-bid-card-scale 1.0) (cg-bid--redisplay)) - (text-scale-set 0) (cg-bid--redisplay))) - -(defun cg-bid-redraw () - "Redraw the table (e.g. after a theme or frame change)." - (interactive) - (cg-bid--redisplay)) - -(defvar cg-bid-mode-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "") #'cg-bid-left) - (define-key map (kbd "") #'cg-bid-right) - (define-key map (kbd "RET") #'cg-bid-select) - (define-key map "b" #'cg-bid-make-bid) - (define-key map "p" #'cg-bid-pass) - (define-key map "x" #'cg-bid-discard-marked) - (define-key map "g" #'cg-bid-redraw) - (define-key map "n" #'cg-bid-new) - (define-key map "?" #'cg-bid-help) - (define-key map "+" #'cg-bid-zoom-in) - (define-key map "=" #'cg-bid-zoom-in) - (define-key map "-" #'cg-bid-zoom-out) - (define-key map "0" #'cg-bid-zoom-reset) - (define-key map (kbd "M-") #'cg-bid-log-up) - (define-key map (kbd "M-") #'cg-bid-log-down) - (define-key map [wheel-up] #'cg-bid-wheel) - (define-key map [wheel-down] #'cg-bid-wheel) - (define-key map [mouse-4] #'cg-bid-wheel) - (define-key map [mouse-5] #'cg-bid-wheel) - (define-key map "v" #'cg-bid-toggle-svg-ui) - (define-key map [mouse-1] #'cg-bid-mouse) - (define-key map "q" #'cg-quit-to-menu) - map) - "Keymap for `cg-bid-mode' (Emacs style; see `cg-keys').") - -(defun cg-bid--classic-keymap () - "Return a copy of `cg-bid-mode-map' with vi-style h/l and SPC added." - (let ((map (copy-keymap cg-bid-mode-map))) - (define-key map "h" #'cg-bid-left) - (define-key map "l" #'cg-bid-right) - (define-key map (kbd "SPC") #'cg-bid-select) - map)) - -(define-derived-mode cg-bid-mode special-mode "500" - "Major mode for playing 500 (Bid)." - (setq-local truncate-lines t) - (setq-local cursor-type cg-cursor-type) - (add-hook 'window-configuration-change-hook #'cg-bid--fit nil t) - (when (eq cg-keys 'classic) - (use-local-map (cg-bid--classic-keymap)))) - -;;;###autoload -(defun cg-bid () - "Play 500 (Bid) against three computer opponents." - (interactive) - (let ((buf (get-buffer-create "*500 Bid*"))) - (with-current-buffer buf - (cg-bid-mode) - (setq cg-bid--game (cg-bid--deal (make-instance 'cg-bid-game))) - (cg-bid--refresh)) - (switch-to-buffer buf))) - - -;;;; Frameless full-SVG UI (opt-in; see `cg-bid-svg-ui') - -(defconst cg-bid--ui-w 860 "Default SVG-UI canvas width.") -(defconst cg-bid--ui-h 540 "Default SVG-UI canvas height.") -(defconst cg-bid--ui-tx 210 "Left edge of the table area.") -(defconst cg-bid--ui-tw 440 "Default width of the table area.") -(defconst cg-bid--sw 58 "South-hand card width (larger, for readability).") -(defconst cg-bid--sh 82 "South-hand card height.") - -(defconst cg-bid--south-minfrac 0.30 - "Minimum South-card step as a fraction of card width. -The smallest gutter that still keeps each card's rank/suit index visible.") - -(defun cg-bid--south-size (w h) - "Return (SW . SH) South-card size for a canvas W by H. -The player's cards grow with the window; height grows about twice as -fast as the window widens, so the hand compresses (cards overlap) as the -table enlarges. Capped at 42% of canvas height; width is capped later, -per-deal, so the hand always fits the table." - (let* ((wf (- w cg-bid--ui-w)) (hf (- h cg-bid--ui-h)) - (base (max 76 (min (round (* h 0.42)) - (round (+ 92 (* hf 0.20) (* wf 0.40)))))) - (sh (max 50 (min (round (* h 0.60)) - (round (* base (or cg-bid-card-scale 1.0)))))) - (sw (round (* sh 0.70)))) - (cons sw sh))) - -(defvar-local cg-bid--regions nil - "Plist of clickable SVG-UI regions for hit-testing.") -(defvar-local cg-bid--last-size nil - "Last window pixel size used to render the SVG-UI.") - -(defun cg-bid--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-bid--text-left (svg str x y size color &optional bold) - "Draw left-anchored text STR on SVG." - (let ((a (list :x (round x) :y (round y) :font-size (round size) - :fill color :text-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-bid--ui-label (svg str x y &optional size) - "Draw an all-caps, letter-spaced section label on SVG (font SIZE, default 10)." - (svg-text svg (upcase str) :x (round x) :y (round y) :font-size (round (or size 10)) - :fill "#8fc79b" :text-anchor "start" :font-family cg-svg-font-family - :font-weight "bold" :letter-spacing "2")) - -(defun cg-bid--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-bid--active-seat (game) - "Return the seat whose action is pending, or nil." - (pcase (cg-get game :phase) - ('auction (cg-get game :bidder)) - ('kitty (cg-get game :contractor)) - ('play (cg-get game :turn)) - (_ nil))) - -(defun cg-bid--hand-layout (n width xoff ybottom &optional cardw cardh) - "Return (X0 STEP Y) for N cards across WIDTH from XOFF, bottom YBOTTOM. -CARDW/CARDH default to the table card size. Cards overlap to fit but -keep a minimum gutter so each rank index stays visible." - (let* ((w (or cardw cg-bid--tw)) - (hgt (or cardh cg-bid--th)) - (maxw (- width 24)) - (minstep (max 14 (round (* w cg-bid--south-minfrac)))) - (fit (if (<= n 1) 0 (/ (- maxw w) (1- n)))) - (step (if (<= n 1) 0 (max minstep (min (+ w 7) fit)))) - (total (+ w (* (max 0 (1- n)) step))) - (x0 (+ xoff (/ (- width total) 2))) - (y (- ybottom hgt 8))) - (list x0 step y))) - -(defun cg-bid--draw-trick-at (svg game cx cy &optional fs) - "Draw the current trick centred at CX, CY on SVG, on a faint drop-zone. -FS scales the drop-zone, the played cards, and their spread." - (let* ((fs (or fs 1.0)) - (r (round (* 80 fs))) - (w (round (* cg-bid--tw fs))) (h (round (* cg-bid--th fs))) - (off (round (* 70 fs))) (gap (round (* 22 fs))) - (spots (list (list 0 (- cx (/ w 2)) (+ cy gap)) - (list 1 (- cx off w) (- cy (/ h 2))) - (list 2 (- cx (/ w 2)) (- cy gap h)) - (list 3 (+ cx off) (- cy (/ h 2)))))) - (svg-circle svg cx cy r :fill "#000000" :fill-opacity 0.08) - (svg-circle svg cx cy r :fill "none" :stroke "#0e5226" :stroke-width 2) - (let ((cg-svg-card-width w) (cg-svg-card-height h)) - (dolist (s spots) - (let* ((card (cg-bid--trick-card-for game (nth 0 s))) (spec (cg-bid--spec card))) - (when spec - (cg-svg-card svg (nth 1 s) (nth 2 s) :rank (car spec) :suit (cdr spec)))))))) - -(defun cg-bid--draw-south-region (svg game tx tw ybottom sw sh) - "Draw South's hand (cards SW by SH) within TX width TW bottom YBOTTOM. -Return (:hand (X0 STEP Y N SH))." - (let* ((trump (and (cg-get game :contract) (cg-bid-trump (cg-get game :contract)))) - (hand (cg-bid-sort-display (cg-bid--hand game 0) trump))) - (cg-put game :sorted-hand hand) - (let* ((n (length hand)) - ;; Cap card width so N cards fit the table at the index-safe - ;; gutter; tall cards shrink only when the table is too narrow. - (maxsw (if (<= n 1) sw - (/ (- tw 24.0) (+ 1.0 (* (1- n) cg-bid--south-minfrac))))) - (capped (and (> n 1) (> sw maxsw))) - (sw (if capped (max 40 (round maxsw)) sw)) - (sh (if capped (round (/ sw 0.70)) sh)) - (lay (cg-bid--hand-layout n tw tx ybottom sw sh)) - (x0 (nth 0 lay)) (step (nth 1 lay)) (y (nth 2 lay)) - (cursor (cg-get game :cursor)) (marks (cg-get game :marks)) (i 0)) - (svg-rectangle svg tx (- y 6) tw (+ sh 14) :rx 10 - :fill "#ffffff" :fill-opacity 0.05) - (let ((cg-svg-card-width sw) (cg-svg-card-height sh) - (legal (and (eq (cg-get game :phase) 'play) (= (cg-get game :turn) 0) - (cg-bid-legal-cards - (cg-bid--hand game 0) (cg-get game :led) - (and (cg-get game :contract) - (cg-bid-trump (cg-get game :contract))))))) - (dolist (card hand) - (let* ((spec (cg-bid--spec card)) (marked (and (member card marks) t)) - (illegal (and legal (not (member card legal)))) - (hl (or (and (eq (cg-get game :phase) 'play) (= i cursor)) marked)) - (cxc (+ x0 (* i step))) - (cy (if marked (- y (round (* sh 0.17))) y))) - (cg-svg-card svg cxc cy :rank (car spec) :suit (cdr spec) :highlight hl) - (when illegal - (svg-rectangle svg cxc cy sw sh :rx 6 :fill "#0a1a0c" :fill-opacity 0.55))) - (setq i (1+ i)))) - (list :hand (list x0 step y n sh))))) - -(defun cg-bid--draw-compass (svg game cx cy r &optional fs) - "Draw a compass turn indicator centred at CX, CY radius R on SVG. -FS scales the N/S/E/W label fonts." - (let ((active (cg-bid--active-seat game)) - (lsz (max 12 (round (* 13 (or fs 1.0)))))) - (svg-circle svg cx cy r :fill "#0d4a22" :stroke "#0a3a1a" :stroke-width 2) - (svg-circle svg cx cy (- r 7) :fill "none" :stroke "#1b6b35" :stroke-width 1) - (cl-flet ((lab (seat lx ly s) - (cg-svg--text svg s lx ly lsz - (if (eql seat active) "#f6e27a" "#bfe0bf") - (eql seat active)))) - (lab 2 cx (- cy r -15) "N") - (lab 0 cx (+ cy r -5) "S") - (lab 1 (- cx r -11) (+ cy 5) "W") - (lab 3 (+ cx r -11) (+ cy 5) "E")) - (when active - (let* ((tip (pcase active - (2 (cons cx (- cy (- r 16)))) - (0 (cons cx (+ cy (- r 16)))) - (1 (cons (- cx (- r 16)) cy)) - (3 (cons (+ cx (- r 16)) cy))))) - (svg-line svg cx cy (car tip) (cdr tip) :stroke "#f1c40f" :stroke-width 2) - (svg-circle svg (car tip) (cdr tip) 3 :fill "#f1c40f"))) - (svg-circle svg cx cy 3 :fill "#cfeccf"))) - -(defun cg-bid--draw-logo (svg cx cy &optional fs) - "Draw the configured Emacs emblem centred at CX, CY on SVG, scaled by FS. -The emblem is chosen with `cg-svg-emacs-logo'." - (cg-svg-draw-logo svg cx cy fs)) - -(defun cg-bid--grid-cell (bid gx gy cw ch g) - "Return (X Y W H) for BID in a grid at GX,GY with cells CW by CH, gutter G. -Suit/NT bids occupy rows by trick count (6-10) and columns by suit; -nullo bids share the bottom row." - (if (cg-bid-nullo-p bid) - (let ((col (pcase (cg-bid-label bid) ("ON" 1) ("GN" 2) (_ 0)))) - (list (+ gx (* col (+ cw g))) (+ gy (* 5 (+ ch g))) cw ch)) - (let ((col (if (eq (cg-bid-trump bid) 'nt) 4 (cg-bid-trump bid))) - (row (- (cg-bid-tricks bid) 6))) - (list (+ gx (* col (+ cw g))) (+ gy (* row (+ ch g))) cw ch)))) - -(defun cg-bid--grid-pass-cell (gx gy cw ch g) - "Return (X Y W H) for the double-width Pass button (bottom row, cols 3-4)." - (list (+ gx (* 3 (+ cw g))) (+ gy (* 5 (+ ch g))) (+ (* 2 cw) g) ch)) - -(defun cg-bid--draw-left-panel (svg game h lpw fs ccy) - "Draw the full-height left status panel; return its clickable regions. -LPW is the panel width, FS the font/element scale, CCY the compass centre -Y (also the North reference line). All metrics scale with FS so the -panel content grows with the window." - (let* ((scores (cg-get game :scores)) - (contract (cg-get game :contract)) - (regions nil) - (F (lambda (n) (round (* n fs)))) - (px0 (funcall F 16)) (pxr (- lpw (funcall F 12))) - (dl (funcall F 8)) (dr (- lpw (funcall F 8))) - (cxp (/ lpw 2)) - (cr (funcall F 44)) - (y 0)) - (svg-rectangle svg 6 6 (- lpw 8) (- h 12) :rx 10 :fill "#0d4a22" :fill-opacity 0.9 - :stroke "#0a3a1a" :stroke-width 1) - (cg-bid--draw-compass svg game cxp ccy cr fs) - (setq y (+ ccy cr (funcall F 12))) - (cg-bid--ui-divider svg dl dr y) - (setq y (+ y (funcall F 18))) - (cg-bid--ui-label svg "Scores" px0 y (funcall F 10)) - (setq y (+ y (funcall F 22))) - (cg-bid--text-left svg "You / North" px0 y (funcall F 13) "#eaffea") - (svg-text svg (number-to-string (car scores)) :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-bid--text-left svg "West / East" px0 y (funcall F 13) "#eaffea") - (svg-text svg (number-to-string (cdr scores)) :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-bid--ui-divider svg dl dr y) - (setq y (+ y (funcall F 18))) - (cg-bid--ui-label svg "Contract" px0 y (funcall F 10)) - (setq y (+ y (funcall F 32))) - (cg-svg--text svg (if contract (cg-bid-label contract) "Auction…") - cxp y (funcall F 24) "#f1c40f" t) - (setq y (+ y (funcall F 20))) - (if contract - (let ((tr (cg-get game :tricks))) - (cg-bid--text-left svg - (format "%s — tricks %d:%d" - (aref cg-bid-seat-names (cg-get game :contractor)) - (+ (aref tr 0) (aref tr 2)) (+ (aref tr 1) (aref tr 3))) - px0 y (funcall F 12) "#cfeccf")) - (cg-bid--text-left svg "Bidding in progress" px0 y (funcall F 12) "#9fd0a8")) - (setq y (+ y (funcall F 14))) - (cg-bid--ui-divider svg dl dr y) - (when (and (eq (cg-get game :phase) 'auction) (= (cg-get game :bidder) 0)) - (setq y (+ y (funcall F 18))) - (cg-bid--ui-label svg "Your bid" px0 y (funcall F 10)) - ;; extra breathing room between the label and the grid - (setq y (+ y (funcall F 16))) - (let* ((gx px0) (gy y) - (g (funcall F 5)) - (cw (max 24 (/ (- lpw px0 (funcall F 12) (* 4 g)) 5))) - ;; full height when the panel is tall; shrink to fit on short windows - (ch (min (funcall F 26) - (max (funcall F 10) - (- (/ (- (- h (funcall F 14)) gy) 6) g)))) - (legal (cg-bid--legal-bids game)) (bids nil)) - (dolist (b cg-bid-schedule) - (when (memq b legal) - (let* ((cell (cg-bid--grid-cell b gx gy cw ch g)) - (x (nth 0 cell)) (cy2 (nth 1 cell)) (w (nth 2 cell)) (h2 (nth 3 cell)) - (color (cg-svg--suit-color (pcase (cg-bid-trump b) - ('nt 0) ('nullo 'joker) (n n))))) - (svg-rectangle svg x cy2 w h2 :rx 5 :fill "#fdfdfb" - :stroke color :stroke-width 1) - (cg-svg--text svg (cg-bid-label b) (+ x (/ w 2)) (+ cy2 (round (* h2 0.66))) - (funcall F 12) color t) - (push (cons b cell) bids)))) - (setq regions (plist-put regions :bids bids)) - (let ((pr (cg-bid--grid-pass-cell gx gy cw ch g))) - (svg-rectangle svg (nth 0 pr) (nth 1 pr) (nth 2 pr) (nth 3 pr) - :rx 5 :fill "#7f8c8d" :stroke "#566573" :stroke-width 1) - (cg-svg--text svg "Pass" (+ (nth 0 pr) (/ (nth 2 pr) 2)) - (+ (nth 1 pr) (round (* ch 0.66))) - (funcall F 12) "#ffffff" t) - (setq regions (plist-put regions :pass pr))))) - ;; kitty: a Discard button for the human contractor (mouse-only path) - (when (and (eq (cg-get game :phase) 'kitty) - (cg-bid--human-p (cg-get game :contractor))) - (setq y (+ y (funcall F 18))) - (cg-bid--ui-label svg "Kitty" px0 y (funcall F 10)) - (setq y (+ y (funcall F 14))) - (let* ((nmk (length (cg-get game :marks))) (ready (= nmk 5)) - (bx px0) (by y) (bw (- lpw px0 (funcall F 12))) (bh (funcall F 30))) - (svg-rectangle svg bx by bw bh :rx 6 - :fill (if ready "#2e7d32" "#14401f") - :fill-opacity (if ready 1.0 0.6) - :stroke "#0a3a1a" :stroke-width 1) - (cg-svg--text svg (format "Discard %d / 5" nmk) - (+ bx (/ bw 2)) (+ by (round (* bh 0.64))) - (funcall F 13) (if ready "#ffffff" "#9fd0a8") t) - (setq regions (plist-put regions :discard (list bx by bw bh))))) - regions)) - -(defun cg-bid--draw-log (svg game x w h fs ccy) - "Draw the full-height right log panel (emblem + scrolling story); return regions. -FS scales the emblem and fonts; CCY aligns the divider with the compass." - (let* ((F (lambda (n) (round (* n fs)))) - (y 6) (bottom (- h 6 (funcall F 64))) ; reserve a control strip - (logtop (+ ccy (funcall F 44) (funcall F 12))) ; align with left divider - (lh (funcall F 16)) - (list-top (+ logtop (funcall F 24))) - (tw (funcall F 5)) (tx (+ x w (- (funcall F 10)))) - (log (cg-get game :log)) (total (max 1 (length log))) - (scroll (or (cg-get game :log-scroll) 0)) - (vis (max 1 (/ (- bottom list-top) lh))) - (maxch (max 12 (round (/ (- w (funcall F 22)) (* 0.62 (funcall F 11))))))) - (svg-rectangle svg x y w (- (- h 6) y) :rx 10 :fill "#0d4a22" :fill-opacity 0.9 - :stroke "#0a3a1a" :stroke-width 1) - ;; emblem in the open top area, divider aligned with the left compass divider - (cg-bid--draw-logo svg (+ x (/ w 2)) ccy fs) - (cg-bid--ui-divider svg (+ x (funcall F 10)) (- (+ x w) (funcall F 10)) logtop) - (cg-bid--ui-label svg "Log" (+ x (funcall F 12)) (+ logtop (funcall F 16)) (funcall F 10)) - ;; scrollbar track + proportional thumb + delicate arrows - (svg-rectangle svg tx list-top tw (- bottom list-top) :rx 2 :fill "#0a3a1a") - (let* ((th2 (max 16 (round (* (- bottom list-top) (min 1.0 (/ (float vis) total)))))) - (room (- (- bottom list-top) th2)) - (ty2 (+ list-top (round (* room (/ (float scroll) (max 1 (- total 1))))))) - (up (list tx (- list-top 11) tw 9)) (dn (list tx (+ bottom 2) tw 9))) - (svg-rectangle svg tx ty2 tw th2 :rx 2 :fill "#7fae8a") - (svg-polygon svg (list (cons (+ tx 2) (nth 1 up)) (cons (- tx 1) (+ (nth 1 up) 7)) - (cons (+ tx 5) (+ (nth 1 up) 7))) :fill "#9fd0a8") - (svg-polygon svg (list (cons (- tx 1) (nth 1 dn)) (cons (+ tx 5) (nth 1 dn)) - (cons (+ tx 2) (+ (nth 1 dn) 7))) :fill "#9fd0a8") - ;; entries: newest first; top item gets ceremony; alternating stripes - (let ((yy (+ list-top (funcall F 12))) (ents (nthcdr scroll log)) (k 0)) - (while (and ents (< k vis)) - (let* ((sline (car ents)) (top? (= k 0))) - (when (cl-oddp k) - (svg-rectangle svg (+ x (funcall F 6)) (- yy (funcall F 12)) - (- w (funcall F 22)) lh :fill "#ffffff" :fill-opacity 0.05)) - (when (> (length sline) maxch) - (setq sline (concat (substring sline 0 (1- maxch)) "…"))) - (cg-bid--text-left svg sline (+ x (funcall F 10)) yy - (if top? (funcall F 13) (funcall F 11)) - (if top? "#f4faf4" "#cfe3cf") top?) - (setq yy (+ yy (if top? (funcall F 22) lh)))) - (setq ents (cdr ents) k (1+ k)))) - ;; global controls (Help, card size) in the reserved bottom strip - (cg-bid--ui-divider svg (+ x (funcall F 10)) (- (+ x w) (funcall F 10)) - (+ bottom (funcall F 4))) - (let* ((cz (+ bottom (funcall F 12))) - (hx (+ x (funcall F 12))) (hw (- w (funcall F 24))) (hh (funcall F 24)) - (sy (+ cz hh (funcall F 14))) - (lx (+ x (funcall F 36))) (rx2 (- (+ x w) (funcall F 14))) - (stops cg-svg-slider-stops) - (segw (/ (float (- rx2 lx)) (max 1 (1- (length stops))))) - (srs nil) (k 0)) - (svg-rectangle svg hx cz hw hh :rx (funcall F 6) - :fill "#14401f" :stroke "#2e7d32" :stroke-width 1) - (cg-svg--text svg "? Help / Rules" (+ hx (/ hw 2)) (+ cz (round (* hh 0.66))) - (funcall F 12) "#cfe3cf" t) - (cg-bid--ui-label svg "Size" (+ x (funcall F 12)) (+ sy (funcall F 4)) (funcall F 9)) - (svg-line svg lx sy rx2 sy :stroke "#1b6b35" :stroke-width 2) - (dolist (v stops) - (let* ((cxk (round (+ lx (* k segw)))) - (near (< (abs (- v (or cg-bid-card-scale 1.0))) 0.08))) - (svg-circle svg cxk sy (if near 7 4) - :fill (if near "#f1c40f" "#eaffea") - :stroke "#0a3a1a" :stroke-width 1) - (push (cons (list (- cxk (round (/ segw 2))) (- sy 10) - (max 12 (round segw)) 20) (cons 'scale v)) srs)) - (setq k (1+ k))) - (list :scroll-up up :scroll-down dn :log-region (list x y w (- bottom y)) - :help (list hx cz hw hh) :sizer (nreverse srs)))))) - -(defun cg-bid--draw-banner (svg game tx tw ty fs) - "Draw the phase-prompt banner across the top of the table." - (let* ((txt (cg-bid--phase-text game)) - (by (+ ty (round (* 6 fs)))) (bh (round (* 30 fs))) - (bw (min (- tw (round (* 90 fs))) - (max (round (* 240 fs)) (* (length txt) (round (* 8 fs)))))) - (bx (+ tx (/ (- tw bw) 2)))) - (svg-rectangle svg bx by bw bh :rx (round (* 15 fs)) - :fill "#0d2c17" :fill-opacity 0.88 :stroke "#2e7d32" :stroke-width 1) - (cg-svg--text svg txt (+ bx (/ bw 2)) (+ by (round (* bh 0.66))) - (round (* 14 fs)) "#f4faf4" t))) - -(defun cg-bid--draw-help-overlay (svg _game tx ty tw th fs) - "Draw the rules/legend overlay over the table; return its regions." - (let* ((F (lambda (n) (round (* n fs)))) - (m (funcall F 26)) - (ox (+ tx m)) (oy (+ ty m)) (ow (- tw (* 2 m))) (oh (- th (* 2 m))) - (lx (+ ox (funcall F 22))) (y (+ oy (funcall F 36))) - (lines '("How to play 500" - "" - "You (South) + North are partners vs West + East." - "1. AUCTION — bid how many tricks your side will take," - " or Pass. Click a bid in the left panel; high bid wins." - "2. KITTY — the winner takes 5 hidden cards, then clicks" - " 5 to throw away (the Discard button turns green at 5)." - "3. PLAY — take turns clicking a card; follow the led suit." - " Take at least as many tricks as you bid to score." - "" - "Bids: 7♠ = take 7 tricks, spades trump. NT = no-trump." - " NL / ON / GN = misère bids (try to take none)." - "Trump rank: Joker, right & left bowers, A K Q 10 9 ... 4.")) - (regions nil)) - (svg-rectangle svg ox oy ow oh :rx (funcall F 14) - :fill "#08200f" :fill-opacity 0.97 :stroke "#2e7d32" :stroke-width 2) - (dolist (ln lines) - (let ((title (string-prefix-p "How to" ln))) - (cg-bid--text-left svg ln lx y (if title (funcall F 18) (funcall F 13)) - (if title "#f1c40f" "#eaffea") title)) - (setq y (+ y (funcall F 22)))) - (let* ((by (- (+ oy oh) (funcall F 44))) - (bw (funcall F 130)) (bh (funcall F 30)) (g (funcall F 14)) (bx lx)) - (cl-flet ((btn (label key fill) - (svg-rectangle svg bx by bw bh :rx (funcall F 6) :fill fill - :stroke "#0a3a1a" :stroke-width 1) - (cg-svg--text svg label (+ bx (/ bw 2)) (+ by (round (* bh 0.64))) - (funcall F 13) "#ffffff" t) - (setq regions (plist-put regions key (list bx by bw bh))) - (setq bx (+ bx bw g)))) - (btn "Close" :help-close "#2e7d32") - (btn "Classic view" :help-classic "#34495e") - (btn "Quit" :help-quit "#7f3b3b"))) - regions)) - -(defun cg-bid--ui-svg (game &optional w h) - "Return (SVG . REGIONS) for the full-buffer SVG-UI of GAME (W by H). -Everything scales proportionally with the canvas: FS drives fonts and -table cards, PSCALE the side-panel widths." - (let* ((W (or w cg-bid--ui-w)) (H (or h cg-bid--ui-h)) - (svg (svg-create W H)) (regions nil) - ;; master scales relative to the base 860x540 canvas - (fs (max 1.0 (min 2.0 (/ (+ (/ (float W) cg-bid--ui-w) - (/ (float H) cg-bid--ui-h)) 2.0)))) - (pscale (max 1.0 (min 1.7 (/ (float W) cg-bid--ui-w)))) - (lpw (round (* 196 pscale))) - (rp-w (round (* 206 pscale))) - (rp-x (- W rp-w)) - (tx (+ lpw 14)) (tw (max 320 (- rp-x tx 8))) - (ty 8) (th (- H 16)) - (cx (+ tx (/ tw 2))) (cy (+ ty (/ th 2))) - ;; opponent/trick card size grows up to ~2x - (otw (round (* cg-bid--tw fs))) (oth (round (* cg-bid--th fs))) - ;; compass-centre line; North sits just below it, its name just above - (ccy (max 56 (round (* H 0.12))))) - (let* ((base (or cg-bid-felt-color "#15692f")) - (lite (or (ignore-errors (color-lighten-name base 12)) base)) - (dark (or (ignore-errors (color-darken-name base 18)) base))) - (svg-gradient svg "cg-felt2" 'radial (list (cons 0 lite) (cons 100 dark))) - (svg-rectangle svg 0 0 W H :rx 14 :gradient "cg-felt2") - (svg-rectangle svg (- tx 6) 8 (+ tw 12) (- H 16) :rx 12 - :fill "none" :stroke "#0e5226" :stroke-width 2)) - (let ((cg-svg-card-width otw) (cg-svg-card-height oth) - (cg-svg-card-gap (max 2 (round (* 4 fs)))) - (inset (round (* 70 fs)))) - ;; North: cards just below the compass line, name just above it - (cg-bid--draw-opponent svg game 2 cx (+ ccy (round (* 4 fs))) fs) - ;; West/East: vertically centred on the table midline - (cg-bid--draw-opponent svg game 1 (+ tx inset) (- cy (/ oth 2)) fs) - (cg-bid--draw-opponent svg game 3 (- (+ tx tw) inset) (- cy (/ oth 2)) fs) - (cg-bid--draw-trick-at svg game cx (- cy 24) fs)) - (let ((ss (cg-bid--south-size W H))) - (setq regions (append regions - (cg-bid--draw-south-region svg game tx tw (+ ty th) - (car ss) (cdr ss))))) - (when (memq (cg-get game :phase) '(done gameover)) - (let* ((hy (nth 2 (plist-get regions :hand))) - (bw (round (* 120 fs))) (bh (round (* 26 fs))) - (bx (- cx (/ bw 2))) (by (- hy bh (round (* 8 fs))))) - (svg-rectangle svg bx by bw bh :rx 6 :fill "#2e7d32" - :stroke "#0a3a1a" :stroke-width 1) - (cg-svg--text svg "Next hand" (+ bx (/ bw 2)) (+ by (round (* bh 0.66))) - (round (* 14 fs)) "#ffffff" t) - (setq regions (plist-put regions :next (list bx by bw bh))))) - (setq regions (append regions (cg-bid--draw-left-panel svg game H lpw fs ccy))) - (setq regions (append regions (cg-bid--draw-log svg game rp-x rp-w H fs ccy))) - (cg-bid--draw-banner svg game tx tw ty fs) - (when (cg-get game :help-open) - (setq regions (append regions - (cg-bid--draw-help-overlay svg game tx ty tw th fs)))) - (cons svg regions))) - -(defun cg-bid--insert-svg-ui (game) - "Insert the full-buffer SVG-UI for GAME and record its regions. -When `cg-bid-svg-fill', size the canvas to fill the window." - (let* ((win (get-buffer-window (current-buffer))) - (fill (and cg-bid-svg-fill win)) - (w (if fill (max 720 (window-body-width win t)) cg-bid--ui-w)) - (h (if fill (max 470 (- (window-body-height win t) 4)) cg-bid--ui-h)) - (sr (cg-bid--ui-svg game w h))) - (when fill (setq cg-bid--last-size (cons (window-body-width win t) - (window-body-height win t)))) - (setq cg-bid--regions (cdr sr)) - (insert-image (cg-svg-image (car sr) (if fill 1.0 (cg-scale)))) - (put-text-property (point-min) (point-max) 'pointer 'hand))) - -(defun cg-bid--fit (&rest _) - "Re-render the SVG-UI to fit the window after a configuration change." - (when (and cg-bid--game cg-bid-svg-ui cg-bid-svg-fill - (eq major-mode 'cg-bid-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-bid--last-size) - (setq cg-bid--last-size sz) - (cg-bid--redisplay))))))) - -(defun cg-bid-log-up () - "Scroll the SVG-UI message log towards older entries." - (interactive) - (let* ((game cg-bid--game) (max (max 0 (1- (length (cg-get game :log)))))) - (cg-put game :log-scroll (min max (1+ (or (cg-get game :log-scroll) 0)))) - (cg-bid--redisplay))) - -(defun cg-bid-log-down () - "Scroll the SVG-UI message log towards newer entries." - (interactive) - (let ((game cg-bid--game)) - (cg-put game :log-scroll (max 0 (1- (or (cg-get game :log-scroll) 0)))) - (cg-bid--redisplay))) - -(defun cg-bid-wheel (event) - "Scroll the message log when the wheel turns over the log area. -Elsewhere, fall back to normal buffer scrolling." - (interactive "e") - (let ((start (event-start event)) (rg cg-bid--regions) (handled nil)) - (when (and cg-bid-svg-ui (display-graphic-p) (posn-image start)) - (let* ((xy (posn-object-x-y start)) (s (cg-scale)) - (px (round (/ (car xy) s))) (py (round (/ (cdr xy) s)))) - (when (cg-bid--in-rect px py (plist-get rg :log-region)) - (setq handled t) - (pcase (event-basic-type event) - ((or 'wheel-up 'mouse-4) (cg-bid-log-up)) - ((or 'wheel-down 'mouse-5) (cg-bid-log-down)))))) - (unless handled - (ignore-errors (require 'mwheel) (mwheel-scroll event))))) - -(defun cg-bid--region-bid (px py rg) - "Return the bid whose button rect contains PX,PY in REGIONS RG, or nil." - (cl-some (lambda (e) (and (cg-bid--in-rect px py (cdr e)) (car e))) - (plist-get rg :bids))) - -(defun cg-bid--region-hand (px py hl) - "Return the South-hand index at PX,PY given hand layout HL, or nil." - (when hl - (let ((x0 (nth 0 hl)) (step (nth 1 hl)) (y (nth 2 hl)) (n (nth 3 hl)) - (sh (or (nth 4 hl) cg-bid--sh))) - (when (and (> n 0) (>= py (- y (round (* sh 0.17)) 4)) - (<= py (+ y sh 8)) (>= px x0)) - (let ((i (if (<= step 0) 0 (/ (- px x0) step)))) (when (< i n) i)))))) - -(defun cg-bid--sizer-hit (px py rg) - "If PX,PY lands on a card-size slider stop in RG, apply it; return non-nil." - (let ((hit (cl-some (lambda (e) (and (cg-bid--in-rect px py (car e)) (cdr e))) - (plist-get rg :sizer)))) - (when (and (consp hit) (eq (car hit) 'scale)) - (setq cg-bid-card-scale (cdr hit)) - (cg-bid--refresh) - t))) - -(defun cg-bid--svg-ui-click (start) - "Dispatch a click at posn START within the SVG-UI." - (let* ((xy (posn-object-x-y start)) (s (cg-scale)) - (px (round (/ (car xy) s))) (py (round (/ (cdr xy) s))) - (game cg-bid--game) (rg cg-bid--regions) bid) - (if (cg-get game :help-open) - (cond - ((cg-bid--in-rect px py (plist-get rg :help-classic)) (cg-bid-toggle-svg-ui)) - ((cg-bid--in-rect px py (plist-get rg :help-quit)) (quit-window)) - (t (cg-put game :help-open nil) (cg-bid--redisplay))) - (cond - ((cg-bid--in-rect px py (plist-get rg :help)) - (cg-put game :help-open t) (cg-bid--redisplay)) - ((cg-bid--in-rect px py (plist-get rg :scroll-up)) (cg-bid-log-up)) - ((cg-bid--in-rect px py (plist-get rg :scroll-down)) (cg-bid-log-down)) - ((cg-bid--in-rect px py (plist-get rg :next)) (cg-bid-new)) - ((cg-bid--in-rect px py (plist-get rg :discard)) (cg-bid-discard-marked)) - ((cg-bid--sizer-hit px py rg)) - ((and (cg-bid--in-rect px py (plist-get rg :pass)) - (eq (cg-get game :phase) 'auction) (= (cg-get game :bidder) 0)) - (cg-bid--auction-act game 0 nil) (cg-bid--refresh)) - ((setq bid (cg-bid--region-bid px py rg)) - (cg-bid--auction-act game 0 bid) (cg-bid--refresh)) - (t (let ((i (cg-bid--region-hand px py (plist-get rg :hand)))) - (when i (cg-put game :cursor i) (cg-bid-select)))))))) - -(defun cg-bid-toggle-svg-ui () - "Toggle the full-buffer SVG UI for 500." - (interactive) - (setq cg-bid-svg-ui (not cg-bid-svg-ui)) - (setq cg-bid--last-size nil) - (cg-bid--redisplay) - (message "Full-SVG UI %s" (if cg-bid-svg-ui "enabled" "disabled"))) - -(provide 'cg-bid-ui) -;;; cg-bid-ui.el ends here diff --git a/cg-bid.el b/cg-bid.el deleted file mode 100644 index 0ea82cf..0000000 --- a/cg-bid.el +++ /dev/null @@ -1,844 +0,0 @@ -;;; cg-bid.el --- 500 (Bid) — game logic -*- lexical-binding: t; -*- - -;; Copyright (C) 2026 Corwin Brust - -;; Author: Corwin Brust -;; Maintainer: Corwin Brust -;; 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 . - -;;; 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 diff --git a/cg-bridge.el b/cg-bridge.el deleted file mode 100644 index 31ac37a..0000000 --- a/cg-bridge.el +++ /dev/null @@ -1,875 +0,0 @@ -;;; cg-bridge.el --- Contract Bridge with rubber scoring -*- lexical-binding: t; -*- - -;; Copyright (C) 2026 Corwin Brust - -;; Author: Corwin Brust -;; Maintainer: Corwin Brust -;; 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 . - -;;; 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 "") #'cg-bridge-left) - (define-key map (kbd "") #'cg-bridge-right) - (define-key map (kbd "") #'cg-bridge-up) - (define-key map (kbd "") #'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 diff --git a/cg-crapette.el b/cg-crapette.el deleted file mode 100644 index d9f302b..0000000 --- a/cg-crapette.el +++ /dev/null @@ -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 -;; Maintainer: Corwin Brust -;; 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 . - -;;; 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 "") #'cg-crap-left) - (define-key map (kbd "") #'cg-crap-right) - (define-key map (kbd "") #'cg-crap-left) - (define-key map (kbd "") #'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 diff --git a/cg-cribbage.el b/cg-cribbage.el deleted file mode 100644 index 1b3f206..0000000 --- a/cg-cribbage.el +++ /dev/null @@ -1,526 +0,0 @@ -;;; cg-cribbage.el --- Cribbage, with pegging and the show -*- lexical-binding: t; -*- - -;; Copyright (C) 2026 Corwin Brust - -;; Author: Corwin Brust -;; Maintainer: Corwin Brust -;; 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 . - -;;; 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")))) - (cg-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 (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) - (cg-crib--peg "You" (aref scores 0) y-peg) - (cg-crib--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 "") #'cg-crib-left) - (define-key map (kbd "") #'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 diff --git a/cg-eights.el b/cg-eights.el deleted file mode 100644 index 238c752..0000000 --- a/cg-eights.el +++ /dev/null @@ -1,444 +0,0 @@ -;;; cg-eights.el --- Crazy Eights, a shedding card game -*- lexical-binding: t; -*- - -;; Copyright (C) 2026 Corwin Brust - -;; Author: Corwin Brust -;; Maintainer: Corwin Brust -;; 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 . - -;;; 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 "") #'cg-eights-left) - (define-key map (kbd "") #'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 diff --git a/cg-gaps.el b/cg-gaps.el deleted file mode 100644 index 8a53833..0000000 --- a/cg-gaps.el +++ /dev/null @@ -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 -;; Maintainer: Corwin Brust -;; 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 . - -;;; 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 "") #'cg-gaps-left) - (define-key map (kbd "") #'cg-gaps-right) - (define-key map (kbd "") #'cg-gaps-up) - (define-key map (kbd "") #'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 diff --git a/cg-handfoot.el b/cg-handfoot.el deleted file mode 100644 index 352e9e8..0000000 --- a/cg-handfoot.el +++ /dev/null @@ -1,796 +0,0 @@ -;;; cg-handfoot.el --- Hand and Foot, a partnership rummy -*- lexical-binding: t; -*- - -;; Copyright (C) 2026 Corwin Brust - -;; Author: Corwin Brust -;; Maintainer: Corwin Brust -;; 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 . - -;;; 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 "") #'cg-hf-left) - (define-key map (kbd "") #'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 diff --git a/cg-match.el b/cg-match.el deleted file mode 100644 index 951d25f..0000000 --- a/cg-match.el +++ /dev/null @@ -1,608 +0,0 @@ -;;; cg-match.el --- Go Fish and Old Maid -*- lexical-binding: t; -*- - -;; Copyright (C) 2026 Corwin Brust - -;; Author: Corwin Brust -;; Maintainer: Corwin Brust -;; 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 . - -;;; 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 "") #'cg-gf-left) - (define-key map (kbd "") #'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 "") #'cg-om-left) - (define-key map (kbd "") #'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 diff --git a/cg-patience.el b/cg-patience.el deleted file mode 100644 index 6deebc0..0000000 --- a/cg-patience.el +++ /dev/null @@ -1,449 +0,0 @@ -;;; cg-patience.el --- Pile solitaires (Golf, TriPeaks, Pyramid) -*- lexical-binding: t; -*- - -;; Copyright (C) 2026 Corwin Brust - -;; Author: Corwin Brust -;; Maintainer: Corwin Brust -;; 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 . - -;;; 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 "") #'cg-pat-left) - (define-key map (kbd "") #'cg-pat-right) - (define-key map (kbd "") #'cg-pat-left) - (define-key map (kbd "") #'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 diff --git a/cg-president.el b/cg-president.el deleted file mode 100644 index 11ada49..0000000 --- a/cg-president.el +++ /dev/null @@ -1,426 +0,0 @@ -;;; cg-president.el --- President (Scum), a climbing card game -*- lexical-binding: t; -*- - -;; Copyright (C) 2026 Corwin Brust - -;; Author: Corwin Brust -;; Maintainer: Corwin Brust -;; 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 . - -;;; 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 "") #'cg-pres-left) - (define-key map (kbd "") #'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 diff --git a/cg-rum500.el b/cg-rum500.el deleted file mode 100644 index 9c92630..0000000 --- a/cg-rum500.el +++ /dev/null @@ -1,666 +0,0 @@ -;;; cg-rum500.el --- Basic Rummy and Rummy 500 -*- lexical-binding: t; -*- - -;; Copyright (C) 2026 Corwin Brust - -;; Author: Corwin Brust -;; Maintainer: Corwin Brust -;; 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 . - -;;; 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 "") #'cg-tm-left) - (define-key map (kbd "") #'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 diff --git a/cg-scopa.el b/cg-scopa.el deleted file mode 100644 index 6947920..0000000 --- a/cg-scopa.el +++ /dev/null @@ -1,439 +0,0 @@ -;;; cg-scopa.el --- Scopa and Casino, capturing games -*- lexical-binding: t; -*- - -;; Copyright (C) 2026 Corwin Brust - -;; Author: Corwin Brust -;; Maintainer: Corwin Brust -;; 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 . - -;;; 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 "") #'cg-fish-left) - (define-key map (kbd "") #'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 diff --git a/cg-solitaire.el b/cg-solitaire.el deleted file mode 100644 index c186c2e..0000000 --- a/cg-solitaire.el +++ /dev/null @@ -1,1017 +0,0 @@ -;;; cg-solitaire.el --- Tableau solitaires (Klondike, FreeCell, Spider, Yukon) -*- lexical-binding: t; -*- - -;; Copyright (C) 2026 Corwin Brust - -;; Author: Corwin Brust -;; Maintainer: Corwin Brust -;; 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 . - -;;; Commentary: - -;; A shared engine for tableau solitaires, with four games built on it: -;; -;; `cg-klondike' -- the classic "Solitaire": seven columns, a stock and -;; waste, build the foundations up by suit from the Ace. -;; `cg-freecell' -- all cards dealt face up, four free cells, no stock; -;; a game of nearly pure skill. -;; `cg-spider' -- two decks, ten columns; build down regardless of suit -;; but only same-suit runs move; clear eight K..A runs. -;; `cg-yukon' -- Klondike's layout, all face up, move any buried group. -;; -;; Cards are the package-standard cons (SUIT . RANK) with SUIT 0 spades, -;; 1 clubs, 2 diamonds, 3 hearts and RANK 0 Ace .. 12 King. Each tableau -;; column is a list ordered bottom (screen top) to top (the accessible -;; card); a per-column face-down count tracks the hidden prefix. -;; -;; Play is by keyboard: move the cursor between piles with the arrow keys -;; and press RET to pick up the movable run from a pile, then RET again on -;; a destination to drop it. `f' sends a card to a foundation, `a' auto- -;; plays everything it can, and the stock pile deals or recycles on RET. - -;;; Code: - -(require 'cl-lib) -(require 'eieio) -(require 'cg-core) -(require 'cg-svg) -(require 'cg-render) - -;;;; Cards - -(defconst cg-sol-ranks - ["A" "2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K"] - "Rank labels indexed 0..12 (Ace through King).") - -(defun cg-sol-card-string (card &optional down) - "Return a short string for CARD. -With DOWN non-nil, draw a face-down back instead. A nil CARD draws an -empty-slot dot." - (cond (down "##") - ((null card) "·") - (t (concat (aref cg-sol-ranks (cdr card)) (cg-suit-glyph (car card)))))) - -(defsubst cg-sol-red-p (card) - "Return non-nil when CARD is a red suit." - (and card (cg-red-suit-p (car card)))) - -(defun cg-sol--make-deck (ndecks) - "Return a shuffled list of NDECKS standard 52-card decks." - (random t) - (let ((cards nil)) - (dotimes (_ ndecks) - (dotimes (s 4) - (dotimes (r 13) - (push (cons s r) cards)))) - (cg-shuffle cards))) - -;;;; Game classes - -(defclass cg-solitaire-game (cg-game) - ((ncols :initform 7 :documentation "Number of tableau columns.") - (ndecks :initform 1 :documentation "Number of 52-card decks used.") - (nfound :initform 4 :documentation "Number of foundation piles.") - (nfree :initform 0 :documentation "Number of free cells.") - (has-stock :initform nil :documentation "Whether a stock pile exists.") - (has-waste :initform nil :documentation "Whether a waste pile exists.") - (build :initform 'alt :documentation "Tableau placement rule: alt, suit, any.") - (run-rule :initform 'alt :documentation "Movable-run cohesion: alt, suit, any.") - (empty-rule :initform 'king :documentation "Empty-column rule: king or any.") - (redeal :initform t :documentation "Whether an empty stock recycles the waste.") - (draw :initform 1 :documentation "Cards turned from the stock to the waste.") - (target-sets :initform 8 :documentation "Completed runs to win when NFOUND is 0.") - (base :initform 0 :documentation "Foundation base rank (0 = Ace).") - (wrap :initform nil :documentation "Whether foundations wrap King to Ace.") - (has-reserve :initform nil :documentation "Whether a reserve pile exists (Canfield).") - (vname :initform "Solitaire" :documentation "Display name.")) - "Abstract base for tableau solitaires." - :abstract t) - -(defclass cg-klondike-game (cg-solitaire-game) - ((has-stock :initform t) (has-waste :initform t) - (vname :initform "Klondike")) - "Klondike: seven columns, stock and waste, foundations up by suit.") - -(defclass cg-freecell-game (cg-solitaire-game) - ((ncols :initform 8) (nfree :initform 4) (empty-rule :initform 'any) - (vname :initform "FreeCell")) - "FreeCell: eight columns dealt face up, four free cells, no stock.") - -(defclass cg-yukon-game (cg-solitaire-game) - ((run-rule :initform 'any) (vname :initform "Yukon")) - "Yukon: Klondike layout dealt mostly face up; move any buried group.") - -(defclass cg-spider-game (cg-solitaire-game) - ((ncols :initform 10) (ndecks :initform 2) (nfound :initform 0) - (has-stock :initform t) (build :initform 'any) (run-rule :initform 'suit) - (empty-rule :initform 'any) (vname :initform "Spider")) - "Spider: two decks, ten columns; clear eight K..A same-suit runs.") - -;;;; Rules (predicates) - -(defun cg-sol--diff-color-p (a b) - "Return non-nil when cards A and B are of opposite colours." - (not (eq (cg-red-suit-p (car a)) (cg-red-suit-p (car b))))) - -(cl-defmethod cg-sol--link-p ((game cg-solitaire-game) upper lower) - "Return non-nil when LOWER may rest directly on UPPER within a run." - (pcase (oref game run-rule) - ('any t) - ('suit (and (= (cdr lower) (1- (cdr upper))) (= (car lower) (car upper)))) - (_ (and (= (cdr lower) (1- (cdr upper))) (cg-sol--diff-color-p upper lower))))) - -(cl-defmethod cg-sol--place-p ((game cg-solitaire-game) top card) - "Return non-nil when CARD may be placed on a column whose top is TOP." - (pcase (oref game build) - ('any (= (cdr card) (1- (cdr top)))) - ('suit (and (= (cdr card) (1- (cdr top))) (= (car card) (car top)))) - (_ (and (= (cdr card) (1- (cdr top))) (cg-sol--diff-color-p top card))))) - -(cl-defmethod cg-sol--empty-accepts ((game cg-solitaire-game) card) - "Return non-nil when CARD may be placed on an empty column." - (pcase (oref game empty-rule) - ('king (= (cdr card) 12)) - (_ t))) - -;;;; Layout and dealing - -(cl-defgeneric cg-sol--layout (game) - "Return a list of (DOWN . UP) card counts, one per tableau column.") - -(cl-defmethod cg-sol--layout ((_ cg-klondike-game)) - (cl-loop for i below 7 collect (cons i 1))) -(cl-defmethod cg-sol--layout ((_ cg-yukon-game)) - (cons (cons 0 1) (cl-loop for i from 1 below 7 collect (cons i 5)))) -(cl-defmethod cg-sol--layout ((_ cg-freecell-game)) - (append (make-list 4 (cons 0 7)) (make-list 4 (cons 0 6)))) -(cl-defmethod cg-sol--layout ((_ cg-spider-game)) - (append (make-list 4 (cons 5 1)) (make-list 6 (cons 4 1)))) - -(cl-defmethod cg-sol--deal ((game cg-solitaire-game)) - "Deal a fresh layout into GAME and initialise its environment." - (let* ((deck (cg-sol--make-deck (oref game ndecks))) - (nc (oref game ncols)) - (layout (cg-sol--layout game)) - (tableau (make-vector nc nil)) - (down (make-vector nc 0))) - (dotimes (c nc) - (let* ((spec (nth c layout)) - (col nil)) - (dotimes (_ (+ (car spec) (cdr spec))) - (push (pop deck) col)) - (aset tableau c (nreverse col)) - (aset down c (car spec)))) - (cg-put game :tableau tableau) - (cg-put game :down down) - (cg-put game :found (make-vector (oref game nfound) nil)) - (cg-put game :free (make-vector (oref game nfree) nil)) - (cg-put game :stock deck) - (cg-put game :waste nil) - (cg-put game :sets 0) - (cg-put game :moves 0) - (cg-put game :cursor 0) - (cg-put game :sel nil) - (cg-put game :sel-n 0) - (cg-put game :history nil) - (cg-put game :message - (format "%s. Arrows move; RET picks up/drops; f=foundation; a=auto; ?=help." - (oref game vname))) - game)) - -;;;; Spots (the cursor visits piles) - -(cl-defmethod cg-sol--spots ((game cg-solitaire-game)) - "Return the ordered list of (TYPE . INDEX) piles the cursor can visit." - (append - (when (oref game has-stock) '((stock . 0))) - (when (oref game has-waste) '((waste . 0))) - (when (oref game has-reserve) '((reserve . 0))) - (cl-loop for i below (oref game nfree) collect (cons 'free i)) - (cl-loop for i below (oref game nfound) collect (cons 'found i)) - (cl-loop for i below (oref game ncols) collect (cons 'col i)))) - -(defun cg-sol--cur-spot (game) - "Return the (TYPE . INDEX) spot currently under the cursor." - (nth (cg-get game :cursor) (cg-sol--spots game))) - -;;;; Pile access helpers - -(defun cg-sol--col (game c) "Column C of GAME (a list)." (aref (cg-get game :tableau) c)) -(defun cg-sol--set-col (game c v) (aset (cg-get game :tableau) c v)) -(defun cg-sol--down (game c) "Face-down count of column C." (aref (cg-get game :down) c)) -(defun cg-sol--set-down (game c v) (aset (cg-get game :down) c v)) - -(defun cg-sol--col-top (game c) - "Return the top (accessible) card of column C, or nil." - (car (last (cg-sol--col game c)))) - -(defun cg-sol--exposed (game c) - "Return the face-up cards of column C (bottom..top order)." - (nthcdr (cg-sol--down game c) (cg-sol--col game c))) - -(cl-defmethod cg-sol--top-run ((game cg-solitaire-game) c) - "Return the longest movable run from the top of column C (bottom..top)." - (let ((top->bottom (reverse (cg-sol--exposed game c)))) - (if (null top->bottom) - nil - (let ((run (list (car top->bottom))) - (prev (car top->bottom))) - (catch 'done - (dolist (card (cdr top->bottom)) - (if (cg-sol--link-p game card prev) - (progn (push card run) (setq prev card)) - (throw 'done nil)))) - run)))) - -(defun cg-sol--spot-top (game spot) - "Return the top card available at SPOT, or nil." - (pcase (car spot) - ('col (cg-sol--col-top game (cdr spot))) - ('waste (car (last (cg-get game :waste)))) - ('free (aref (cg-get game :free) (cdr spot))) - ('found (car (last (aref (cg-get game :found) (cdr spot))))) - ('reserve (car (last (cg-get game :reserve)))) - (_ nil))) - -;;;; Foundations - -(defun cg-sol--found-accepts (game i card) - "Return non-nil when CARD may go onto foundation I of GAME." - (and card - (let ((f (aref (cg-get game :found) i))) - (if (null f) - (= (cdr card) (oref game base)) ; empty foundation takes the base rank - (let* ((top (car (last f))) - (need (if (oref game wrap) (mod (1+ (cdr top)) 13) (1+ (cdr top))))) - (and (= (car card) (car top)) - (= (cdr card) need))))))) - -(defun cg-sol--found-for (game card) - "Return the index of a foundation that would accept CARD, or nil." - (cl-loop for i below (oref game nfound) - when (cg-sol--found-accepts game i card) return i)) - -;;;; Move primitives - -(defun cg-sol--snapshot (game) - "Push a deep-ish copy of GAME's mutable state onto the undo history." - (let ((tab (cg-get game :tableau)) - (frv (cg-get game :found)) - (fre (cg-get game :free))) - (cg-put game :history - (cons (list (vconcat (mapcar #'copy-sequence tab)) - (copy-sequence (cg-get game :down)) - (vconcat (mapcar #'copy-sequence frv)) - (copy-sequence fre) - (copy-sequence (cg-get game :stock)) - (copy-sequence (cg-get game :waste)) - (cg-get game :sets) - (cg-get game :moves) - (copy-sequence (cg-get game :reserve))) - (cg-get game :history))))) - -(defun cg-sol--restore (game) - "Pop and restore the most recent undo snapshot of GAME, if any." - (let ((h (cg-get game :history))) - (when h - (cl-destructuring-bind (tab down frv fre stock waste sets moves reserve) (car h) - (cg-put game :tableau tab) - (cg-put game :down down) - (cg-put game :found frv) - (cg-put game :free fre) - (cg-put game :stock stock) - (cg-put game :waste waste) - (cg-put game :sets sets) - (cg-put game :moves moves) - (cg-put game :reserve reserve)) - (cg-put game :history (cdr h)) - (cg-put game :sel nil) - t))) - -(defun cg-sol--flip (game c) - "Flip the top of column C face up if it is face down." - (let ((len (length (cg-sol--col game c))) - (d (cg-sol--down game c))) - (when (and (> len 0) (>= d len)) - (cg-sol--set-down game c (1- len))))) - -(defun cg-sol--take (game spot n) - "Remove and return the top N cards (bottom..top order) from SPOT." - (pcase (car spot) - ('col (let* ((c (cdr spot)) (col (cg-sol--col game c)) - (run (last col n))) - (cg-sol--set-col game c (butlast col n)) - (let ((len (length (cg-sol--col game c)))) - (when (> (cg-sol--down game c) len) - (cg-sol--set-down game c len))) - (cg-sol--flip game c) - run)) - ('waste (let ((w (cg-get game :waste))) - (cg-put game :waste (butlast w 1)) (last w 1))) - ('free (let ((card (aref (cg-get game :free) (cdr spot)))) - (aset (cg-get game :free) (cdr spot) nil) (list card))) - ('found (let* ((i (cdr spot)) (f (aref (cg-get game :found) i))) - (aset (cg-get game :found) i (butlast f 1)) (last f 1))) - ('reserve (let ((r (cg-get game :reserve))) - (cg-put game :reserve (butlast r 1)) (last r 1))) - (_ nil))) - -(defun cg-sol--can-drop (game spot cards) - "Return non-nil when the run CARDS (bottom..top) may drop on SPOT." - (and cards - (pcase (car spot) - ('col (let* ((c (cdr spot)) (top (cg-sol--col-top game c))) - (if top - (cg-sol--place-p game top (car cards)) - (cg-sol--empty-accepts game (car cards))))) - ('found (and (= 1 (length cards)) - (cg-sol--found-accepts game (cdr spot) (car cards)))) - ('free (and (= 1 (length cards)) - (null (aref (cg-get game :free) (cdr spot))))) - (_ nil)))) - -(defun cg-sol--drop (game spot cards) - "Place the run CARDS (bottom..top) onto SPOT." - (pcase (car spot) - ('col (let ((c (cdr spot))) - (cg-sol--set-col game c (append (cg-sol--col game c) cards)))) - ('found (let ((i (cdr spot))) - (aset (cg-get game :found) i - (append (aref (cg-get game :found) i) cards)))) - ('free (aset (cg-get game :free) (cdr spot) (car cards))))) - -;;;; Spider: complete-run removal - -(cl-defmethod cg-sol--harvest ((game cg-solitaire-game)) - "Remove any complete K..A same-suit run from a column top; bump :sets. -Only games without foundations (NFOUND 0: Spider, Scorpion) harvest runs." - (when (= 0 (oref game nfound)) - (dotimes (c (oref game ncols)) - (let* ((col (cg-sol--col game c)) - (exp (cg-sol--exposed game c))) - (when (>= (length exp) 13) - (let ((run (last exp 13)) (ok t) (suit (car (nth 0 (last exp 13))))) - (cl-loop for k below 13 - for card = (nth k run) - unless (and (= (car card) suit) (= (cdr card) (- 12 k))) - do (setq ok nil)) - (when ok - (cg-sol--set-col game c (butlast col 13)) - (let ((len (length (cg-sol--col game c)))) - (when (> (cg-sol--down game c) len) (cg-sol--set-down game c len))) - (cg-sol--flip game c) - (cg-put game :sets (1+ (cg-get game :sets)))))))))) - -;;;; Stock action - -(defcustom cg-sol-klondike-draw 1 - "Number of cards turned from the stock to the waste in Klondike." - :type '(choice (const :tag "Draw one" 1) (const :tag "Draw three" 3)) - :group 'card-games) - -(cl-defmethod cg-sol--stock-action ((game cg-solitaire-game)) - "Deal `draw' cards to the waste, recycling the waste when `redeal'." - (if (not (oref game has-waste)) - (cg-put game :message "No stock to deal.") - (cg-sol--snapshot game) - (let ((stock (cg-get game :stock)) (waste (cg-get game :waste))) - (if stock - (let ((n (min (oref game draw) (length stock)))) - (dotimes (_ n) - (setq waste (append waste (last stock 1))) - (setq stock (butlast stock 1))) - (cg-put game :stock stock) (cg-put game :waste waste) - (cg-put game :message "Dealt from stock.")) - (if (and (oref game redeal) waste) - (progn (cg-put game :stock (reverse waste)) (cg-put game :waste nil) - (cg-put game :message "Recycled the waste into the stock.")) - (cg-put game :message "The stock is empty.")))))) - -(cl-defmethod cg-sol--stock-action ((game cg-klondike-game)) - (cg-sol--snapshot game) - (let ((stock (cg-get game :stock)) (waste (cg-get game :waste))) - (if stock - (let ((n (min cg-sol-klondike-draw (length stock)))) - (dotimes (_ n) - (setq waste (append waste (last stock 1))) - (setq stock (butlast stock 1))) - (cg-put game :stock stock) (cg-put game :waste waste) - (cg-put game :message "Dealt from stock.")) - (if waste - (progn (cg-put game :stock (reverse waste)) (cg-put game :waste nil) - (cg-put game :message "Recycled the waste into the stock.")) - (cg-put game :message "Stock and waste are both empty."))))) - -(cl-defmethod cg-sol--stock-action ((game cg-spider-game)) - (let ((stock (cg-get game :stock))) - (cond - ((null stock) (cg-put game :message "The stock is empty.")) - ((cl-loop for c below (oref game ncols) - thereis (null (cg-sol--col game c))) - (cg-put game :message "Fill every column before dealing from the stock.")) - (t (cg-sol--snapshot game) - (dotimes (c (oref game ncols)) - (cg-sol--set-col game c (append (cg-sol--col game c) (last stock 1))) - (setq stock (butlast stock 1))) - (cg-put game :stock stock) - (cg-sol--harvest game) - (cg-put game :message "Dealt a row from the stock."))))) - -;;;; Win - -(cl-defmethod cg-won-p ((game cg-solitaire-game)) - "Return non-nil when GAME is solved." - (if (= 0 (oref game nfound)) - (>= (cg-get game :sets) (oref game target-sets)) - (cl-every (lambda (f) (= 13 (length f))) - (append (cg-get game :found) nil)))) - -;;;; Interaction - -(defvar-local cg-sol--game nil "The solitaire game in the current buffer.") - -(cl-defmethod cg-sol--selectable ((game cg-solitaire-game) spot) - "Return the run (bottom..top) GAME would pick up from SPOT, or nil." - (pcase (car spot) - ('col (cg-sol--top-run game (cdr spot))) - ('waste (let ((c (cg-sol--spot-top game spot))) (and c (list c)))) - ('free (let ((c (cg-sol--spot-top game spot))) (and c (list c)))) - ('found (let ((c (cg-sol--spot-top game spot))) (and c (list c)))) - ('reserve (let ((c (cg-sol--spot-top game spot))) (and c (list c)))) - (_ nil))) - -(defun cg-sol-act (&optional count) - "Pick up from, or drop onto, the pile under the cursor. -With prefix COUNT, pick up exactly COUNT cards from a column." - (interactive "P") - (let* ((game cg-sol--game) - (spot (cg-sol--cur-spot game)) - (sel (cg-get game :sel))) - (cond - ((eq (car spot) 'stock) - (cg-put game :sel nil) - (cg-sol--stock-action game)) - ((null sel) - (let ((run (cg-sol--selectable game spot))) - (cond - ((null run) (cg-put game :message "Nothing to pick up there.")) - (t (when (and count (eq (car spot) 'col)) - (setq run (last run (min (prefix-numeric-value count) (length run))))) - (cg-put game :sel spot) - (cg-put game :sel-n (length run)) - (cg-put game :message - (format "Picked up %d card%s. RET on a destination." - (length run) (if (= 1 (length run)) "" "s"))))))) - ((equal sel spot) - (cg-put game :sel nil) (cg-put game :message "Cancelled.")) - (t - (let* ((n (cg-get game :sel-n)) - (cards (last (pcase (car sel) - ('col (cg-sol--col game (cdr sel))) - ('waste (cg-get game :waste)) - ('found (aref (cg-get game :found) (cdr sel))) - ('free (list (aref (cg-get game :free) (cdr sel))))) - n))) - (if (cg-sol--can-drop game spot cards) - (progn (cg-sol--snapshot game) - (cg-sol--take game sel n) - (cg-sol--drop game spot cards) - (cg-put game :moves (1+ (cg-get game :moves))) - (cg-sol--harvest game) - (cg-put game :sel nil) - (cg-put game :message "Moved.")) - (cg-put game :sel nil) - (cg-put game :message "That move is not allowed.")))))) - (cg-sol--after cg-sol--game)) - -(defun cg-sol-to-foundation () - "Send the top card of the pile under the cursor to a foundation." - (interactive) - (let* ((game cg-sol--game) - (spot (cg-sol--cur-spot game)) - (card (cg-sol--spot-top game spot))) - (if (and card (memq (car spot) '(col waste free reserve))) - (let ((i (cg-sol--found-for game card))) - (if i - (progn (cg-sol--snapshot game) - (cg-sol--take game spot 1) - (cg-sol--drop game (cons 'found i) (list card)) - (cg-put game :moves (1+ (cg-get game :moves))) - (cg-put game :sel nil) - (cg-put game :message "To the foundation.")) - (cg-put game :message "No foundation will take that card."))) - (cg-put game :message "Nothing to send to a foundation."))) - (cg-sol--after cg-sol--game)) - -(defun cg-sol-auto () - "Repeatedly send any eligible card to the foundations." - (interactive) - (let ((game cg-sol--game) (moved 0)) - (when (> (oref game nfound) 0) - (cg-sol--snapshot game) - (let (again) - (cl-loop - do (setq again nil) - (dolist (spot (cg-sol--spots game)) - (when (memq (car spot) '(col waste free reserve)) - (let* ((card (cg-sol--spot-top game spot)) - (i (and card (cg-sol--found-for game card)))) - (when i - (cg-sol--take game spot 1) - (cg-sol--drop game (cons 'found i) (list card)) - (setq moved (1+ moved) again t))))) - while again)) - (if (> moved 0) - (progn (cg-put game :moves (+ moved (cg-get game :moves))) - (cg-put game :sel nil) - (cg-put game :message (format "Auto-played %d card%s." - moved (if (= 1 moved) "" "s")))) - (cg-put game :history (cdr (cg-get game :history))) - (cg-put game :message "Nothing to auto-play.")))) - (cg-sol--after cg-sol--game)) - -(defun cg-sol-undo () - "Undo the last move." - (interactive) - (let ((game cg-sol--game)) - (if (cg-sol--restore game) - (cg-put game :message "Undid a move.") - (cg-put game :message "Nothing to undo.")) - (cg-sol--redisplay))) - -(defun cg-sol--move (delta) - "Move the cursor by DELTA spots." - (let* ((game cg-sol--game) - (n (length (cg-sol--spots game))) - (cur (cg-get game :cursor))) - (cg-put game :cursor (mod (+ cur delta) n)) - (cg-sol--redisplay))) - -(defun cg-sol-left () "Move cursor left." (interactive) (cg-sol--move -1)) -(defun cg-sol-right () "Move cursor right." (interactive) (cg-sol--move 1)) -(defun cg-sol-up () "Move cursor left (previous pile)." (interactive) (cg-sol--move -1)) -(defun cg-sol-down () "Move cursor right (next pile)." (interactive) (cg-sol--move 1)) - -(defun cg-sol--after (game) - "Fill empty columns from the reserve, redisplay GAME, and announce a win." - (cg-sol--autofill game) - (cg-sol--redisplay) - (when (cg-won-p game) - (cg-put game :message "You won! Press n for a new game.") - (cg-sol--redisplay) - (message "Solved! Well played."))) - -(defun cg-sol-new () - "Start a fresh deal of the same game." - (interactive) - (let ((game cg-sol--game)) - (cg-sol--deal game) - (cg-sol--redisplay))) - -(defun cg-sol-help () - "Describe the controls." - (interactive) - (message "Arrows: move RET: pick up/drop f: to foundation a: auto u: undo n: new g: redraw")) - -(defun cg-sol-redraw () "Redraw the board." (interactive) (cg-sol--redisplay)) - -;;;; Rendering (console) - -(defun cg-sol--render-card (card down sel cursor) - "Return a propertized 3-column cell for CARD (DOWN, SEL, CURSOR flags)." - (let* ((s (cg-sol-card-string card down)) - (faces nil)) - (when (and card (not down) (cg-sol-red-p card)) (push 'cg-red-suit faces)) - (when down (push 'cg-gap faces)) - (when sel (push 'cg-hint faces)) - (when cursor (push 'cg-cursor faces)) - (propertize (format "%3s " s) 'face (or faces 'default)))) - -(defcustom cg-sol-svg-cards t - "When non-nil, draw the solitaire board as SVG on a graphical display." - :type 'boolean :group 'card-games) - -(defun cg-sol--spec (card) - "Return the cg-svg display spec (RANK-STRING . SUIT) for CARD, or nil." - (and card (cons (aref cg-sol-ranks (cdr card)) (car card)))) - -(defun cg-sol--svg (game) - "Return (DISPLAY . REGIONS) for an SVG board of solitaire GAME. -DISPLAY is a propertized one-image string; REGIONS is a click map of -\(RECT . SPOT) entries, RECT being (X Y W H) in unscaled image pixels." - (let* ((w cg-svg-card-width) (h cg-svg-card-height) - (pad 12) (gap cg-svg-card-gap) (colgap 8) (vdown 12) (vup 26) - (ncols (oref game ncols)) - (cur-spot (cg-sol--cur-spot game)) - (sel (cg-get game :sel)) (sel-n (or (cg-get game :sel-n) 0)) - (lc (cg-color 'shadow :foreground "gray40")) - (regions '()) (slots '())) - (when (oref game has-stock) - (push (list (format "Stock(%d)" (length (cg-get game :stock))) - nil (and (cg-get game :stock) t) (equal cur-spot '(stock . 0)) - '(stock . 0)) slots)) - (when (oref game has-waste) - (push (list "Waste" (cg-sol--spec (car (last (cg-get game :waste)))) nil - (equal cur-spot '(waste . 0)) '(waste . 0)) slots)) - (when (oref game has-reserve) - (push (list (format "Resv(%d)" (length (cg-get game :reserve))) - (cg-sol--spec (car (last (cg-get game :reserve)))) nil - (equal cur-spot '(reserve . 0)) '(reserve . 0)) slots)) - (dotimes (i (oref game nfree)) - (push (list (format "F%d" (1+ i)) (cg-sol--spec (aref (cg-get game :free) i)) nil - (equal cur-spot (cons 'free i)) (cons 'free i)) slots)) - (dotimes (i (oref game nfound)) - (push (list (format "%d" (1+ i)) - (cg-sol--spec (car (last (aref (cg-get game :found) i)))) nil - (equal cur-spot (cons 'found i)) (cons 'found i)) slots)) - (setq slots (nreverse slots)) - (let* ((ntop (length slots)) - (topw (+ (* 2 pad) (* ntop (+ w gap)))) - (colsw (+ (* 2 pad) (* ncols (+ w colgap)))) - (width (max topw colsw)) - (top-y (+ pad 14)) (col-label-y (+ top-y h 18)) (col-y (+ col-label-y 6)) - (tab (cg-get game :tableau)) - (maxext (let ((m h)) - (dotimes (c ncols) - (let* ((col (aref tab c)) (d (cg-sol--down game c)) - (nu (- (length col) d)) - (ext (+ (* d vdown) (* (max 0 (1- nu)) vup) h))) - (setq m (max m ext)))) - m)) - (height (+ col-y maxext pad)) - (svg (svg-create width height))) - (let ((x pad)) - (dolist (sl slots) - (cl-destructuring-bind (label spec downp cursorp spot) sl - (svg-text svg label :x (+ x 1) :y (- top-y 3) :font-size 11 :fill lc - :font-family cg-svg-font-family) - (cond (downp (cg-svg-card svg x top-y :down t :highlight cursorp)) - (spec (cg-svg-card svg x top-y :rank (car spec) :suit (cdr spec) - :highlight cursorp)) - (t (cg-svg-card svg x top-y :gap t :highlight cursorp))) - (push (cons (list x top-y w h) spot) regions)) - (setq x (+ x w gap)))) - (dotimes (c ncols) - (let* ((x (+ pad (* c (+ w colgap)))) (col (aref tab c)) (len (length col)) - (d (cg-sol--down game c)) (y col-y) (r 0) - (cursorp (equal cur-spot (cons 'col c)))) - (svg-text svg (format "%d" (1+ c)) :x (+ x 1) :y col-label-y - :font-size 11 :fill lc :font-family cg-svg-font-family) - (push (cons (list x col-y w maxext) (cons 'col c)) regions) - (if (= len 0) - (cg-svg-card svg x y :gap t :highlight cursorp) - (dolist (card col) - (let* ((downp (< r d)) (top-card (= r (1- len))) - (selp (and (equal sel (cons 'col c)) (>= r (- len sel-n))))) - (if downp (cg-svg-card svg x y :down t) - (cg-svg-card svg x y :rank (car (cg-sol--spec card)) - :suit (cdr (cg-sol--spec card)) - :highlight (and top-card cursorp) :hint selp)) - (setq y (+ y (if downp vdown vup)) r (1+ r))))))) - (cons (propertize "*" 'display (cg-svg-image svg (cg-scale))) - (nreverse regions))))) - -(cl-defmethod cg-render ((game cg-solitaire-game)) - "Return a propertized depiction of GAME (SVG on a graphical display)." - (if (and cg-sol-svg-cards (display-graphic-p)) - (car (cg-sol--svg game)) - (cg-sol--render-text game))) - -(cl-defmethod cg-render-text ((game cg-solitaire-game)) - (cg-sol--render-text game)) - -(cl-defmethod cg-render-svg ((game cg-solitaire-game)) - (if cg-sol-svg-cards (cg-sol--svg game) - (cons (cg-sol--render-text game) nil))) - -(cl-defmethod cg-render-apply ((game cg-solitaire-game) action) - "Apply a click ACTION (a cursor spot) by selecting it and acting." - (let ((idx (cl-position action (cg-sol--spots game) :test #'equal))) - (when idx (cg-put game :cursor idx) (cg-sol-act)))) - -(defun cg-sol--render-text (game) - "Return a plain-text depiction of solitaire GAME." - (let* ((spots (cg-sol--spots game)) - (cur (cg-get game :cursor)) - (cur-spot (nth cur spots)) - (sel (cg-get game :sel)) - (sel-n (cg-get game :sel-n)) - (out (list))) - (push (format " %s Moves: %d%s\n\n" - (oref game vname) (cg-get game :moves) - (if (> (oref game nfound) 0) "" - (format " Sets: %d/%d" (cg-get game :sets) (oref game target-sets)))) - out) - ;; Top line: stock / waste / free cells / foundations. - (let ((line " ")) - (when (oref game has-stock) - (let ((on (equal cur-spot '(stock . 0)))) - (setq line (concat line "Stock:" - (propertize (format "%-4s" - (if (cg-get game :stock) "##" "·")) - 'face (if on 'cg-cursor 'default)) - (format "(%d) " (length (cg-get game :stock))))) )) - (when (oref game has-waste) - (let ((on (equal cur-spot '(waste . 0))) (w (car (last (cg-get game :waste))))) - (setq line (concat line "Waste:" - (cg-sol--render-card w nil nil on))))) - (when (oref game has-reserve) - (let ((on (equal cur-spot '(reserve . 0))) (r (car (last (cg-get game :reserve))))) - (setq line (concat line "Reserve:" - (cg-sol--render-card r nil nil on) - (format "(%d) " (length (cg-get game :reserve))))))) - (dotimes (i (oref game nfree)) - (let ((on (equal cur-spot (cons 'free i))) (c (aref (cg-get game :free) i))) - (setq line (concat line (format "F%d:" (1+ i)) - (cg-sol--render-card c nil nil on))))) - (dotimes (i (oref game nfound)) - (let ((on (equal cur-spot (cons 'found i))) - (c (car (last (aref (cg-get game :found) i))))) - (setq line (concat line (format "%d:" (1+ i)) - (cg-sol--render-card c nil nil on))))) - (push (concat line "\n\n") out)) - ;; Column headers. - (let ((hdr " ")) - (dotimes (c (oref game ncols)) - (let ((on (equal cur-spot (cons 'col c)))) - (setq hdr (concat hdr (propertize (format "%2d " (1+ c)) - 'face (if on 'cg-cursor 'default)))))) - (push (concat hdr "\n") out)) - ;; Column bodies, row by row. - (let* ((tab (cg-get game :tableau)) - (maxlen (apply #'max 1 (mapcar #'length (append tab nil))))) - (dotimes (r maxlen) - (let ((row " ")) - (dotimes (c (oref game ncols)) - (let* ((col (aref tab c)) - (len (length col)) - (card (and (< r len) (nth r col))) - (down (and card (< r (cg-sol--down game c)))) - (selp (and (equal sel (cons 'col c)) - card (>= r (- len sel-n)))) - (cursorp (and (equal cur-spot (cons 'col c)) (= r (1- len))))) - (setq row (concat row - (if (< r len) - (cg-sol--render-card card down selp cursorp) - " "))))) - (push (concat row "\n") out)))) - (push (format "\n %s\n" (cg-get game :message)) out) - (apply #'concat (nreverse out)))) - -(defun cg-sol--redisplay () - "Redraw the current solitaire buffer." - (let ((game cg-sol--game) - (inhibit-read-only t)) - (setq-local mode-line-process - (format " [%s]" (if (cg-won-p game) "solved" - (let ((s (cg-get game :sel))) - (if s "carrying" "playing"))))) - (erase-buffer) - (cg-render-game game) - (insert "\n") - (cg-insert-legend - "arrows move · RET pick up/drop · f foundation · a auto · u undo · n new · q menu · ? help") - (goto-char (point-min)))) - -;;;; Mode and commands - -(defun cg-sol-mouse (event) - "Handle a mouse click on the solitaire board: select that pile and act." - (interactive "e") - (let* ((game cg-sol--game) - (r (and game (oref game renderer))) - (action (and r (cg-renderer-hit r game (event-start event))))) - (when action (cg-render-apply game action)))) - -(defvar cg-sol-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [mouse-1] #'cg-sol-mouse) - (define-key map (kbd "") #'cg-sol-left) - (define-key map (kbd "") #'cg-sol-right) - (define-key map (kbd "") #'cg-sol-up) - (define-key map (kbd "") #'cg-sol-down) - (define-key map (kbd "RET") #'cg-sol-act) - (define-key map (kbd "SPC") #'cg-sol-act) - (define-key map "f" #'cg-sol-to-foundation) - (define-key map "a" #'cg-sol-auto) - (define-key map "u" #'cg-sol-undo) - (define-key map "n" #'cg-sol-new) - (define-key map "g" #'cg-sol-redraw) - (define-key map "?" #'cg-sol-help) - (define-key map "q" #'cg-quit-to-menu) - map) - "Keymap for `cg-sol-mode'.") - -(defun cg-sol--classic-keymap () - "Return a copy of `cg-sol-mode-map' with vi-style hjkl added." - (let ((map (copy-keymap cg-sol-mode-map))) - (define-key map "h" #'cg-sol-left) - (define-key map "l" #'cg-sol-right) - (define-key map "j" #'cg-sol-down) - (define-key map "k" #'cg-sol-up) - map)) - -(define-derived-mode cg-sol-mode special-mode "Solitaire" - "Major mode for the tableau solitaires." - (setq-local truncate-lines t) - (setq-local cursor-type cg-cursor-type) - (when (eq cg-keys 'classic) - (use-local-map (cg-sol--classic-keymap)))) - -(defun cg-sol--play (class) - "Start a solitaire game of CLASS in its own buffer." - (let* ((game (cg-sol--deal (make-instance class))) - (buf (get-buffer-create (format "*%s*" (oref game vname))))) - (with-current-buffer buf - (cg-sol-mode) - (setq cg-sol--game game) - (cg-sol--redisplay)) - (switch-to-buffer buf))) - -;;;###autoload -(defun cg-klondike () - "Play Klondike, the classic solitaire." - (interactive) (cg-sol--play 'cg-klondike-game)) - -;;;###autoload -(defun cg-freecell () - "Play FreeCell solitaire." - (interactive) (cg-sol--play 'cg-freecell-game)) - -;;;###autoload -(defun cg-spider () - "Play Spider solitaire (two decks)." - (interactive) (cg-sol--play 'cg-spider-game)) - -;;;###autoload -(defun cg-yukon () - "Play Yukon solitaire." - (interactive) (cg-sol--play 'cg-yukon-game)) - - -;;;; More games: Forty Thieves, Scorpion, Canfield - -(defclass cg-forty-game (cg-solitaire-game) - ((ncols :initform 10) (ndecks :initform 2) (nfound :initform 8) - (has-stock :initform t) (has-waste :initform t) (redeal :initform nil) - (build :initform 'suit) (run-rule :initform 'suit) (empty-rule :initform 'any) - (vname :initform "Forty Thieves")) - "Forty Thieves: two decks, ten columns, eight foundations, no redeal.") - -(cl-defmethod cg-sol--layout ((_ cg-forty-game)) - (make-list 10 (cons 0 4))) - -(defclass cg-scorpion-game (cg-solitaire-game) - ((ncols :initform 7) (nfound :initform 0) (has-stock :initform t) - (build :initform 'suit) (run-rule :initform 'any) (empty-rule :initform 'king) - (target-sets :initform 4) (vname :initform "Scorpion")) - "Scorpion: build down by suit, move any buried group, clear four runs.") - -(cl-defmethod cg-sol--layout ((_ cg-scorpion-game)) - (append (make-list 4 (cons 3 4)) (make-list 3 (cons 0 7)))) - -(cl-defmethod cg-sol--stock-action ((game cg-scorpion-game)) - "Deal the three stock cards onto the first three columns." - (let ((stock (cg-get game :stock))) - (if (null stock) - (cg-put game :message "The stock is empty.") - (cg-sol--snapshot game) - (dotimes (c (min 3 (length stock))) - (cg-sol--set-col game c (append (cg-sol--col game c) (last stock 1))) - (setq stock (butlast stock 1))) - (cg-put game :stock stock) - (cg-sol--harvest game) - (cg-put game :message "Dealt the stock onto the first columns.")))) - -(defclass cg-canfield-game (cg-solitaire-game) - ((ncols :initform 4) (nfound :initform 4) (has-stock :initform t) - (has-waste :initform t) (has-reserve :initform t) (draw :initform 3) - (redeal :initform t) (build :initform 'alt) (run-rule :initform 'alt) - (empty-rule :initform 'any) (wrap :initform t) (vname :initform "Canfield")) - "Canfield: a 13-card reserve and a variable foundation base rank.") - -(cl-defmethod cg-sol--deal ((game cg-canfield-game)) - "Deal a Canfield layout: reserve, base foundation, four columns, stock." - (let* ((deck (cg-sol--make-deck 1)) - (reserve (cl-loop repeat 13 collect (pop deck))) - (first (pop deck)) - (found (make-vector 4 nil)) - (tableau (make-vector 4 nil)) - (down (make-vector 4 0))) - (oset game base (cdr first)) - (aset found 0 (list first)) - (dotimes (c 4) (aset tableau c (list (pop deck)))) - (cg-put game :reserve reserve) - (cg-put game :tableau tableau) - (cg-put game :down down) - (cg-put game :found found) - (cg-put game :free (make-vector 0 nil)) - (cg-put game :stock deck) - (cg-put game :waste nil) - (cg-put game :sets 0) - (cg-put game :moves 0) - (cg-put game :cursor 0) - (cg-put game :sel nil) - (cg-put game :sel-n 0) - (cg-put game :history nil) - (cg-put game :message - (format "Canfield. Foundations build up from %s (wrapping). RET deals three." - (aref cg-sol-ranks (cdr first)))) - game)) - -(cl-defmethod cg-sol--autofill ((_ cg-solitaire-game)) nil) -(cl-defmethod cg-sol--autofill ((game cg-canfield-game)) - "Fill empty columns from the reserve, as Canfield requires." - (dotimes (c (oref game ncols)) - (when (and (null (cg-sol--col game c)) (cg-get game :reserve)) - (let ((card (car (last (cg-get game :reserve))))) - (cg-put game :reserve (butlast (cg-get game :reserve) 1)) - (cg-sol--set-col game c (list card)))))) - - -;;;; Russian Bank (single-player patience) - -;; A one-deck patience in the spirit of Russian Bank (Crapette): eight -;; "houses" build down in alternating colours, the four foundations build -;; up by suit from the Ace, and a thirteen-card reserve feeds the houses. -;; The competitive two-player game (with its "stops" and loading rules) -;; is a separate, larger build; this is the solitaire adaptation. - -(defclass cg-russian-bank-game (cg-solitaire-game) - ((ncols :initform 8) (nfound :initform 4) (has-stock :initform t) - (has-waste :initform t) (has-reserve :initform t) (draw :initform 1) - (redeal :initform t) (build :initform 'alt) (run-rule :initform 'alt) - (empty-rule :initform 'any) (base :initform 0) (wrap :initform nil) - (vname :initform "Russian Bank")) - "Russian Bank patience: eight houses down by alternating colour, four -foundations up by suit from the Ace, and a thirteen-card reserve.") - -(cl-defmethod cg-sol--deal ((game cg-russian-bank-game)) - "Deal a Russian Bank patience layout: reserve, eight houses, and a stock." - (let* ((deck (cg-sol--make-deck 1)) - (reserve (cl-loop repeat 13 collect (pop deck))) - (tableau (make-vector 8 nil)) - (down (make-vector 8 0))) - (dotimes (c 8) (aset tableau c (list (pop deck)))) - (cg-put game :reserve reserve) - (cg-put game :tableau tableau) - (cg-put game :down down) - (cg-put game :found (make-vector 4 nil)) - (cg-put game :free (make-vector 0 nil)) - (cg-put game :stock deck) - (cg-put game :waste nil) - (cg-put game :sets 0) - (cg-put game :moves 0) - (cg-put game :cursor 0) - (cg-put game :sel nil) - (cg-put game :sel-n 0) - (cg-put game :history nil) - (cg-put game :message - "Russian Bank. Houses build down in alternating colours; foundations up by suit from the Ace.") - game)) - -(cl-defmethod cg-sol--autofill ((game cg-russian-bank-game)) - "Fill an empty house from the reserve, as Russian Bank does." - (dotimes (c (oref game ncols)) - (when (and (null (cg-sol--col game c)) (cg-get game :reserve)) - (let ((card (car (last (cg-get game :reserve))))) - (cg-put game :reserve (butlast (cg-get game :reserve) 1)) - (cg-sol--set-col game c (list card)))))) - -;;;###autoload -(defun cg-forty-thieves () - "Play Forty Thieves solitaire (two decks)." - (interactive) (cg-sol--play 'cg-forty-game)) - -;;;###autoload -(defun cg-scorpion () - "Play Scorpion solitaire." - (interactive) (cg-sol--play 'cg-scorpion-game)) - -;;;###autoload -(defun cg-canfield () - "Play Canfield solitaire." - (interactive) (cg-sol--play 'cg-canfield-game)) - -;;;###autoload -(defun cg-russian-bank () - "Play Russian Bank, the single-player patience adaptation." - (interactive) (cg-sol--play 'cg-russian-bank-game)) - -(provide 'cg-solitaire) -;;; cg-solitaire.el ends here diff --git a/cg-spite.el b/cg-spite.el deleted file mode 100644 index 83a30bf..0000000 --- a/cg-spite.el +++ /dev/null @@ -1,507 +0,0 @@ -;;; cg-spite.el --- Spite and Malice, a competitive patience -*- lexical-binding: t; -*- - -;; Copyright (C) 2026 Corwin Brust - -;; Author: Corwin Brust -;; Maintainer: Corwin Brust -;; 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 . - -;;; 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 "") #'cg-spite-left) - (define-key map (kbd "") #'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 diff --git a/cg-trick-ext.el b/cg-trick-ext.el deleted file mode 100644 index 57409da..0000000 --- a/cg-trick-ext.el +++ /dev/null @@ -1,501 +0,0 @@ -;;; cg-trick-ext.el --- Euchre, Pitch and Briscola -*- lexical-binding: t; -*- - -;; Copyright (C) 2026 Corwin Brust - -;; Author: Corwin Brust -;; Maintainer: Corwin Brust -;; 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 . - -;;; 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 diff --git a/cg-trick.el b/cg-trick.el deleted file mode 100644 index 0d5cd83..0000000 --- a/cg-trick.el +++ /dev/null @@ -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 -;; Maintainer: Corwin Brust -;; 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 . - -;;; 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 "") #'cg-trick-left) - (define-key map (kbd "") #'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 diff --git a/doc/card-games.texi b/doc/card-games.texi index 17af0ed..673bab4 100644 --- a/doc/card-games.texi +++ b/doc/card-games.texi @@ -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. diff --git a/test/card-games-tests.el b/test/card-games-tests.el index cb50a6c..2059265 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -10,39 +10,39 @@ (require 'cl-lib) (require 'card-games) -;;;; cg-core +;;;; card-games-core (ert-deftest cgt-core-color-fallback () - (should (equal "#123456" (cg-color 'no-such-face-xyzzy :background "#123456")))) + (should (equal "#123456" (card-games-color 'no-such-face-xyzzy :background "#123456")))) (ert-deftest cgt-core-suit-glyph () - (let ((cg-symbols '((0 . "S") (1 . "C") (2 . "D") (3 . "H") (joker . "JK")))) - (should (equal "S" (cg-suit-glyph 0))) - (should (equal "JK" (cg-suit-glyph 'joker)))) - (should (equal "♠" (cg-suit-glyph 0)))) + (let ((card-games-symbols '((0 . "S") (1 . "C") (2 . "D") (3 . "H") (joker . "JK")))) + (should (equal "S" (card-games-suit-glyph 0))) + (should (equal "JK" (card-games-suit-glyph 'joker)))) + (should (equal "♠" (card-games-suit-glyph 0)))) ;;;; Renderer skins (ert-deftest cgt-render-registry () - (should (memq 'text (cg-renderer-names))) - (should (memq 'svg (cg-renderer-names))) - (should (memq 'svg-fill (cg-renderer-names))) - (should (object-of-class-p (cg-make-renderer 'svg) 'cg-svg-renderer)) - (should (object-of-class-p (cg-make-renderer 'svg-fill) 'cg-svg-renderer)) - (should-not (cg-make-renderer 'no-such-treatment))) + (should (memq 'text (card-games-renderer-names))) + (should (memq 'svg (card-games-renderer-names))) + (should (memq 'svg-fill (card-games-renderer-names))) + (should (object-of-class-p (card-games-make-renderer 'svg) 'card-games-svg-renderer)) + (should (object-of-class-p (card-games-make-renderer 'svg-fill) 'card-games-svg-renderer)) + (should-not (card-games-make-renderer 'no-such-treatment))) (ert-deftest cgt-render-resolve () - (should (eq 'text (cg-render-resolve-treatment 'text))) - (should (memq (cg-render-resolve-treatment 'auto) '(text svg)))) + (should (eq 'text (card-games-render-resolve-treatment 'text))) + (should (memq (card-games-render-resolve-treatment 'auto) '(text svg)))) ;;;; Networking -(defclass cgt-net-game (cg-game) +(defclass cgt-net-game (card-games-game) ((env :initarg :env :initform '(:counter 0))) "Throwaway game whose only move adds to a counter.") -(cl-defmethod cg-net-apply-move ((g cgt-net-game) _seat move) - (cg-put g :counter (+ (or (cg-get g :counter) 0) move)) +(cl-defmethod card-games-net-apply-move ((g cgt-net-game) _seat move) + (card-games-put g :counter (+ (or (card-games-get g :counter) 0) move)) t) (ert-deftest cgt-net-loopback () @@ -53,20 +53,20 @@ :host "127.0.0.1" :family 'ipv4)) (error (ert-skip "TCP not available"))) (let* ((hgame (make-instance 'cgt-net-game :env (list :counter 0))) - (srv (cg-net-host-start hgame 0)) + (srv (card-games-net-host-start hgame 0)) (port (process-contact srv :service)) (cgame (make-instance 'cgt-net-game :env (list :counter 0)))) (unwind-protect (progn - (cg-net-connect "127.0.0.1" port "Test" cgame) + (card-games-net-connect "127.0.0.1" port "Test" cgame) (dotimes (_ 12) (accept-process-output nil 0.05)) - (should (= 0 (cg-get cgame :counter))) - (cg-net-send-move 7) + (should (= 0 (card-games-get cgame :counter))) + (card-games-net-send-move 7) (dotimes (_ 12) (accept-process-output nil 0.05)) - (should (= 7 (cg-get hgame :counter))) - (should (= 7 (cg-get cgame :counter)))) - (cg-net-disconnect) - (cg-net-host-stop)))) + (should (= 7 (card-games-get hgame :counter))) + (should (= 7 (card-games-get cgame :counter)))) + (card-games-net-disconnect) + (card-games-net-host-stop)))) (ert-deftest cgt-net-strips-properties () "Text properties on wire strings are stripped at the boundary, both ways. @@ -80,54 +80,54 @@ host must reach the client bare." (error (ert-skip "TCP not available"))) (cl-flet ((pump () (dotimes (_ 12) (accept-process-output nil 0.05)))) (let* ((hgame (make-instance 'cgt-net-game :env (list :counter 0))) - (srv (cg-net-host-start hgame 0)) + (srv (card-games-net-host-start hgame 0)) (port (process-contact srv :service)) (cgame (make-instance 'cgt-net-game :env (list :counter 0)))) (unwind-protect (progn - (cg-net-connect "127.0.0.1" port + (card-games-net-connect "127.0.0.1" port (propertize "Eve" 'keymap '(keymap)) cgame) (pump) ;; client -> host: the hello name arrives with no attachments - (let* ((conn (car (cg-net-host-clients cg-net--host))) - (name (process-get conn 'cg-net-name))) + (let* ((conn (car (card-games-net-host-clients card-games-net--host))) + (name (process-get conn 'card-games-net-name))) (should (equal name "Eve")) (should-not (text-properties-at 0 name))) ;; host -> client: a state string arrives with no attachments - (cg-put hgame :message + (card-games-put hgame :message (propertize "hi" 'keymap '(keymap) 'help-echo "boo")) - (cg-net-host-broadcast) + (card-games-net-host-broadcast) (pump) - (let ((m (cg-get cgame :message))) + (let ((m (card-games-get cgame :message))) (should (equal m "hi")) (should-not (text-properties-at 0 m)))) - (cg-net-disconnect) - (cg-net-host-stop))))) + (card-games-net-disconnect) + (card-games-net-host-stop))))) (ert-deftest cgt-net-host-loopback-default () "Hosting binds to this machine only unless deliberately widened. Finding 1 of the 2026-07-29 review: the default of -`cg-net-host-address' is loopback, and the listening socket really +`card-games-net-host-address' is loopback, and the listening socket really binds it -- wider exposure is a setting the user turns on, not a silent default." - (should (equal "127.0.0.1" (default-value 'cg-net-host-address))) + (should (equal "127.0.0.1" (default-value 'card-games-net-host-address))) (condition-case _ (delete-process (make-network-process :name "cgt-probe4" :server t :service 0 :host "127.0.0.1" :family 'ipv4)) (error (ert-skip "TCP not available"))) (let* ((hgame (make-instance 'cgt-net-game :env (list :counter 0))) - (srv (cg-net-host-start hgame 0))) + (srv (card-games-net-host-start hgame 0))) (unwind-protect (should (equal [127 0 0 1] (substring (process-contact srv :local) 0 4))) - (cg-net-host-stop)))) + (card-games-net-host-stop)))) (ert-deftest cgt-net-line-cap () "A connection sending endless bytes with no newline is dropped. Finding 4 of the 2026-07-29 review: the partial-line buffer grew without limit, so one connection could consume all available memory. -It is now bounded by `cg-net-max-line'." +It is now bounded by `card-games-net-max-line'." (condition-case _ (delete-process (make-network-process :name "cgt-probe5" :server t :service 0 @@ -135,7 +135,7 @@ It is now bounded by `cg-net-max-line'." (error (ert-skip "TCP not available"))) (cl-flet ((pump () (dotimes (_ 8) (accept-process-output nil 0.05)))) (let* ((hgame (make-instance 'cgt-net-game :env (list :counter 0))) - (srv (cg-net-host-start hgame 0)) + (srv (card-games-net-host-start hgame 0)) (port (process-contact srv :service)) (raw (make-network-process :name "cgt-flood" :host "127.0.0.1" :service port :family 'ipv4))) @@ -149,10 +149,10 @@ It is now bounded by `cg-net-max-line'." ;; 80 KiB with no newline: the host must have hung up on us (should-not (process-live-p raw))) (when (process-live-p raw) (delete-process raw)) - (cg-net-host-stop))))) + (card-games-net-host-stop))))) (ert-deftest cgt-net-connection-cap () - "Connections beyond `cg-net-max-connections' are refused. + "Connections beyond `card-games-net-max-connections' are refused. Finding 4's second bound: the client list cannot grow without limit." (condition-case _ (delete-process @@ -160,9 +160,9 @@ Finding 4's second bound: the client list cannot grow without limit." :host "127.0.0.1" :family 'ipv4)) (error (ert-skip "TCP not available"))) (cl-flet ((pump () (dotimes (_ 8) (accept-process-output nil 0.05)))) - (let* ((cg-net-max-connections 2) + (let* ((card-games-net-max-connections 2) (hgame (make-instance 'cgt-net-game :env (list :counter 0))) - (srv (cg-net-host-start hgame 0)) + (srv (card-games-net-host-start hgame 0)) (port (process-contact srv :service)) (procs nil)) (unwind-protect @@ -175,11 +175,11 @@ Finding 4's second bound: the client list cannot grow without limit." (pump)) (should (= 2 (length (cl-remove-if-not #'process-live-p - (cg-net-host-clients cg-net--host))))) + (card-games-net-host-clients card-games-net--host))))) ;; the newest connection is the one turned away (should-not (process-live-p (car procs)))) (dolist (p procs) (when (process-live-p p) (delete-process p))) - (cg-net-host-stop))))) + (card-games-net-host-stop))))) (ert-deftest cgt-net-reaps-disconnected () "A client that disconnects is removed from the host's client list. @@ -193,19 +193,19 @@ sending to them. A process sentinel now reaps them." (error (ert-skip "TCP not available"))) (cl-flet ((pump () (dotimes (_ 12) (accept-process-output nil 0.05)))) (let* ((hgame (make-instance 'cgt-net-game :env (list :counter 0))) - (srv (cg-net-host-start hgame 0)) + (srv (card-games-net-host-start hgame 0)) (port (process-contact srv :service)) (cgame (make-instance 'cgt-net-game :env (list :counter 0)))) (unwind-protect (progn - (cg-net-connect "127.0.0.1" port "Test" cgame) + (card-games-net-connect "127.0.0.1" port "Test" cgame) (pump) - (should (= 1 (length (cg-net-host-clients cg-net--host)))) - (cg-net-disconnect) + (should (= 1 (length (card-games-net-host-clients card-games-net--host)))) + (card-games-net-disconnect) (pump) - (should (= 0 (length (cg-net-host-clients cg-net--host))))) - (cg-net-disconnect) - (cg-net-host-stop))))) + (should (= 0 (length (card-games-net-host-clients card-games-net--host))))) + (card-games-net-disconnect) + (card-games-net-host-stop))))) (ert-deftest cgt-net-shape-gate () "Malformed messages are dropped before any game code sees them. @@ -213,7 +213,7 @@ Finding 6 of the 2026-07-29 review: parsing can produce structures that hang or confuse code walking them -- self-references, objects impersonating internal types. A message must be a proper plist of a known :type built from plain data; anything else never reaches -`cg-net-apply-move'." +`card-games-net-apply-move'." (condition-case _ (delete-process (make-network-process :name "cgt-probe8" :server t :service 0 @@ -221,10 +221,10 @@ known :type built from plain data; anything else never reaches (error (ert-skip "TCP not available"))) (cl-flet ((pump () (dotimes (_ 10) (accept-process-output nil 0.05)))) (let* ((hgame (make-instance 'cgt-net-game :env (list :counter 0))) - (srv (cg-net-host-start hgame 0)) + (srv (card-games-net-host-start hgame 0)) (port (process-contact srv :service)) (applied nil)) - (cl-letf (((symbol-function 'cg-net-apply-move) + (cl-letf (((symbol-function 'card-games-net-apply-move) (lambda (_game _seat move) (push move applied) nil))) (let ((raw (make-network-process :name "cgt-shapes" :host "127.0.0.1" :service port :family 'ipv4))) @@ -241,26 +241,26 @@ known :type built from plain data; anything else never reaches ;; only the one well-shaped, host-legal move arrived (should (equal applied (list 5)))) (when (process-live-p raw) (delete-process raw)) - (cg-net-host-stop))))))) + (card-games-net-host-stop))))))) (ert-deftest cgt-net-valid-p () "Unit contract of the wire-shape check itself." - (should (cg-net--valid-p '(:type move :move (bid (7 . 3))) '(hello move))) - (should (cg-net--valid-p '(:type hello :name "n") '(hello move))) + (should (card-games-net--valid-p '(:type move :move (bid (7 . 3))) '(hello move))) + (should (card-games-net--valid-p '(:type hello :name "n") '(hello move))) ;; wrong direction: a host does not accept host->client types - (should-not (cg-net--valid-p '(:type welcome :seat 1) '(hello move))) + (should-not (card-games-net--valid-p '(:type welcome :seat 1) '(hello move))) ;; not a plist / unknown / impersonating / shared structure - (should-not (cg-net--valid-p 42 '(hello move))) - (should-not (cg-net--valid-p '(:type reboot) '(hello move))) - (should-not (cg-net--valid-p (list :type 'move :move (make-hash-table)) + (should-not (card-games-net--valid-p 42 '(hello move))) + (should-not (card-games-net--valid-p '(:type reboot) '(hello move))) + (should-not (card-games-net--valid-p (list :type 'move :move (make-hash-table)) '(hello move))) - (should-not (cg-net--valid-p (record 'cg-net-host nil nil nil 0) '(hello move))) + (should-not (card-games-net--valid-p (record 'card-games-net-host nil nil nil 0) '(hello move))) (let ((shared (list 1 2))) - (should-not (cg-net--valid-p (list :type 'move :move (list shared shared)) + (should-not (card-games-net--valid-p (list :type 'move :move (list shared shared)) '(hello move)))) (let ((cyc (list 1 2))) (setcdr (cdr cyc) cyc) - (should-not (cg-net--valid-p (list :type 'move :move cyc) '(hello move))))) + (should-not (card-games-net--valid-p (list :type 'move :move cyc) '(hello move))))) ;;;; Seeded shuffle @@ -268,215 +268,215 @@ known :type built from plain data; anything else never reaches "A seeded shuffle is deterministic, portable, and a true permutation; the unseeded shuffle keeps its system-random behaviour. Opening #4." (let ((deck (number-sequence 0 51))) - ;; same seed -> identical order (FAILS on HEAD: cg-shuffle takes 1 arg) - (should (equal (cg-shuffle deck 12345) (cg-shuffle deck 12345))) + ;; same seed -> identical order (FAILS on HEAD: card-games-shuffle takes 1 arg) + (should (equal (card-games-shuffle deck 12345) (card-games-shuffle deck 12345))) ;; still a permutation of the input, nothing dropped or duplicated - (should (equal (sort (copy-sequence (cg-shuffle deck 12345)) #'<) deck)) + (should (equal (sort (copy-sequence (card-games-shuffle deck 12345)) #'<) deck)) ;; different seeds -> different order (almost surely) - (should-not (equal (cg-shuffle deck 1) (cg-shuffle deck 2))) + (should-not (equal (card-games-shuffle deck 1) (card-games-shuffle deck 2))) ;; the dynamic variable seeds it too, and an explicit seed overrides it - (should (equal (let ((cg-shuffle-seed "deal-A")) (cg-shuffle deck)) - (let ((cg-shuffle-seed "deal-A")) (cg-shuffle deck)))) - (should (equal (cg-shuffle deck 7) - (let ((cg-shuffle-seed "ignored")) (cg-shuffle deck 7)))) + (should (equal (let ((card-games-shuffle-seed "deal-A")) (card-games-shuffle deck)) + (let ((card-games-shuffle-seed "deal-A")) (card-games-shuffle deck)))) + (should (equal (card-games-shuffle deck 7) + (let ((card-games-shuffle-seed "ignored")) (card-games-shuffle deck 7)))) ;; portability pin: this exact prefix must hold on every platform - (should (equal (seq-take (cg-shuffle deck "GOLDEN") 6) '(15 20 35 24 31 23))))) + (should (equal (seq-take (card-games-shuffle deck "GOLDEN") 6) '(15 20 35 24 31 23))))) ;;;; Gaps (ert-deftest cgt-gaps-deal () - (let* ((g (cg-gaps--deal (make-instance 'cg-montana-game))) - (b (cg-get g :board)) (cards 0) (gaps 0)) + (let* ((g (card-games-gaps--deal (make-instance 'card-games-montana-game))) + (b (card-games-get g :board)) (cards 0) (gaps 0)) (dotimes (r 4) (dotimes (c 13) - (if (cg-gaps--cell b r c) (cl-incf cards) (cl-incf gaps)))) + (if (card-games-gaps--cell b r c) (cl-incf cards) (cl-incf gaps)))) (should (= cards 48)) (should (= gaps 4)))) (ert-deftest cgt-gaps-win () - (let ((g (make-instance 'cg-montana-game)) (b (make-vector 4 nil))) + (let ((g (make-instance 'card-games-montana-game)) (b (make-vector 4 nil))) (dotimes (r 4) (let ((row (make-vector 13 nil))) (dotimes (c 12) (aset row c (cons r c))) (aset b r row))) - (cg-put g :board b) - (should (cg-won-p g)))) + (card-games-put g :board b) + (should (card-games-won-p g)))) (ert-deftest cgt-acre-win () ;; King-head descending: row r col c == (suit r . (- 11 c)), gap at col 12 - (let ((g (make-instance 'cg-acre-game)) (b (make-vector 4 nil))) + (let ((g (make-instance 'card-games-acre-game)) (b (make-vector 4 nil))) (dotimes (r 4) (let ((row (make-vector 13 nil))) (dotimes (c 12) (aset row c (cons r (- 11 c)))) (aset b r row))) - (cg-put g :board b) - (should (cg-won-p g)) + (card-games-put g :board b) + (should (card-games-won-p g)) ;; head gap wants a King; right of a Two is dead - (should (eq 'head (cg-gaps--needed g b 0 0))))) + (should (eq 'head (card-games-gaps--needed g b 0 0))))) (ert-deftest cgt-acre-needed () - (let ((g (make-instance 'cg-acre-game)) (b (make-vector 4 nil))) + (let ((g (make-instance 'card-games-acre-game)) (b (make-vector 4 nil))) (dotimes (r 4) (aset b r (make-vector 13 nil))) ;; left neighbour King(11) at (0,0): gap (0,1) wants Queen(10) same suit (aset (aref b 0) 0 (cons 0 11)) - (should (equal (cons 0 10) (cg-gaps--needed g b 0 1))) + (should (equal (cons 0 10) (card-games-gaps--needed g b 0 1))) ;; left neighbour Two(0): nothing follows -> nil (Two is the dead end) (aset (aref b 1) 0 (cons 0 0)) - (should (null (cg-gaps--needed g b 1 1))))) + (should (null (card-games-gaps--needed g b 1 1))))) (ert-deftest cgt-gaps-hit () (dotimes (r 4) (dotimes (c 13) - (let ((px (+ cg-gaps--svg-pad (* c (+ cg-gaps--svg-card-w cg-gaps--svg-gap)) - (/ cg-gaps--svg-card-w 2))) - (py (+ cg-gaps--svg-pad (* r (+ cg-gaps--svg-card-h cg-gaps--svg-gap)) - (/ cg-gaps--svg-card-h 2)))) - (should (equal (cons r c) (cg-gaps--xy->cell px py))))))) + (let ((px (+ card-games-gaps--svg-pad (* c (+ card-games-gaps--svg-card-w card-games-gaps--svg-gap)) + (/ card-games-gaps--svg-card-w 2))) + (py (+ card-games-gaps--svg-pad (* r (+ card-games-gaps--svg-card-h card-games-gaps--svg-gap)) + (/ card-games-gaps--svg-card-h 2)))) + (should (equal (cons r c) (card-games-gaps--xy->cell px py))))))) ;;;; 500 -(ert-deftest cgt-bid-deck () (should (= 45 (length (cg-bid--full-deck))))) +(ert-deftest cgt-bid-deck () (should (= 45 (length (card-games-bid--full-deck))))) (ert-deftest cgt-bid-power () - (should (> (cg-bid-power cg-bid-joker 0 0) (cg-bid-power '(0 . 7) 0 0))) - (should (> (cg-bid-power '(0 . 7) 0 0) (cg-bid-power '(1 . 7) 0 0))) - (should (< (cg-bid-power '(2 . 10) 0 3) 100))) + (should (> (card-games-bid-power card-games-bid-joker 0 0) (card-games-bid-power '(0 . 7) 0 0))) + (should (> (card-games-bid-power '(0 . 7) 0 0) (card-games-bid-power '(1 . 7) 0 0))) + (should (< (card-games-bid-power '(2 . 10) 0 3) 100))) (ert-deftest cgt-bid-trick () - (should (= 2 (cg-bid-trick-winner + (should (= 2 (card-games-bid-trick-winner '((0 . (3 . 10)) (1 . (3 . 0)) (2 . (0 . 0)) (3 . (2 . 10))) 0 3)))) (ert-deftest cgt-bid-follow () - (should (equal '((1 . 7)) (cg-bid-legal-cards '((1 . 7) (1 . 0) (3 . 0)) 0 0)))) + (should (equal '((1 . 7)) (card-games-bid-legal-cards '((1 . 7) (1 . 0) (3 . 0)) 0 0)))) (ert-deftest cgt-bid-sort-display () - (should (cg-bid-joker-p - (car (cg-bid-sort-display (list '(3 . 10) cg-bid-joker '(0 . 7)) 0))))) + (should (card-games-bid-joker-p + (car (card-games-bid-sort-display (list '(3 . 10) card-games-bid-joker '(0 . 7)) 0))))) (ert-deftest cgt-bid-south-hit () (dolist (n '(1 5 10 15)) - (cl-destructuring-bind (x0 step y) (cg-bid--south-layout n) + (cl-destructuring-bind (x0 step y) (card-games-bid--south-layout n) (dotimes (i n) - (should (equal i (cg-bid--south-hit (+ x0 (* i step) 2) (+ y 5) n))))))) + (should (equal i (card-games-bid--south-hit (+ x0 (* i step) 2) (+ y 5) n))))))) (ert-deftest cgt-bid-full-game () - (let ((cg-bid--human-seats nil)) + (let ((card-games-bid--human-seats nil)) (dotimes (_ 12) - (let ((g (cg-bid--deal (make-instance 'cg-bid-game))) (guard 0)) - (cg-bid--run g) - (while (and (not (eq (cg-get g :phase) 'gameover)) (< (cl-incf guard) 4000)) - (cg-bid--deal g (mod (1+ (cg-get g :dealer)) 4)) (cg-bid--run g)) - (should (eq 'gameover (cg-get g :phase))))))) + (let ((g (card-games-bid--deal (make-instance 'card-games-bid-game))) (guard 0)) + (card-games-bid--run g) + (while (and (not (eq (card-games-get g :phase) 'gameover)) (< (cl-incf guard) 4000)) + (card-games-bid--deal g (mod (1+ (card-games-get g :dealer)) 4)) (card-games-bid--run g)) + (should (eq 'gameover (card-games-get g :phase))))))) (ert-deftest cgt-bid-smart-beats-basic () (let ((w0 0) (w1 0)) (random "ert-h2h") (dotimes (_ 50) - (let ((cg-bid--human-seats nil) - (cg-bid-ai-policies (vector 'smart 'basic 'smart 'basic)) - (g (cg-bid--deal (make-instance 'cg-bid-game))) (guard 0)) - (cg-bid--run g) - (while (and (not (eq (cg-get g :phase) 'gameover)) (< (cl-incf guard) 4000)) - (cg-bid--deal g (mod (1+ (cg-get g :dealer)) 4)) (cg-bid--run g)) - (pcase (cg-get g :game-over) (0 (cl-incf w0)) (1 (cl-incf w1))))) + (let ((card-games-bid--human-seats nil) + (card-games-bid-ai-policies (vector 'smart 'basic 'smart 'basic)) + (g (card-games-bid--deal (make-instance 'card-games-bid-game))) (guard 0)) + (card-games-bid--run g) + (while (and (not (eq (card-games-get g :phase) 'gameover)) (< (cl-incf guard) 4000)) + (card-games-bid--deal g (mod (1+ (card-games-get g :dealer)) 4)) (card-games-bid--run g)) + (pcase (card-games-get g :game-over) (0 (cl-incf w0)) (1 (cl-incf w1))))) (should (> w0 (* 1.8 w1))))) ;;;; SVG (ert-deftest cgt-svg-builds () - (should (stringp (cg-svg-to-string - (cg-svg-grid-svg (list (list (cons "A" 0) (cons nil 'joker) 'down nil)))))) - (should (stringp (cg-svg-to-string - (cg-bid--table-svg (cg-bid--deal (make-instance 'cg-bid-game))))))) + (should (stringp (card-games-svg-to-string + (card-games-svg-grid-svg (list (list (cons "A" 0) (cons nil 'joker) 'down nil)))))) + (should (stringp (card-games-svg-to-string + (card-games-bid--table-svg (card-games-bid--deal (make-instance 'card-games-bid-game))))))) ;;;; Chooser (ert-deftest cgt-chooser-registry () (should (assoc "500 (Bid)" card-games-list)) - (should (commandp 'card-game))) + (should (commandp 'card-games))) (provide 'card-games-tests) ;;; card-games-tests.el ends here (ert-deftest cgt-ai-step () ;; ai-step advances within a hand; the caller deals the next hand at 'done. - (let ((cg-bid--human-seats nil) - (g (cg-bid--deal (make-instance 'cg-bid-game))) (guard 0)) - (while (and (not (eq (cg-get g :phase) 'gameover)) (< (cl-incf guard) 6000)) - (unless (cg-bid--ai-step g) - (cg-bid--deal g (mod (1+ (cg-get g :dealer)) 4)))) - (should (eq 'gameover (cg-get g :phase))))) + (let ((card-games-bid--human-seats nil) + (g (card-games-bid--deal (make-instance 'card-games-bid-game))) (guard 0)) + (while (and (not (eq (card-games-get g :phase) 'gameover)) (< (cl-incf guard) 6000)) + (unless (card-games-bid--ai-step g) + (card-games-bid--deal g (mod (1+ (card-games-get g :dealer)) 4)))) + (should (eq 'gameover (card-games-get g :phase))))) (ert-deftest cgt-card-back-presets () - (dolist (cg-svg-card-back '(dots rings solid)) - (should (stringp (cg-svg-to-string - (cg-svg-cards-svg (list 'down))))))) + (dolist (card-games-svg-card-back '(dots rings solid)) + (should (stringp (card-games-svg-to-string + (card-games-svg-cards-svg (list 'down))))))) (ert-deftest cgt-set-theme () (let ((inhibit-message t)) ; keep the theme banner out of test output (card-games-set-theme 'dark) - (should (equal "#23272e" cg-bid-felt-color)) + (should (equal "#23272e" card-games-bid-felt-color)) (card-games-set-theme 'classic) - (should (equal "#15692f" cg-bid-felt-color)))) + (should (equal "#15692f" card-games-bid-felt-color)))) (ert-deftest cgt-scale () (require 'face-remap) - (let ((text-scale-mode-amount 0)) (should (= 1.0 (cg-scale)))) - (let ((text-scale-mode-amount 2)) (should (> (cg-scale) 1.0))) - (let ((text-scale-mode-amount -2)) (should (< (cg-scale) 1.0)))) + (let ((text-scale-mode-amount 0)) (should (= 1.0 (card-games-scale)))) + (let ((text-scale-mode-amount 2)) (should (> (card-games-scale) 1.0))) + (let ((text-scale-mode-amount -2)) (should (< (card-games-scale) 1.0)))) (ert-deftest cgt-mode-line-announce () - (let ((g (cg-bid--deal (make-instance 'cg-bid-game)))) - (should (stringp (cg-bid--mode-line g))) - (should (string-match-p "bid" (cg-bid--mode-line g))))) + (let ((g (card-games-bid--deal (make-instance 'card-games-bid-game)))) + (should (stringp (card-games-bid--mode-line g))) + (should (string-match-p "bid" (card-games-bid--mode-line g))))) (ert-deftest cgt-gaps-mode-line () - (let ((g (cg-gaps--deal (make-instance 'cg-montana-game)))) - (should (string-match-p "moves" (cg-gaps--mode-line g))))) + (let ((g (card-games-gaps--deal (make-instance 'card-games-montana-game)))) + (should (string-match-p "moves" (card-games-gaps--mode-line g))))) (ert-deftest cgt-keys-default () - (should (eq cg-keys 'emacs)) - (should (commandp 'cg-gaps-redraw)) - (should (commandp 'cg-bid-redraw)) + (should (eq card-games-keys 'emacs)) + (should (commandp 'card-games-gaps-redraw)) + (should (commandp 'card-games-bid-redraw)) ;; g redraws (not new) - (should (eq 'cg-gaps-redraw (lookup-key cg-gaps-mode-map "g"))) - (should (eq 'cg-bid-redraw (lookup-key cg-bid-mode-map "g")))) + (should (eq 'card-games-gaps-redraw (lookup-key card-games-gaps-mode-map "g"))) + (should (eq 'card-games-bid-redraw (lookup-key card-games-bid-mode-map "g")))) (ert-deftest cgt-keys-classic () ;; emacs map has no h/SPC binding; classic adds them - (should-not (lookup-key cg-gaps-mode-map "h")) - (should (eq 'cg-gaps-left (lookup-key (cg-gaps--classic-keymap) "h"))) - (should (eq 'cg-bid-left (lookup-key (cg-bid--classic-keymap) "h")))) + (should-not (lookup-key card-games-gaps-mode-map "h")) + (should (eq 'card-games-gaps-left (lookup-key (card-games-gaps--classic-keymap) "h"))) + (should (eq 'card-games-bid-left (lookup-key (card-games-bid--classic-keymap) "h")))) (ert-deftest cgt-svgui-builds () - (let ((g (cg-bid--deal (make-instance 'cg-bid-game)))) - (cg-put g :phase 'auction) (cg-put g :bidder 0) - (let ((sr (cg-bid--ui-svg g))) - (should (stringp (cg-svg-to-string (car sr)))) + (let ((g (card-games-bid--deal (make-instance 'card-games-bid-game)))) + (card-games-put g :phase 'auction) (card-games-put g :bidder 0) + (let ((sr (card-games-bid--ui-svg g))) + (should (stringp (card-games-svg-to-string (car sr)))) ;; available bids have clickable rects; a cell centre maps back to its bid (let* ((bids (plist-get (cdr sr) :bids)) (e (car bids)) (r (cdr e)) (cx (+ (nth 0 r) (/ (nth 2 r) 2))) (cy (+ (nth 1 r) (/ (nth 3 r) 2)))) - (should (eq (car e) (cg-bid--region-bid cx cy (cdr sr)))))))) + (should (eq (car e) (card-games-bid--region-bid cx cy (cdr sr)))))))) (ert-deftest cgt-gaps-svgui-builds () ;; the full-SVG gaps UI builds, and a cell centre maps back to its (row . col) - (let ((g (cg-gaps--deal (make-instance 'cg-montana-game)))) - (let* ((sr (cg-gaps--ui-svg g 820 380)) + (let ((g (card-games-gaps--deal (make-instance 'card-games-montana-game)))) + (let* ((sr (card-games-gaps--ui-svg g 820 380)) (geom (plist-get (cdr sr) :board)) (x0 (nth 0 geom)) (y0 (nth 1 geom)) (cw (nth 2 geom)) (ch (nth 3 geom)) (gp (nth 4 geom))) - (should (stringp (cg-svg-to-string (car sr)))) + (should (stringp (card-games-svg-to-string (car sr)))) (should (plist-get (cdr sr) :new)) ; control regions present (should (equal (cons 2 3) - (cg-gaps--ui-cell (+ x0 (* 3 (+ cw gp)) (/ cw 2)) + (card-games-gaps--ui-cell (+ x0 (* 3 (+ cw gp)) (/ cw 2)) (+ y0 (* 2 (+ ch gp)) (/ ch 2)) geom)))))) (ert-deftest cgt-classic-folds-controls () ;; graphical classic UI: one action-button row, no textual key-help (with-temp-buffer - (cg-bid-mode) - (setq cg-bid--game (cg-bid--deal (make-instance 'cg-bid-game))) - (let ((cg-bid-svg-ui nil) (inhibit-read-only t)) - (cg-bid--insert-graphical cg-bid--game) - (cg-bid--insert-buttons cg-bid--game)) + (card-games-bid-mode) + (setq card-games-bid--game (card-games-bid--deal (make-instance 'card-games-bid-game))) + (let ((card-games-bid-svg-ui nil) (inhibit-read-only t)) + (card-games-bid--insert-graphical card-games-bid--game) + (card-games-bid--insert-buttons card-games-bid--game)) (let ((s (buffer-string))) (should-not (string-match-p "RET\\] play card" s)) ; key-help removed (should (string-match-p "Help" s)) ; button row present @@ -487,16 +487,16 @@ the unseeded shuffle keeps its system-random behaviour. Opening #4." (ert-deftest cgt-bid-net-filter () "Per-seat 500 state hides others' cards and rotates the viewer South." (cl-flet ((ck (h) (sort (mapcar #'prin1-to-string h) #'string<))) - (let* ((cg-bid--human-seats '(0 1 2 3)) - (g (cg-bid--deal (make-instance 'cg-bid-game) 3)) - (st (cg-net-game-state g 1))) ; West's viewpoint + (let* ((card-games-bid--human-seats '(0 1 2 3)) + (g (card-games-bid--deal (make-instance 'card-games-bid-game) 3)) + (st (card-games-net-game-state g 1))) ; West's viewpoint ;; West sees its own ten cards rotated to index 0 (should (equal (ck (aref (plist-get st :hands) 0)) - (ck (cg-bid--hand g 1)))) + (ck (card-games-bid--hand g 1)))) ;; opponents are face-down counts only, not the real cards (should (= 10 (length (aref (plist-get st :hands) 1)))) (should-not (equal (ck (aref (plist-get st :hands) 1)) - (ck (cg-bid--hand g 2)))) + (ck (card-games-bid--hand g 2)))) ;; the kitty stays hidden (should-not (plist-get st :kitty)) ;; South (abs 0) bids first; in West's frame that is seat 3 @@ -505,12 +505,12 @@ the unseeded shuffle keeps its system-random behaviour. Opening #4." (ert-deftest cgt-bid-net-apply () "The host applies only legal, in-turn moves." - (let* ((cg-bid--human-seats '(0 1 2 3)) - (g (cg-bid--deal (make-instance 'cg-bid-game) 3))) - (should-not (cg-net-apply-move g 1 '(pass))) ; not West's turn yet - (should (cg-net-apply-move g 0 '(pass))) ; South may pass - (should (aref (cg-get g :passed) 0)) - (should-not (cg-net-apply-move g 0 '(play (0 . 0)))) ; wrong phase + (let* ((card-games-bid--human-seats '(0 1 2 3)) + (g (card-games-bid--deal (make-instance 'card-games-bid-game) 3))) + (should-not (card-games-net-apply-move g 1 '(pass))) ; not West's turn yet + (should (card-games-net-apply-move g 0 '(pass))) ; South may pass + (should (aref (card-games-get g :passed) 0)) + (should-not (card-games-net-apply-move g 0 '(play (0 . 0)))) ; wrong phase )) (ert-deftest cgt-bid-net-discard-checked () @@ -519,26 +519,26 @@ Finding 3 of the 2026-07-29 review: the other move checks were real, but a discard only counted its cards, and cl-set-difference silently ignores cards that are not in the hand -- so five phantom discards left a 15-card hand in play." - (let* ((cg-bid--human-seats '(0 1 2 3)) - (g (cg-bid--deal (make-instance 'cg-bid-game) 3))) + (let* ((card-games-bid--human-seats '(0 1 2 3)) + (g (card-games-bid--deal (make-instance 'card-games-bid-game) 3))) ;; put the game where a discard is legal: West won the auction - (cg-put g :phase 'kitty) - (cg-put g :contractor 1) - (cg-bid--set-hand g 1 (append (cg-get g :kitty) (cg-bid--hand g 1))) - (let* ((hand (copy-sequence (cg-bid--hand g 1))) - (foreign (cl-subseq (cg-bid--hand g 2) 0 5))) + (card-games-put g :phase 'kitty) + (card-games-put g :contractor 1) + (card-games-bid--set-hand g 1 (append (card-games-get g :kitty) (card-games-bid--hand g 1))) + (let* ((hand (copy-sequence (card-games-bid--hand g 1))) + (foreign (cl-subseq (card-games-bid--hand g 2) 0 5))) ;; five cards West does not hold: refused, nothing moves - (should-not (cg-net-apply-move g 1 (cons 'discard foreign))) - (should (equal hand (cg-bid--hand g 1))) - (should (eq 'kitty (cg-get g :phase))) + (should-not (card-games-net-apply-move g 1 (cons 'discard foreign))) + (should (equal hand (card-games-bid--hand g 1))) + (should (eq 'kitty (card-games-get g :phase))) ;; one held card named five times: also refused - (should-not (cg-net-apply-move g 1 + (should-not (card-games-net-apply-move g 1 (cons 'discard (make-list 5 (car hand))))) - (should (eq 'kitty (cg-get g :phase))) + (should (eq 'kitty (card-games-get g :phase))) ;; an honest five from the hand is accepted and play begins - (should (cg-net-apply-move g 1 (cons 'discard (cl-subseq hand 0 5)))) - (should (eq 'play (cg-get g :phase))) - (should (= 10 (length (cg-bid--hand g 1))))))) + (should (card-games-net-apply-move g 1 (cons 'discard (cl-subseq hand 0 5)))) + (should (eq 'play (card-games-get g :phase))) + (should (= 10 (length (card-games-bid--hand g 1))))))) (ert-deftest cgt-bid-net-loopback () "A 500 move travels client -> host -> filtered broadcast over TCP." @@ -548,1049 +548,1049 @@ left a 15-card hand in play." :host "127.0.0.1" :family 'ipv4)) (error (ert-skip "TCP not available"))) (cl-flet ((pump () (dotimes (_ 16) (accept-process-output nil 0.05)))) - (let* ((cg-bid--human-seats '(0 1)) - (hgame (cg-bid--deal (make-instance 'cg-bid-game) 3)) - (srv (cg-net-host-start hgame 0)) + (let* ((card-games-bid--human-seats '(0 1)) + (hgame (card-games-bid--deal (make-instance 'card-games-bid-game) 3)) + (srv (card-games-net-host-start hgame 0)) (port (process-contact srv :service)) - (cgame (make-instance 'cg-bid-game))) - (setf (cg-net-host-next-seat cg-net--host) 1) ; reserve South for host + (cgame (make-instance 'card-games-bid-game))) + (setf (card-games-net-host-next-seat card-games-net--host) 1) ; reserve South for host (unwind-protect (progn - (cg-net-connect "127.0.0.1" port "P1" cgame) + (card-games-net-connect "127.0.0.1" port "P1" cgame) (pump) ;; the client (seat 1) sees its own ten cards at index 0 - (should (= 10 (length (aref (cg-get cgame :hands) 0)))) + (should (= 10 (length (aref (card-games-get cgame :hands) 0)))) (should (equal - (sort (mapcar #'prin1-to-string (aref (cg-get cgame :hands) 0)) #'string<) - (sort (mapcar #'prin1-to-string (cg-bid--hand hgame 1)) #'string<))) + (sort (mapcar #'prin1-to-string (aref (card-games-get cgame :hands) 0)) #'string<) + (sort (mapcar #'prin1-to-string (card-games-bid--hand hgame 1)) #'string<))) ;; make it the client's turn, then let it pass - (cg-put hgame :bidder 1) - (cg-net-host-broadcast) + (card-games-put hgame :bidder 1) + (card-games-net-host-broadcast) (pump) - (should (= 0 (cg-get cgame :bidder))) ; rotated: West sees itself bidding - (cg-net-send-move '(pass)) + (should (= 0 (card-games-get cgame :bidder))) ; rotated: West sees itself bidding + (card-games-net-send-move '(pass)) (pump) - (should (aref (cg-get hgame :passed) 1))) - (cg-net-disconnect) - (cg-net-host-stop))))) + (should (aref (card-games-get hgame :passed) 1))) + (card-games-net-disconnect) + (card-games-net-host-stop))))) ;;;; --- New games added 2026-06-24: solitaires, trick games, Crazy Eights --- (ert-deftest cgt-sol-deck () - (should (= 52 (length (cg-sol--make-deck 1)))) - (should (= 104 (length (cg-sol--make-deck 2))))) + (should (= 52 (length (card-games-sol--make-deck 1)))) + (should (= 104 (length (card-games-sol--make-deck 2))))) (ert-deftest cgt-sol-klondike-deal () - (let* ((g (cg-sol--deal (cg-klondike-game)))) + (let* ((g (card-games-sol--deal (card-games-klondike-game)))) (should (= 7 (oref g ncols))) (dotimes (c 7) - (should (= (1+ c) (length (cg-sol--col g c)))) - (should (= c (cg-sol--down g c))) + (should (= (1+ c) (length (card-games-sol--col g c)))) + (should (= c (card-games-sol--down g c))) ;; top card is face up - (should (cg-sol--col-top g c))) - (should (= 24 (length (cg-get g :stock)))) - (should (cl-every #'null (append (cg-get g :found) nil))))) + (should (card-games-sol--col-top g c))) + (should (= 24 (length (card-games-get g :stock)))) + (should (cl-every #'null (append (card-games-get g :found) nil))))) (ert-deftest cgt-sol-freecell-deal () - (let* ((g (cg-sol--deal (cg-freecell-game))) + (let* ((g (card-games-sol--deal (card-games-freecell-game))) (total 0)) (should (= 8 (oref g ncols))) - (dotimes (c 8) (cl-incf total (length (cg-sol--col g c))) - (should (= 0 (cg-sol--down g c)))) + (dotimes (c 8) (cl-incf total (length (card-games-sol--col g c))) + (should (= 0 (card-games-sol--down g c)))) (should (= 52 total)) - (should (null (cg-get g :stock))) - (should (= 4 (length (cg-get g :free)))))) + (should (null (card-games-get g :stock))) + (should (= 4 (length (card-games-get g :free)))))) (ert-deftest cgt-sol-spider-deal () - (let* ((g (cg-sol--deal (cg-spider-game))) + (let* ((g (card-games-sol--deal (card-games-spider-game))) (total 0)) (should (= 10 (oref g ncols))) - (dotimes (c 10) (cl-incf total (length (cg-sol--col g c)))) + (dotimes (c 10) (cl-incf total (length (card-games-sol--col g c)))) (should (= 54 total)) - (should (= 50 (length (cg-get g :stock)))) - (dotimes (c 4) (should (= 6 (length (cg-sol--col g c))))) - (dotimes (k 6) (should (= 5 (length (cg-sol--col g (+ 4 k)))))))) + (should (= 50 (length (card-games-get g :stock)))) + (dotimes (c 4) (should (= 6 (length (card-games-sol--col g c))))) + (dotimes (k 6) (should (= 5 (length (card-games-sol--col g (+ 4 k)))))))) (ert-deftest cgt-sol-rules-alt () - (let ((g (cg-klondike-game))) + (let ((g (card-games-klondike-game))) ;; red 6 onto black 7 ok; black 6 onto black 7 no - (should (cg-sol--place-p g '(0 . 6) '(3 . 5))) ; 7s under 6h - (should-not (cg-sol--place-p g '(0 . 6) '(1 . 5))) ; 6c on 7s same color - (should (cg-sol--empty-accepts g '(0 . 12))) ; king - (should-not (cg-sol--empty-accepts g '(0 . 11))))) ; queen + (should (card-games-sol--place-p g '(0 . 6) '(3 . 5))) ; 7s under 6h + (should-not (card-games-sol--place-p g '(0 . 6) '(1 . 5))) ; 6c on 7s same color + (should (card-games-sol--empty-accepts g '(0 . 12))) ; king + (should-not (card-games-sol--empty-accepts g '(0 . 11))))) ; queen (ert-deftest cgt-sol-rules-spider () - (let ((g (cg-spider-game))) + (let ((g (card-games-spider-game))) ;; build down any suit - (should (cg-sol--place-p g '(0 . 6) '(3 . 5))) - (should (cg-sol--place-p g '(0 . 6) '(1 . 5))) + (should (card-games-sol--place-p g '(0 . 6) '(3 . 5))) + (should (card-games-sol--place-p g '(0 . 6) '(1 . 5))) ;; run cohesion requires same suit - (should (cg-sol--link-p g '(0 . 6) '(0 . 5))) - (should-not (cg-sol--link-p g '(0 . 6) '(1 . 5))) - (should (cg-sol--empty-accepts g '(0 . 3))))) + (should (card-games-sol--link-p g '(0 . 6) '(0 . 5))) + (should-not (card-games-sol--link-p g '(0 . 6) '(1 . 5))) + (should (card-games-sol--empty-accepts g '(0 . 3))))) (ert-deftest cgt-sol-top-run () - (let ((g (cg-klondike-game))) - (cg-put g :tableau (vector (list '(0 . 9) '(2 . 8) '(1 . 7)))) ; 9s 8d 7c - (cg-put g :down (vector 0)) + (let ((g (card-games-klondike-game))) + (card-games-put g :tableau (vector (list '(0 . 9) '(2 . 8) '(1 . 7)))) ; 9s 8d 7c + (card-games-put g :down (vector 0)) ;; 9s(black) 8d(red) 7c(black) is a valid alt run of 3 - (should (= 3 (length (cg-sol--top-run g 0)))) + (should (= 3 (length (card-games-sol--top-run g 0)))) ;; break color: 9s 8d 7d -> only 8d 7d? 7d red on 8d red invalid -> run is just 7d - (cg-put g :tableau (vector (list '(0 . 9) '(2 . 8) '(2 . 7)))) - (should (= 1 (length (cg-sol--top-run g 0)))))) + (card-games-put g :tableau (vector (list '(0 . 9) '(2 . 8) '(2 . 7)))) + (should (= 1 (length (card-games-sol--top-run g 0)))))) (ert-deftest cgt-sol-move-col () - (let ((g (cg-sol--deal (cg-klondike-game)))) + (let ((g (card-games-sol--deal (card-games-klondike-game)))) ;; craft: col0 top = 7c(black), col1 top = 6h(red); move 6h onto 7c - (cg-put g :tableau (vector (list '(1 . 7)) (list '(3 . 6)) nil nil nil nil nil)) - (cg-put g :down (vector 0 0 0 0 0 0 0)) - (let ((cards (last (cg-sol--col g 1) 1))) - (should (cg-sol--can-drop g '(col . 0) cards)) - (cg-sol--take g '(col . 1) 1) - (cg-sol--drop g '(col . 0) cards)) - (should (equal '((1 . 7) (3 . 6)) (cg-sol--col g 0))) - (should (null (cg-sol--col g 1))))) + (card-games-put g :tableau (vector (list '(1 . 7)) (list '(3 . 6)) nil nil nil nil nil)) + (card-games-put g :down (vector 0 0 0 0 0 0 0)) + (let ((cards (last (card-games-sol--col g 1) 1))) + (should (card-games-sol--can-drop g '(col . 0) cards)) + (card-games-sol--take g '(col . 1) 1) + (card-games-sol--drop g '(col . 0) cards)) + (should (equal '((1 . 7) (3 . 6)) (card-games-sol--col g 0))) + (should (null (card-games-sol--col g 1))))) (ert-deftest cgt-sol-foundation-and-win () - (let ((g (cg-sol--deal (cg-klondike-game)))) + (let ((g (card-games-sol--deal (card-games-klondike-game)))) ;; empty foundations: place an Ace then a 2 of same suit - (should (cg-sol--found-accepts g 0 '(0 . 0))) - (cg-sol--drop g '(found . 0) (list '(0 . 0))) - (should (cg-sol--found-accepts g 0 '(0 . 1))) - (should-not (cg-sol--found-accepts g 0 '(1 . 1))) + (should (card-games-sol--found-accepts g 0 '(0 . 0))) + (card-games-sol--drop g '(found . 0) (list '(0 . 0))) + (should (card-games-sol--found-accepts g 0 '(0 . 1))) + (should-not (card-games-sol--found-accepts g 0 '(1 . 1))) ;; build a winning state: fill all four foundations A..K (let ((found (make-vector 4 nil))) (dotimes (s 4) (aset found s (cl-loop for r below 13 collect (cons s r)))) - (cg-put g :found found)) - (should (cg-won-p g)))) + (card-games-put g :found found)) + (should (card-games-won-p g)))) (ert-deftest cgt-sol-spider-harvest () - (let ((g (cg-sol--deal (cg-spider-game)))) + (let ((g (card-games-sol--deal (card-games-spider-game)))) ;; put a complete K..A spade run as the whole of column 0 - (cg-put g :tableau (let ((v (cg-get g :tableau))) + (card-games-put g :tableau (let ((v (card-games-get g :tableau))) (aset v 0 (cl-loop for r from 12 downto 0 collect (cons 0 r))) v)) - (cg-put g :down (let ((v (cg-get g :down))) (aset v 0 0) v)) - (cg-put g :sets 0) - (cg-sol--harvest g) - (should (= 1 (cg-get g :sets))) - (should (null (cg-sol--col g 0))))) + (card-games-put g :down (let ((v (card-games-get g :down))) (aset v 0 0) v)) + (card-games-put g :sets 0) + (card-games-sol--harvest g) + (should (= 1 (card-games-get g :sets))) + (should (null (card-games-sol--col g 0))))) (ert-deftest cgt-sol-undo () - (let ((g (cg-sol--deal (cg-klondike-game)))) - (cg-put g :tableau (vector (list '(1 . 7)) (list '(3 . 6)) nil nil nil nil nil)) - (cg-put g :down (vector 0 0 0 0 0 0 0)) - (cg-sol--snapshot g) - (let ((cards (last (cg-sol--col g 1) 1))) - (cg-sol--take g '(col . 1) 1) - (cg-sol--drop g '(col . 0) cards)) - (should (null (cg-sol--col g 1))) - (should (cg-sol--restore g)) - (should (equal '((3 . 6)) (cg-sol--col g 1))))) + (let ((g (card-games-sol--deal (card-games-klondike-game)))) + (card-games-put g :tableau (vector (list '(1 . 7)) (list '(3 . 6)) nil nil nil nil nil)) + (card-games-put g :down (vector 0 0 0 0 0 0 0)) + (card-games-sol--snapshot g) + (let ((cards (last (card-games-sol--col g 1) 1))) + (card-games-sol--take g '(col . 1) 1) + (card-games-sol--drop g '(col . 0) cards)) + (should (null (card-games-sol--col g 1))) + (should (card-games-sol--restore g)) + (should (equal '((3 . 6)) (card-games-sol--col g 1))))) (ert-deftest cgt-sol-render-builds () - (dolist (cls '(cg-klondike-game cg-freecell-game cg-spider-game cg-yukon-game)) - (let ((g (cg-sol--deal (make-instance cls)))) - (should (stringp (cg-render g)))))) + (dolist (cls '(card-games-klondike-game card-games-freecell-game card-games-spider-game card-games-yukon-game)) + (let ((g (card-games-sol--deal (make-instance cls)))) + (should (stringp (card-games-render g)))))) (defun cgt--init-hearts () - (let ((g (cg-hearts-game))) - (cg-put g :scores (make-vector 4 0)) - (cg-trick--start-hand g) g)) + (let ((g (card-games-hearts-game))) + (card-games-put g :scores (make-vector 4 0)) + (card-games-trick--start-hand g) g)) (defun cgt--init-spades () - (let ((g (cg-spades-game))) - (cg-put g :scores (make-vector 4 0)) - (cg-put g :bags (make-vector 2 0)) - (cg-put g :dealer 3) - (cg-trick--deal g) - (cg-put g :bids (let ((v (make-vector 4 0))) - (dotimes (s 4) (aset v s (cg-trick--ai-bid g s))) v)) - (cg-trick--leader-init g) g)) + (let ((g (card-games-spades-game))) + (card-games-put g :scores (make-vector 4 0)) + (card-games-put g :bags (make-vector 2 0)) + (card-games-put g :dealer 3) + (card-games-trick--deal g) + (card-games-put g :bids (let ((v (make-vector 4 0))) + (dotimes (s 4) (aset v s (card-games-trick--ai-bid g s))) v)) + (card-games-trick--leader-init g) g)) (ert-deftest cgt-trick-deal () - (let ((g (cg-trick--deal (cg-hearts-game)))) + (let ((g (card-games-trick--deal (card-games-hearts-game)))) (let ((tot 0)) - (dotimes (s 4) (cl-incf tot (length (cg-trick--hand g s)))) + (dotimes (s 4) (cl-incf tot (length (card-games-trick--hand g s)))) (should (= 52 tot))) - (dotimes (s 4) (should (= 13 (length (cg-trick--hand g s))))))) + (dotimes (s 4) (should (= 13 (length (card-games-trick--hand g s))))))) (ert-deftest cgt-trick-winner-trump () - (let ((g (cg-spades-game))) + (let ((g (card-games-spades-game))) ;; play order: S leads 10h, W 13h(K), N 2s(trump), E 12h - (cg-put g :trick (list (cons 3 '(3 . 11)) (cons 2 '(0 . 0)) + (card-games-put g :trick (list (cons 3 '(3 . 11)) (cons 2 '(0 . 0)) (cons 1 '(3 . 12)) (cons 0 '(3 . 8)))) ;; :trick is stored reversed (newest first); winner = North (trump) - (should (= 2 (cg-trick--winner g))))) + (should (= 2 (card-games-trick--winner g))))) (ert-deftest cgt-trick-winner-notrump () - (let ((g (cg-hearts-game))) + (let ((g (card-games-hearts-game))) ;; led hearts; highest heart wins (no trump) - (cg-put g :trick (list (cons 3 '(1 . 12)) (cons 2 '(3 . 12)) + (card-games-put g :trick (list (cons 3 '(1 . 12)) (cons 2 '(3 . 12)) (cons 1 '(3 . 5)) (cons 0 '(3 . 8)))) ;; North played Ace of hearts (3 . 12) -> winner North - (should (= 2 (cg-trick--winner g))))) + (should (= 2 (card-games-trick--winner g))))) (ert-deftest cgt-hearts-first-must-be-2c () (let* ((g (cgt--init-hearts)) - (leader (cg-get g :turn))) - (let ((moves (cg-trick--legal-moves g leader))) + (leader (card-games-get g :turn))) + (let ((moves (card-games-trick--legal-moves g leader))) (should (equal moves '((1 . 0))))))) (ert-deftest cgt-hearts-full-hand () (let ((g (cgt--init-hearts))) - (cg-trick--simulate-hand g) + (card-games-trick--simulate-hand g) ;; 13 tricks distributed - (should (= 13 (apply #'+ (append (cg-get g :tricks) nil)))) + (should (= 13 (apply #'+ (append (card-games-get g :tricks) nil)))) ;; total points across players is 26 (no moon) or 78 (moon: 3*26) - (let ((tot (apply #'+ (append (cg-get g :scores) nil)))) + (let ((tot (apply #'+ (append (card-games-get g :scores) nil)))) (should (memq tot '(26 78)))))) (ert-deftest cgt-hearts-many-hands () (let ((g (cgt--init-hearts)) (n 0)) - (while (and (not (cg-trick--game-over-p g)) (< n 60)) - (cg-trick--simulate-hand g) + (while (and (not (card-games-trick--game-over-p g)) (< n 60)) + (card-games-trick--simulate-hand g) (cl-incf n) - (unless (cg-trick--game-over-p g) (cg-trick--start-hand g))) - (should (cg-trick--game-over-p g)) - (should (integerp (cg-trick--winner-seat g))))) + (unless (card-games-trick--game-over-p g) (card-games-trick--start-hand g))) + (should (card-games-trick--game-over-p g)) + (should (integerp (card-games-trick--winner-seat g))))) (ert-deftest cgt-spades-bid-range () - (let ((g (cg-trick--deal (cg-spades-game)))) + (let ((g (card-games-trick--deal (card-games-spades-game)))) (dotimes (s 4) - (let ((b (cg-trick--ai-bid g s))) + (let ((b (card-games-trick--ai-bid g s))) (should (and (>= b 1) (<= b 13))))))) (ert-deftest cgt-spades-full-hand () (let ((g (cgt--init-spades))) - (cg-trick--simulate-hand g) - (should (= 13 (apply #'+ (append (cg-get g :tricks) nil)))) + (card-games-trick--simulate-hand g) + (should (= 13 (apply #'+ (append (card-games-get g :tricks) nil)))) ;; teammates share a score - (should (= (aref (cg-get g :scores) 0) (aref (cg-get g :scores) 2))) - (should (= (aref (cg-get g :scores) 1) (aref (cg-get g :scores) 3))))) + (should (= (aref (card-games-get g :scores) 0) (aref (card-games-get g :scores) 2))) + (should (= (aref (card-games-get g :scores) 1) (aref (card-games-get g :scores) 3))))) (ert-deftest cgt-spades-full-game () (let ((g (cgt--init-spades)) (n 0)) - (while (and (not (cg-trick--game-over-p g)) (< n 80)) - (cg-trick--simulate-hand g) + (while (and (not (card-games-trick--game-over-p g)) (< n 80)) + (card-games-trick--simulate-hand g) (cl-incf n) - (unless (cg-trick--game-over-p g) - (cg-trick--deal g) - (cg-put g :bids (let ((v (make-vector 4 0))) - (dotimes (s 4) (aset v s (cg-trick--ai-bid g s))) v)) - (cg-trick--leader-init g))) - (should (cg-trick--game-over-p g)))) + (unless (card-games-trick--game-over-p g) + (card-games-trick--deal g) + (card-games-put g :bids (let ((v (make-vector 4 0))) + (dotimes (s 4) (aset v s (card-games-trick--ai-bid g s))) v)) + (card-games-trick--leader-init g))) + (should (card-games-trick--game-over-p g)))) (ert-deftest cgt-trick-ui-new-and-render () - (dolist (cls '(cg-hearts-game cg-spades-game)) + (dolist (cls '(card-games-hearts-game card-games-spades-game)) (let ((noninteractive t) (g (make-instance cls))) - (cg-trick--new g) ; spades bids via ai (noninteractive), hearts -> pass phase - (should (stringp (cg-render g))) - (should (memq (cg-get g :phase) '(pass play)))))) + (card-games-trick--new g) ; spades bids via ai (noninteractive), hearts -> pass phase + (should (stringp (card-games-render g))) + (should (memq (card-games-get g :phase) '(pass play)))))) (ert-deftest cgt-trick-ui-hearts-pass () - (let* ((noninteractive t) (g (make-instance 'cg-hearts-game))) - (cg-trick--new g) + (let* ((noninteractive t) (g (make-instance 'card-games-hearts-game))) + (card-games-trick--new g) ;; hand 1 passes left; mark 3 cards from South and pass - (when (eq (cg-get g :phase) 'pass) - (cg-put g :marks (cl-subseq (cg-trick--sort (cg-trick--hand g 0)) 0 3)) - (cg-trick--do-pass g) - (should (eq (cg-get g :phase) 'play)) + (when (eq (card-games-get g :phase) 'pass) + (card-games-put g :marks (cl-subseq (card-games-trick--sort (card-games-trick--hand g 0)) 0 3)) + (card-games-trick--do-pass g) + (should (eq (card-games-get g :phase) 'play)) ;; cards are conserved: hands plus the cards already played this trick - (let ((tot (length (cg-get g :trick)))) - (dotimes (s 4) (cl-incf tot (length (cg-trick--hand g s)))) + (let ((tot (length (card-games-get g :trick)))) + (dotimes (s 4) (cl-incf tot (length (card-games-trick--hand g s)))) (should (= 52 tot)))))) (ert-deftest cgt-trick-ui-spades-human-play () - (let* ((noninteractive t) (g (make-instance 'cg-spades-game))) - (cg-trick--new g) ; runs AI until South's turn - (should (eq (cg-get g :phase) 'play)) - (should (= 0 (cg-get g :turn))) + (let* ((noninteractive t) (g (make-instance 'card-games-spades-game))) + (card-games-trick--new g) ; runs AI until South's turn + (should (eq (card-games-get g :phase) 'play)) + (should (= 0 (card-games-get g :turn))) ;; play a legal card for South, then run; eventually hand completes/scores (let ((guard 0)) - (while (and (eq (cg-get g :phase) 'play) (< guard 20) - (= 0 (cg-get g :turn))) - (let ((card (car (cg-trick--legal-moves g 0)))) - (cg-trick--play g 0 card) - (cg-trick--run g)) + (while (and (eq (card-games-get g :phase) 'play) (< guard 20) + (= 0 (card-games-get g :turn))) + (let ((card (car (card-games-trick--legal-moves g 0)))) + (card-games-trick--play g 0 card) + (card-games-trick--run g)) (cl-incf guard))) - (should (vectorp (cg-get g :scores))))) + (should (vectorp (card-games-get g :scores))))) (ert-deftest cgt-eights-deal () - (let* ((cg-eights-players 3) (g (cg-eights--deal (cg-eights-game)))) - (should (= 3 (cg-get g :nplayers))) - (dotimes (s 3) (should (= 5 (length (cg-eights--hand g s))))) - (should (cg-eights--top g)) - (should-not (= cg-eights--wild (cdr (cg-eights--top g)))))) ; starter not an eight + (let* ((card-games-eights-players 3) (g (card-games-eights--deal (card-games-eights-game)))) + (should (= 3 (card-games-get g :nplayers))) + (dotimes (s 3) (should (= 5 (length (card-games-eights--hand g s))))) + (should (card-games-eights--top g)) + (should-not (= card-games-eights--wild (cdr (card-games-eights--top g)))))) ; starter not an eight (ert-deftest cgt-eights-legal () - (let ((g (cg-eights-game))) - (cg-put g :discard (list '(0 . 3))) (cg-put g :suit 0) - (should (cg-eights--legal-p g '(0 . 8))) ; same suit (spades) - (should (cg-eights--legal-p g '(1 . 3))) ; same rank - (should (cg-eights--legal-p g '(2 . 6))) ; eight (wild) - (should-not (cg-eights--legal-p g '(1 . 4))))) ; neither + (let ((g (card-games-eights-game))) + (card-games-put g :discard (list '(0 . 3))) (card-games-put g :suit 0) + (should (card-games-eights--legal-p g '(0 . 8))) ; same suit (spades) + (should (card-games-eights--legal-p g '(1 . 3))) ; same rank + (should (card-games-eights--legal-p g '(2 . 6))) ; eight (wild) + (should-not (card-games-eights--legal-p g '(1 . 4))))) ; neither (ert-deftest cgt-eights-full-game () - (let* ((cg-eights-players 4) (noninteractive t) (g (cg-eights--deal (cg-eights-game))) + (let* ((card-games-eights-players 4) (noninteractive t) (g (card-games-eights--deal (card-games-eights-game))) (guard 0)) ;; drive entirely by AI from every seat - (while (and (eq (cg-get g :phase) 'play) (< guard 2000)) - (cg-eights--ai-turn g (cg-get g :turn)) - (when (>= (cg-get g :passes) (cg-get g :nplayers)) (cg-eights--deadlock g)) + (while (and (eq (card-games-get g :phase) 'play) (< guard 2000)) + (card-games-eights--ai-turn g (card-games-get g :turn)) + (when (>= (card-games-get g :passes) (card-games-get g :nplayers)) (card-games-eights--deadlock g)) (cl-incf guard)) - (should (eq (cg-get g :phase) 'game-over)) - (should (integerp (cg-get g :winner))))) + (should (eq (card-games-get g :phase) 'game-over)) + (should (integerp (card-games-get g :winner))))) (ert-deftest cgt-eights-wild-sets-suit () - (let* ((cg-eights-players 2) (g (cg-eights--deal (cg-eights-game)))) - (cg-eights--set-hand g 0 (list '(3 . 6))) ; the human holds only an eight - (cg-put g :discard (list '(0 . 3))) (cg-put g :suit 0) - (cg-eights--play g 0 '(3 . 6) 2) ; play it, name diamonds (2) - (should (= 2 (cg-get g :suit))) - (should (eq (cg-get g :phase) 'game-over)))) + (let* ((card-games-eights-players 2) (g (card-games-eights--deal (card-games-eights-game)))) + (card-games-eights--set-hand g 0 (list '(3 . 6))) ; the human holds only an eight + (card-games-put g :discard (list '(0 . 3))) (card-games-put g :suit 0) + (card-games-eights--play g 0 '(3 . 6) 2) ; play it, name diamonds (2) + (should (= 2 (card-games-get g :suit))) + (should (eq (card-games-get g :phase) 'game-over)))) ;;;; --- Wave 2 (2026-06-24): Forty Thieves/Scorpion/Canfield, Golf/TriPeaks/Pyramid, Whist/Oh Hell, President --- (ert-deftest cgt-sol-forty-deal () - (let ((g (cg-sol--deal (cg-forty-game))) (tot 0)) + (let ((g (card-games-sol--deal (card-games-forty-game))) (tot 0)) (should (= 10 (oref g ncols))) - (dotimes (c 10) (should (= 4 (length (cg-sol--col g c)))) (cl-incf tot 4)) + (dotimes (c 10) (should (= 4 (length (card-games-sol--col g c)))) (cl-incf tot 4)) (should (= 8 (oref g nfound))) - (should (= 64 (length (cg-get g :stock)))) - (should (= 104 (+ tot (length (cg-get g :stock))))))) + (should (= 64 (length (card-games-get g :stock)))) + (should (= 104 (+ tot (length (card-games-get g :stock))))))) (ert-deftest cgt-sol-forty-no-redeal () - (let ((g (cg-sol--deal (cg-forty-game)))) - (cg-put g :stock nil) (cg-put g :waste '((0 . 0) (1 . 1))) - (cg-sol--stock-action g) ; redeal nil -> stays empty - (should (null (cg-get g :stock))))) + (let ((g (card-games-sol--deal (card-games-forty-game)))) + (card-games-put g :stock nil) (card-games-put g :waste '((0 . 0) (1 . 1))) + (card-games-sol--stock-action g) ; redeal nil -> stays empty + (should (null (card-games-get g :stock))))) (ert-deftest cgt-sol-forty-win () - (let ((g (cg-sol--deal (cg-forty-game))) (found (make-vector 8 nil))) + (let ((g (card-games-sol--deal (card-games-forty-game))) (found (make-vector 8 nil))) (dotimes (i 8) (aset found i (cl-loop for r below 13 collect (cons (mod i 4) r)))) - (cg-put g :found found) - (should (cg-won-p g)))) + (card-games-put g :found found) + (should (card-games-won-p g)))) (ert-deftest cgt-sol-scorpion-deal () - (let ((g (cg-sol--deal (cg-scorpion-game))) (tot 0)) + (let ((g (card-games-sol--deal (card-games-scorpion-game))) (tot 0)) (should (= 7 (oref g ncols))) - (dotimes (c 7) (should (= 7 (length (cg-sol--col g c)))) (cl-incf tot 7)) - (dotimes (c 4) (should (= 3 (cg-sol--down g c)))) - (dotimes (k 3) (should (= 0 (cg-sol--down g (+ 4 k))))) - (should (= 3 (length (cg-get g :stock)))) + (dotimes (c 7) (should (= 7 (length (card-games-sol--col g c)))) (cl-incf tot 7)) + (dotimes (c 4) (should (= 3 (card-games-sol--down g c)))) + (dotimes (k 3) (should (= 0 (card-games-sol--down g (+ 4 k))))) + (should (= 3 (length (card-games-get g :stock)))) (should (= 0 (oref g nfound))))) (ert-deftest cgt-sol-scorpion-harvest-win () - (let ((g (cg-sol--deal (cg-scorpion-game)))) - (cg-put g :sets 3) + (let ((g (card-games-sol--deal (card-games-scorpion-game)))) + (card-games-put g :sets 3) ;; place a complete K..A clubs run as column 0 - (aset (cg-get g :tableau) 0 (cl-loop for r from 12 downto 0 collect (cons 1 r))) - (aset (cg-get g :down) 0 0) - (cg-sol--harvest g) - (should (= 4 (cg-get g :sets))) - (should (cg-won-p g)))) + (aset (card-games-get g :tableau) 0 (cl-loop for r from 12 downto 0 collect (cons 1 r))) + (aset (card-games-get g :down) 0 0) + (card-games-sol--harvest g) + (should (= 4 (card-games-get g :sets))) + (should (card-games-won-p g)))) (ert-deftest cgt-sol-canfield-deal () - (let ((g (cg-sol--deal (cg-canfield-game)))) - (should (= 13 (length (cg-get g :reserve)))) - (should (= 1 (length (aref (cg-get g :found) 0)))) - (dotimes (c 4) (should (= 1 (length (cg-sol--col g c))))) - (should (= 34 (length (cg-get g :stock)))) + (let ((g (card-games-sol--deal (card-games-canfield-game)))) + (should (= 13 (length (card-games-get g :reserve)))) + (should (= 1 (length (aref (card-games-get g :found) 0)))) + (dotimes (c 4) (should (= 1 (length (card-games-sol--col g c))))) + (should (= 34 (length (card-games-get g :stock)))) ;; base equals the rank of the first foundation card - (should (= (oref g base) (cdr (car (aref (cg-get g :found) 0))))))) + (should (= (oref g base) (cdr (car (aref (card-games-get g :found) 0))))))) (ert-deftest cgt-sol-canfield-base-wrap () - (let ((g (cg-canfield-game))) + (let ((g (card-games-canfield-game))) (oset g base 5) (oset g wrap t) - (cg-put g :found (make-vector 4 nil)) - (should (cg-sol--found-accepts g 1 '(2 . 5))) ; empty -> base rank 5 - (should-not (cg-sol--found-accepts g 1 '(2 . 6))) + (card-games-put g :found (make-vector 4 nil)) + (should (card-games-sol--found-accepts g 1 '(2 . 5))) ; empty -> base rank 5 + (should-not (card-games-sol--found-accepts g 1 '(2 . 6))) ;; wrap: a King on top accepts the Ace next - (aset (cg-get g :found) 0 (list '(0 . 12))) - (should (cg-sol--found-accepts g 0 '(0 . 0))))) + (aset (card-games-get g :found) 0 (list '(0 . 12))) + (should (card-games-sol--found-accepts g 0 '(0 . 0))))) (ert-deftest cgt-sol-canfield-autofill () - (let ((g (cg-sol--deal (cg-canfield-game)))) - (let ((rlen (length (cg-get g :reserve)))) - (aset (cg-get g :tableau) 0 nil) ; empty a column - (cg-sol--autofill g) - (should (= 1 (length (cg-sol--col g 0)))) - (should (= (1- rlen) (length (cg-get g :reserve))))))) + (let ((g (card-games-sol--deal (card-games-canfield-game)))) + (let ((rlen (length (card-games-get g :reserve)))) + (aset (card-games-get g :tableau) 0 nil) ; empty a column + (card-games-sol--autofill g) + (should (= 1 (length (card-games-sol--col g 0)))) + (should (= (1- rlen) (length (card-games-get g :reserve))))))) (ert-deftest cgt-sol-russian-bank-deal () - (let ((g (cg-sol--deal (cg-russian-bank-game)))) + (let ((g (card-games-sol--deal (card-games-russian-bank-game)))) (should (= 8 (oref g ncols))) - (should (= 13 (length (cg-get g :reserve)))) - (dotimes (c 8) (should (= 1 (length (cg-sol--col g c))))) - (dotimes (i 4) (should (null (aref (cg-get g :found) i)))) - (should (= 31 (length (cg-get g :stock)))) ; 52 - 13 reserve - 8 houses + (should (= 13 (length (card-games-get g :reserve)))) + (dotimes (c 8) (should (= 1 (length (card-games-sol--col g c))))) + (dotimes (i 4) (should (null (aref (card-games-get g :found) i)))) + (should (= 31 (length (card-games-get g :stock)))) ; 52 - 13 reserve - 8 houses ;; Houses build down by alternating colour; foundations up by suit. - (should (cg-sol--place-p g '(0 . 6) '(2 . 5))) ; 7S <- 6D (down, alt) - (should-not (cg-sol--place-p g '(0 . 6) '(1 . 5))) ; 7S <- 6C (same colour) - (should (cg-sol--found-accepts g 0 '(3 . 0))) ; empty foundation takes an Ace - (should-not (cg-sol--found-accepts g 0 '(3 . 1))))) ; but not a Two + (should (card-games-sol--place-p g '(0 . 6) '(2 . 5))) ; 7S <- 6D (down, alt) + (should-not (card-games-sol--place-p g '(0 . 6) '(1 . 5))) ; 7S <- 6C (same colour) + (should (card-games-sol--found-accepts g 0 '(3 . 0))) ; empty foundation takes an Ace + (should-not (card-games-sol--found-accepts g 0 '(3 . 1))))) ; but not a Two (ert-deftest cgt-sol-russian-bank-autofill () - (let ((g (cg-sol--deal (cg-russian-bank-game)))) - (let ((rlen (length (cg-get g :reserve)))) - (aset (cg-get g :tableau) 0 nil) ; empty a house - (cg-sol--autofill g) - (should (= 1 (length (cg-sol--col g 0)))) - (should (= (1- rlen) (length (cg-get g :reserve))))))) + (let ((g (card-games-sol--deal (card-games-russian-bank-game)))) + (let ((rlen (length (card-games-get g :reserve)))) + (aset (card-games-get g :tableau) 0 nil) ; empty a house + (card-games-sol--autofill g) + (should (= 1 (length (card-games-sol--col g 0)))) + (should (= (1- rlen) (length (card-games-get g :reserve))))))) ;;;; Russian Bank duel (Crapette) (ert-deftest cgt-crap-deal () - (let ((g (cg-crap--deal (cg-crapette-game)))) + (let ((g (card-games-crap--deal (card-games-crapette-game)))) (dotimes (p 2) - (should (= 13 (length (cg-crap--reserve g p)))) - (should (= 35 (length (cg-crap--hand g p)))) - (should (null (cg-crap--waste g p)))) - (dotimes (i 8) (should (= 1 (length (cg-crap--house g i))))) - (dotimes (i 8) (should (null (cg-crap--found g i)))) - (should (= 0 (cg-get g :turn))))) + (should (= 13 (length (card-games-crap--reserve g p)))) + (should (= 35 (length (card-games-crap--hand g p)))) + (should (null (card-games-crap--waste g p)))) + (dotimes (i 8) (should (= 1 (length (card-games-crap--house g i))))) + (dotimes (i 8) (should (null (card-games-crap--found g i)))) + (should (= 0 (card-games-get g :turn))))) (ert-deftest cgt-crap-legality () - (let ((g (cg-crap--deal (cg-crapette-game)))) - (aset (cg-get g :found) 0 nil) - (should (cg-crap--found-accepts g 0 '(3 . 0))) ; empty -> Ace - (should-not (cg-crap--found-accepts g 0 '(3 . 1))) ; not a Two - (aset (cg-get g :found) 0 (list '(3 . 0))) - (should (cg-crap--found-accepts g 0 '(3 . 1))) ; up in suit - (should-not (cg-crap--found-accepts g 0 '(2 . 1))) ; wrong suit - (aset (cg-get g :houses) 0 (list '(0 . 6))) ; 7 of spades (black) - (should (cg-crap--house-accepts g 0 '(2 . 5))) ; 6 of diamonds (red) - (should-not (cg-crap--house-accepts g 0 '(1 . 5))) ; 6 of clubs (black) - (should (cg-crap--load-accepts '(2 . 5) '(2 . 6))) ; same suit, one up - (should (cg-crap--load-accepts '(2 . 5) '(2 . 4))) ; same suit, one down - (should-not (cg-crap--load-accepts '(2 . 5) '(3 . 6))) ; wrong suit - (should-not (cg-crap--load-accepts '(2 . 5) '(2 . 7))))) ; not adjacent + (let ((g (card-games-crap--deal (card-games-crapette-game)))) + (aset (card-games-get g :found) 0 nil) + (should (card-games-crap--found-accepts g 0 '(3 . 0))) ; empty -> Ace + (should-not (card-games-crap--found-accepts g 0 '(3 . 1))) ; not a Two + (aset (card-games-get g :found) 0 (list '(3 . 0))) + (should (card-games-crap--found-accepts g 0 '(3 . 1))) ; up in suit + (should-not (card-games-crap--found-accepts g 0 '(2 . 1))) ; wrong suit + (aset (card-games-get g :houses) 0 (list '(0 . 6))) ; 7 of spades (black) + (should (card-games-crap--house-accepts g 0 '(2 . 5))) ; 6 of diamonds (red) + (should-not (card-games-crap--house-accepts g 0 '(1 . 5))) ; 6 of clubs (black) + (should (card-games-crap--load-accepts '(2 . 5) '(2 . 6))) ; same suit, one up + (should (card-games-crap--load-accepts '(2 . 5) '(2 . 4))) ; same suit, one down + (should-not (card-games-crap--load-accepts '(2 . 5) '(3 . 6))) ; wrong suit + (should-not (card-games-crap--load-accepts '(2 . 5) '(2 . 7))))) ; not adjacent (ert-deftest cgt-crap-win () - (let ((g (cg-crap--deal (cg-crapette-game)))) - (aset (cg-get g :reserve) 0 nil) - (aset (cg-get g :hand) 0 nil) - (aset (cg-get g :waste) 0 nil) - (should (cg-crap--won-p g 0)) - (should-not (cg-crap--won-p g 1)))) + (let ((g (card-games-crap--deal (card-games-crapette-game)))) + (aset (card-games-get g :reserve) 0 nil) + (aset (card-games-get g :hand) 0 nil) + (aset (card-games-get g :waste) 0 nil) + (should (card-games-crap--won-p g 0)) + (should-not (card-games-crap--won-p g 1)))) (ert-deftest cgt-crap-ai-turn () - (let ((g (cg-crap--deal (cg-crapette-game)))) + (let ((g (card-games-crap--deal (card-games-crapette-game)))) (cl-flet ((total () (let ((n 0)) (dotimes (i 8) - (setq n (+ n (length (cg-crap--found g i)) - (length (cg-crap--house g i))))) + (setq n (+ n (length (card-games-crap--found g i)) + (length (card-games-crap--house g i))))) (dotimes (p 2) - (setq n (+ n (length (cg-crap--reserve g p)) - (length (cg-crap--waste g p)) - (length (cg-crap--hand g p))))) + (setq n (+ n (length (card-games-crap--reserve g p)) + (length (card-games-crap--waste g p)) + (length (card-games-crap--hand g p))))) n))) (should (= 104 (total))) - (cg-put g :turn 1) - (let ((cg-crap--recording nil)) (cg-crap--ai-play g)) + (card-games-put g :turn 1) + (let ((card-games-crap--recording nil)) (card-games-crap--ai-play g)) (should (= 104 (total))) ; the AI turn conserves every card - (should-not (eq (cg-get g :winner) 0))))) ; the AI cannot make YOU win + (should-not (eq (card-games-get g :winner) 0))))) ; the AI cannot make YOU win (ert-deftest cgt-crap-ai-plays-foundation () - (let ((g (cg-crap--deal (cg-crapette-game)))) - (aset (cg-get g :reserve) 1 (list '(0 . 0))) ; AI reserve top = Ace of spades - (aset (cg-get g :waste) 1 nil) - (aset (cg-get g :hand) 1 nil) - (aset (cg-get g :found) 0 nil) - (cg-put g :turn 1) - (let ((cg-crap--recording nil)) (cg-crap--ai-play g)) - (should (eq (cg-get g :winner) 1)))) ; plays its last card, wins + (let ((g (card-games-crap--deal (card-games-crapette-game)))) + (aset (card-games-get g :reserve) 1 (list '(0 . 0))) ; AI reserve top = Ace of spades + (aset (card-games-get g :waste) 1 nil) + (aset (card-games-get g :hand) 1 nil) + (aset (card-games-get g :found) 0 nil) + (card-games-put g :turn 1) + (let ((card-games-crap--recording nil)) (card-games-crap--ai-play g)) + (should (eq (card-games-get g :winner) 1)))) ; plays its last card, wins (ert-deftest cgt-crap-ai-enabling () ;; reserve 5D cannot be placed until the AI shifts 6H off 6S (crafty rearrange) - (let ((g (cg-crap--deal (cg-crapette-game)))) - (aset (cg-get g :reserve) 1 (list '(2 . 4))) ; 5 of diamonds - (aset (cg-get g :waste) 1 nil) (aset (cg-get g :hand) 1 nil) - (aset (cg-get g :reserve) 0 nil) (aset (cg-get g :waste) 0 nil) - (aset (cg-get g :found) 0 nil) - (aset (cg-get g :houses) 0 (list '(0 . 5) '(3 . 5))) ; 6S (bottom), 6H (top) - (aset (cg-get g :houses) 1 (list '(1 . 6))) ; 7C - (dotimes (k 6) (aset (cg-get g :houses) (+ 2 k) (list '(2 . 6)))) ; 7D fillers, none empty - (cg-put g :turn 1) - (let ((cg-ai-level 'hard) (cg-crap--recording nil)) (cg-crap--ai-play g)) - (should (null (cg-crap--reserve g 1))))) ; hard unstuck and unloaded + (let ((g (card-games-crap--deal (card-games-crapette-game)))) + (aset (card-games-get g :reserve) 1 (list '(2 . 4))) ; 5 of diamonds + (aset (card-games-get g :waste) 1 nil) (aset (card-games-get g :hand) 1 nil) + (aset (card-games-get g :reserve) 0 nil) (aset (card-games-get g :waste) 0 nil) + (aset (card-games-get g :found) 0 nil) + (aset (card-games-get g :houses) 0 (list '(0 . 5) '(3 . 5))) ; 6S (bottom), 6H (top) + (aset (card-games-get g :houses) 1 (list '(1 . 6))) ; 7C + (dotimes (k 6) (aset (card-games-get g :houses) (+ 2 k) (list '(2 . 6)))) ; 7D fillers, none empty + (card-games-put g :turn 1) + (let ((card-games-ai-level 'hard) (card-games-crap--recording nil)) (card-games-crap--ai-play g)) + (should (null (card-games-crap--reserve g 1))))) ; hard unstuck and unloaded (ert-deftest cgt-crap-ai-loads-you () ;; reserve 6D loads onto your reserve top 7D; the AI should prefer that - (let ((g (cg-crap--deal (cg-crapette-game)))) - (aset (cg-get g :reserve) 1 (list '(2 . 5))) ; 6D - (aset (cg-get g :waste) 1 nil) (aset (cg-get g :hand) 1 nil) - (aset (cg-get g :reserve) 0 (list '(2 . 6))) ; your reserve top 7D - (aset (cg-get g :waste) 0 nil) (aset (cg-get g :found) 0 nil) - (dotimes (k 8) (aset (cg-get g :houses) k (list '(1 . 10)))) ; nowhere on a house, none empty - (cg-put g :turn 1) - (let ((cg-crap--recording nil)) (cg-crap--ai-play g)) - (should (null (cg-crap--reserve g 1))) - (should (member '(2 . 5) (cg-crap--reserve g 0))))) ; loaded onto you + (let ((g (card-games-crap--deal (card-games-crapette-game)))) + (aset (card-games-get g :reserve) 1 (list '(2 . 5))) ; 6D + (aset (card-games-get g :waste) 1 nil) (aset (card-games-get g :hand) 1 nil) + (aset (card-games-get g :reserve) 0 (list '(2 . 6))) ; your reserve top 7D + (aset (card-games-get g :waste) 0 nil) (aset (card-games-get g :found) 0 nil) + (dotimes (k 8) (aset (card-games-get g :houses) k (list '(1 . 10)))) ; nowhere on a house, none empty + (card-games-put g :turn 1) + (let ((card-games-crap--recording nil)) (card-games-crap--ai-play g)) + (should (null (card-games-crap--reserve g 1))) + (should (member '(2 . 5) (card-games-crap--reserve g 0))))) ; loaded onto you (ert-deftest cgt-svg-logo-smoke () (dolist (choice '(modern classic gnu splash drawn none nonexistent)) - (let ((cg-svg-emacs-logo choice) (svg (svg-create 200 120))) - (cg-svg-draw-logo svg 100 60 1.0) + (let ((card-games-svg-emacs-logo choice) (svg (svg-create 200 120))) + (card-games-svg-draw-logo svg 100 60 1.0) (should (imagep (svg-image svg)))))) (ert-deftest cgt-svg-card-back-smoke () (dolist (b '(dots rings solid lattice waves diamond emacs emacs-classic gnu splash random)) - (let ((cg-svg-card-back b) (svg (svg-create 80 100))) - (cg-svg-card svg 12 10 :down t) + (let ((card-games-svg-card-back b) (svg (svg-create 80 100))) + (card-games-svg-card svg 12 10 :down t) (should (imagep (svg-image svg))))) - (cg-svg--roll-back) - (should (memq cg-svg--random-back cg-svg--card-backs))) + (card-games-svg--roll-back) + (should (memq card-games-svg--random-back card-games-svg--card-backs))) (ert-deftest cgt-crap-house-run () - (let ((g (cg-crap--deal (cg-crapette-game)))) - (aset (cg-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6))) ; 9D 8S 7H - (should (= 3 (length (cg-crap--house-run g 0)))) - (aset (cg-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(0 . 6))) ; 7S breaks colour - (should (= 1 (length (cg-crap--house-run g 0)))))) + (let ((g (card-games-crap--deal (card-games-crapette-game)))) + (aset (card-games-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6))) ; 9D 8S 7H + (should (= 3 (length (card-games-crap--house-run g 0)))) + (aset (card-games-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(0 . 6))) ; 7S breaks colour + (should (= 1 (length (card-games-crap--house-run g 0)))))) (ert-deftest cgt-crap-sequence-move () - (let ((g (cg-crap--deal (cg-crapette-game)))) - (aset (cg-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6))) ; 9D 8S 7H - (aset (cg-get g :houses) 1 (list '(1 . 9))) ; 10C - (dotimes (i 6) (aset (cg-get g :houses) (+ 2 i) nil)) ; 6 empty houses - (should (eq t (cg-crap--house-move g 0 1))) - (should (= 0 (length (cg-crap--house g 0)))) - (should (= 4 (length (cg-crap--house g 1)))) - (should (equal '(3 . 6) (cg-crap--top (cg-crap--house g 1)))))) + (let ((g (card-games-crap--deal (card-games-crapette-game)))) + (aset (card-games-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6))) ; 9D 8S 7H + (aset (card-games-get g :houses) 1 (list '(1 . 9))) ; 10C + (dotimes (i 6) (aset (card-games-get g :houses) (+ 2 i) nil)) ; 6 empty houses + (should (eq t (card-games-crap--house-move g 0 1))) + (should (= 0 (length (card-games-crap--house g 0)))) + (should (= 4 (length (card-games-crap--house g 1)))) + (should (equal '(3 . 6) (card-games-crap--top (card-games-crap--house g 1)))))) (ert-deftest cgt-crap-sequence-space () - (let ((g (cg-crap--deal (cg-crapette-game)))) - (aset (cg-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6))) ; 3-card run - (aset (cg-get g :houses) 1 (list '(1 . 9))) ; 10C - (dotimes (i 6) (aset (cg-get g :houses) (+ 2 i) (list '(0 . 0)))) ; no empty houses - (should (eq 'space (cg-crap--house-move g 0 1))) ; too big to relay - (should (= 3 (length (cg-crap--house g 0)))))) ; unchanged + (let ((g (card-games-crap--deal (card-games-crapette-game)))) + (aset (card-games-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6))) ; 3-card run + (aset (card-games-get g :houses) 1 (list '(1 . 9))) ; 10C + (dotimes (i 6) (aset (card-games-get g :houses) (+ 2 i) (list '(0 . 0)))) ; no empty houses + (should (eq 'space (card-games-crap--house-move g 0 1))) ; too big to relay + (should (= 3 (length (card-games-crap--house g 0)))))) ; unchanged (ert-deftest cgt-crap-stop () - (let ((g (cg-crap--deal (cg-crapette-game)))) - (aset (cg-get g :reserve) 0 (list '(3 . 0))) ; your reserve top is an Ace - (aset (cg-get g :found) 0 nil) - (should (cg-crap--forced g 0)) - (let ((cg-crapette-stops nil)) ; assist: block, no penalty - (cg-put g :turn 0) - (should (cg-crap--stop g)) - (should (= 0 (cg-get g :turn))) - (should (string-match-p "foundation first" (cg-get g :message)))) - (let ((cg-crapette-stops t)) ; competitive: STOP ends your turn - (cg-put g :turn 0) - (should (cg-crap--stop g)) - (should (string-match-p "STOP" (cg-get g :message)))))) + (let ((g (card-games-crap--deal (card-games-crapette-game)))) + (aset (card-games-get g :reserve) 0 (list '(3 . 0))) ; your reserve top is an Ace + (aset (card-games-get g :found) 0 nil) + (should (card-games-crap--forced g 0)) + (let ((card-games-crapette-stops nil)) ; assist: block, no penalty + (card-games-put g :turn 0) + (should (card-games-crap--stop g)) + (should (= 0 (card-games-get g :turn))) + (should (string-match-p "foundation first" (card-games-get g :message)))) + (let ((card-games-crapette-stops t)) ; competitive: STOP ends your turn + (card-games-put g :turn 0) + (should (card-games-crap--stop g)) + (should (string-match-p "STOP" (card-games-get g :message)))))) (ert-deftest cgt-crap-sequence-partial () - (let ((g (cg-crap--deal (cg-crapette-game)))) - (aset (cg-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6))) ; 9D 8S 7H - (aset (cg-get g :houses) 1 nil) ; empty destination - (dotimes (i 6) (aset (cg-get g :houses) (+ 2 i) nil)) ; plenty of space - (should (eq t (cg-crap--house-move g 0 1 2))) ; move only the top 2 - (should (equal '(2 . 8) (cg-crap--top (cg-crap--house g 0)))) ; 9D stays behind - (should (= 2 (length (cg-crap--house g 1)))) - (should (equal '(0 . 7) (car (cg-crap--house g 1)))) ; 8S is the moved bottom - (should (equal '(3 . 6) (cg-crap--top (cg-crap--house g 1)))))) ; 7H the top + (let ((g (card-games-crap--deal (card-games-crapette-game)))) + (aset (card-games-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6))) ; 9D 8S 7H + (aset (card-games-get g :houses) 1 nil) ; empty destination + (dotimes (i 6) (aset (card-games-get g :houses) (+ 2 i) nil)) ; plenty of space + (should (eq t (card-games-crap--house-move g 0 1 2))) ; move only the top 2 + (should (equal '(2 . 8) (card-games-crap--top (card-games-crap--house g 0)))) ; 9D stays behind + (should (= 2 (length (card-games-crap--house g 1)))) + (should (equal '(0 . 7) (car (card-games-crap--house g 1)))) ; 8S is the moved bottom + (should (equal '(3 . 6) (card-games-crap--top (card-games-crap--house g 1)))))) ; 7H the top (ert-deftest cgt-crap-partial-space () - (let ((g (cg-crap--deal (cg-crapette-game)))) - (aset (cg-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6))) ; run of 3 - (aset (cg-get g :houses) 1 nil) ; the only empty house - (dotimes (i 6) (aset (cg-get g :houses) (+ 2 i) (list '(0 . 0)))) - (should (eq 'space (cg-crap--house-move g 0 1 3))) ; 3 needs more space - (should (eq t (cg-crap--house-move g 0 1 1))) ; but 1 fits - (should (= 2 (length (cg-crap--house g 0)))) - (should (= 1 (length (cg-crap--house g 1)))))) + (let ((g (card-games-crap--deal (card-games-crapette-game)))) + (aset (card-games-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6))) ; run of 3 + (aset (card-games-get g :houses) 1 nil) ; the only empty house + (dotimes (i 6) (aset (card-games-get g :houses) (+ 2 i) (list '(0 . 0)))) + (should (eq 'space (card-games-crap--house-move g 0 1 3))) ; 3 needs more space + (should (eq t (card-games-crap--house-move g 0 1 1))) ; but 1 fits + (should (= 2 (length (card-games-crap--house g 0)))) + (should (= 1 (length (card-games-crap--house g 1)))))) (ert-deftest cgt-crap-svg-smoke () - (let ((g (cg-crap--deal (cg-crapette-game)))) - (aset (cg-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6))) ; a run to draw - (aset (cg-get g :reserve) 0 (list '(3 . 0))) ; a forced foundation - (cg-put g :sel '(house . 0)) (cg-put g :sel-n 2) (cg-put g :cursor 3) - (let ((res (cg-crap--svg g))) + (let ((g (card-games-crap--deal (card-games-crapette-game)))) + (aset (card-games-get g :houses) 0 (list '(2 . 8) '(0 . 7) '(3 . 6))) ; a run to draw + (aset (card-games-get g :reserve) 0 (list '(3 . 0))) ; a forced foundation + (card-games-put g :sel '(house . 0)) (card-games-put g :sel-n 2) (card-games-put g :cursor 3) + (let ((res (card-games-crap--svg g))) (should (stringp (car res))) (should (get-text-property 0 'display (car res))) - (should (get-text-property 0 'cg-regions (car res))) + (should (get-text-property 0 'card-games-regions (car res))) ;; every clickable region is a (RECT . SPOT) with a 4-number RECT (should (cl-every (lambda (r) (= 4 (length (car r)))) (cdr res))) (should (rassoc '(house . 0) (cdr res)))))) (ert-deftest cgt-trick-svg-smoke () - (let ((g (cg-hearts-game))) - (cg-trick--deal g) - (cg-put g :cursor 0) (cg-put g :phase 'play) (cg-put g :turn 0) (cg-put g :message "x") - (cg-put g :trick (list (cons 1 (car (cg-trick--hand g 1))))) ; West has led - (should (stringp (cg-trick--render-text g))) - (let ((s (cg-trick--svg g))) + (let ((g (card-games-hearts-game))) + (card-games-trick--deal g) + (card-games-put g :cursor 0) (card-games-put g :phase 'play) (card-games-put g :turn 0) (card-games-put g :message "x") + (card-games-put g :trick (list (cons 1 (car (card-games-trick--hand g 1))))) ; West has led + (should (stringp (card-games-trick--render-text g))) + (let ((s (card-games-trick--svg g))) (should (stringp s)) (should (get-text-property 0 'display s)) - (let ((regs (get-text-property 0 'cg-regions s))) + (let ((regs (get-text-property 0 'card-games-regions s))) (should regs) (should (rassoc '(hand . 0) regs)) (should (cl-every (lambda (r) (= 4 (length (car r)))) regs)))))) (ert-deftest cgt-trick-svg-bidding () - (let ((g (cg-spades-game))) - (cg-trick--deal g) - (cg-put g :cursor 2) (cg-put g :phase 'bid) (cg-put g :turn 0) (cg-put g :message "bid") - (cg-put g :bids (vector 3 nil 4 nil)) (cg-put g :scores (vector 100 50 100 50)) - (should (stringp (cg-trick--svg g))))) + (let ((g (card-games-spades-game))) + (card-games-trick--deal g) + (card-games-put g :cursor 2) (card-games-put g :phase 'bid) (card-games-put g :turn 0) (card-games-put g :message "bid") + (card-games-put g :bids (vector 3 nil 4 nil)) (card-games-put g :scores (vector 100 50 100 50)) + (should (stringp (card-games-trick--svg g))))) (ert-deftest cgt-gin-svg-smoke () - (let ((g (cg-gin-game))) - (cg-gin--deal g) - (cg-put g :cursor 0) (cg-put g :message "x") (cg-put g :scores (vector 0 0)) - (should (stringp (cg-gin--render-text g))) - (let ((sres (cg-gin--svg g))) + (let ((g (card-games-gin-game))) + (card-games-gin--deal g) + (card-games-put g :cursor 0) (card-games-put g :message "x") (card-games-put g :scores (vector 0 0)) + (should (stringp (card-games-gin--render-text g))) + (let ((sres (card-games-gin--svg g))) (should (get-text-property 0 'display sres)) - (should (rassoc '(hand . 0) (get-text-property 0 'cg-regions sres)))))) + (should (rassoc '(hand . 0) (get-text-property 0 'card-games-regions sres)))))) (ert-deftest cgt-tm-svg-smoke () - (let ((g (cg-rum500-game))) - (cg-tm--deal g) - (cg-put g :cursor 1) (cg-put g :message "x") - (cg-put g :table (list (cons 0 (list '(0 . 0) '(0 . 1) '(0 . 2))) + (let ((g (card-games-rum500-game))) + (card-games-tm--deal g) + (card-games-put g :cursor 1) (card-games-put g :message "x") + (card-games-put g :table (list (cons 0 (list '(0 . 0) '(0 . 1) '(0 . 2))) (cons 2 (list '(1 . 5) '(2 . 5) '(3 . 5))))) - (cg-put g :marks (list 0 2)) - (should (stringp (cg-tm--render-text g))) - (let ((regs (get-text-property 0 'cg-regions (cg-tm--svg g)))) + (card-games-put g :marks (list 0 2)) + (should (stringp (card-games-tm--render-text g))) + (let ((regs (get-text-property 0 'card-games-regions (card-games-tm--svg g)))) (should (rassoc '(hand . 0) regs)) (should (cl-every (lambda (r) (= 4 (length (car r)))) regs))))) (ert-deftest cgt-hf-svg-smoke () - (let ((g (cg-handfoot-game))) - (cg-put g :nplayers 4) (cg-put g :nteams 2) (cg-put g :scores (make-vector 2 0)) - (cg-hf--deal g) - (cg-put g :cursor 0) (cg-put g :message "x") - (should (stringp (cg-hf--render-text g))) - (let ((regs (get-text-property 0 'cg-regions (cg-hf--svg g)))) + (let ((g (card-games-handfoot-game))) + (card-games-put g :nplayers 4) (card-games-put g :nteams 2) (card-games-put g :scores (make-vector 2 0)) + (card-games-hf--deal g) + (card-games-put g :cursor 0) (card-games-put g :message "x") + (should (stringp (card-games-hf--render-text g))) + (let ((regs (get-text-property 0 'card-games-regions (card-games-hf--svg g)))) (should (rassoc '(hand . 0) regs)) (should (cl-every (lambda (r) (= 4 (length (car r)))) regs))))) (ert-deftest cgt-fish-svg-smoke () - (let ((g (cg-scopa-game))) - (cg-fish--deal-round g) - (cg-put g :cursor 0) (cg-put g :message "x") - (should (stringp (cg-fish--render-text g))) + (let ((g (card-games-scopa-game))) + (card-games-fish--deal-round g) + (card-games-put g :cursor 0) (card-games-put g :message "x") + (should (stringp (card-games-fish--render-text g))) (should (rassoc '(hand . 0) - (get-text-property 0 'cg-regions (cg-fish--svg g)))))) + (get-text-property 0 'card-games-regions (card-games-fish--svg g)))))) (ert-deftest cgt-eights-svg-smoke () - (let ((g (cg-eights-game))) - (cg-put g :nplayers 3) (cg-put g :scores (make-vector 3 0)) - (cg-eights--deal g) (cg-put g :cursor 0) (cg-put g :message "x") - (should (stringp (cg-eights--render-text g))) - (let ((regs (get-text-property 0 'cg-regions (cg-eights--board-svg g)))) + (let ((g (card-games-eights-game))) + (card-games-put g :nplayers 3) (card-games-put g :scores (make-vector 3 0)) + (card-games-eights--deal g) (card-games-put g :cursor 0) (card-games-put g :message "x") + (should (stringp (card-games-eights--render-text g))) + (let ((regs (get-text-property 0 'card-games-regions (card-games-eights--board-svg g)))) (should (rassoc '(hand . 0) regs)) (should (cl-every (lambda (r) (= 4 (length (car r)))) regs))))) (ert-deftest cgt-spite-svg-smoke () - (let ((g (cg-spite-game))) - (cg-put g :nplayers 2) (cg-put g :scores (make-vector 2 0)) - (cg-spite--deal g) (cg-put g :cursor 0) (cg-put g :message "x") - (aset (cg-get g :center) 0 (cons 3 (list '(1 . 3)))) - (should (stringp (cg-spite--render-text g))) + (let ((g (card-games-spite-game))) + (card-games-put g :nplayers 2) (card-games-put g :scores (make-vector 2 0)) + (card-games-spite--deal g) (card-games-put g :cursor 0) (card-games-put g :message "x") + (aset (card-games-get g :center) 0 (cons 3 (list '(1 . 3)))) + (should (stringp (card-games-spite--render-text g))) (should (rassoc '(hand . 0) - (get-text-property 0 'cg-regions (cg-spite--board-svg g)))))) + (get-text-property 0 'card-games-regions (card-games-spite--board-svg g)))))) (ert-deftest cgt-om-svg-smoke () - (let ((g (cg-old-maid-game))) - (cg-om--deal g) - (cg-put g :phase 'play) (cg-put g :turn 0) (cg-put g :message "x") - (should (stringp (cg-om--render-text g))) - (should (stringp (cg-om--svg g))))) + (let ((g (card-games-old-maid-game))) + (card-games-om--deal g) + (card-games-put g :phase 'play) (card-games-put g :turn 0) (card-games-put g :message "x") + (should (stringp (card-games-om--render-text g))) + (should (stringp (card-games-om--svg g))))) (ert-deftest cgt-crib-svg-smoke () - (let ((g (cg-cribbage-game))) - (cg-put g :scores (make-vector 2 0)) - (cg-crib--deal g) - (cg-put g :cursor 0) (cg-put g :message "x") - (should (stringp (cg-crib--render-text g))) - (let ((regs (get-text-property 0 'cg-regions (cg-crib--svg g)))) + (let ((g (card-games-cribbage-game))) + (card-games-put g :scores (make-vector 2 0)) + (card-games-crib--deal g) + (card-games-put g :cursor 0) (card-games-put g :message "x") + (should (stringp (card-games-crib--render-text g))) + (let ((regs (get-text-property 0 'card-games-regions (card-games-crib--svg g)))) (should (rassoc '(hand . 0) regs)) (should (cl-every (lambda (r) (= 4 (length (car r)))) regs)))) - (let ((g (cg-cribbage-game))) - (cg-put g :scores (vector 60 90)) - (cg-crib--deal g) - (cg-put g :phase 'play) (cg-put g :starter '(2 . 4)) (cg-put g :total 15) - (cg-put g :play (vector (cg-crib--hand g 0) (cg-crib--hand g 1))) - (cg-put g :seq (list '(0 . 6) '(3 . 8))) (cg-put g :message "x") - (should (stringp (cg-crib--svg g))))) + (let ((g (card-games-cribbage-game))) + (card-games-put g :scores (vector 60 90)) + (card-games-crib--deal g) + (card-games-put g :phase 'play) (card-games-put g :starter '(2 . 4)) (card-games-put g :total 15) + (card-games-put g :play (vector (card-games-crib--hand g 0) (card-games-crib--hand g 1))) + (card-games-put g :seq (list '(0 . 6) '(3 . 8))) (card-games-put g :message "x") + (should (stringp (card-games-crib--svg g))))) (ert-deftest cgt-bridge-svg-smoke () - (let ((g (cg-bridge-game))) - (cg-bridge--deal g) - (cg-put g :cursor 0) (cg-put g :turn 0) (cg-put g :bid-level 1) (cg-put g :bid-strain 0) - (cg-put g :message "x") - (should (stringp (cg-bridge--render-text g))) + (let ((g (card-games-bridge-game))) + (card-games-bridge--deal g) + (card-games-put g :cursor 0) (card-games-put g :turn 0) (card-games-put g :bid-level 1) (card-games-put g :bid-strain 0) + (card-games-put g :message "x") + (should (stringp (card-games-bridge--render-text g))) (should (rassoc '(hand . 0) - (get-text-property 0 'cg-regions (cg-bridge--svg g))))) - (let ((g (cg-bridge-game))) - (cg-bridge--deal g) - (cg-put g :phase 'play) (cg-put g :turn 0) (cg-put g :cursor 0) - (cg-put g :declarer 0) (cg-put g :dummy 2) (cg-put g :exposed t) (cg-put g :tricks 0) - (cg-put g :contract '(3 . 3)) (cg-put g :doubled nil) - (cg-put g :trick (list (cons 1 (car (cg-bridge--hand g 1))))) - (cg-put g :message "x") - (should (stringp (cg-bridge--svg g))))) + (get-text-property 0 'card-games-regions (card-games-bridge--svg g))))) + (let ((g (card-games-bridge-game))) + (card-games-bridge--deal g) + (card-games-put g :phase 'play) (card-games-put g :turn 0) (card-games-put g :cursor 0) + (card-games-put g :declarer 0) (card-games-put g :dummy 2) (card-games-put g :exposed t) (card-games-put g :tricks 0) + (card-games-put g :contract '(3 . 3)) (card-games-put g :doubled nil) + (card-games-put g :trick (list (cons 1 (car (card-games-bridge--hand g 1))))) + (card-games-put g :message "x") + (should (stringp (card-games-bridge--svg g))))) (ert-deftest cgt-pat-golf-deal () - (let ((g (cg-pat--deal (cg-golf-game)))) - (should (= 35 (length (cg-get g :cards)))) - (should (= 16 (length (cg-get g :stock)))) - (should (= 1 (length (cg-get g :waste)))) - (should (= 7 (length (cg-pat--exposed g)))))) ; one per column (r=4) + (let ((g (card-games-pat--deal (card-games-golf-game)))) + (should (= 35 (length (card-games-get g :cards)))) + (should (= 16 (length (card-games-get g :stock)))) + (should (= 1 (length (card-games-get g :waste)))) + (should (= 7 (length (card-games-pat--exposed g)))))) ; one per column (r=4) (ert-deftest cgt-pat-tripeaks-deal () - (let ((g (cg-pat--deal (cg-tripeaks-game)))) - (should (= 28 (length (cg-get g :cards)))) - (should (= 23 (length (cg-get g :stock)))) - (should (equal (number-sequence 18 27) (cg-pat--exposed g))) ; base row - (should-not (cg-pat--exposed-p g 0)))) ; apex covered + (let ((g (card-games-pat--deal (card-games-tripeaks-game)))) + (should (= 28 (length (card-games-get g :cards)))) + (should (= 23 (length (card-games-get g :stock)))) + (should (equal (number-sequence 18 27) (card-games-pat--exposed g))) ; base row + (should-not (card-games-pat--exposed-p g 0)))) ; apex covered (ert-deftest cgt-pat-pyramid-deal () - (let ((g (cg-pat--deal (cg-pyramid-game)))) - (should (= 28 (length (cg-get g :cards)))) - (should (= 24 (length (cg-get g :stock)))) - (should (null (cg-get g :waste))) - (should (equal (number-sequence 21 27) (cg-pat--exposed g))) ; base row r=6 - (should-not (cg-pat--exposed-p g 0)))) ; apex covered by 1,2 + (let ((g (card-games-pat--deal (card-games-pyramid-game)))) + (should (= 28 (length (card-games-get g :cards)))) + (should (= 24 (length (card-games-get g :stock)))) + (should (null (card-games-get g :waste))) + (should (equal (number-sequence 21 27) (card-games-pat--exposed g))) ; base row r=6 + (should-not (card-games-pat--exposed-p g 0)))) ; apex covered by 1,2 (ert-deftest cgt-pat-exposed-reveal () - (let ((g (cg-pat--deal (cg-golf-game)))) + (let ((g (card-games-pat--deal (card-games-golf-game)))) ;; clear column 0's lower cards; slot 0 (top) becomes exposed - (dolist (i '(4 3 2 1)) (cg-pat--remove-slot g i)) - (should (cg-pat--exposed-p g 0)))) + (dolist (i '(4 3 2 1)) (card-games-pat--remove-slot g i)) + (should (card-games-pat--exposed-p g 0)))) (ert-deftest cgt-pat-build-and-win () - (let ((g (cg-pat--deal (cg-golf-game)))) + (let ((g (card-games-pat--deal (card-games-golf-game)))) ;; reduce to one exposed card adjacent to the waste top - (cg-put g :cards (let ((v (make-vector 35 nil))) (aset v 34 '(0 . 5)) v)) - (cg-put g :waste (list '(1 . 4))) ; 5 of clubs, rank 4; 6s is adjacent - (cg-put g :stock nil) (cg-put g :cursor 0) + (card-games-put g :cards (let ((v (make-vector 35 nil))) (aset v 34 '(0 . 5)) v)) + (card-games-put g :waste (list '(1 . 4))) ; 5 of clubs, rank 4; 6s is adjacent + (card-games-put g :stock nil) (card-games-put g :cursor 0) (with-temp-buffer - (setq cg-pat--game g) - (cg-pat-act)) ; plays slot 34 onto the waste - (should (null (aref (cg-get g :cards) 34))) - (should (cg-won-p g)))) + (setq card-games-pat--game g) + (card-games-pat-act)) ; plays slot 34 onto the waste + (should (null (aref (card-games-get g :cards) 34))) + (should (card-games-won-p g)))) (ert-deftest cgt-pat-sum13 () - (let ((g (cg-pat--deal (cg-pyramid-game)))) + (let ((g (card-games-pat--deal (card-games-pyramid-game)))) ;; King value is 13 - (should (= 13 (cg-pat--value '(0 . 12)))) + (should (= 13 (card-games-pat--value '(0 . 12)))) ;; mark two base cards summing to 13 -> both removed - (cg-put g :cards (let ((v (make-vector 28 nil))) + (card-games-put g :cards (let ((v (make-vector 28 nil))) (aset v 21 '(0 . 4)) (aset v 22 '(1 . 7)) v)) ; 5 (val5) + 8 (val8) = 13 - (cg-put g :marks nil) - (cg-pat--toggle-mark g '(slot . 21)) - (cg-pat--toggle-mark g '(slot . 22)) - (should (null (aref (cg-get g :cards) 21))) - (should (null (aref (cg-get g :cards) 22))))) + (card-games-put g :marks nil) + (card-games-pat--toggle-mark g '(slot . 21)) + (card-games-pat--toggle-mark g '(slot . 22)) + (should (null (aref (card-games-get g :cards) 21))) + (should (null (aref (card-games-get g :cards) 22))))) (ert-deftest cgt-pat-render () - (dolist (cls '(cg-golf-game cg-tripeaks-game cg-pyramid-game)) - (let ((g (cg-pat--deal (make-instance cls)))) - (should (stringp (cg-render g)))))) + (dolist (cls '(card-games-golf-game card-games-tripeaks-game card-games-pyramid-game)) + (let ((g (card-games-pat--deal (make-instance cls)))) + (should (stringp (card-games-render g)))))) (defun cgt--drive (g limit) "Play a whole match with AI for every seat, including the human seat 0." (let ((n 0)) - (while (and (not (cg-trick--game-over-p g)) (< n limit)) - (when (eq (cg-get g :phase) 'play) - (cg-trick--play g (cg-get g :turn) (cg-trick--ai-play g (cg-get g :turn))) - (cg-trick--run g)) + (while (and (not (card-games-trick--game-over-p g)) (< n limit)) + (when (eq (card-games-get g :phase) 'play) + (card-games-trick--play g (card-games-get g :turn) (card-games-trick--ai-play g (card-games-get g :turn))) + (card-games-trick--run g)) (cl-incf n)))) (ert-deftest cgt-whist-deal-trump () - (let ((noninteractive t) (g (make-instance 'cg-whist-game))) - (cg-trick--new g) + (let ((noninteractive t) (g (make-instance 'card-games-whist-game))) + (card-games-trick--new g) (should (memq (oref g trump) '(0 1 2 3))) - (let ((tot (length (cg-get g :trick)))) - (dotimes (s 4) (cl-incf tot (length (cg-trick--hand g s)))) + (let ((tot (length (card-games-get g :trick)))) + (dotimes (s 4) (cl-incf tot (length (card-games-trick--hand g s)))) (should (= 52 tot))))) (ert-deftest cgt-whist-full-game () - (let ((noninteractive t) (g (make-instance 'cg-whist-game))) - (cg-trick--new g) + (let ((noninteractive t) (g (make-instance 'card-games-whist-game))) + (card-games-trick--new g) (cgt--drive g 400) - (should (cg-trick--game-over-p g)) - (should (integerp (cg-trick--winner-seat g))))) + (should (card-games-trick--game-over-p g)) + (should (integerp (card-games-trick--winner-seat g))))) (ert-deftest cgt-ohhell-rounds () - (let ((noninteractive t) (g (make-instance 'cg-ohhell-game))) - (cg-trick--new g) + (let ((noninteractive t) (g (make-instance 'card-games-ohhell-game))) + (card-games-trick--new g) ;; first round deals 7 cards each - (should (= 7 (length (cg-trick--hand g 0)))) + (should (= 7 (length (card-games-trick--hand g 0)))) (cgt--drive g 400) - (should (cg-trick--game-over-p g)) - (should (= 7 (cg-get g :round))) ; seven rounds played - (should (integerp (cg-trick--winner-seat g))))) + (should (card-games-trick--game-over-p g)) + (should (= 7 (card-games-get g :round))) ; seven rounds played + (should (integerp (card-games-trick--winner-seat g))))) (ert-deftest cgt-ohhell-exact-scoring () - (let ((g (make-instance 'cg-ohhell-game))) - (cg-put g :scores (make-vector 4 0)) - (cg-put g :round 0) - (cg-put g :bids (vector 2 0 1 3)) - (cg-put g :tricks (vector 2 1 1 0)) ; seats 0 and 2 made exact bids - (cg-trick--score-hand g) - (should (= 12 (aref (cg-get g :scores) 0))) ; 10 + 2 - (should (= 0 (aref (cg-get g :scores) 1))) ; bid 0 took 1 -> miss - (should (= 11 (aref (cg-get g :scores) 2))) ; 10 + 1 - (should (= 0 (aref (cg-get g :scores) 3))))) + (let ((g (make-instance 'card-games-ohhell-game))) + (card-games-put g :scores (make-vector 4 0)) + (card-games-put g :round 0) + (card-games-put g :bids (vector 2 0 1 3)) + (card-games-put g :tricks (vector 2 1 1 0)) ; seats 0 and 2 made exact bids + (card-games-trick--score-hand g) + (should (= 12 (aref (card-games-get g :scores) 0))) ; 10 + 2 + (should (= 0 (aref (card-games-get g :scores) 1))) ; bid 0 took 1 -> miss + (should (= 11 (aref (card-games-get g :scores) 2))) ; 10 + 1 + (should (= 0 (aref (card-games-get g :scores) 3))))) (ert-deftest cgt-whist-render () - (let ((noninteractive t) (g (make-instance 'cg-whist-game))) - (cg-trick--new g) (should (stringp (cg-render g))))) + (let ((noninteractive t) (g (make-instance 'card-games-whist-game))) + (card-games-trick--new g) (should (stringp (card-games-render g))))) (ert-deftest cgt-pres-power () - (should (> (cg-pres--power 0) (cg-pres--power 12))) ; the Two beats the Ace - (should (< (cg-pres--power 1) (cg-pres--power 11)))) ; 3 below King + (should (> (card-games-pres--power 0) (card-games-pres--power 12))) ; the Two beats the Ace + (should (< (card-games-pres--power 1) (card-games-pres--power 11)))) ; 3 below King (ert-deftest cgt-pres-deal () - (let* ((cg-president-players 4) (g (cg-pres--deal (cg-president-game))) (tot 0)) - (should (= 4 (cg-get g :nplayers))) - (dotimes (s 4) (cl-incf tot (length (cg-pres--hand g s)))) + (let* ((card-games-president-players 4) (g (card-games-pres--deal (card-games-president-game))) (tot 0)) + (should (= 4 (card-games-get g :nplayers))) + (dotimes (s 4) (cl-incf tot (length (card-games-pres--hand g s)))) (should (= 52 tot)) - (should (= 0 (cg-get g :count))))) + (should (= 0 (card-games-get g :count))))) (ert-deftest cgt-pres-legal () - (let ((g (cg-president-game))) - (cg-put g :hands (vector (list '(0 . 5) '(1 . 5) '(0 . 8)) nil nil nil)) - (cg-put g :nplayers 4) + (let ((g (card-games-president-game))) + (card-games-put g :hands (vector (list '(0 . 5) '(1 . 5) '(0 . 8)) nil nil nil)) + (card-games-put g :nplayers 4) ;; leading: any rank ok - (cg-put g :count 0) (cg-put g :top -1) - (should (= 2 (length (cg-pres--legal-ranks g 0)))) ; ranks 5 and 8 + (card-games-put g :count 0) (card-games-put g :top -1) + (should (= 2 (length (card-games-pres--legal-ranks g 0)))) ; ranks 5 and 8 ;; following a single of power 5: need power>5 -> only rank 8 - (cg-put g :count 1) (cg-put g :top 5) - (should (equal '(8) (cg-pres--legal-ranks g 0))) + (card-games-put g :count 1) (card-games-put g :top 5) + (should (equal '(8) (card-games-pres--legal-ranks g 0))) ;; following a PAIR: need 2 of a higher rank -> rank 5 has two but power 5 not >5; none - (cg-put g :count 2) (cg-put g :top 5) - (should (null (cg-pres--legal-ranks g 0))))) + (card-games-put g :count 2) (card-games-put g :top 5) + (should (null (card-games-pres--legal-ranks g 0))))) (ert-deftest cgt-pres-full-game () - (let* ((cg-president-players 4) (g (cg-pres--deal (cg-president-game))) (n 0)) - (while (and (eq (cg-get g :phase) 'play) (< n 5000)) - (cg-pres--ai-move g (cg-get g :turn)) + (let* ((card-games-president-players 4) (g (card-games-pres--deal (card-games-president-game))) (n 0)) + (while (and (eq (card-games-get g :phase) 'play) (< n 5000)) + (card-games-pres--ai-move g (card-games-get g :turn)) (cl-incf n)) - (should (eq (cg-get g :phase) 'game-over)) - (should (= 4 (length (cg-get g :order)))) ; everyone placed - (should (= 4 (length (delete-dups (copy-sequence (cg-get g :order)))))))) ; all distinct + (should (eq (card-games-get g :phase) 'game-over)) + (should (= 4 (length (card-games-get g :order)))) ; everyone placed + (should (= 4 (length (delete-dups (copy-sequence (card-games-get g :order)))))))) ; all distinct (ert-deftest cgt-pres-exchange () - (let* ((cg-president-players 4) (g (cg-president-game))) + (let* ((card-games-president-players 4) (g (card-games-president-game))) ;; simulate a prior finishing order, then deal and check the swap happened - (cg-put g :order '(2 3 1 0)) ; prez=2, scum=0 - (cg-pres--deal g) + (card-games-put g :order '(2 3 1 0)) ; prez=2, scum=0 + (card-games-pres--deal g) ;; conservation: still 52 cards across 4 hands after the exchange - (let ((tot 0)) (dotimes (s 4) (cl-incf tot (length (cg-pres--hand g s)))) + (let ((tot 0)) (dotimes (s 4) (cl-incf tot (length (card-games-pres--hand g s)))) (should (= 52 tot))))) (ert-deftest cgt-pres-render () - (let ((g (cg-pres--deal (cg-president-game)))) (should (stringp (cg-render g))))) + (let ((g (card-games-pres--deal (card-games-president-game)))) (should (stringp (card-games-render g))))) ;;;; Rummy family (ert-deftest cgt-rummy-set-run () - (should (cg-rummy-set-p '((0 . 5) (1 . 5) (2 . 5)) :distinct-suits t)) - (should-not (cg-rummy-set-p '((0 . 5) (0 . 5) (2 . 5)) :distinct-suits t)) - (should (cg-rummy-run-p '((0 . 3) (0 . 4) (0 . 5)))) - (should-not (cg-rummy-run-p '((0 . 3) (1 . 4) (0 . 5)))) - (should (cg-rummy-run-p '((0 . 10) (0 . 11) (0 . 12) (0 . 0)) :ace-high t)) - (should-not (cg-rummy-run-p '((0 . 11) (0 . 12) (0 . 0)))) - (should (cg-rummy-run-p '((0 . 0) (0 . 1) (0 . 2))))) + (should (card-games-rummy-set-p '((0 . 5) (1 . 5) (2 . 5)) :distinct-suits t)) + (should-not (card-games-rummy-set-p '((0 . 5) (0 . 5) (2 . 5)) :distinct-suits t)) + (should (card-games-rummy-run-p '((0 . 3) (0 . 4) (0 . 5)))) + (should-not (card-games-rummy-run-p '((0 . 3) (1 . 4) (0 . 5)))) + (should (card-games-rummy-run-p '((0 . 10) (0 . 11) (0 . 12) (0 . 0)) :ace-high t)) + (should-not (card-games-rummy-run-p '((0 . 11) (0 . 12) (0 . 0)))) + (should (card-games-rummy-run-p '((0 . 0) (0 . 1) (0 . 2))))) (ert-deftest cgt-rummy-best-partition () (let* ((hand '((0 . 2)(0 . 3)(0 . 4) (0 . 6)(1 . 6)(2 . 6) (3 . 8)(3 . 9)(3 . 10) (3 . 12))) - (p (cg-rummy-best-partition hand))) + (p (card-games-rummy-best-partition hand))) (should (= 3 (length (plist-get p :melds)))) (should (= 10 (plist-get p :count)))) - (should (= 0 (cg-rummy-deadwood + (should (= 0 (card-games-rummy-deadwood '((0 . 0)(0 . 1)(0 . 2) (1 . 4)(1 . 5)(1 . 6) (2 . 8)(2 . 9)(2 . 10)(2 . 11)))))) (ert-deftest cgt-rummy-layoff () - (should (cg-rummy-layoff-p '(3 . 11) '(((3 . 8)(3 . 9)(3 . 10))))) - (should-not (cg-rummy-layoff-p '(0 . 4) '(((3 . 8)(3 . 9)(3 . 10)))))) + (should (card-games-rummy-layoff-p '(3 . 11) '(((3 . 8)(3 . 9)(3 . 10))))) + (should-not (card-games-rummy-layoff-p '(0 . 4) '(((3 . 8)(3 . 9)(3 . 10)))))) (ert-deftest cgt-gin-full-game () - (let ((g (cg-gin-game)) (turns 0)) - (cg-gin--deal g) - (while (and (not (eq (cg-get g :phase) 'game-over)) (< turns 100000)) - (if (eq (cg-get g :phase) 'hand-over) - (progn (cg-put g :reveal nil) (cg-gin--deal g)) - (cg-gin--ai-turn g (cg-get g :turn)) (cl-incf turns))) - (should (eq (cg-get g :phase) 'game-over)) - (should (>= (apply #'max (append (cg-get g :scores) nil)) cg-gin-target)))) + (let ((g (card-games-gin-game)) (turns 0)) + (card-games-gin--deal g) + (while (and (not (eq (card-games-get g :phase) 'game-over)) (< turns 100000)) + (if (eq (card-games-get g :phase) 'hand-over) + (progn (card-games-put g :reveal nil) (card-games-gin--deal g)) + (card-games-gin--ai-turn g (card-games-get g :turn)) (cl-incf turns))) + (should (eq (card-games-get g :phase) 'game-over)) + (should (>= (apply #'max (append (card-games-get g :scores) nil)) card-games-gin-target)))) -(ert-deftest cgt-gin-render () (let ((g (cg-gin--deal (cg-gin-game)))) - (should (stringp (cg-render g))))) +(ert-deftest cgt-gin-render () (let ((g (card-games-gin--deal (card-games-gin-game)))) + (should (stringp (card-games-render g))))) (ert-deftest cgt-tablemeld-games () - (dolist (mk (list (lambda () (cg-rummy-basic-game :nplayers 3 :hand-size 7)) - (lambda () (cg-rum500-game :nplayers 3 :hand-size 7)))) + (dolist (mk (list (lambda () (card-games-rummy-basic-game :nplayers 3 :hand-size 7)) + (lambda () (card-games-rum500-game :nplayers 3 :hand-size 7)))) (let ((g (funcall mk)) (turns 0)) - (cg-tm--deal g) - (while (and (not (eq (cg-get g :phase) 'game-over)) (< turns 200000)) - (if (eq (cg-get g :phase) 'hand-over) - (progn (cg-put g :reveal nil) (cg-tm--deal g)) - (cg-tm--ai-turn g (cg-get g :turn)) (cl-incf turns))) - (should (eq (cg-get g :phase) 'game-over)) - (should (stringp (cg-render g)))))) + (card-games-tm--deal g) + (while (and (not (eq (card-games-get g :phase) 'game-over)) (< turns 200000)) + (if (eq (card-games-get g :phase) 'hand-over) + (progn (card-games-put g :reveal nil) (card-games-tm--deal g)) + (card-games-tm--ai-turn g (card-games-get g :turn)) (cl-incf turns))) + (should (eq (card-games-get g :phase) 'game-over)) + (should (stringp (card-games-render g)))))) (ert-deftest cgt-tablemeld-conservation () - (let ((g (cg-rum500-game :nplayers 3 :hand-size 7))) - (cg-tm--deal g) - (dotimes (_ 30) (when (eq (cg-get g :phase) 'play) - (cg-tm--ai-turn g (cg-get g :turn)))) - (let ((tot (+ (length (cg-get g :stock)) (length (cg-get g :discard)) - (apply #'+ (mapcar (lambda (r) (length (cdr r))) (cg-get g :table)))))) - (dotimes (s 3) (setq tot (+ tot (length (cg-rummy--hand g s))))) + (let ((g (card-games-rum500-game :nplayers 3 :hand-size 7))) + (card-games-tm--deal g) + (dotimes (_ 30) (when (eq (card-games-get g :phase) 'play) + (card-games-tm--ai-turn g (card-games-get g :turn)))) + (let ((tot (+ (length (card-games-get g :stock)) (length (card-games-get g :discard)) + (apply #'+ (mapcar (lambda (r) (length (cdr r))) (card-games-get g :table)))))) + (dotimes (s 3) (setq tot (+ tot (length (card-games-rummy--hand g s))))) (should (= tot 52))))) (ert-deftest cgt-handfoot-book () - (should (cg-hf--book-valid-p '((0 . 7)(1 . 7)(2 . 7)))) - (should (cg-hf--book-valid-p '((0 . 7)(1 . 7)(joker . 0)))) ; dirty - (should-not (cg-hf--book-valid-p '((0 . 7)(joker . 0)(joker . 0)))) ; wilds > nats - (should-not (cg-hf--book-valid-p '((0 . 2)(1 . 2)(2 . 2)))) ; threes - (should (cg-hf--book-complete-p '(a b c d e f g))) - (should (cg-hf--book-clean-p '((0 . 7)(1 . 7)(2 . 7)))) - (should-not (cg-hf--book-clean-p '((0 . 7)(1 . 7)(joker . 0))))) + (should (card-games-hf--book-valid-p '((0 . 7)(1 . 7)(2 . 7)))) + (should (card-games-hf--book-valid-p '((0 . 7)(1 . 7)(joker . 0)))) ; dirty + (should-not (card-games-hf--book-valid-p '((0 . 7)(joker . 0)(joker . 0)))) ; wilds > nats + (should-not (card-games-hf--book-valid-p '((0 . 2)(1 . 2)(2 . 2)))) ; threes + (should (card-games-hf--book-complete-p '(a b c d e f g))) + (should (card-games-hf--book-clean-p '((0 . 7)(1 . 7)(2 . 7)))) + (should-not (card-games-hf--book-clean-p '((0 . 7)(1 . 7)(joker . 0))))) (ert-deftest cgt-handfoot-full-game () - (let ((g (cg-handfoot-game)) (rounds 0) (turns 0) (expect (* 5 54))) - (cg-put g :nplayers 4) (cg-put g :nteams 2) (cg-put g :scores (make-vector 2 0)) - (cg-hf--deal g) - (while (and (not (eq (cg-get g :phase) 'game-over)) (< rounds 60)) - (cond ((eq (cg-get g :phase) 'round-over) - (cg-put g :reveal nil) (cg-hf--deal g) (cl-incf rounds)) - (t (cg-hf--ai-turn g (cg-get g :turn)) (cl-incf turns) + (let ((g (card-games-handfoot-game)) (rounds 0) (turns 0) (expect (* 5 54))) + (card-games-put g :nplayers 4) (card-games-put g :nteams 2) (card-games-put g :scores (make-vector 2 0)) + (card-games-hf--deal g) + (while (and (not (eq (card-games-get g :phase) 'game-over)) (< rounds 60)) + (cond ((eq (card-games-get g :phase) 'round-over) + (card-games-put g :reveal nil) (card-games-hf--deal g) (cl-incf rounds)) + (t (card-games-hf--ai-turn g (card-games-get g :turn)) (cl-incf turns) (when (> turns 500000) (error "runaway"))))) - (should (eq (cg-get g :phase) 'game-over)) - (should (stringp (cg-render g))))) + (should (eq (card-games-get g :phase) 'game-over)) + (should (stringp (card-games-render g))))) ;;;; Matching games (Go Fish, Old Maid) (ert-deftest cgt-gofish-full () - (let ((cg-go-fish-players 4) (g (cg-go-fish-game)) (guard 0)) - (cg-gf--deal g) - (while (and (not (eq (cg-get g :phase) 'game-over)) (< guard 20000)) - (cg-gf--ai-turn g (cg-get g :turn)) (cl-incf guard)) - (should (eq (cg-get g :phase) 'game-over)) - (let ((tot 0)) (dotimes (s 4) (cl-incf tot (cg-gf--books g s))) + (let ((card-games-go-fish-players 4) (g (card-games-go-fish-game)) (guard 0)) + (card-games-gf--deal g) + (while (and (not (eq (card-games-get g :phase) 'game-over)) (< guard 20000)) + (card-games-gf--ai-turn g (card-games-get g :turn)) (cl-incf guard)) + (should (eq (card-games-get g :phase) 'game-over)) + (let ((tot 0)) (dotimes (s 4) (cl-incf tot (card-games-gf--books g s))) (should (= tot 13))) - (should (stringp (cg-render g))))) + (should (stringp (card-games-render g))))) (ert-deftest cgt-oldmaid-full () - (let ((cg-old-maid-players 4) (g (cg-old-maid-game)) (guard 0)) - (cg-om--deal g) - (while (and (not (eq (cg-get g :phase) 'game-over)) (< guard 20000)) - (cg-om--ai-turn g (cg-get g :turn)) (cl-incf guard)) - (should (eq (cg-get g :phase) 'game-over)) - (should (= 1 (cg-om--total g))) - (should (stringp (cg-render g))))) + (let ((card-games-old-maid-players 4) (g (card-games-old-maid-game)) (guard 0)) + (card-games-om--deal g) + (while (and (not (eq (card-games-get g :phase) 'game-over)) (< guard 20000)) + (card-games-om--ai-turn g (card-games-get g :turn)) (cl-incf guard)) + (should (eq (card-games-get g :phase) 'game-over)) + (should (= 1 (card-games-om--total g))) + (should (stringp (card-games-render g))))) ;;;; Cribbage (ert-deftest cgt-cribbage-scorer () - (should (= 29 (cg-crib--score-show '((0 . 4)(1 . 4)(3 . 4)(2 . 10)) '(2 . 4)))) - (should (= 12 (cg-crib--count-pairs '((0 . 4)(1 . 4)(2 . 4)(3 . 4))))) - (should (= 5 (cg-crib--count-runs '((0 . 1)(0 . 2)(0 . 3)(0 . 4)(0 . 5))))) - (should (= 2 (cg-crib--peg-score '((0 . 10)(0 . 4)) 15))) - (should (= 3 (cg-crib--peg-score '((0 . 2)(0 . 3)(0 . 4)) 12))) - (should (= 6 (cg-crib--peg-score '((0 . 6)(1 . 6)(2 . 6)) 21)))) + (should (= 29 (card-games-crib--score-show '((0 . 4)(1 . 4)(3 . 4)(2 . 10)) '(2 . 4)))) + (should (= 12 (card-games-crib--count-pairs '((0 . 4)(1 . 4)(2 . 4)(3 . 4))))) + (should (= 5 (card-games-crib--count-runs '((0 . 1)(0 . 2)(0 . 3)(0 . 4)(0 . 5))))) + (should (= 2 (card-games-crib--peg-score '((0 . 10)(0 . 4)) 15))) + (should (= 3 (card-games-crib--peg-score '((0 . 2)(0 . 3)(0 . 4)) 12))) + (should (= 6 (card-games-crib--peg-score '((0 . 6)(1 . 6)(2 . 6)) 21)))) (ert-deftest cgt-cribbage-full () - (let ((g (cg-cribbage-game)) (deals 0)) - (cg-put g :dealer 1) + (let ((g (card-games-cribbage-game)) (deals 0)) + (card-games-put g :dealer 1) (cl-flet ((ai-deal (g) - (cg-crib--deal g) - (let ((d0 (cg-crib--ai-discard g 0)) (d1 (cg-crib--ai-discard g 1))) - (cg-crib--set-hand g 0 (cl-set-difference (cg-crib--hand g 0) d0 :test #'equal)) - (cg-crib--set-hand g 1 (cl-set-difference (cg-crib--hand g 1) d1 :test #'equal)) - (cg-put g :crib (append d0 d1))) - (cg-crib--start-play g) + (card-games-crib--deal g) + (let ((d0 (card-games-crib--ai-discard g 0)) (d1 (card-games-crib--ai-discard g 1))) + (card-games-crib--set-hand g 0 (cl-set-difference (card-games-crib--hand g 0) d0 :test #'equal)) + (card-games-crib--set-hand g 1 (cl-set-difference (card-games-crib--hand g 1) d1 :test #'equal)) + (card-games-put g :crib (append d0 d1))) + (card-games-crib--start-play g) (let ((guard 0)) - (while (and (eq (cg-get g :phase) 'play) (not (cg-crib--peg-over-p g)) + (while (and (eq (card-games-get g :phase) 'play) (not (card-games-crib--peg-over-p g)) (< guard 400)) (cl-incf guard) - (let ((s (cg-get g :pturn))) - (if (cg-crib--legal g s) (cg-crib--ai-play g s) (cg-crib--peg-go g s))))) - (when (and (eq (cg-get g :phase) 'play) (cg-crib--peg-over-p g)) - (cg-crib--show g)))) - (while (and (not (eq (cg-get g :phase) 'game-over)) (< deals 300)) - (cg-put g :dealer (- 1 (cg-get g :dealer))) + (let ((s (card-games-get g :pturn))) + (if (card-games-crib--legal g s) (card-games-crib--ai-play g s) (card-games-crib--peg-go g s))))) + (when (and (eq (card-games-get g :phase) 'play) (card-games-crib--peg-over-p g)) + (card-games-crib--show g)))) + (while (and (not (eq (card-games-get g :phase) 'game-over)) (< deals 300)) + (card-games-put g :dealer (- 1 (card-games-get g :dealer))) (ai-deal g) (cl-incf deals))) - (should (eq (cg-get g :phase) 'game-over)) - (should (stringp (cg-render g))))) + (should (eq (card-games-get g :phase) 'game-over)) + (should (stringp (card-games-render g))))) ;;;; Fishing games (Scopa, Casino) (ert-deftest cgt-fish-capture () - (let ((g (cg-scopa-game))) - (cg-put g :table '((0 . 0)(1 . 1)(2 . 3))) - (should (equal (sort (mapcar #'cdr (cg-fish--capture g '(3 . 4))) #'<) '(0 3)))) - (let ((g (cg-casino-game))) - (cg-put g :table '((0 . 12)(1 . 12)(2 . 5))) - (should (= 1 (length (cg-fish--capture g '(3 . 12))))))) + (let ((g (card-games-scopa-game))) + (card-games-put g :table '((0 . 0)(1 . 1)(2 . 3))) + (should (equal (sort (mapcar #'cdr (card-games-fish--capture g '(3 . 4))) #'<) '(0 3)))) + (let ((g (card-games-casino-game))) + (card-games-put g :table '((0 . 12)(1 . 12)(2 . 5))) + (should (= 1 (length (card-games-fish--capture g '(3 . 12))))))) (ert-deftest cgt-fish-full () - (dolist (mk (list #'cg-scopa-game #'cg-casino-game)) + (dolist (mk (list #'card-games-scopa-game #'card-games-casino-game)) (let ((g (funcall mk)) (rounds 0)) - (cg-fish--deal-round g) - (while (and (not (eq (cg-get g :phase) 'game-over)) (< rounds 200)) - (if (eq (cg-get g :phase) 'round-over) - (cg-fish--deal-round g) - (cg-fish--ai-play g (cg-get g :turn)) (cl-incf rounds))) - (should (eq (cg-get g :phase) 'game-over)) - (should (stringp (cg-render g)))))) + (card-games-fish--deal-round g) + (while (and (not (eq (card-games-get g :phase) 'game-over)) (< rounds 200)) + (if (eq (card-games-get g :phase) 'round-over) + (card-games-fish--deal-round g) + (card-games-fish--ai-play g (card-games-get g :turn)) (cl-incf rounds))) + (should (eq (card-games-get g :phase) 'game-over)) + (should (stringp (card-games-render g)))))) ;;;; Trick extensions (Euchre, Pitch, Briscola) (ert-deftest cgt-euchre-bowers () - (should (> (cg-euchre--power '(0 . 9) 0 0) (cg-euchre--power '(1 . 9) 0 0))) - (should (> (cg-euchre--power '(1 . 9) 0 0) (cg-euchre--power '(0 . 12) 0 0))) + (should (> (card-games-euchre--power '(0 . 9) 0 0) (card-games-euchre--power '(1 . 9) 0 0))) + (should (> (card-games-euchre--power '(1 . 9) 0 0) (card-games-euchre--power '(0 . 12) 0 0))) (should (= 120 (let ((s 0)) (dolist (su '(0 1 2 3)) - (dolist (r cg-briscola--ranks) - (setq s (+ s (cg-bris--points (cons su r)))))) s)))) + (dolist (r card-games-briscola--ranks) + (setq s (+ s (card-games-bris--points (cons su r)))))) s)))) (ert-deftest cgt-trick-ext-full () - (dolist (class '(cg-briscola-game cg-pitch-game cg-euchre-game)) + (dolist (class '(card-games-briscola-game card-games-pitch-game card-games-euchre-game)) (let ((g (make-instance class)) (guard 0)) - (cg-trick--new g) - (while (and (not (eq (cg-get g :phase) 'game-over)) (< guard 50000)) + (card-games-trick--new g) + (while (and (not (eq (card-games-get g :phase) 'game-over)) (< guard 50000)) (cl-incf guard) - (if (cg-trick--hand-over-p g) - (cg-trick--finish-hand g) - (let ((s (cg-get g :turn))) - (cg-trick--play g s (cg-trick--ai-play g s))))) - (should (eq (cg-get g :phase) 'game-over)) - (should (stringp (cg-render g)))))) + (if (card-games-trick--hand-over-p g) + (card-games-trick--finish-hand g) + (let ((s (card-games-get g :turn))) + (card-games-trick--play g s (card-games-trick--ai-play g s))))) + (should (eq (card-games-get g :phase) 'game-over)) + (should (stringp (card-games-render g)))))) ;;;; Spite & Malice (ert-deftest cgt-spite-legal () - (let ((g (cg-spite-game))) - (cg-spite--deal g) (cg-put g :center (make-vector 4 nil)) - (should (eql 0 (cg-spite--legal-center g '(0 . 0)))) ; Ace starts a pile - (should (null (cg-spite--legal-center g '(0 . 1)))) ; a Two cannot - (should (eql 0 (cg-spite--legal-center g '(0 . 12)))) ; King is wild - (cg-spite--put-center g '(0 . 0) 0) - (should (= 1 (cg-spite--needed g 0))))) + (let ((g (card-games-spite-game))) + (card-games-spite--deal g) (card-games-put g :center (make-vector 4 nil)) + (should (eql 0 (card-games-spite--legal-center g '(0 . 0)))) ; Ace starts a pile + (should (null (card-games-spite--legal-center g '(0 . 1)))) ; a Two cannot + (should (eql 0 (card-games-spite--legal-center g '(0 . 12)))) ; King is wild + (card-games-spite--put-center g '(0 . 0) 0) + (should (= 1 (card-games-spite--needed g 0))))) (ert-deftest cgt-spite-full () - (let ((cg-spite-goal-size 10) (g (cg-spite-game)) (turns 0)) - (cg-spite--deal g) - (while (and (eq (cg-get g :phase) 'play) (< turns 6000)) - (cl-incf turns) (cg-spite--ai-turn g (cg-get g :turn))) - (should (eq (cg-get g :phase) 'game-over)) - (should (stringp (cg-render g))))) + (let ((card-games-spite-goal-size 10) (g (card-games-spite-game)) (turns 0)) + (card-games-spite--deal g) + (while (and (eq (card-games-get g :phase) 'play) (< turns 6000)) + (cl-incf turns) (card-games-spite--ai-turn g (card-games-get g :turn))) + (should (eq (card-games-get g :phase) 'game-over)) + (should (stringp (card-games-render g))))) ;;;; Bridge (ert-deftest cgt-bridge-score () - (cl-flet ((b (l s d v tk) (plist-get (cg-bridge--deal-score l s d v tk) :below)) - (a (l s d v tk) (plist-get (cg-bridge--deal-score l s d v tk) :datk)) - (f (l s d v tk) (plist-get (cg-bridge--deal-score l s d v tk) :defend))) + (cl-flet ((b (l s d v tk) (plist-get (card-games-bridge--deal-score l s d v tk) :below)) + (a (l s d v tk) (plist-get (card-games-bridge--deal-score l s d v tk) :datk)) + (f (l s d v tk) (plist-get (card-games-bridge--deal-score l s d v tk) :defend))) (should (= 100 (b 3 4 0 nil 9))) ; 3NT made (should (= 120 (b 4 3 0 nil 10))) ; 4 spades made (should (= 180 (b 6 2 0 nil 12))) ; 6 hearts made @@ -1598,156 +1598,156 @@ left a 15-card hand in play." (should (= 50 (a 1 4 1 nil 7))) ; 1NT doubled, insult (should (= 100 (f 4 3 0 nil 8))) ; down two undoubled (should (= 500 (f 4 3 1 t 8)))) ; down two doubled vulnerable - (should (= 1 (cg-bridge--trick-winner + (should (= 1 (card-games-bridge--trick-winner '((0 . (0 . 12)) (1 . (3 . 0)) (2 . (0 . 2)) (3 . (0 . 5))) 3)))) (ert-deftest cgt-bridge-full () (let ((scored 0) (passed 0)) (dotimes (i 12) - (let ((g (cg-bridge-game)) (guard 0)) - (cg-put g :dealer (mod i 4)) - (cg-bridge--deal g) - (while (and (eq (cg-get g :phase) 'auction) (< guard 60)) + (let ((g (card-games-bridge-game)) (guard 0)) + (card-games-put g :dealer (mod i 4)) + (card-games-bridge--deal g) + (while (and (eq (card-games-get g :phase) 'auction) (< guard 60)) (cl-incf guard) - (let* ((s (cg-get g :bidder)) (call (cg-bridge--ai-call g s))) - (unless (cg-bridge--legal-call-p g call) (setq call 'pass)) - (cg-bridge--apply-call g s call) - (cg-bridge--auction-done-p g))) - (if (eq (cg-get g :phase) 'passed-out) (cl-incf passed) + (let* ((s (card-games-get g :bidder)) (call (card-games-bridge--ai-call g s))) + (unless (card-games-bridge--legal-call-p g call) (setq call 'pass)) + (card-games-bridge--apply-call g s call) + (card-games-bridge--auction-done-p g))) + (if (eq (card-games-get g :phase) 'passed-out) (cl-incf passed) (let ((p 0)) - (while (and (eq (cg-get g :phase) 'play) (< p 60)) + (while (and (eq (card-games-get g :phase) 'play) (< p 60)) (cl-incf p) - (cg-bridge--play-card g (cg-get g :turn) (cg-bridge--ai-play g (cg-get g :turn))))) - (when (eq (cg-get g :phase) 'scored) + (card-games-bridge--play-card g (card-games-get g :turn) (card-games-bridge--ai-play g (card-games-get g :turn))))) + (when (eq (card-games-get g :phase) 'scored) (cl-incf scored) - (should (cl-every #'null (append (cg-get g :hands) nil))))) - (should (memq (cg-get g :phase) '(scored passed-out))) - (should (stringp (cg-render g))))) + (should (cl-every #'null (append (card-games-get g :hands) nil))))) + (should (memq (card-games-get g :phase) '(scored passed-out))) + (should (stringp (card-games-render g))))) (should (> scored 0)))) ;;;; Renderer registry / region keystone (ert-deftest cgt-keystone-regions () - (let* ((g (cg-sol--deal (make-instance 'cg-klondike-game))) - (res (cg-render-svg g))) + (let* ((g (card-games-sol--deal (make-instance 'card-games-klondike-game))) + (res (card-games-render-svg g))) (should (stringp (car res))) (should (>= (length (cdr res)) 13)) ; 6 top slots + 7 columns (let* ((reg (cl-find '(col . 3) (cdr res) :key #'cdr :test #'equal)) (rect (car reg))) (should reg) (should (equal '(col . 3) - (cg-regions-hit (cdr res) + (card-games-regions-hit (cdr res) (+ (nth 0 rect) (/ (nth 2 rect) 2)) (+ (nth 1 rect) 10))))) - (should (null (cg-regions-hit (cdr res) -5 -5)))) + (should (null (card-games-regions-hit (cdr res) -5 -5)))) (with-temp-buffer - (setq cg-sol--game (cg-sol--deal (make-instance 'cg-klondike-game))) - (cg-render-game cg-sol--game) - (should (oref cg-sol--game renderer)) + (setq card-games-sol--game (card-games-sol--deal (make-instance 'card-games-klondike-game))) + (card-games-render-game card-games-sol--game) + (should (oref card-games-sol--game renderer)) (should (> (buffer-size) 0)) - (cg-render-apply cg-sol--game '(col . 5)) - (should (= 11 (cg-get cg-sol--game :cursor))))) ; spot index of (col . 5) + (card-games-render-apply card-games-sol--game '(col . 5)) + (should (= 11 (card-games-get card-games-sol--game :cursor))))) ; spot index of (col . 5) ;;;; Hand-cluster click regions + card-size slider (ert-deftest cgt-hand-regions () (let* ((cards '((0 . 0) (0 . 1) (1 . 5))) - (str (cg-rummy--svg-row cards 0 nil nil 'hand)) - (regs (get-text-property 0 'cg-regions str))) - (should (= (+ 3 (length cg-svg-slider-stops)) (length regs))) ; 3 cards + stops + (str (card-games-rummy--svg-row cards 0 nil nil 'hand)) + (regs (get-text-property 0 'card-games-regions str))) + (should (= (+ 3 (length card-games-svg-slider-stops)) (length regs))) ; 3 cards + stops (should (equal '(hand . 0) (cdr (car regs)))) (should (cl-find-if (lambda (r) (eq (car-safe (cdr r)) 'scale)) regs))) - (let ((g (cg-gin--deal (cg-gin-game))) (cg-card-scale 1.0)) - (cg-render-apply g '(hand . 2)) - (should (= 2 (cg-get g :cursor))) - (cg-render-apply g '(scale . 1.5)) ; base method handles scale - (should (= 1.5 cg-card-scale)) - (cg-render-apply g 'zoom-reset) - (should (= 1.0 cg-card-scale)))) + (let ((g (card-games-gin--deal (card-games-gin-game))) (card-games-card-scale 1.0)) + (card-games-render-apply g '(hand . 2)) + (should (= 2 (card-games-get g :cursor))) + (card-games-render-apply g '(scale . 1.5)) ; base method handles scale + (should (= 1.5 card-games-card-scale)) + (card-games-render-apply g 'zoom-reset) + (should (= 1.0 card-games-card-scale)))) ;;;; Rummy 500 deep pickup and Hand & Foot rule completions (ert-deftest cgt-rum500-deep-pickup () "Taking a buried discard card melds it at once, keeping the cards above." - (let ((g (cg-rum500-game :nplayers 2 :hand-size 10))) - (cg-put g :nplayers 2) (cg-put g :scores (make-vector 2 0)) - (cg-put g :hands (vector (list (cons 0 5) (cons 0 6)) nil)) ; 6S 7S - (cg-put g :discard (list (cons 1 9) (cons 0 4) (cons 2 3))) ; top 10C, buried 5S - (cg-put g :table nil) (cg-put g :laid (make-vector 2 0)) - (cg-put g :turn 0) (cg-put g :step 'draw) (cg-put g :phase 'play) - (should (cg-tm--take-deep g 0 1)) - (should (equal (cg-get g :table) '((0 (0 . 4) (0 . 5) (0 . 6))))) - (should (equal (cg-rummy--hand g 0) '((1 . 9)))) - (should (= 1 (length (cg-get g :discard)))) + (let ((g (card-games-rum500-game :nplayers 2 :hand-size 10))) + (card-games-put g :nplayers 2) (card-games-put g :scores (make-vector 2 0)) + (card-games-put g :hands (vector (list (cons 0 5) (cons 0 6)) nil)) ; 6S 7S + (card-games-put g :discard (list (cons 1 9) (cons 0 4) (cons 2 3))) ; top 10C, buried 5S + (card-games-put g :table nil) (card-games-put g :laid (make-vector 2 0)) + (card-games-put g :turn 0) (card-games-put g :step 'draw) (card-games-put g :phase 'play) + (should (card-games-tm--take-deep g 0 1)) + (should (equal (card-games-get g :table) '((0 (0 . 4) (0 . 5) (0 . 6))))) + (should (equal (card-games-rummy--hand g 0) '((1 . 9)))) + (should (= 1 (length (card-games-get g :discard)))) ;; a card you cannot use immediately may not be taken - (cg-put g :hands (vector (list (cons 3 11)) nil)) - (cg-put g :discard (list (cons 1 9) (cons 2 2))) - (should-not (cg-tm--take-deep g 0 1)))) + (card-games-put g :hands (vector (list (cons 3 11)) nil)) + (card-games-put g :discard (list (cons 1 9) (cons 2 2))) + (should-not (card-games-tm--take-deep g 0 1)))) (ert-deftest cgt-handfoot-redthree () "Red threes leave the hand on deal and collect to the team pile." - (let ((g (cg-handfoot-game))) - (cg-put g :nplayers 4) (cg-put g :nteams 2) (cg-put g :scores (make-vector 2 0)) - (cg-hf--deal g) + (let ((g (card-games-handfoot-game))) + (card-games-put g :nplayers 4) (card-games-put g :nteams 2) (card-games-put g :scores (make-vector 2 0)) + (card-games-hf--deal g) (dotimes (s 4) - (should (= 0 (cl-count-if #'cg-hf--red-three-p (cg-rummy--hand g s))))) - (cg-put g :redthrees (make-vector 2 nil)) - (cg-rummy--set-hand g 0 (list (cons 2 2) (cons 0 5))) ; 3 of diamonds + 6S - (cg-put g :stock (list (cons 0 9))) - (should (= 1 (cg-hf--collect-red-threes g 0))) - (should (= 1 (length (aref (cg-get g :redthrees) (cg-hf--team g 0))))) - (should-not (cl-find-if #'cg-hf--red-three-p (cg-rummy--hand g 0))))) + (should (= 0 (cl-count-if #'card-games-hf--red-three-p (card-games-rummy--hand g s))))) + (card-games-put g :redthrees (make-vector 2 nil)) + (card-games-rummy--set-hand g 0 (list (cons 2 2) (cons 0 5))) ; 3 of diamonds + 6S + (card-games-put g :stock (list (cons 0 9))) + (should (= 1 (card-games-hf--collect-red-threes g 0))) + (should (= 1 (length (aref (card-games-get g :redthrees) (card-games-hf--team g 0))))) + (should-not (cl-find-if #'card-games-hf--red-three-p (card-games-rummy--hand g 0))))) (ert-deftest cgt-handfoot-min-meld () "Initial meld must reach the round minimum; below it is refused." - (let ((g (cg-handfoot-game))) - (cg-put g :nplayers 4) (cg-put g :nteams 2) (cg-put g :scores (make-vector 2 0)) - (cg-hf--deal g) (cg-put g :round 0) - (cg-put g :down (make-vector 2 nil)) (cg-put g :books (make-vector 2 nil)) - (cg-put g :hands (vector (list (cons 0 3)(cons 1 3)(cons 2 3)) nil nil nil)) ; three 4s = 15 - (should-not (cg-hf--initial-meld g 0 (cg-rummy--hand g 0))) - (should-not (cg-hf--down-p g 0)) - (cg-put g :hands (vector (list (cons 0 0)(cons 1 0)(cons 2 0)) nil nil nil)) ; three aces = 60 - (should (cg-hf--initial-meld g 0 (cg-rummy--hand g 0))) - (should (cg-hf--down-p g 0)) - (should (= 1 (length (cg-hf--books g 0)))))) + (let ((g (card-games-handfoot-game))) + (card-games-put g :nplayers 4) (card-games-put g :nteams 2) (card-games-put g :scores (make-vector 2 0)) + (card-games-hf--deal g) (card-games-put g :round 0) + (card-games-put g :down (make-vector 2 nil)) (card-games-put g :books (make-vector 2 nil)) + (card-games-put g :hands (vector (list (cons 0 3)(cons 1 3)(cons 2 3)) nil nil nil)) ; three 4s = 15 + (should-not (card-games-hf--initial-meld g 0 (card-games-rummy--hand g 0))) + (should-not (card-games-hf--down-p g 0)) + (card-games-put g :hands (vector (list (cons 0 0)(cons 1 0)(cons 2 0)) nil nil nil)) ; three aces = 60 + (should (card-games-hf--initial-meld g 0 (card-games-rummy--hand g 0))) + (should (card-games-hf--down-p g 0)) + (should (= 1 (length (card-games-hf--books g 0)))))) (ert-deftest cgt-handfoot-pickup () "Picking up melds the top discard and rakes in the cards beneath it." - (let ((g (cg-handfoot-game))) - (cg-put g :nplayers 4) (cg-put g :nteams 2) (cg-put g :scores (make-vector 2 0)) - (cg-hf--deal g) - (cg-put g :redthrees (make-vector 2 nil)) (cg-put g :books (make-vector 2 nil)) - (cg-put g :hands (vector (list (cons 0 8)(cons 1 8)(cons 0 4)) nil nil nil)) ; two 9s + 5S - (cg-put g :discard (list (cons 2 8)(cons 3 5)(cons 0 6)(cons 1 7))) ; top 9D + 3 beneath - (cg-put g :stock nil) - (should (cg-hf--pickup-eligible g 0)) - (let ((top (cg-hf--pickup g 0))) + (let ((g (card-games-handfoot-game))) + (card-games-put g :nplayers 4) (card-games-put g :nteams 2) (card-games-put g :scores (make-vector 2 0)) + (card-games-hf--deal g) + (card-games-put g :redthrees (make-vector 2 nil)) (card-games-put g :books (make-vector 2 nil)) + (card-games-put g :hands (vector (list (cons 0 8)(cons 1 8)(cons 0 4)) nil nil nil)) ; two 9s + 5S + (card-games-put g :discard (list (cons 2 8)(cons 3 5)(cons 0 6)(cons 1 7))) ; top 9D + 3 beneath + (card-games-put g :stock nil) + (should (card-games-hf--pickup-eligible g 0)) + (let ((top (card-games-hf--pickup g 0))) (should (equal top (cons 2 8))) - (should (= 1 (length (cg-hf--books g 0)))) - (should (cg-hf--book-valid-p (car (cg-hf--books g 0)))) - (should (= 4 (length (cg-rummy--hand g 0)))) - (should-not (cg-get g :discard))))) + (should (= 1 (length (card-games-hf--books g 0)))) + (should (card-games-hf--book-valid-p (car (card-games-hf--books g 0)))) + (should (= 4 (length (card-games-rummy--hand g 0)))) + (should-not (card-games-get g :discard))))) ;;;; Mouse click-region wiring for eights, president, and the patience boards (ert-deftest cgt-mouse-regions () - "The newly clickable games attach a `cg-regions' map to their SVG." - (let* ((g (cg-pat--deal (cg-golf-game))) - (regs (get-text-property 0 'cg-regions (cg-pat--svg g)))) + "The newly clickable games attach a `card-games-regions' map to their SVG." + (let* ((g (card-games-pat--deal (card-games-golf-game))) + (regs (get-text-property 0 'card-games-regions (card-games-pat--svg g)))) (should regs) (should (cl-find '(waste . 0) (mapcar #'cdr regs) :test #'equal)) (should (cl-find '(stock . 0) (mapcar #'cdr regs) :test #'equal)) (should (cl-find-if (lambda (a) (eq (car a) 'slot)) (mapcar #'cdr regs)))) - (let ((g (cg-president-game))) - (cg-put g :games 0) (cg-pres--deal g) - (let ((regs (get-text-property 0 'cg-regions (cg-pres--svg g)))) + (let ((g (card-games-president-game))) + (card-games-put g :games 0) (card-games-pres--deal g) + (let ((regs (get-text-property 0 'card-games-regions (card-games-pres--svg g)))) (should regs) (should (cl-find-if (lambda (a) (and (consp a) (eq (car a) 'hand))) (mapcar #'cdr regs))))) - (let ((g (cg-eights-game))) - (cg-put g :scores (make-vector 3 0)) (cg-eights--deal g) - (let* ((img (cg-svg-hand-image (mapcar #'cg-eights--spec (cg-eights--hand g 0)) + (let ((g (card-games-eights-game))) + (card-games-put g :scores (make-vector 3 0)) (card-games-eights--deal g) + (let* ((img (card-games-svg-hand-image (mapcar #'card-games-eights--spec (card-games-eights--hand g 0)) :region-tag 'hand)) - (regs (get-text-property 0 'cg-regions img))) + (regs (get-text-property 0 'card-games-regions img))) (should regs) (should (cl-find-if (lambda (a) (and (consp a) (eq (car a) 'hand))) (mapcar #'cdr regs)))))) @@ -1756,41 +1756,41 @@ left a 15-card hand in play." (ert-deftest cgt-bid-kitty-cap () "Kitty marking never exceeds five cards, and the UI exposes the controls." - (let ((g (cg-bid-game)) (cg-bid--human-seats '(0))) - (cg-bid--deal g 3) - (cg-put g :phase 'kitty) (cg-put g :contractor 0) - (cg-put g :contract (nth 0 cg-bid-schedule)) - (let ((hand (cg-bid-sort-display (cg-bid--hand g 0) nil))) - (cg-put g :sorted-hand hand) - (cg-put g :marks (cl-subseq hand 0 5)) ; already five - (cg-put g :cursor 5) ; a sixth, unmarked + (let ((g (card-games-bid-game)) (card-games-bid--human-seats '(0))) + (card-games-bid--deal g 3) + (card-games-put g :phase 'kitty) (card-games-put g :contractor 0) + (card-games-put g :contract (nth 0 card-games-bid-schedule)) + (let ((hand (card-games-bid-sort-display (card-games-bid--hand g 0) nil))) + (card-games-put g :sorted-hand hand) + (card-games-put g :marks (cl-subseq hand 0 5)) ; already five + (card-games-put g :cursor 5) ; a sixth, unmarked (with-temp-buffer - (setq-local cg-bid--game g) - (cg-bid-select) ; must refuse the sixth - (should (= 5 (length (cg-get g :marks)))) + (setq-local card-games-bid--game g) + (card-games-bid-select) ; must refuse the sixth + (should (= 5 (length (card-games-get g :marks)))) ;; unmark a card that is actually marked (redisplay may have re-sorted ;; the hand by trump, so cursor 0 is not necessarily a marked card) - (let* ((sh (cg-get g :sorted-hand)) (mk (cg-get g :marks)) + (let* ((sh (card-games-get g :sorted-hand)) (mk (card-games-get g :marks)) (idx (cl-position-if (lambda (c) (member c mk)) sh))) - (cg-put g :cursor idx) - (cg-bid-select) - (should (= 4 (length (cg-get g :marks))))))) + (card-games-put g :cursor idx) + (card-games-bid-select) + (should (= 4 (length (card-games-get g :marks))))))) ;; the full-SVG kitty panel exposes a Discard region and a card-size slider - (let* ((cg-bid-svg-ui t) (cg-bid-svg-fill t) - (rg (cdr (cg-bid--ui-svg g 1100 700)))) + (let* ((card-games-bid-svg-ui t) (card-games-bid-svg-fill t) + (rg (cdr (card-games-bid--ui-svg g 1100 700)))) (should (plist-get rg :discard)) (should (plist-get rg :sizer))))) (ert-deftest cgt-bid-svg-controls () "The full-SVG UI exposes Help and, when open, the overlay's buttons." - (let ((g (cg-bid-game)) (cg-bid-svg-ui t) (cg-bid-svg-fill t)) - (cg-bid--deal g 3) - (cg-put g :phase 'auction) (cg-put g :bidder 0) - (let ((rg (cdr (cg-bid--ui-svg g 1100 700)))) + (let ((g (card-games-bid-game)) (card-games-bid-svg-ui t) (card-games-bid-svg-fill t)) + (card-games-bid--deal g 3) + (card-games-put g :phase 'auction) (card-games-put g :bidder 0) + (let ((rg (cdr (card-games-bid--ui-svg g 1100 700)))) (should (plist-get rg :help)) (should-not (plist-get rg :help-close))) - (cg-put g :help-open t) - (let ((rg (cdr (cg-bid--ui-svg g 1100 700)))) + (card-games-put g :help-open t) + (let ((rg (cdr (card-games-bid--ui-svg g 1100 700)))) (should (plist-get rg :help-close)) (should (plist-get rg :help-classic)) (should (plist-get rg :help-quit))))) @@ -1798,29 +1798,29 @@ left a 15-card hand in play." (ert-deftest cgt-red-suit-boolean () "Two red suits compare equal by colour (the diamond/heart eq bug)." - (should (eq (cg-red-suit-p 2) (cg-red-suit-p 3))) ; both red -> eq - (should (eq (cg-red-suit-p 0) (cg-red-suit-p 1))) ; both black -> eq - (should-not (eq (cg-red-suit-p 2) (cg-red-suit-p 0))) ; red vs black + (should (eq (card-games-red-suit-p 2) (card-games-red-suit-p 3))) ; both red -> eq + (should (eq (card-games-red-suit-p 0) (card-games-red-suit-p 1))) ; both black -> eq + (should-not (eq (card-games-red-suit-p 2) (card-games-red-suit-p 0))) ; red vs black ;; a diamond may NOT sit on a heart in a house (both red) - (let ((g (cg-crap--deal (cg-crapette-game)))) - (aset (cg-get g :houses) 0 (list '(3 . 5))) ; 6 of hearts - (should-not (cg-crap--house-accepts g 0 '(2 . 4))) ; 5 of diamonds (both red) - (aset (cg-get g :houses) 0 (list '(0 . 5))) ; 6 of spades (black) - (should (cg-crap--house-accepts g 0 '(2 . 4))))) ; 5 of diamonds ok + (let ((g (card-games-crap--deal (card-games-crapette-game)))) + (aset (card-games-get g :houses) 0 (list '(3 . 5))) ; 6 of hearts + (should-not (card-games-crap--house-accepts g 0 '(2 . 4))) ; 5 of diamonds (both red) + (aset (card-games-get g :houses) 0 (list '(0 . 5))) ; 6 of spades (black) + (should (card-games-crap--house-accepts g 0 '(2 . 4))))) ; 5 of diamonds ok (ert-deftest cgt-ai-level-easy-crapette () "The easy Crapette AI does not rearrange houses, so a stuck card stays." - (let ((g (cg-crap--deal (cg-crapette-game)))) - (aset (cg-get g :reserve) 1 (list '(2 . 4))) - (aset (cg-get g :waste) 1 nil) (aset (cg-get g :hand) 1 nil) - (aset (cg-get g :reserve) 0 nil) (aset (cg-get g :waste) 0 nil) - (aset (cg-get g :found) 0 nil) - (aset (cg-get g :houses) 0 (list '(0 . 5) '(3 . 5))) - (aset (cg-get g :houses) 1 (list '(1 . 6))) - (dotimes (k 6) (aset (cg-get g :houses) (+ 2 k) (list '(2 . 6)))) - (cg-put g :turn 1) - (let ((cg-ai-level 'easy) (cg-crap--recording nil)) (cg-crap--ai-play g)) - (should (cg-crap--reserve g 1)))) + (let ((g (card-games-crap--deal (card-games-crapette-game)))) + (aset (card-games-get g :reserve) 1 (list '(2 . 4))) + (aset (card-games-get g :waste) 1 nil) (aset (card-games-get g :hand) 1 nil) + (aset (card-games-get g :reserve) 0 nil) (aset (card-games-get g :waste) 0 nil) + (aset (card-games-get g :found) 0 nil) + (aset (card-games-get g :houses) 0 (list '(0 . 5) '(3 . 5))) + (aset (card-games-get g :houses) 1 (list '(1 . 6))) + (dotimes (k 6) (aset (card-games-get g :houses) (+ 2 k) (list '(2 . 6)))) + (card-games-put g :turn 1) + (let ((card-games-ai-level 'easy) (card-games-crap--recording nil)) (card-games-crap--ai-play g)) + (should (card-games-crap--reserve g 1)))) (ert-deftest cgt-treatment-set () @@ -1830,10 +1830,10 @@ left a 15-card hand in play." (unwind-protect (progn (card-games-set-treatment 'text) - (should-not cg-sol-svg-cards) (should-not cg-crapette-svg-cards) + (should-not card-games-sol-svg-cards) (should-not card-games-crapette-svg-cards) (card-games-set-treatment 'full) - (should cg-sol-svg-cards) (should cg-bid-svg-ui) (should cg-gaps-svg-ui) + (should card-games-sol-svg-cards) (should card-games-bid-svg-ui) (should card-games-gaps-svg-ui) (card-games-set-treatment 'svg) - (should cg-sol-svg-cards) (should-not cg-bid-svg-ui)) + (should card-games-sol-svg-cards) (should-not card-games-bid-svg-ui)) (dolist (pr saved) (set (car pr) (cdr pr))) (setq card-games-treatment savedt))))