902 lines
42 KiB
EmacsLisp
902 lines
42 KiB
EmacsLisp
;;; card-games-crapette.el --- Russian Bank (Crapette), two-player vs AI -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2026 Corwin Brust
|
|
|
|
;; Author: Corwin Brust <corwin@bru.st>
|
|
;; Maintainer: Corwin Brust <corwin@bru.st>
|
|
;; Version: 1.0.91
|
|
;; Keywords: games
|
|
;; URL: https://code.bru.st/corwin/card-game.el
|
|
|
|
;; This program is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; Russian Bank -- also called Crapette -- is the competitive, two-player
|
|
;; ancestor of the single-player patience in `card-games-solitaire'. You (South)
|
|
;; play against one computer opponent (North).
|
|
;;
|
|
;; Two 52-card packs are used, one per player. In the centre sit eight
|
|
;; FOUNDATIONS, built up by suit from the Ace, and eight HOUSES, built
|
|
;; down in alternating colours; both are common ground either player may
|
|
;; build on. Each player also has a 13-card RESERVE (its top card face
|
|
;; up), a WASTE, and a face-down HAND. You win by getting rid of every
|
|
;; card in your reserve, hand, and waste.
|
|
;;
|
|
;; On your turn you make as many legal moves as you like:
|
|
;; - move the top of your reserve, your waste, or any house onto a
|
|
;; foundation or a house;
|
|
;; - move a whole SEQUENCE (a run built down in alternating colours)
|
|
;; from one house to another -- but only when there are enough empty
|
|
;; houses to have shifted it a card at a time; and
|
|
;; - LOAD a card from your reserve or waste onto the opponent's reserve
|
|
;; or waste when it is the same suit and one rank up or down.
|
|
;;
|
|
;; FOUNDATION PRIORITY and "STOP": a card that can go to a foundation must
|
|
;; be played there before anything else. If you build a house, load your
|
|
;; opponent, turn a card, or end your turn while a foundation play is
|
|
;; waiting, your opponent calls "STOP!" and your turn ends at once. The
|
|
;; piles that owe a foundation play are ringed in the hint colour. Set
|
|
;; `card-games-crapette-stops' to nil for a gentler assist mode that blocks the
|
|
;; slip with a reminder instead of ending your turn.
|
|
;;
|
|
;; When you can do no more, turn the top of your hand: if it fits
|
|
;; somewhere you keep going, otherwise it goes to your waste and your turn
|
|
;; ends.
|
|
;;
|
|
;; The AI observes foundation priority, empties its reserve first (the
|
|
;; bottleneck), prefers loading its cards onto you, and looks one move
|
|
;; ahead to rearrange the houses when that frees a stuck reserve or waste
|
|
;; card. It never breaks foundation priority, so in practice only you can
|
|
;; be "stopped".
|
|
|
|
;;; Code:
|
|
|
|
(require 'card-games-core)
|
|
(require 'card-games-svg)
|
|
|
|
(defconst card-games-crap-ranks
|
|
["A" "2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K"]
|
|
"Rank labels indexed 0 (Ace) .. 12 (King).")
|
|
|
|
(defcustom card-games-crapette-stops t
|
|
"How Russian Bank enforces foundation priority on your turn.
|
|
When non-nil (the competitive rule), the opponent calls \"stop\" and you
|
|
forfeit the rest of your turn if you make any play other than an
|
|
available foundation move. When nil, such a slip is simply blocked with
|
|
a reminder and costs you nothing -- a gentler assist mode for learning."
|
|
:type 'boolean :group 'card-games)
|
|
|
|
(defcustom card-games-crapette-svg-cards t
|
|
"When non-nil, draw the board with SVG cards on a graphical display.
|
|
Set to nil to force the plain-text board everywhere."
|
|
:type 'boolean :group 'card-games)
|
|
|
|
(defclass card-games-crapette-game (card-games-game)
|
|
((vname :initform "Russian Bank"))
|
|
"Two-player Russian Bank (Crapette): you (South) versus one AI opponent.")
|
|
|
|
(defvar-local card-games-crap--game nil
|
|
"The `card-games-crapette-game' played in the current buffer.")
|
|
|
|
(defvar card-games-crap--recording t
|
|
"When nil, `card-games-crap--snapshot' does not record (used during the AI turn).")
|
|
|
|
|
|
;;;; Cards
|
|
|
|
(defun card-games-crap--card-string (card)
|
|
"Return a short label for CARD, or a dot for an empty pile."
|
|
(if (null card) "·"
|
|
(concat (aref card-games-crap-ranks (cdr card)) (card-games-suit-glyph (car card)))))
|
|
|
|
(defun card-games-crap--red-p (card)
|
|
"Return non-nil when CARD is a red suit."
|
|
(and card (card-games-red-suit-p (car card))))
|
|
|
|
(defun card-games-crap--spec (card)
|
|
"Return the card-games-svg display spec (RANK-STRING . SUIT) for CARD, or nil."
|
|
(and card (cons (aref card-games-crap-ranks (cdr card)) (car card))))
|
|
|
|
(defun card-games-crap--deck ()
|
|
"Return one freshly shuffled 52-card deck."
|
|
(let (cards)
|
|
(dotimes (s 4) (dotimes (r 13) (push (cons s r) cards)))
|
|
(card-games-shuffle cards)))
|
|
|
|
(defun card-games-crap--top (pile)
|
|
"Return the top (last) card of PILE, or nil."
|
|
(car (last pile)))
|
|
|
|
|
|
;;;; Pile access
|
|
|
|
(defun card-games-crap--found (g i) "Foundation I of G." (aref (card-games-get g :found) i))
|
|
(defun card-games-crap--house (g i) "House I of G." (aref (card-games-get g :houses) i))
|
|
(defun card-games-crap--reserve (g p) "Player P's reserve list in G." (aref (card-games-get g :reserve) p))
|
|
(defun card-games-crap--waste (g p) "Player P's waste list in G." (aref (card-games-get g :waste) p))
|
|
(defun card-games-crap--hand (g p) "Player P's hand list in G." (aref (card-games-get g :hand) p))
|
|
|
|
|
|
;;;; Dealing
|
|
|
|
(defun card-games-crap--deal (game)
|
|
"Deal a fresh Russian Bank layout into GAME and return it."
|
|
(let ((d0 (card-games-crap--deck)) (d1 (card-games-crap--deck))
|
|
(found (make-vector 8 nil)) (houses (make-vector 8 nil))
|
|
(reserve (make-vector 2 nil)) (waste (make-vector 2 nil))
|
|
(hand (make-vector 2 nil)))
|
|
(dotimes (i 4) (aset houses i (list (pop d0))))
|
|
(dotimes (i 4) (aset houses (+ 4 i) (list (pop d1))))
|
|
(aset reserve 0 (cl-loop repeat 13 collect (pop d0)))
|
|
(aset reserve 1 (cl-loop repeat 13 collect (pop d1)))
|
|
(aset hand 0 d0)
|
|
(aset hand 1 d1)
|
|
(card-games-put game :found found)
|
|
(card-games-put game :houses houses)
|
|
(card-games-put game :reserve reserve)
|
|
(card-games-put game :waste waste)
|
|
(card-games-put game :hand hand)
|
|
(card-games-put game :turn 0)
|
|
(card-games-put game :cursor 0)
|
|
(card-games-put game :sel nil)
|
|
(card-games-put game :moves 0)
|
|
(card-games-put game :history nil)
|
|
(card-games-put game :winner nil)
|
|
(card-games-put game :message
|
|
"Your turn. Foundations first -- skip one and North calls STOP! Build the houses or load North.")
|
|
game))
|
|
|
|
|
|
;;;; Legality
|
|
|
|
(defun card-games-crap--found-accepts (game i card)
|
|
"Return non-nil when CARD may go onto foundation I of GAME."
|
|
(and card
|
|
(let ((f (card-games-crap--found game i)))
|
|
(if (null f)
|
|
(= (cdr card) 0) ; empty foundation takes an Ace
|
|
(let ((top (card-games-crap--top f)))
|
|
(and (= (car card) (car top))
|
|
(= (cdr card) (1+ (cdr top)))))))))
|
|
|
|
(defun card-games-crap--house-accepts (game i card)
|
|
"Return non-nil when CARD may go onto house I of GAME."
|
|
(and card
|
|
(let ((h (card-games-crap--house game i)))
|
|
(if (null h)
|
|
t ; empty house takes anything
|
|
(card-games-crap--builds-down-p (card-games-crap--top h) card)))))
|
|
|
|
(defun card-games-crap--builds-down-p (upper lower)
|
|
"Return non-nil when LOWER may sit on UPPER: one rank down, opposite colour."
|
|
(and upper lower
|
|
(= (cdr lower) (1- (cdr upper)))
|
|
(not (eq (card-games-crap--red-p upper) (card-games-crap--red-p lower)))))
|
|
|
|
(defun card-games-crap--load-accepts (pile-top card)
|
|
"Return non-nil when CARD may be loaded onto a pile whose top is PILE-TOP.
|
|
Loading needs the same suit and a rank one step up or down."
|
|
(and pile-top card
|
|
(= (car pile-top) (car card))
|
|
(= 1 (abs (- (cdr pile-top) (cdr card))))))
|
|
|
|
(defun card-games-crap--found-for (game card)
|
|
"Return the index of a 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 "<left>") #'card-games-crap-left)
|
|
(define-key map (kbd "<right>") #'card-games-crap-right)
|
|
(define-key map (kbd "<up>") #'card-games-crap-left)
|
|
(define-key map (kbd "<down>") #'card-games-crap-right)
|
|
(define-key map (kbd "RET") #'card-games-crap-act)
|
|
(define-key map [mouse-1] #'card-games-crap-mouse)
|
|
(define-key map "+" #'card-games-card-zoom-in)
|
|
(define-key map "=" #'card-games-card-zoom-in)
|
|
(define-key map "-" #'card-games-card-zoom-out)
|
|
(define-key map "0" #'card-games-card-zoom-reset)
|
|
(define-key map (kbd "SPC") #'card-games-crap-draw)
|
|
(define-key map "f" #'card-games-crap-found)
|
|
(define-key map "[" #'card-games-crap-hold-less)
|
|
(define-key map "]" #'card-games-crap-hold-more)
|
|
(define-key map "d" #'card-games-crap-draw)
|
|
(define-key map "e" #'card-games-crap-end)
|
|
(define-key map "u" #'card-games-crap-undo)
|
|
(define-key map "n" #'card-games-crap-new)
|
|
(define-key map "g" #'card-games-crap-redraw)
|
|
(define-key map "?" #'card-games-crap-help)
|
|
(define-key map "q" #'card-games-quit-to-menu)
|
|
map)
|
|
"Keymap for `card-games-crapette-mode'.")
|
|
|
|
(define-derived-mode card-games-crapette-mode special-mode "Crapette"
|
|
"Major mode for two-player Russian Bank (Crapette)."
|
|
(setq-local truncate-lines t)
|
|
(setq-local cursor-type card-games-cursor-type))
|
|
|
|
;;;###autoload
|
|
(defun card-games-crapette ()
|
|
"Play two-player Russian Bank (Crapette) against the computer."
|
|
(interactive)
|
|
(let ((buf (get-buffer-create "*Russian Bank (Crapette)*")))
|
|
(with-current-buffer buf
|
|
(card-games-crapette-mode)
|
|
(setq card-games-crap--game (card-games-crap--deal (card-games-crapette-game)))
|
|
(card-games-crap--redisplay))
|
|
(switch-to-buffer buf)))
|
|
|
|
;;;###autoload
|
|
(defalias 'card-games-russian-bank-duel #'card-games-crapette
|
|
"Alias for `card-games-crapette'.")
|
|
|
|
(provide 'card-games-crapette)
|
|
;;; card-games-crapette.el ends here
|