corwin/card-game.el
1
0
Fork 0
Code Issues Pull requests Projects Releases 1 Packages Wiki Activity Actions

placate checkdoc

Browse source
This commit is contained in:
Corwin Brust 2026-08-04 09:08:21 -05:00
parent 209ebdc02a
commit 99cf31930b
21 changed files with 506 additions and 416 deletions
Download patch file Download diff file Expand all files Collapse all files

60
card-games-bid-ui.el
View file

@ -40,7 +40,7 @@
;;;; Rendering
(defun card-games-bid--trick-card-for (game seat)
"Return the card SEAT has played to the current (or last) trick, or nil."
"Return the card GAME 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))))
@ -162,14 +162,14 @@ matches your Emacs theme."
: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."
"Whether to render 500 as one full-buffer SVG.
When non-nil (and on a graphical display), the table sits 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'."
"Whether the full-SVG UI fills the window and enlarges the South hand.
Re-fit on window changes. Only used when `card-games-bid-svg-ui' is set."
:type 'boolean :group 'card-games-svg)
(defcustom card-games-bid-card-scale 1.0
@ -233,7 +233,7 @@ Card size and fan step follow the dynamic `card-games-svg-card-width'."
(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.
"Draw GAME 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)))
@ -253,7 +253,7 @@ FS scales the name pill and its fonts."
(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."
"Draw GAME's 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))
@ -269,7 +269,7 @@ FS scales the name pill and its fonts."
: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."
"Draw GAME 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)))
@ -321,7 +321,7 @@ Folds the controls into the single action-button row (see
(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."
"Map a click at PX, PY to one of the N South-hand indices, 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))
@ -431,7 +431,7 @@ The treatment is chosen by `card-games-bid--treatment' and dispatched with
(goto-char (point-min))))
(defun card-games-bid--refresh ()
"Advance AI to the next human action, animating turns if enabled."
"Advance AI to the next human action, animating each turn 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))
@ -562,9 +562,9 @@ Type a short code such as 7H, 8NT, NL (case-insensitive)."
(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)."
"Advance to the next hand, or start a fresh game once one is 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
@ -581,7 +581,7 @@ progress must be played out (unlike the solitaire games)."
(card-games-bid--redisplay)))))
(defun card-games-bid-mouse (event)
"Handle a click in the 500 buffer (SVG-UI panels, table, or text)."
"Handle click EVENT 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))
@ -727,17 +727,17 @@ per-deal, so the hand always fits the table."
(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)."
"Draw STR as 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."
"Draw a faint horizontal divider on SVG from X1 to X2 at height Y."
(svg-line svg x1 y x2 y :stroke "#1b6b35" :stroke-width 1))
(defun card-games-bid--active-seat (game)
"Return the seat whose action is pending, or nil."
"Return the GAME 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))
@ -760,7 +760,7 @@ keep a minimum gutter so each rank index stays visible."
(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.
"Draw GAME's 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)))
@ -779,7 +779,7 @@ FS scales the drop-zone, the played cards, and their spread."
(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.
"Draw GAME South's hand on SVG (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)))
@ -816,7 +816,7 @@ Return (:hand (X0 STEP Y N SH))."
(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.
"Draw GAME's 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))))))
@ -857,11 +857,11 @@ nullo bids share the bottom row."
(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)."
"Return (X Y W H) for the double-width Pass button, from GX GY CW CH G (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.
"Draw GAME's full-height left status panel on SVG; 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."
@ -960,8 +960,9 @@ panel content grows with the window."
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."
"Draw GAME's full-height right log panel on SVG; return its regions.
The panel shows the emblem and scrolling story. 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
@ -1032,7 +1033,7 @@ FS scales the emblem and fonts; CCY aligns the divider with the compass."
: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."
"Draw GAME's phase-prompt banner on SVG 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)))
@ -1044,7 +1045,8 @@ FS scales the emblem and fonts; CCY aligns the divider with the compass."
(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."
"Draw the rules/legend overlay on SVG over the table; return its regions.
The overlay fills TX, TY, TW, TH; FS scales the text."
(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)))
@ -1181,7 +1183,7 @@ When `card-games-bid-svg-fill', size the canvas to fill the window."
(card-games-bid--redisplay)))
(defun card-games-bid-wheel (event)
"Scroll the message log when the wheel turns over the log area.
"Scroll the message log for wheel EVENT 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))
@ -1197,7 +1199,7 @@ Elsewhere, fall back to normal buffer scrolling."
(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."
"Return the bid at PX,PY within REGIONS RG, or nil."
(cl-some (lambda (e) (and (card-games-bid--in-rect px py (cdr e)) (car e)))
(plist-get rg :bids)))

82
card-games-bid.el
View file

@ -109,13 +109,13 @@
"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))
(defsubst card-games-bid-label (bid) "Return BID's label string." (nth 0 bid))
(defsubst card-games-bid-name (bid) "Return BID's full name." (nth 1 bid))
(defsubst card-games-bid-value (bid) "Return BID's score value." (nth 2 bid))
(defsubst card-games-bid-tricks (bid) "Return BID's trick target." (nth 3 bid))
(defsubst card-games-bid-trump (bid) "Return BID's trump suit." (nth 4 bid))
(defsubst card-games-bid-open-p (bid) "Return non-nil when BID is an open misère." (nth 5 bid))
(defsubst card-games-bid-nullo-p (bid) "Return non-nil when BID is a nullo (misère)." (eq (card-games-bid-trump bid) 'nullo))
;;;; Card power and trick logic
@ -170,7 +170,7 @@ must follow the led suit if able."
(or follow hand))))
(defun card-games-bid-sort-hand (hand trump)
"Return HAND sorted for display: trumps first (by power), then by suit."
"Return HAND sorted for display under TRUMP: trumps first, then by suit."
(sort (copy-sequence hand)
(lambda (a b)
(let* (( at (and (numberp trump)
@ -190,7 +190,7 @@ must follow the led suit if able."
(defun card-games-bid--display-key (card trump)
"Return an ascending sort key for CARD to group a hand for display.
"Return an ascending display sort key for CARD under TRUMP.
Trumps (and the Joker) sort first, strongest first; the remaining
suits are grouped spades, hearts, clubs, diamonds, high rank first."
(cond
@ -224,8 +224,8 @@ Trumps lead (strongest first), then each side suit runs high to low."
"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)
(defsubst card-games-bid--partner (seat) "Return SEAT's partner seat." (mod (+ seat 2) 4))
(defsubst card-games-bid--team (seat) "Return SEAT's team index (0 or 1)." (mod seat 2)) ; 0 -> team 0 (S/N), 1 -> team 1 (W/E)
(cl-defmethod card-games-bid--deal ((game card-games-bid-game) &optional dealer)
"Deal a fresh hand into GAME. DEALER defaults to East so South bids first."
@ -266,25 +266,25 @@ Trumps lead (strongest first), then each side suit runs high to low."
(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))
(defun card-games-bid--hand (game seat) "Return SEAT's hand in GAME." (aref (card-games-get game :hands) seat))
(defun card-games-bid--set-hand (game seat cards) "Set SEAT's hand in GAME to CARDS." (aset (card-games-get game :hands) seat cards))
;;;; Auction
(defun card-games-bid--legal-bids (game)
"Return the schedule entries that outbid the current high bid."
"Return GAME's schedule entries that outbid the current high bid."
(let ((hv (if (card-games-get game :high-bid)
(card-games-bid-value (card-games-get game :high-bid)) 0)))
(cl-remove-if-not (lambda (b) (> (card-games-bid-value b) hv)) card-games-bid-schedule)))
(defun card-games-bid--active-seats (game)
"Return the seats that have not passed."
"Return GAME's seats that have not passed."
(cl-loop for s below 4
unless (aref (card-games-get game :passed) s) collect s))
(defun card-games-bid--next-bidder (game from)
"Return the next non-passed seat after FROM, or nil if none."
"Return GAME's next non-passed seat after FROM, or nil if none."
(cl-loop for i from 1 to 4
for s = (mod (+ from i) 4)
unless (aref (card-games-get game :passed) s) return s))
@ -295,7 +295,7 @@ Trumps lead (strongest first), then each side suit runs high to low."
(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."
"Record GAME SEAT's action: BID is a schedule entry, or nil to pass."
(if bid
(progn (card-games-put game :high-bid bid)
(card-games-put game :high-bidder seat)
@ -320,7 +320,7 @@ Trumps lead (strongest first), then each side suit runs high to low."
(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."
"Set GAME's winning contract and move to the kitty phase."
(let* ((contractor (card-games-get game :high-bidder))
(bid (card-games-get game :high-bid)))
(card-games-put game :contractor contractor)
@ -344,7 +344,7 @@ Trumps lead (strongest first), then each side suit runs high to low."
;;;; 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."
"Have GAME SEAT discard CARDS (a list of 5) and start play."
(card-games-bid--set-hand game seat
(cl-set-difference (card-games-bid--hand game seat) cards
:test #'equal))
@ -362,24 +362,24 @@ Trumps lead (strongest first), then each side suit runs high to low."
;;;; 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."
"Return non-nil when GAME's current contract is a nullo/misère."
(let ((c (card-games-get game :contract))) (and c (card-games-bid-nullo-p c))))
(defun card-games-bid--sitter (game)
"Return the seat sitting out (contractor's partner) in a misère, else nil."
"Return GAME's seat sitting out (contractor's partner) in a misère, else nil."
(and (card-games-bid--misere-p game)
(card-games-bid--partner (card-games-get game :contractor))))
(defun card-games-bid--in-play-p (game seat)
"Return non-nil when SEAT takes part in the current hand's play."
"Return non-nil when SEAT takes part in GAME's current hand."
(not (eql seat (card-games-bid--sitter game))))
(defun card-games-bid--num-players (game)
"Return the number of seats playing to each trick (3 in misère, else 4)."
"Return GAME's seats playing to each trick (3 in misère, else 4)."
(if (card-games-bid--misere-p game) 3 4))
(defun card-games-bid--next-seat (game seat)
"Return the next in-play seat clockwise from SEAT."
"Return GAME's next in-play seat clockwise from SEAT."
(let ((n (mod (1+ seat) 4)))
(if (card-games-bid--in-play-p game n) n (mod (1+ n) 4))))
@ -387,7 +387,7 @@ Trumps lead (strongest first), then each side suit runs high to low."
;;;; 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."
"Have GAME SEAT play CARD into the current trick and advance."
(let* ((trump (card-games-bid-trump (card-games-get game :contract)))
(led (card-games-get game :led))
(lead-p (null (card-games-get game :trick))))
@ -412,7 +412,7 @@ Trumps lead (strongest first), then each side suit runs high to low."
(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."
"Choose the suit GAME SEAT nominates when the Joker leads under no-trump."
(let ((hand (card-games-bid--hand game seat)))
(if (card-games-bid--human-p seat)
(let ((ch (read-char-choice
@ -429,7 +429,7 @@ Trumps lead (strongest first), then each side suit runs high to low."
best)))))
(cl-defmethod card-games-bid--finish-trick ((game card-games-bid-game))
"Resolve the completed trick, award it, and set up the next."
"Resolve GAME's completed trick, award it, and set up the next."
(let* ((trump (card-games-bid-trump (card-games-get game :contract)))
(led (card-games-get game :led))
(plays (card-games-get game :trick))
@ -458,7 +458,7 @@ Trumps lead (strongest first), then each side suit runs high to low."
;;;; Scoring
(cl-defmethod card-games-bid--score-hand ((game card-games-bid-game))
"Score the completed hand per the Avondale schedule."
"Score GAME's completed hand per the Avondale schedule."
(let* ((bid (card-games-get game :contract))
(contractor (card-games-get game :contractor))
(cteam (card-games-bid--team contractor))
@ -509,7 +509,7 @@ Trumps lead (strongest first), then each side suit runs high to low."
(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).
"End GAME if a side has won (front door) or lost (back door).
Return the winning team, or nil. MADE and CTEAM describe the hand
just scored: a side wins only by reaching 500 on a made contract;
a side that sinks to -500 loses."
@ -554,7 +554,7 @@ a side that sinks to -500 loses."
(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)."
"Return HAND's trump cards under TRUMP (Joker and bowers included)."
(cl-remove-if-not
(lambda (c) (or (card-games-bid-joker-p c)
(and (numberp trump) (eq (card-games-bid-effective-suit c trump) trump))))
@ -591,7 +591,7 @@ a side that sinks to -500 loses."
best))
(defun card-games-bid--ai-bid-basic (game seat)
"Pick and record a bid (or pass) for AI SEAT using the basic estimate."
"Pick and record a bid (or pass) for GAME AI SEAT using the basic estimate."
(let* ((hand (card-games-bid--hand game seat))
(best (card-games-bid--ai-best-contract hand))
(trump (car best))
@ -608,14 +608,14 @@ a side that sinks to -500 loses."
(card-games-bid--auction-act game seat choice)))
(defun card-games-bid--ai-discard-basic (game seat)
"Discard SEAT's five weakest cards (basic)."
"Discard GAME SEAT's five weakest cards (basic)."
(let* ((trump (card-games-bid-trump (card-games-get game :contract)))
(sorted (card-games-bid-sort-hand (card-games-bid--hand game seat) trump))
(discard (last sorted 5)))
(card-games-bid--discard game seat discard)))
(defun card-games-bid--ai-play-positive (game seat)
"Trick-play for AI SEAT under a suit or no-trump contract (basic)."
"Trick-play for GAME AI SEAT under a suit or no-trump contract (basic)."
(let* ((trump (card-games-bid-trump (card-games-get game :contract)))
(led (card-games-get game :led))
(hand (card-games-bid--hand game seat))
@ -683,7 +683,7 @@ a side that sinks to -500 loses."
best))
(defun card-games-bid--ai-bid-smart (game seat)
"Pick and record a bid (or pass) for AI SEAT using the smart evaluation."
"Pick and record a bid (or pass) for GAME AI SEAT using the smart evaluation."
(let* ((hand (card-games-bid--hand game seat))
(best (card-games-bid--best-smart hand))
(trump (car best))
@ -700,7 +700,7 @@ a side that sinks to -500 loses."
(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."
"For GAME SEAT, discard to keep trumps and aces and void short suits for ruffs."
(let* ((trump (card-games-bid-trump (card-games-get game :contract)))
(hand (card-games-bid--hand game seat))
(cand '()))
@ -721,7 +721,7 @@ a side that sinks to -500 loses."
(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."
"Lead the lowest card of HAND's longest side suit, from LEGAL (TRUMP set)."
(let ((best-suit nil) (best-len -1))
(dotimes (s 4)
(unless (and (numberp trump) (= s trump))
@ -735,7 +735,7 @@ a side that sinks to -500 loses."
(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:
"Trick-play for GAME AI SEAT under a suit/NT contract with simple tactics:
declarer draws trumps and cashes aces; everyone wins as cheaply as
possible and never overtakes a partner who is already winning."
(let* ((trump (card-games-bid-trump (card-games-get game :contract)))
@ -779,25 +779,25 @@ possible and never overtakes a partner who is already winning."
;;; 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."
"Pick and record a bid for GAME AI SEAT per its policy."
(if (eq (card-games-bid--policy seat) 'smart)
(card-games-bid--ai-bid-smart game seat)
(card-games-bid--ai-bid-basic game seat)))
(cl-defmethod card-games-bid--ai-discard ((game card-games-bid-game) seat)
"Have AI SEAT exchange the kitty per its policy."
"Have GAME AI SEAT exchange the kitty per its policy."
(if (eq (card-games-bid--policy seat) 'smart)
(card-games-bid--ai-discard-smart game seat)
(card-games-bid--ai-discard-basic game seat)))
(cl-defmethod card-games-bid--ai-play ((game card-games-bid-game) seat)
"Choose and play a card for AI SEAT per its policy."
"Choose and play a card for GAME AI SEAT per its policy."
(cond ((card-games-bid--misere-p game) (card-games-bid--ai-play-misere game seat))
((eq (card-games-bid--policy seat) 'smart) (card-games-bid--ai-play-smart game seat))
(t (card-games-bid--ai-play-positive game seat))))
(defun card-games-bid--ai-play-misere (game seat)
"Trick-play for AI SEAT during a misère.
"Trick-play for GAME AI SEAT during a misère.
The contractor sheds its highest card that still loses (or ducks
lowest when leading); defenders simply play low."
(let* ((trump 'nullo)

51
card-games-bridge.el
View file

@ -96,7 +96,7 @@
(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)."
"Return the suit index HAND has most of (ties prefer majors, then spades)."
(let ((best 0) (bestn -1))
;; check in order hearts, diamonds, clubs, spades so spades win ties last
(dolist (s '(3 2 1 0))
@ -115,9 +115,9 @@
;;;; 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))
(defsubst card-games-bridge--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
(defsubst card-games-bridge--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
(defsubst card-games-bridge--side (s) "Return the partnership side (0 or 1) of seat S." (mod s 2))
(cl-defmethod card-games-bridge--deal ((game card-games-bridge-game))
"Deal a fresh Bridge hand into GAME, leaving it ready for the auction."
@ -147,12 +147,12 @@
game))
(defun card-games-bridge--high-bid (game)
"Return the highest (LEVEL . STRAIN) bid so far, or nil."
"Return GAME's highest (LEVEL . STRAIN) bid so far, or nil."
(cl-loop for (_s . call) in (card-games-get game :calls)
when (consp call) return call))
(defun card-games-bridge--high-bidder (game)
"Return the seat that made the highest bid, or nil."
"Return the GAME seat that made the highest bid, or nil."
(cl-loop for (s . call) in (card-games-get game :calls)
when (consp call) return s))
@ -176,7 +176,7 @@
(card-games-bridge--call> call high))))))
(defun card-games-bridge--apply-call (game seat call)
"Record CALL by SEAT and update doubling state."
"Record CALL by SEAT in GAME and update doubling state."
(card-games-put game :calls (cons (cons seat call) (card-games-get game :calls)))
(pcase call
('double (card-games-put game :doubled 1))
@ -185,7 +185,7 @@
(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.
"Return non-nil when GAME's auction has ended.
Sets up the contract (or a pass-out) as a side effect."
(let* ((calls (card-games-get game :calls)) (n (length calls)))
(cond
@ -201,7 +201,7 @@ Sets up the contract (or a pass-out) as a side effect."
(t nil))))
(defun card-games-bridge--establish-contract (game)
"Set the contract, declarer, and start of play from the finished auction."
"Set GAME's contract, declarer, and start of play from the auction."
(let* ((bid (card-games-bridge--high-bid game))
(side (card-games-bridge--side (card-games-bridge--high-bidder game)))
(strain (cdr bid))
@ -240,12 +240,12 @@ Sets up the contract (or a pass-out) as a side effect."
(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."
"Return the suit led to GAME's current trick, or nil."
(let ((tr (card-games-get game :trick)))
(and tr (car (cdr (car (last tr)))))))
(defun card-games-bridge--legal-play-p (game seat card)
"Return non-nil when SEAT may play CARD now (follow suit if able)."
"Return non-nil when SEAT may play CARD in GAME now (follow suit if able)."
(let ((hand (card-games-bridge--hand game seat)) (led (card-games-bridge--led-suit game)))
(and (member card hand)
(or (null led)
@ -253,12 +253,12 @@ Sets up the contract (or a pass-out) as a side effect."
(not (cl-some (lambda (c) (= (car c) led)) hand))))))
(defun card-games-bridge--legal-plays (game seat)
"Return SEAT's legal cards now."
"Return SEAT's legal cards in GAME now."
(cl-remove-if-not (lambda (c) (card-games-bridge--legal-play-p game seat c))
(card-games-bridge--hand game seat)))
(defun card-games-bridge--trick-winner (plays trump)
"Return the winning seat of complete PLAYS ((SEAT . CARD), play order)."
"Return the winning seat of complete PLAYS, given TRUMP ((SEAT . CARD) order)."
(let ((best (car plays)))
(dolist (p (cdr plays))
(let ((bc (cdr best)) (pc (cdr p)))
@ -268,7 +268,7 @@ Sets up the contract (or a pass-out) as a side effect."
(car best)))
(defun card-games-bridge--play-card (game seat card)
"Have SEAT play CARD; resolve and score the trick when it completes."
"Have SEAT play CARD in GAME; resolve and score the trick when complete."
(card-games-bridge--set-hand game seat (remove card (card-games-bridge--hand game seat)))
(card-games-put game :trick (cons (cons seat card) (card-games-get game :trick)))
;; expose the dummy after the opening lead
@ -361,7 +361,7 @@ vulnerability, and TRICKS the declarer side's trick count. Keys:
;;;; 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."
"Return a call for GAME AI SEAT from a small natural system."
(let* ((hand (card-games-bridge--hand game seat)) (hcp (card-games-bridge--hcp hand))
(high (card-games-bridge--high-bid game)) (hb (card-games-bridge--high-bidder game))
(ours (and high (= (card-games-bridge--side hb) (card-games-bridge--side seat)))))
@ -398,7 +398,7 @@ vulnerability, and TRICKS the declarer side's trick count. Keys:
;;;; 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."
"Return a card for GAME AI SEAT: win cheaply or shed low."
(let* ((legal (card-games-bridge--legal-plays game seat))
(trump (card-games-bridge--trump game)) (trick (card-games-get game :trick)))
(if (null trick)
@ -422,7 +422,7 @@ vulnerability, and TRICKS the declarer side's trick count. Keys:
(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."
"Return the GAME seats the human controls during play."
(let ((decl (card-games-get game :declarer)))
(cond ((null decl) nil)
((= decl 0) '(0 2)) ; South declares: play hand + dummy
@ -434,7 +434,7 @@ vulnerability, and TRICKS the declarer side's trick count. Keys:
(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."
"Advance GAME's AI plays until a human seat must act or the deal ends."
(let ((guard 0))
(while (and (eq (card-games-get game :phase) 'play)
(card-games-bridge--auto-seat-p game (card-games-get game :turn))
@ -444,7 +444,7 @@ vulnerability, and TRICKS the declarer side's trick count. Keys:
(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."
"Advance GAME's auction through AI seats until South must call or it ends."
(let ((guard 0))
(while (and (eq (card-games-get game :phase) 'auction) (/= (card-games-get game :bidder) 0)
(< guard 40))
@ -471,7 +471,7 @@ vulnerability, and TRICKS the declarer side's trick count. Keys:
(apply #'concat (nreverse out))))
(defun card-games-bridge--auction-string (game)
"Return a compact record of the auction so far."
"Return a compact record of GAME's auction so far."
(let ((calls (reverse (card-games-get game :calls))) (out '()))
(dolist (sc calls)
(push (format "%s:%s" (aref card-games-bridge-seat-names (car sc))
@ -490,7 +490,7 @@ vulnerability, and TRICKS the declarer side's trick count. Keys:
(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)."
"Return an SVG row for CARDS with CURSOR and HINTS, clickable via REGION-TAG."
(card-games-svg-hand-image (mapcar #'card-games-bridge--spec cards)
:cursor cursor :hints hints
:overlap (if (> (length cards) 11)
@ -498,7 +498,7 @@ vulnerability, and TRICKS the declarer side's trick count. Keys:
: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."
"Draw up to three overlapped backs on SVG at X, Y for a hand of N cards."
(let ((k (min (max n 0) 3)) (xx x))
(dotimes (_ k) (card-games-svg-card svg xx y :down t) (setq xx (+ xx 16)))))
@ -678,12 +678,13 @@ vulnerability, and TRICKS the declarer side's trick count. Keys:
(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."
"Apply click ACTION on G's hand: select that card and play it."
(pcase action
(`(hand . ,i) (card-games-put g :cursor i) (card-games-bridge-play))
(_ (cl-call-next-method))))
(defun card-games-bridge--redisplay ()
"Redraw the current Bridge buffer."
(let ((game card-games-bridge--game) (inhibit-read-only t))
(setq card-games-current-game game card-games-redisplay-function #'card-games-bridge--redisplay)
(setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))
@ -720,7 +721,7 @@ vulnerability, and TRICKS the declarer side's trick count. Keys:
(card-games-bridge--redisplay)))
(defun card-games-bridge--after-call (g)
"Resolve end-of-auction and run AI after South calls in G."
"Resolve the end of the auction and run AI after South's call in G."
(unless (card-games-bridge--auction-done-p g)
(card-games-bridge--run-auction g))
(when (eq (card-games-get g :phase) 'play) (card-games-bridge--run-play g))
@ -762,7 +763,7 @@ vulnerability, and TRICKS the declarer side's trick count. Keys:
;;;; Play commands
(defun card-games-bridge--act-hand (g)
"Return the hand the cursor currently indexes (the seat to act)."
"Return the hand G's cursor currently indexes (the seat to act)."
(let ((act (if (memq (card-games-get g :turn) (card-games-bridge--controls g)) (card-games-get g :turn) 0)))
(card-games-bridge--sort (card-games-bridge--hand g act))))

44
card-games-crapette.el
View file

@ -193,14 +193,14 @@ Loading needs the same suit and a rank one step up or down."
(= 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."
"Return the index of a GAME foundation that would accept CARD, or nil."
(cl-loop for i below 8 when (card-games-crap--found-accepts game i card) return i))
;;;; Sequenced house moves
(defun card-games-crap--house-run (game i)
"Return the movable top run of house I as a list, bottom-to-top.
"Return the movable top run of GAME house I as a list, bottom-to-top.
The run is the longest sequence of cards at the top of the house that is
built down in alternating colours."
(let ((rev (reverse (card-games-crap--house game i)))) ; top-first
@ -218,7 +218,7 @@ built down in alternating colours."
(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.
"Return how many cards may be moved as a group onto GAME house DEST-I.
With F empty houses you may relay F+1 cards onto a non-empty house, or
F onto an empty house (the destination itself cannot serve as a relay)."
(let ((free (card-games-crap--free-houses game)))
@ -291,7 +291,7 @@ and nil when nothing fits."
(_ 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."
"Return non-nil when player P may move CARD from FROM to TO in GAME."
(pcase (car to)
('found (card-games-crap--found-accepts game (cdr to) card))
('house (card-games-crap--house-accepts game (cdr to) card))
@ -342,7 +342,7 @@ and nil when nothing fits."
(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.
"Move the top card of FROM onto TO in GAME for player P.
Return non-nil when the move was legal and performed."
(let ((card (card-games-crap--spot-top game from)))
(when (and card (card-games-crap--source-p from p) (card-games-crap--dest-ok game from to card p))
@ -355,9 +355,10 @@ Return non-nil when the move was legal and performed."
(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)."
`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)))
@ -366,7 +367,7 @@ success, `space' when a sequence is too long for the empty houses)."
;;;; Turn logic
(defun card-games-crap--forced (game p)
"Return the source spots of GAME whose top card must go to a foundation."
"Return player P's GAME spots whose top card must go to a foundation."
(let (out)
(dolist (spot (card-games-crap--sources game p))
(let ((card (card-games-crap--spot-top game spot)))
@ -374,14 +375,14 @@ success, `space' when a sequence is too long for the empty houses)."
(nreverse out)))
(defun card-games-crap--card-playable (game p card)
"Return non-nil when CARD has any legal destination for player P."
"Return non-nil when CARD has a legal destination in GAME for player P."
(or (card-games-crap--found-for game card)
(cl-loop for i below 8 thereis (card-games-crap--house-accepts game i card))
(card-games-crap--load-accepts (card-games-crap--top (card-games-crap--reserve game (- 1 p))) card)
(card-games-crap--load-accepts (card-games-crap--top (card-games-crap--waste game (- 1 p))) card)))
(defun card-games-crap--won-p (game p)
"Return non-nil when player P has emptied reserve, hand, and waste."
"Return non-nil when GAME player P has emptied reserve, hand, and waste."
(and (null (card-games-crap--reserve game p))
(null (card-games-crap--hand game p))
(null (card-games-crap--waste game p))))
@ -401,7 +402,7 @@ success, `space' when a sequence is too long for the empty houses)."
(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."
"Pass GAME's turn from you to the AI, run it, and return control to you."
(unless (card-games-get game :winner)
(card-games-put game :sel nil)
(card-games-put game :turn 1)
@ -412,8 +413,9 @@ success, `space' when a sequence is too long for the empty houses)."
(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."
"Enforce GAME's foundation priority, per `card-games-crapette-stops'.
Call \"stop\" or block; return non-nil when the offending action must be
abandoned by its caller."
(when (card-games-crap--forced game 0)
(if card-games-crapette-stops
(let ((note "North calls STOP -- you must play to a foundation first!"))
@ -428,14 +430,14 @@ Return non-nil when the offending action must be abandoned by its caller."
;;;; The AI opponent (player 1)
(defun card-games-crap--ai-found-move (game)
"Return an AI (SOURCE . FOUNDATION) foundation move, or nil."
"Return an AI (SOURCE . FOUNDATION) foundation move for GAME, or nil."
(cl-loop for spot in (card-games-crap--sources game 1)
for card = (card-games-crap--spot-top game spot)
for fi = (and card (card-games-crap--found-for game card))
when fi return (cons spot (cons 'found fi))))
(defun card-games-crap--ai-unload-move (game)
"Return the best AI (SOURCE . DEST) move that empties its reserve or waste.
"Return GAME's best AI (SOURCE . DEST) move that empties reserve or waste.
Emptying the RESERVE is the goal of the game, so it outscores the waste;
LOADING a card onto you (which also burdens you) outscores building a
house. Every such move reduces the AI's own cards, so its turn ends."
@ -458,7 +460,7 @@ house. Every such move reduces the AI's own cards, so its turn ends."
best))
(defun card-games-crap--ai-enabling-move (game)
"Return a single-card house->house move that unlocks an unload, or nil.
"Return a GAME single-card house->house move that unlocks an unload, or nil.
This is the crafty bit: when the AI cannot place its reserve or waste top
anywhere, it looks one move ahead for a house rearrangement that would
make such a placement legal. It only fires when no direct unload exists,
@ -481,7 +483,7 @@ and only when the shuffle genuinely opens one, so the turn still ends."
nil)))
(defun card-games-crap--ai-greedy-move (game)
"A simple first-fit unload move -- the `easy' AI.
"A simple first-fit unload move for GAME -- the `easy' AI.
Empties the reserve or waste top onto the first legal spot, without the
scoring or the house-rearranging lookahead of the tougher levels."
(catch 'm
@ -569,7 +571,7 @@ scoring or the house-rearranging lookahead of the tougher levels."
(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.
"Return a line showing G's picked-up house run, marking the held top cards.
Empty when nothing (or a single card) is held from a house."
(let ((sel (card-games-get g :sel)))
(if (not (and sel (eq (car sel) 'house)))
@ -675,7 +677,7 @@ REGIONS maps clicked rectangles to (TYPE . INDEX) spots."
rev))))
(defun card-games-crap-mouse (event)
"Handle a click on the SVG board: select that pile and act on it."
"Handle click EVENT on the SVG board: select that pile and act on it."
(interactive "e")
(let* ((g card-games-crap--game) (spot (card-games-mouse-action event)))
(when spot
@ -720,7 +722,7 @@ REGIONS maps clicked rectangles to (TYPE . INDEX) spots."
(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)."
"Return non-nil when it is your move in G (and warn otherwise)."
(cond ((card-games-get g :winner)
(card-games-crap--msg g "The game is over -- press n for a new game.") nil)
((/= (card-games-get g :turn) 0)

38
card-games-cribbage.el
View file

@ -75,7 +75,7 @@
tot))
(defun card-games-crib--count-runs (cards)
"Return points for all runs of three or more in CARDS (with multiplicity)."
"Return points for every run of three or more in CARDS (with multiplicity)."
(let ((cnt (make-vector 13 0)) (total 0) (r 0))
(dolist (c cards) (aset cnt (cdr c) (1+ (aref cnt (cdr c)))))
(while (< r 13)
@ -96,7 +96,7 @@ A crib (IS-CRIB) flush must include the starter."
(t 4))))
(defun card-games-crib--nobs (hand starter)
"Return 1 when HAND holds the Jack of the STARTER's suit, else 0."
"Return 1 when HAND has the Jack of the STARTER's suit, else 0."
(if (cl-find-if (lambda (c) (and (= (cdr c) 10) (= (car c) (car starter)))) hand)
1 0))
@ -135,12 +135,12 @@ TOTAL is the running count after the play."
;;;; 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))
(defsubst card-games-crib--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
(defsubst card-games-crib--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
(defsubst card-games-crib--play (game s) "Return seat S's pegging-play cards in GAME." (aref (card-games-get game :play) s))
(defsubst card-games-crib--set-play (game s v) "Set seat S's pegging-play cards in GAME to V." (aset (card-games-get game :play) s v))
(defun card-games-crib--who (s) (if (= s 0) "You" "Computer"))
(defun card-games-crib--who (s) "Return the display name of seat S." (if (= s 0) "You" "Computer"))
(cl-defmethod card-games-crib--deal ((game card-games-cribbage-game))
"Deal a fresh Cribbage hand into GAME."
@ -160,7 +160,7 @@ TOTAL is the running count after the play."
game))
(defun card-games-crib--add (game s pts)
"Add PTS to seat S and end the game if it reaches the target."
"Add PTS to GAME seat S and end the game if it reaches the target."
(when (> pts 0)
(aset (card-games-get game :scores) s (+ (aref (card-games-get game :scores) s) pts))
(when (>= (aref (card-games-get game :scores) s) card-games-cribbage-target)
@ -168,7 +168,7 @@ TOTAL is the running count after the play."
(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)."
"Return the two cards GAME seat S should lay away (keep the best four)."
(let* ((hand (card-games-crib--hand game s)) (best nil) (bestv -1))
(dolist (combo (card-games-rummy--combinations hand 4))
(let ((v (card-games-crib--score-show combo '(0 . 0)))) ; rough: no starter
@ -176,7 +176,7 @@ TOTAL is the running count after the play."
(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."
"Cut GAME's starter and begin the pegging round."
(let* ((deck (card-games-get game :deck))
(starter (nth (random (length deck)) deck))
(dealer (card-games-get game :dealer)))
@ -196,12 +196,12 @@ TOTAL is the running count after the play."
(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."
"Return GAME seat S's play-cards that fit under 31."
(cl-remove-if (lambda (c) (> (card-games-crib--val c) (- 31 (card-games-get game :total))))
(card-games-crib--play game s)))
(defun card-games-crib--peg-play (game s card)
"Seat S plays CARD into the pegging round and pegs any points."
"Have GAME seat S play CARD into the pegging round, pegging any points."
(card-games-crib--set-play game s (cl-remove card (card-games-crib--play game s) :test #'equal :count 1))
(card-games-put game :seq (cons card (card-games-get game :seq)))
(card-games-put game :total (+ (card-games-get game :total) (card-games-crib--val card)))
@ -218,18 +218,18 @@ TOTAL is the running count after the play."
(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."
"Reset GAME's running count; the player after the last to play leads."
(card-games-put game :seq nil)
(card-games-put game :total 0)
(card-games-put game :go nil)
(card-games-put game :pturn (- 1 (card-games-get game :last-player))))
(defun card-games-crib--peg-over-p (game)
"Return non-nil when both players have played out their cards."
"Return non-nil when both GAME players have played out their cards."
(and (null (card-games-crib--play game 0)) (null (card-games-crib--play game 1))))
(defun card-games-crib--peg-go (game s)
"Handle seat S being unable to play (a go)."
"Handle GAME seat S being unable to play (a go)."
(let ((other (- 1 s)))
(if (card-games-crib--legal game other)
(card-games-put game :pturn other) ; opponent plays on
@ -241,7 +241,7 @@ TOTAL is the running count after the play."
(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."
"Have GAME AI seat S play its best pegging card or declare a go."
(let ((legal (card-games-crib--legal game s)))
(if (null legal) (card-games-crib--peg-go game s)
(let ((best (car legal)) (bestv -1))
@ -256,7 +256,7 @@ TOTAL is the running count after the play."
(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."
"Run GAME's AI pegging until your turn or the round ends."
(let ((guard 0))
(while (and (eq (card-games-get game :phase) 'play) (not (card-games-crib--peg-over-p game))
(/= (card-games-get game :pturn) 0) (< guard 200))
@ -271,7 +271,7 @@ TOTAL is the running count after the play."
(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."
"Count GAME's hands and crib, then set up the next deal."
(let* ((starter (card-games-get game :starter))
(dealer (card-games-get game :dealer)) (pone (- 1 dealer))
(h-pone (card-games-crib--hand game pone)) (h-dealer (card-games-crib--hand game dealer))
@ -404,12 +404,14 @@ TOTAL is the running count after the play."
(_ (cl-call-next-method))))
(defun card-games-crib--redisplay ()
"Redraw the current Cribbage buffer."
(let ((game card-games-crib--game) (inhibit-read-only t))
(setq card-games-current-game game card-games-redisplay-function #'card-games-crib--redisplay)
(setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
(defun card-games-crib--cur-list (g)
"Return seat 0's current card list in G (pegging plays or hand)."
(if (eq (card-games-get g :phase) 'play) (card-games-crib--play g 0) (card-games-crib--hand g 0)))
(defun card-games-crib-left ()

29
card-games-eights.el
View file

@ -55,7 +55,7 @@
(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))))
(defsubst card-games-eights-red-p (card) "Return non-nil when CARD is red." (and card (card-games-red-suit-p (car card))))
(defun card-games-eights--value (card)
"Return the scoring value of CARD held at the end of a hand."
@ -74,9 +74,9 @@
((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)))
(defsubst card-games-eights--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
(defsubst card-games-eights--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
(defsubst card-games-eights--top (game) "Return the top card of GAME's discard pile." (car (card-games-get game :discard)))
(cl-defmethod card-games-eights--deal ((game card-games-eights-game))
"Deal a fresh Crazy Eights hand into GAME."
@ -104,18 +104,18 @@
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."
"Return non-nil when CARD may be played onto GAME's discard now."
(or (= (cdr card) card-games-eights--wild)
(= (car card) (card-games-get game :suit))
(= (cdr card) (cdr (card-games-eights--top game)))))
(defun card-games-eights--legal-moves (game s)
"Return the cards in seat S's hand that may be played now."
"Return the cards in GAME seat S's hand that may be played now."
(cl-remove-if-not (lambda (c) (card-games-eights--legal-p game c))
(card-games-eights--hand game s)))
(defun card-games-eights--best-suit (game s)
"Return the suit seat S holds most of (ignoring eights)."
"Return the suit most common in GAME seat S's hand (ignoring eights)."
(let ((counts (make-vector 4 0)))
(dolist (c (card-games-eights--hand game s))
(unless (= (cdr c) card-games-eights--wild)
@ -125,7 +125,7 @@
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."
"Have GAME seat S play CARD; SUIT names the next suit for a wild eight."
(card-games-eights--set-hand game s (remove card (card-games-eights--hand game s)))
(card-games-put game :discard (cons card (card-games-get game :discard)))
(card-games-put game :suit (if (= (cdr card) card-games-eights--wild)
@ -137,7 +137,7 @@
(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.
"Move one card from GAME's stock to seat S's hand, recycling if needed.
Return the drawn card, or nil when none is available."
(when (and (null (card-games-get game :stock)) (cdr (card-games-get game :discard)))
(let ((top (car (card-games-get game :discard))))
@ -151,7 +151,7 @@ Return the drawn card, or nil when none is available."
card))))
(cl-defmethod card-games-eights--finish ((game card-games-eights-game) winner)
"Record WINNER going out and score the other hands against them."
"Record WINNER going out in GAME and score the other hands against them."
(let ((sum 0))
(dotimes (s (card-games-get game :nplayers))
(unless (= s winner)
@ -165,7 +165,7 @@ Return the drawn card, or nil when none is available."
(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."
"Take GAME seat S's whole turn: play if able, else draw then play or pass."
(let ((moves (card-games-eights--legal-moves game s)))
(unless moves
;; draw up to a small limit looking for a play
@ -184,7 +184,7 @@ Return the drawn card, or nil when none is available."
(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."
"Advance GAME's AI seats until the human's turn or the hand ends."
(while (and (eq (card-games-get game :phase) 'play)
(/= (card-games-get game :turn) 0)
(< (card-games-get game :passes) (card-games-get game :nplayers)))
@ -193,7 +193,7 @@ Return the drawn card, or nil when none is available."
(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."
"End a GAME hand in which everyone passed; lowest hand value wins."
(let ((best 0) (bestv most-positive-fixnum))
(dotimes (s (card-games-get game :nplayers))
(let ((v (apply #'+ (mapcar #'card-games-eights--value (card-games-eights--hand game s)))))
@ -323,6 +323,7 @@ Return the drawn card, or nil when none is available."
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
(defun card-games-eights--cursor-card (game)
"Return the card under GAME's cursor in the human hand."
(nth (card-games-get game :cursor) (card-games-eights--hand game 0)))
(defun card-games-eights-left ()
@ -340,7 +341,7 @@ Return the drawn card, or nil when none is available."
(card-games-eights--redisplay)))
(defun card-games-eights--choose-suit (game)
"Return a suit the human names for a wild eight."
"Return a suit the human names for a wild eight in GAME."
(if noninteractive (card-games-eights--best-suit game 0)
(let* ((names (mapcar (lambda (i) (cons (aref card-games-suit-names i) i)) '(0 1 2 3)))
(pick (completing-read "Name the suit: " (mapcar #'car names) nil t)))

37
card-games-gaps.el
View file

@ -86,25 +86,25 @@ Subclasses set the head rank and build direction by overriding
:abstract t)
(cl-defgeneric card-games-gaps--head (game)
"Return the rank index that anchors the head (left) of each row.")
"Return the rank index that anchors the head (left) of each row in GAME.")
(cl-defgeneric card-games-gaps--step (game)
"Return the per-column rank increment: +1 ascending, -1 descending.")
"Return GAME's per-column rank increment: +1 ascending, -1 descending.")
(cl-defgeneric card-games-gaps--vname (game)
"Return the human-readable variant name for GAME.")
(defclass card-games-montana-game (card-games-gaps-game)
((name :initform "Montana"))
"Gaps / Montana: a Two anchors the head; rows build up 2..K.")
(cl-defmethod card-games-gaps--head ((_ card-games-montana-game)) 0)
(cl-defmethod card-games-gaps--step ((_ card-games-montana-game)) 1)
(cl-defmethod card-games-gaps--vname ((_ card-games-montana-game)) "Gaps (Montana)")
(cl-defmethod card-games-gaps--head ((_ card-games-montana-game)) "Montana anchors its head on the Two (rank 0)." 0)
(cl-defmethod card-games-gaps--step ((_ card-games-montana-game)) "Montana builds up, +1 per column." 1)
(cl-defmethod card-games-gaps--vname ((_ card-games-montana-game)) "Return Montana's display name." "Gaps (Montana)")
(defclass card-games-acre-game (card-games-gaps-game)
((name :initform "Hell's Half-Acre"))
"Hell's Half-Acre: a King anchors the head; rows build down K..2.")
(cl-defmethod card-games-gaps--head ((_ card-games-acre-game)) 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")
(cl-defmethod card-games-gaps--head ((_ card-games-acre-game)) "Hell's Half-Acre anchors its head on the King (rank 11)." 11)
(cl-defmethod card-games-gaps--step ((_ card-games-acre-game)) "Hell's Half-Acre builds down, -1 per column." -1)
(cl-defmethod card-games-gaps--vname ((_ card-games-acre-game)) "Return Hell's Half-Acre's display name." "Hell's Half-Acre")
(defalias 'card-games-gaps--shuffle 'card-games-shuffle)
@ -250,7 +250,7 @@ other fillable gap, or nil if nothing fits."
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."
"Return the length of GAME's correct run at the head of row R of BOARD."
(let ((row (aref board r))
(head (card-games-gaps--head game))
(step (card-games-gaps--step game))
@ -356,14 +356,15 @@ where each key hint is itself the clickable button."
(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'."
"Whether to render the gaps board as one full-buffer SVG.
When non-nil (and on a graphical display), the board fills the window with a
status/controls panel down the left side, mirroring the 500 full-SVG UI.
Toggle with `v'."
:type 'boolean :group 'card-games-svg)
(defcustom card-games-gaps-svg-fill t
"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."
"Whether the full-SVG gaps UI fills the window and re-fits on size changes.
Only used when `card-games-gaps-svg-ui' is enabled."
:type 'boolean :group 'card-games-svg)
(defun card-games-gaps--insert-graphical (game)
@ -401,7 +402,7 @@ window changes. Only used when `card-games-gaps-svg-ui' is enabled."
(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."
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)
@ -617,17 +618,17 @@ SVG board (pixel) or the text grid (text property)."
(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."
"Draw STR as an all-caps, letter-spaced section label on SVG at X, Y, SIZE."
(svg-text svg (upcase str) :x (round x) :y (round y) :font-size (round size)
:fill "#8fc79b" :text-anchor "start" :font-family card-games-svg-font-family
:font-weight "bold" :letter-spacing "2"))
(defun card-games-gaps--ui-divider (svg x1 x2 y)
"Draw a faint horizontal divider on SVG."
"Draw a faint horizontal divider on SVG from X1 to X2 at height Y."
(svg-line svg x1 y x2 y :stroke "#1b6b35" :stroke-width 1))
(defun card-games-gaps--draw-panel (svg game h lpw fs)
"Draw the left status/controls panel (width LPW, scale FS).
"Draw GAME's left status/controls panel on SVG (height H, width LPW, scale FS).
Return a plist of clickable control regions."
(let* ((regions nil)
(F (lambda (n) (round (* n fs))))

57
card-games-handfoot.el
View file

@ -110,12 +110,12 @@
(<= (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)))
(defun card-games-hf--book-complete-p (cards) "Return non-nil when CARDS form a complete (7+ card) book." (>= (length cards) 7))
(defun card-games-hf--book-clean-p (cards) "Return non-nil when CARDS is a clean book (no wilds)." (not (cl-some #'card-games-hf--wild-p cards)))
;;;; Setup
(defun card-games-hf--team (game s) (mod s (card-games-get game :nteams)))
(defun card-games-hf--team (game s) "Return the team index of seat S in GAME." (mod s (card-games-get game :nteams)))
(cl-defmethod card-games-hf--deal ((game card-games-handfoot-game))
"Deal a fresh round into GAME."
@ -145,11 +145,11 @@
(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--books (game team) "Return TEAM's books in GAME." (aref (card-games-get game :books) team))
(defun card-games-hf--set-books (game team v) "Set TEAM's books in GAME to V." (aset (card-games-get game :books) team v))
(defun card-games-hf--down-p (game team)
"Return non-nil when TEAM has met this round's go-down minimum."
"Return non-nil when GAME TEAM has met this round's go-down minimum."
(aref (card-games-get game :down) team))
(defun card-games-hf--min-for-round (game)
@ -159,7 +159,7 @@
(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.
"Move GAME seat S's red threes to its team pile, drawing replacements.
Return the number collected."
(let ((team (card-games-hf--team game s)) (moved 0) (again t))
(while again
@ -179,13 +179,13 @@ Return the number collected."
moved))
(defun card-games-hf--take-foot (game s)
"Move seat S onto its foot, collecting any red threes it holds."
"Move GAME seat S onto its foot, collecting any red threes it has."
(aset (card-games-get game :stage) s 1)
(card-games-rummy--set-hand game s (aref (card-games-get game :feet) s))
(card-games-hf--collect-red-threes game s))
(defun card-games-hf--pickup-eligible (game s)
"Return non-nil when seat S may pick up the discard pile.
"Return non-nil when GAME seat S may pick up the discard pile.
That needs two natural cards in hand matching a meldable top discard."
(let ((top (card-games-rummy--top game)))
(and top (not (card-games-hf--wild-p top)) (not (card-games-hf--three-p top))
@ -195,10 +195,10 @@ That needs two natural cards in hand matching a meldable top discard."
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."
"Have GAME seat S pick up the discard pile, melding its top card.
Take the top card plus up to `card-games-handfoot-pickup-count' - 1 cards
beneath it into hand, melding the top with two matching naturals. Return
the top card, or nil if ineligible."
(when (card-games-hf--pickup-eligible game s)
(let* ((pile (card-games-get game :discard)) (top (car pile)) (rank (cdr top))
(team (card-games-hf--team game s)) (books (card-games-hf--books game team))
@ -257,7 +257,7 @@ Naturals group by rank (each rank needs two), and wilds fill the groups."
(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.
"Lay CARDS as GAME seat S's initial meld, meeting the round minimum.
Return non-nil when the team goes down."
(let* ((books (card-games-hf--partition-books cards))
(team (card-games-hf--team game s)))
@ -274,7 +274,7 @@ Return non-nil when the team goes down."
t)))
(defun card-games-hf--ai-go-down (game s)
"Try to lay seat S's initial meld meeting the round minimum.
"Try to lay GAME seat S's initial meld meeting the round minimum.
Return non-nil when the team goes down."
(let* ((hand (card-games-rummy--hand game s))
(byrank (make-hash-table :test 'eql))
@ -293,7 +293,7 @@ Return non-nil when the team goes down."
(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."
"Meld for GAME seat S, going down only when the round minimum is met."
(let ((team (card-games-hf--team game s)))
(unless (card-games-hf--down-p game team) (card-games-hf--ai-go-down game s))
(when (card-games-hf--down-p game team) (card-games-hf--ai-extend game s))))
@ -301,7 +301,7 @@ Return non-nil when the team goes down."
;;;; Engine
(defun card-games-hf--draw2 (game s)
"Draw two stock cards into seat S's hand. Return nil if stock runs out."
"Draw two of GAME's stock cards into seat S's hand; nil if stock is empty."
(let ((ok t))
(dotimes (_ 2)
(let ((stock (card-games-get game :stock)))
@ -312,7 +312,7 @@ Return non-nil when the team goes down."
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."
"Have GAME seat S lay CARDS as a new team book; non-nil on win."
(when (and (card-games-hf--book-valid-p cards)
(cl-subsetp cards (card-games-rummy--hand game s) :test #'equal))
(let ((team (card-games-hf--team game s)))
@ -329,7 +329,7 @@ Return non-nil when the team goes down."
(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."
"Lay CARD off from seat S onto a GAME team book; non-nil on success."
(let* ((team (card-games-hf--team game s)) (books (card-games-hf--books game team)) (done nil))
(catch 'hit
(dolist (bk books)
@ -343,7 +343,7 @@ Return non-nil when the team goes down."
done))
(defun card-games-hf--advance (game s)
"After a play, take up the foot or finish, then pass the turn."
"After a play by GAME seat S, take up the foot or finish, then pass the turn."
(let ((stage (card-games-get game :stage)))
(when (and (= (aref stage s) 0) (null (card-games-rummy--hand game s)))
;; hand exhausted: pick up the foot
@ -355,17 +355,17 @@ Return non-nil when the team goes down."
(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."
"Return non-nil when GAME TEAM owns at least two complete books."
(>= (cl-count-if #'card-games-hf--book-complete-p (card-games-hf--books game team)) 2))
(defun card-games-hf--discard (game s card)
"Discard CARD from seat S and end the play portion of the turn."
"Discard CARD from GAME seat S and end the play portion of the turn."
(card-games-rummy--set-hand game s (card-games-rummy--remove1 card (card-games-rummy--hand game s)))
(card-games-put game :discard (cons card (card-games-get game :discard)))
(card-games-hf--advance game s))
(cl-defmethod card-games-hf--score-round ((game card-games-handfoot-game) outseat)
"Score the round (OUTSEAT went out, or nil if the stock ran dry)."
"Score GAME's round (OUTSEAT went out, or nil if the stock ran dry)."
(let* ((nt (card-games-get game :nteams)) (scores (card-games-get game :scores)))
(dotimes (team nt)
(let ((pts 0))
@ -411,7 +411,7 @@ Return non-nil when the team goes down."
;;;; AI
(defun card-games-hf--ai-extend (game s)
"Extend and add books for seat S once the team is down."
"Extend and add books for GAME seat S once the team is down."
;; lay off naturals onto existing incomplete team books
(let ((again t))
(while again
@ -462,7 +462,7 @@ Return non-nil when the team goes down."
(setq again t))))))))
(defun card-games-hf--ai-discard-card (game s)
"Return the card seat S should discard."
"Return the card GAME seat S should discard."
(let ((hand (card-games-rummy--hand game s)))
(or (cl-find-if #'card-games-hf--three-p hand)
;; a high singleton, else the first card
@ -477,7 +477,7 @@ Return non-nil when the team goes down."
best))))
(cl-defmethod card-games-hf--ai-turn ((game card-games-handfoot-game) s)
"Play seat S's whole turn."
"Play GAME seat S's whole turn."
(let ((got (or (and (> (length (card-games-get game :stock)) 30)
(card-games-hf--pickup-eligible game s)
(card-games-hf--pickup game s))
@ -496,7 +496,7 @@ Return non-nil when the team goes down."
(card-games-hf--advance game s)))))))
(defun card-games-hf--run (game)
"Advance AI seats until it is your turn or the round ends."
"Advance GAME's AI seats until your turn or the round ends."
(while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0))
(card-games-hf--ai-turn game (card-games-get game :turn))))
@ -598,12 +598,13 @@ Return non-nil when the team goes down."
(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."
"Keep G's cursor in range and drop stale marked cards."
(let ((n (length (card-games-rummy--hand g 0))))
(card-games-put g :cursor (if (> n 0) (min (card-games-get g :cursor) (1- n)) 0))
(card-games-put g :marks (cl-remove-if (lambda (i) (>= i n)) (card-games-get g :marks)))))
(defun card-games-hf--my-turn-p (g)
"Return non-nil when it is your turn in G."
(and (eq (card-games-get g :phase) 'play) (= (card-games-get g :turn) 0)))
(defun card-games-hf-left ()

52
card-games-match.el
View file

@ -52,17 +52,17 @@
((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))
(defsubst card-games-gf--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
(defsubst card-games-gf--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
(defun card-games-gf--books (game s) (aref (card-games-get game :books) s))
(defun card-games-gf--books (game s) "Return seat S's laid-down books in GAME." (aref (card-games-get game :books) s))
(defun card-games-gf--rank-count (hand rank)
"Return how many cards of RANK are in HAND."
(cl-count rank hand :key #'cdr))
(defun card-games-gf--check-books (game s)
"Lay down any completed four-of-a-kind books from seat S's hand."
"Lay down any completed four-of-a-kind books from GAME seat S's hand."
(dotimes (r 13)
(when (>= (card-games-gf--rank-count (card-games-gf--hand game s) r) 4)
(card-games-gf--set-hand game s (cl-remove r (card-games-gf--hand game s) :key #'cdr))
@ -88,7 +88,7 @@
game))
(defun card-games-gf--draw (game s)
"Draw one stock card into seat S's hand. Return it, or nil if empty."
"Draw one stock card into GAME seat S's hand. Return it, or nil if empty."
(let ((stock (card-games-get game :stock)))
(when stock
(card-games-gf--set-hand game s (card-games-rummy-sort-hand (cons (car stock) (card-games-gf--hand game s))))
@ -96,12 +96,13 @@
(car stock))))
(defun card-games-gf--total-books (game)
"Return the total number of books laid down in GAME."
(let ((sum 0)) (dotimes (s (card-games-get game :nplayers))
(setq sum (+ sum (card-games-gf--books game s))))
sum))
(defun card-games-gf--maybe-over (game)
"End the game when all thirteen books are made."
"End GAME when all thirteen books are made."
(when (>= (card-games-gf--total-books game) 13)
(let ((best 0))
(dotimes (s (card-games-get game :nplayers))
@ -112,10 +113,10 @@
(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)))
(defun card-games-gf--who (s) "Return the display name of seat S." (if (= s 0) "You" (format "Player %d" s)))
(cl-defmethod card-games-gf--ask ((game card-games-go-fish-game) asker target rank)
"ASKER asks TARGET for RANK. Return non-nil if ASKER keeps the turn."
"In GAME, ASKER asks TARGET for RANK; return non-nil for another turn."
(let* ((got (cl-remove-if-not (lambda (c) (= (cdr c) rank)) (card-games-gf--hand game target)))
(keep nil))
(if got
@ -148,14 +149,14 @@
keep))
(defun card-games-gf--next (game s)
"Return the next seat after S that still has cards (or stock to draw)."
"Return the next GAME seat after S that still has cards (or stock to draw)."
(let ((n (card-games-get game :nplayers)) (i (mod (1+ s) (card-games-get game :nplayers))) (tries 0))
(while (and (< tries n) (null (card-games-gf--hand game i)) (null (card-games-get game :stock)))
(setq i (mod (1+ i) n) tries (1+ tries)))
i))
(defun card-games-gf--start-turn (game s)
"Ready seat S to act: draw up if empty; pass the turn if it cannot ask.
"Ready GAME seat S to act: draw up if empty; pass if it cannot ask.
Return non-nil when S can ask."
(when (and (null (card-games-gf--hand game s)) (card-games-get game :stock))
(card-games-gf--draw game s))
@ -165,7 +166,7 @@ Return non-nil when S can ask."
(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)."
"Take GAME seat S's whole AI turn (it may keep asking)."
(when (card-games-gf--start-turn game s)
(let ((guard 0))
(while (and (= (card-games-get game :turn) s) (eq (card-games-get game :phase) 'play)
@ -182,7 +183,7 @@ Return non-nil when S can ask."
(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."
"Advance GAME's AI seats until your turn or the game ends."
(let ((guard 0))
(while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0) (< guard 1000))
(setq guard (1+ guard))
@ -218,7 +219,7 @@ Return non-nil when S can ask."
(_ (cl-call-next-method))))
(defun card-games-gf--hand-ranks (game)
"Return the distinct ranks in your hand, low to high (Ace..King)."
"Return the distinct ranks in your GAME hand, low to high (Ace..King)."
(let ((seen (make-vector 13 nil)) (out '()))
(dolist (c (card-games-gf--hand game 0)) (aset seen (cdr c) t))
(dotimes (r 13) (when (aref seen r) (push r out)))
@ -237,7 +238,7 @@ Moves the hand cursor to a card of that rank so the existing
(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.
"Insert clickable rank buttons for the ranks in your GAME hand.
Each rank is a large, easy target, so you pick what to ask for by rank
instead of hunting for one overlapped card in a big hand."
(let* ((ranks (card-games-gf--hand-ranks game))
@ -257,6 +258,7 @@ instead of hunting for one overlapped card in a big hand."
(insert "\n"))))
(defun card-games-gf--redisplay ()
"Redraw the current Go Fish buffer."
(let ((game card-games-gf--game) (inhibit-read-only t))
(setq card-games-current-game game card-games-redisplay-function #'card-games-gf--redisplay)
(setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))
@ -350,8 +352,8 @@ instead of hunting for one overlapped card in a big hand."
((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))
(defsubst card-games-om--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
(defsubst card-games-om--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
(defun card-games-om--discard-pairs (hand)
"Return HAND with every matched pair of ranks removed."
@ -381,31 +383,32 @@ instead of hunting for one overlapped card in a big hand."
game))
(defun card-games-om--active (game)
"Return the list of seats still holding cards."
"Return GAME's seats still holding cards."
(cl-loop for s below (card-games-get game :nplayers)
when (card-games-om--hand game s) collect s))
(defun card-games-om--target (game s)
"Return the next active seat after S to draw from."
"Return the next active GAME seat after S to draw from."
(let ((n (card-games-get game :nplayers)) (i (mod (1+ s) (card-games-get game :nplayers))) (tries 0))
(while (and (< tries n) (or (= i s) (null (card-games-om--hand game i))))
(setq i (mod (1+ i) n) tries (1+ tries)))
(and (card-games-om--hand game i) i)))
(defun card-games-om--skip-empty (game)
"Advance the turn past any seat that has run out of cards."
"Advance GAME's turn past any seat that has run out of cards."
(let ((n (card-games-get game :nplayers)) (tries 0))
(while (and (< tries n) (null (card-games-om--hand game (card-games-get game :turn))))
(card-games-put game :turn (mod (1+ (card-games-get game :turn)) n))
(setq tries (1+ tries)))))
(defun card-games-om--total (game)
"Return the total cards remaining in GAME."
(let ((sum 0)) (dotimes (s (card-games-get game :nplayers))
(setq sum (+ sum (length (card-games-om--hand game s)))))
sum))
(cl-defmethod card-games-om--draw ((game card-games-old-maid-game) drawer idx)
"DRAWER takes card IDX from the next active hand, then discards a pair."
"In GAME, DRAWER takes card IDX from the next hand, then discards a pair."
(let ((target (card-games-om--target game drawer)))
(when target
(let* ((thand (card-games-om--hand game target))
@ -424,7 +427,7 @@ instead of hunting for one overlapped card in a big hand."
(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."
"End GAME; whoever has the last card is the Old Maid."
(let ((loser (car (card-games-om--active game))))
(card-games-put game :phase 'game-over)
(card-games-put game :winner loser)
@ -435,13 +438,13 @@ instead of hunting for one overlapped card in a big hand."
"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."
"Take GAME seat S's AI turn: draw a random card from the next hand."
(let ((target (card-games-om--target game s)))
(if (null target) (card-games-om--finish game)
(card-games-om--draw game s (random (length (card-games-om--hand game target)))))))
(defun card-games-om--run (game)
"Advance AI seats until it is your turn or the game ends."
"Advance GAME's AI seats until your turn or the game ends."
(let ((guard 0))
(while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0) (< guard 500))
(setq guard (1+ guard))
@ -501,7 +504,7 @@ instead of hunting for one overlapped card in a big hand."
(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."
"Apply click ACTION on G: pick that card from the target and draw it."
(pcase action
(`(pick . ,i) (card-games-put g :pick i) (card-games-om-draw))
(_ (cl-call-next-method))))
@ -531,6 +534,7 @@ instead of hunting for one overlapped card in a big hand."
(apply #'concat (nreverse out))))
(defun card-games-om--redisplay ()
"Redraw the current Old Maid buffer."
(let ((game card-games-om--game) (inhibit-read-only t))
(setq card-games-current-game game card-games-redisplay-function #'card-games-om--redisplay)
(setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))

5
card-games-net.el
View file

@ -230,8 +230,9 @@ strings inside MSG have their text properties stripped first, by
(and card-games-net--host (process-live-p (card-games-net-host-server card-games-net--host))))
(defun card-games-net-host-start (game &optional port)
"Begin hosting GAME on PORT (default `card-games-net-port'). Return the server process.
The socket binds `card-games-net-host-address' -- by default, this machine only."
"Begin hosting GAME on PORT (default `card-games-net-port').
Return the server process. The socket binds
`card-games-net-host-address' -- by default, this machine only."
(let* ((port (or port card-games-net-port))
(server (make-network-process
:name "card-games-host" :server t :service port

34
card-games-patience.el
View file

@ -54,9 +54,9 @@
(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))))
(defsubst card-games-pat-red-p (card) "Return non-nil when CARD is red." (and card (card-games-red-suit-p (car card))))
(defun card-games-pat--deck () (card-games-shuffle (cl-loop for s below 4 append
(defun card-games-pat--deck () "Return a fresh shuffled 52-card deck." (card-games-shuffle (cl-loop for s below 4 append
(cl-loop for r below 13 collect (cons s r)))))
;;;; Classes
@ -81,6 +81,7 @@
"Build GAME's board from DECK; return (CARDS COVER ROWS STOCK WASTE).")
(cl-defmethod card-games-pat--layout ((_ card-games-golf-game) deck)
"Lay out DECK as a Golf board."
(let ((cards (make-vector 35 nil)) (cover (make-vector 35 nil)) (rows nil))
(dotimes (c 7) (dotimes (r 5)
(let ((i (+ (* c 5) r)))
@ -91,6 +92,7 @@
(list cards cover (nreverse rows) deck waste))))
(cl-defmethod card-games-pat--layout ((_ card-games-tripeaks-game) deck)
"Lay out DECK as a TriPeaks board."
(let ((cards (make-vector 28 nil))
(cover (vector '(3 4) '(5 6) '(7 8)
'(9 10) '(10 11) '(12 13) '(13 14) '(15 16) '(16 17)
@ -105,6 +107,7 @@
(list cards cover rows deck waste))))
(cl-defmethod card-games-pat--layout ((_ card-games-pyramid-game) deck)
"Lay out DECK as a Pyramid board."
(let ((cards (make-vector 28 nil)) (cover (make-vector 28 nil)) (rows nil))
(dotimes (r 7)
(let ((start (/ (* r (1+ r)) 2)) (row nil))
@ -140,33 +143,33 @@
game))
(defun card-games-pat--exposed-p (game i)
"Return non-nil when board slot I is present and uncovered."
"Return non-nil when GAME board slot I is present and uncovered."
(let ((cards (card-games-get game :cards)))
(and (aref cards i)
(cl-every (lambda (j) (null (aref cards j))) (aref (card-games-get game :cover) i)))))
(defun card-games-pat--exposed (game)
"Return the list of exposed board slot indices."
"Return GAME's list of exposed board slot indices."
(cl-loop for i below (length (card-games-get game :cards))
when (card-games-pat--exposed-p game i) collect i))
(defun card-games-pat--spots (game)
"Return the ordered spots the cursor can visit."
"Return the ordered spots the cursor can visit in GAME."
(append (mapcar (lambda (i) (cons 'slot i)) (card-games-pat--exposed game))
'((waste . 0) (stock . 0))))
(defun card-games-pat--waste-top (game) (car (last (card-games-get game :waste))))
(defun card-games-pat--waste-top (game) "Return the top card of GAME's waste pile." (car (last (card-games-get game :waste))))
(defun card-games-pat--board-empty-p (game)
"Return non-nil when every board slot has been cleared."
"Return non-nil when every GAME board slot has been cleared."
(cl-every #'null (append (card-games-get game :cards) nil)))
(cl-defmethod card-games-won-p ((game card-games-patience-game))
"Return non-nil when the board has been cleared."
"Return non-nil when GAME's board has been cleared."
(card-games-pat--board-empty-p game))
(defun card-games-pat--adjacent (a b wrap)
"Return non-nil when ranks A and B differ by one (or wrap Ace-King)."
"Return non-nil when ranks A and B differ by one, or (with WRAP) Ace-King."
(let ((d (abs (- a b)))) (or (= d 1) (and wrap (= d 12)))))
(defun card-games-pat--snapshot (game)
@ -190,7 +193,7 @@
t)))
(defun card-games-pat--deal-stock (game)
"Turn one card from the stock to the waste."
"Turn one of GAME's stock cards to the waste."
(let ((stock (card-games-get game :stock)))
(if (null stock)
(card-games-put game :message "The stock is empty.")
@ -203,7 +206,7 @@
(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."
"Clear GAME board slot I."
(aset (card-games-get game :cards) i nil))
;;;; Interaction
@ -211,6 +214,7 @@
(defvar-local card-games-pat--game nil "The pile-solitaire game in the current buffer.")
(defun card-games-pat--cur-spot (game)
"Return the spot the cursor is on in GAME."
(let ((spots (card-games-pat--spots game)))
(nth (min (card-games-get game :cursor) (1- (length spots))) spots)))
@ -242,13 +246,13 @@
(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)."
"Return the card value of GAME mark M (a slot or the waste)."
(pcase (car m)
('slot (card-games-pat--value (aref (card-games-get game :cards) (cdr m))))
('waste (let ((w (card-games-pat--waste-top game))) (and w (card-games-pat--value w))))))
(defun card-games-pat--toggle-mark (game m)
"Toggle mark M; when two marks sum to 13, remove both."
"Toggle GAME mark M; when two marked slots sum to 13, remove both."
(if (member m (card-games-get game :marks))
(card-games-put game :marks (remove m (card-games-get game :marks)))
(card-games-put game :marks (cons m (card-games-get game :marks))))
@ -276,6 +280,7 @@
(message "Solved!")))
(defun card-games-pat--move (delta)
"Move the cursor by DELTA spots."
(let* ((game card-games-pat--game) (n (length (card-games-pat--spots game))))
(card-games-put game :cursor (mod (+ (card-games-get game :cursor) delta) n))
(card-games-pat--redisplay)))
@ -295,6 +300,7 @@
;;;; Rendering
(defun card-games-pat--render-card (card &optional exposed marked cursor)
"Return CARD's display text, flagged by EXPOSED, MARKED, and CURSOR."
(let ((s (card-games-pat-card-string card)) (faces nil))
(when (card-games-pat-red-p card) (push 'card-games-red-suit faces))
(when (and card (not exposed)) (push 'card-games-gap faces))
@ -397,6 +403,7 @@ matching spot); a card-size slider sits below."
(apply #'concat (nreverse out))))
(defun card-games-pat--redisplay ()
"Redraw the current patience-game buffer."
(let ((game card-games-pat--game) (inhibit-read-only t))
(setq card-games-current-game game card-games-redisplay-function #'card-games-pat--redisplay)
(setq-local mode-line-process (format " [%s]" (if (card-games-won-p game) "solved" "playing")))
@ -431,6 +438,7 @@ matching spot); a card-size slider sits below."
(setq-local cursor-type card-games-cursor-type))
(defun card-games-pat--play (class)
"Start a patience game of CLASS."
(let* ((game (card-games-pat--deal (make-instance class)))
(buf (get-buffer-create (format "*%s*" (oref game vname)))))
(with-current-buffer buf

45
card-games-president.el
View file

@ -58,12 +58,14 @@
(if (= rank 0) 13 rank))
(defun card-games-pres-card-string (card)
"Return the display string for CARD (a middot for nil)."
(if (null card) "·"
(concat (aref card-games-pres-ranks (cdr card)) (card-games-suit-glyph (car card)))))
(defsubst card-games-pres-red-p (card) (and card (card-games-red-suit-p (car card))))
(defsubst card-games-pres-red-p (card) "Return non-nil when CARD is red." (and card (card-games-red-suit-p (car card))))
(defun card-games-pres--deck ()
"Return a fresh shuffled 52-card deck."
(card-games-shuffle (cl-loop for s below 4 append
(cl-loop for r below 13 collect (cons s r)))))
@ -78,14 +80,16 @@
((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--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
(defsubst card-games-pres--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
(defsubst card-games-pres--name (_game s)
"Return the display name of seat S."
(if (= s 0) "You" (format "Player %d" s)))
;;;; Dealing and the inter-game exchange
(cl-defmethod card-games-pres--deal ((game card-games-president-game))
"Deal a new round into GAME (3-6 players)."
(let* ((n (max 3 (min 6 card-games-president-players)))
(deck (card-games-pres--deck))
(hands (make-vector n nil))
@ -114,7 +118,7 @@
(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."
"Trade GAME cards by rank from the previous deal's finishing order, if any."
(let ((order (card-games-get game :order)) (n (card-games-get game :nplayers)))
(when (and order (= (length order) n) (>= n 4))
(let* ((prez (nth 0 order)) (scum (nth (1- n) order))
@ -125,7 +129,7 @@
(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."
"Move K cards (best, or WORST) from GAME seat FROM to seat TO."
(let* ((cards (if worst (card-games-pres--worst (card-games-pres--hand game from) k)
(card-games-pres--best (card-games-pres--hand game from) k))))
(card-games-pres--set-hand game from
@ -136,14 +140,14 @@
;;;; Move logic
(defun card-games-pres--rank-counts (game s)
"Return an alist (RANK . COUNT) for seat S's hand."
"Return an alist (RANK . COUNT) for GAME seat S's hand."
(let ((tbl nil))
(dolist (c (card-games-pres--hand game s))
(setf (alist-get (cdr c) tbl 0) (1+ (alist-get (cdr c) tbl 0))))
tbl))
(defun card-games-pres--legal-ranks (game s)
"Return the ranks seat S may legally play now."
"Return the ranks GAME seat S may legally play now."
(let ((cnt (card-games-get game :count)) (top (card-games-get game :top)))
(cl-loop for (r . c) in (card-games-pres--rank-counts game s)
when (if (= cnt 0) t (and (>= c cnt) (> (card-games-pres--power r) top)))
@ -157,18 +161,18 @@
(nreverse out)))
(defun card-games-pres--in-game (game)
"Seats that still hold cards."
"Return GAME seats that still hold cards."
(cl-loop for s below (card-games-get game :nplayers)
unless (memq s (card-games-get game :out)) collect s))
(defun card-games-pres--round-active (game)
"Seats that can still act on the current pile."
"Return GAME seats that can still act on the current pile."
(cl-loop for s below (card-games-get game :nplayers)
unless (or (memq s (card-games-get game :out)) (aref (card-games-get game :passed) s))
collect s))
(defun card-games-pres--next (game from)
"Next seat after FROM that is still in the round."
"Return the next GAME seat after FROM still in the round."
(let ((n (card-games-get game :nplayers)) (s from) (res nil))
(dotimes (_ n)
(setq s (mod (1+ s) n))
@ -179,7 +183,7 @@
(or res from)))
(defun card-games-pres--clear (game)
"Clear the pile; the last player to play leads (or the next active seat)."
"Clear GAME's pile; the last player to play leads, else the next active seat."
(card-games-put game :count 0) (card-games-put game :top -1)
(card-games-put game :passed (make-vector (card-games-get game :nplayers) nil))
(let ((last (card-games-get game :last-player)))
@ -188,7 +192,7 @@
(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)."
"End GAME when only one player still has cards (the Scum)."
(let ((in (card-games-pres--in-game game)))
(when (<= (length in) 1)
(when in (card-games-put game :out (append (card-games-get game :out) in)))
@ -199,7 +203,7 @@
t)))
(defun card-games-pres--advance (game)
"Decide the next turn or clear the pile after a move."
"Decide GAME's next turn or clear the pile after a move."
(unless (card-games-pres--check-finish game)
(let* ((active (card-games-pres--round-active game))
(last (card-games-get game :last-player))
@ -209,7 +213,7 @@
(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."
"Have GAME seat SEAT play N cards of RANK."
(card-games-pres--set-hand game seat (card-games-pres--remove-n (card-games-pres--hand game seat) rank n))
(card-games-put game :count n) (card-games-put game :top (card-games-pres--power rank))
(card-games-put game :last-player seat)
@ -220,13 +224,13 @@
(card-games-pres--advance game))
(defun card-games-pres--pass (game seat)
"Seat SEAT passes for the current pile."
"Have GAME seat SEAT pass on the current pile."
(aset (card-games-get game :passed) seat t)
(card-games-put game :message (format "%s passes." (card-games-pres--name game seat)))
(card-games-pres--advance game))
(defun card-games-pres--ai-move (game seat)
"Make seat SEAT's move: lead low, beat low, or pass."
"Make GAME seat SEAT's move: lead low, beat low, or pass."
(let* ((cnt (card-games-get game :count)) (top (card-games-get game :top))
(counts (card-games-pres--rank-counts game seat)))
(if (= cnt 0)
@ -240,7 +244,7 @@
(card-games-pres--pass game seat))))))
(defun card-games-pres--result (game)
"Return a finishing summary string."
"Return a finishing summary string for GAME."
(let* ((order (card-games-get game :order)) (n (length order)) (parts nil))
(dotimes (i n)
(let ((title (cond ((= i 0) "President") ((= i (1- n)) "Scum")
@ -255,12 +259,12 @@
(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."
"Advance GAME's AI seats until the human's turn or the game ends."
(while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0))
(card-games-pres--ai-move game (card-games-get game :turn))))
(defun card-games-pres--hand-ranks (game)
"Distinct ranks in seat 0's hand, ordered by power."
"Return the distinct ranks in GAME seat 0's hand, ordered by power."
(let ((rs (delete-dups (mapcar #'cdr (card-games-pres--hand game 0)))))
(cl-sort rs #'< :key #'card-games-pres--power)))
@ -316,7 +320,7 @@
:type 'boolean :group 'card-games)
(defun card-games-pres--svg (game)
"Return a propertized, clickable SVG row of the hand: one card per rank.
"Return a propertized, clickable SVG row of GAME's hand: one card per rank.
Each rank maps to a (hand . INDEX) region and a card-size slider sits below."
(let* ((w card-games-svg-card-width) (h card-games-svg-card-height) (pad 10)
(gap (+ card-games-svg-card-gap 8)) (ranks (card-games-pres--hand-ranks game))
@ -379,6 +383,7 @@ Each rank maps to a (hand . INDEX) region and a card-size slider sits below."
(_ (cl-call-next-method))))
(defun card-games-pres--redisplay ()
"Redraw the current President buffer."
(let ((game card-games-pres--game) (inhibit-read-only t))
(setq card-games-current-game game card-games-redisplay-function #'card-games-pres--redisplay)
(setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))

41
card-games-rum500.el
View file

@ -84,12 +84,12 @@
(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--ace-high (game) "Return non-nil when GAME plays the Ace high." (oref game ace-high))
(defun card-games-tm--ace-15 (game) "Return non-nil when GAME scores the Ace as 15." (oref game ace-15))
(defun card-games-tm--deep-pickup (game) "Return non-nil when GAME's deep discard pickups are enabled." (oref game deep-pickup))
(defun card-games-tm--draw (game s)
"Move one stock card to seat S's hand; return it or nil if stock empty."
"Move one of GAME's stock cards to seat S's hand; return it or nil if empty."
(let ((stock (card-games-get game :stock)))
(when stock
(let ((c (pop stock)))
@ -99,7 +99,7 @@
c))))
(defun card-games-tm--take-top (game s)
"Move the discard top to seat S's hand and return it."
"Move GAME's discard top to seat S's hand and return it."
(let ((c (card-games-rummy--top game)))
(when c
(card-games-put game :discard (cdr (card-games-get game :discard)))
@ -112,7 +112,7 @@
(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."
"Have GAME seat S meld CARDS onto the table. Return non-nil on success."
(when (card-games-rummy-meld-p cards :min 3 :ace-high (card-games-tm--ace-high game)
:distinct-suits t)
(dolist (c cards) (card-games-rummy--set-hand game s (remove c (card-games-rummy--hand game s))))
@ -123,7 +123,7 @@
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."
"Have GAME seat S lay CARD off onto a matching meld; non-nil on success."
(let ((rec (cl-find-if
(lambda (r) (card-games-rummy-meld-p (cons card (cdr r)) :min 3
:ace-high (card-games-tm--ace-high game)))
@ -136,7 +136,7 @@
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)."
"Score GAME's hand ended by OUTSEAT (or nil for a washed-out hand)."
(let* ((n (card-games-get game :nplayers)) (scores (card-games-get game :scores))
(style (oref game score-style)))
(cond
@ -173,7 +173,7 @@
(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--who (s) "Return the display name of seat S." (if (= s 0) "You" (format "Player %d" s)))
(defun card-games-tm--scores-string (game)
"Return a compact \"You N · P1 N ...\" score line for GAME."
@ -184,14 +184,14 @@
(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."
"Finish GAME seat S's turn: go out if the hand is empty, else advance."
(if (null (card-games-rummy--hand game s))
(card-games-tm--score-hand game s)
(card-games-put game :turn (mod (1+ s) (card-games-get game :nplayers)))
(card-games-put game :step 'draw)))
(cl-defmethod card-games-tm--discard ((game card-games-tablemeld-game) s card)
"Discard CARD from seat S and finish the turn."
"Discard CARD from GAME seat S and finish the turn."
(card-games-rummy--set-hand game s (remove card (card-games-rummy--hand game s)))
(card-games-put game :discard (cons card (card-games-get game :discard)))
(card-games-tm--end-turn game s))
@ -199,7 +199,7 @@
;;;; AI
(defun card-games-tm--ai-melds (game s)
"Lay down every meld seat S can, keeping a card back to discard.
"Lay down every meld GAME seat S can, keeping a card back to discard.
Return non-nil if any meld was laid."
(let ((did nil) (again t))
(while again
@ -218,7 +218,7 @@ Return non-nil if any meld was laid."
did))
(defun card-games-tm--ai-layoffs (game s)
"Lay off every fitting card from seat S, keeping a card back to discard."
"Lay off every fitting card from GAME seat S, keeping a card to discard."
(let ((again t))
(while again
(setq again nil)
@ -233,7 +233,7 @@ Return non-nil if any meld was laid."
(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)."
"Return the best card for GAME seat S to discard (highest deadwood)."
(let* ((hand (card-games-rummy--hand game s))
(p (card-games-rummy-best-partition hand :ace-high (card-games-tm--ace-high game)
:ace-15 (card-games-tm--ace-15 game)))
@ -244,7 +244,7 @@ Return non-nil if any meld was laid."
(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 a minimal valid GAME meld (card list) with TARGET drawn from CARDS.
Return nil when TARGET cannot join a set or run with the other CARDS."
(let* ((ace-high (card-games-tm--ace-high game))
(pool (cons target cards))
@ -256,7 +256,7 @@ Return nil when TARGET cannot join a set or run with the other CARDS."
(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.
"Have GAME seat S take the card at DEPTH in the discard, plus all above.
The chosen card is melded or laid off at once, as Rummy 500 requires; the
rest enter the hand. Return a status string, or nil when the move is not
legal (the chosen card cannot be used immediately)."
@ -283,7 +283,7 @@ legal (the chosen card cannot be used immediately)."
(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.
"Try a worthwhile below-the-top discard pickup for GAME seat S.
Return non-nil when one was taken."
(when (card-games-tm--deep-pickup game)
(let* ((pile (card-games-get game :discard)) (n (length pile))
@ -296,7 +296,7 @@ Return non-nil when one was taken."
(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."
"Play GAME seat S's whole turn."
(let* ((deep (card-games-tm--ai-deep-pickup game s))
(drew (if deep t
(let* ((hand (card-games-rummy--hand game s))
@ -319,7 +319,7 @@ Return non-nil when one was taken."
(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."
"Advance GAME's AI seats until the human's turn or the hand ends."
(while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0))
(card-games-tm--ai-turn game (card-games-get game :turn))))
@ -430,12 +430,13 @@ Deep-pickup games show the whole pile with depth indices (0 = top)."
(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."
"Keep G's cursor within the hand and drop stale marked cards."
(let ((n (length (card-games-rummy--hand g 0))))
(card-games-put g :cursor (if (> n 0) (min (card-games-get g :cursor) (1- n)) 0))
(card-games-put g :marks (cl-remove-if (lambda (i) (>= i n)) (card-games-get g :marks)))))
(defun card-games-tm--my-turn-p (g)
"Return non-nil when it is your turn in G."
(and (eq (card-games-get g :phase) 'play) (= (card-games-get g :turn) 0)))
(defun card-games-tm-left ()

33
card-games-rummy.el
View file

@ -123,7 +123,7 @@ MIN, ACE-HIGH and DISTINCT-SUITS are passed through to the predicates."
;;;; Candidate melds and best partition
(defun card-games-rummy--combinations (lst k)
"Return all K-element combinations of LST, each as a list."
"Return all combinations of LST taken K at a time, each as a list."
(cond ((= k 0) (list nil))
((null lst) nil)
(t (append
@ -132,7 +132,7 @@ MIN, ACE-HIGH and DISTINCT-SUITS are passed through to the predicates."
(card-games-rummy--combinations (cdr lst) k)))))
(defun card-games-rummy--runs-in (pairs)
"Return index-lists of runs (length >= 3) within PAIRS.
"Return an index-list for each run (length >= 3) within PAIRS.
PAIRS is a list of (RANK . INDEX) sorted ascending by RANK."
(let ((res '()) (vec (vconcat pairs)))
(let ((n (length vec)))
@ -243,7 +243,7 @@ ACE-HIGH and ACE-15 are passed to `card-games-rummy-best-partition'."
:count))
(defun card-games-rummy-layoff-p (card melds &optional ace-high)
"Return the first meld in MELDS that CARD extends, or nil.
"Return the first meld in MELDS that CARD can extend, or nil.
ACE-HIGH allows extending a run with a high Ace."
(cl-find-if (lambda (m)
(card-games-rummy-meld-p (cons card m) :min 3 :ace-high ace-high))
@ -266,9 +266,9 @@ NDECKS defaults to 1 and JOKERS to 0."
"Abstract base for rummy-style draw-and-discard games."
:abstract t)
(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)))
(defsubst card-games-rummy--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
(defsubst card-games-rummy--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
(defsubst card-games-rummy--top (game) "Return the top card of GAME's discard pile." (car (card-games-get game :discard)))
(defun card-games-rummy-sort-hand (cards)
"Return CARDS sorted by suit then rank for display, jokers last."
@ -290,7 +290,8 @@ Set to nil to force the plain-text card row everywhere."
(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."
CURSOR is the highlighted index and MARKS the selected ones; HINT-FN is an
optional predicate marking playable cards."
(let ((hints (when hint-fn
(let ((hs '()) (i 0))
(dolist (c cards) (when (funcall hint-fn c) (push i hs))
@ -453,10 +454,10 @@ Keyword ARGS: :title :infos :melds :discard :stock :hand :cursor :marks
"Your turn: s draws from stock, t takes the discard.")
game))
(defun card-games-gin--deadwood (cards) (card-games-rummy-deadwood cards))
(defun card-games-gin--deadwood (cards) "Return the deadwood value of CARDS." (card-games-rummy-deadwood cards))
(defun card-games-gin--draw (game s)
"Move one stock card to seat S's hand; return it or nil if stock empty."
"Move one of GAME's stock cards to seat S's hand; return it or nil if empty."
(let ((stock (card-games-get game :stock)))
(when stock
(let ((c (pop stock)))
@ -465,20 +466,20 @@ Keyword ARGS: :title :infos :melds :discard :stock :hand :cursor :marks
c))))
(defun card-games-gin--take (game s)
"Move the discard top to seat S's hand and return it."
"Move GAME's discard top to seat S's hand and return it."
(let ((c (card-games-rummy--top game)))
(card-games-put game :discard (cdr (card-games-get game :discard)))
(card-games-rummy--set-hand game s (cons c (card-games-rummy--hand game s)))
c))
(defun card-games-gin--discard (game s card)
"Discard CARD from seat S's hand onto the pile."
"Discard CARD from GAME seat S's hand onto the pile."
(card-games-rummy--set-hand game s (card-games-rummy-sort-hand
(remove card (card-games-rummy--hand game s))))
(card-games-put game :discard (cons card (card-games-get game :discard))))
(defun card-games-gin--ai-best-discard (game s)
"Return the card seat S should discard to minimise its deadwood."
"Return the card GAME seat S should discard to minimise its deadwood."
(let ((hand (card-games-rummy--hand game s)) (best nil) (bestv most-positive-fixnum))
(dolist (c hand best)
(let ((d (card-games-gin--deadwood (remove c hand))))
@ -488,7 +489,7 @@ Keyword ARGS: :title :infos :melds :discard :stock :hand :cursor :marks
(setq best c bestv d))))))
(cl-defmethod card-games-gin--ai-turn ((game card-games-gin-game) s)
"Play seat S's whole turn, then hand control back."
"Play GAME seat S's whole turn, then hand control back."
(let* ((hand (card-games-rummy--hand game s))
(cur (card-games-gin--deadwood hand))
(up (card-games-rummy--top game))
@ -511,7 +512,7 @@ Keyword ARGS: :title :infos :melds :discard :stock :hand :cursor :marks
(card-games-rummy-card-string card)))))))))
(cl-defmethod card-games-gin--knock ((game card-games-gin-game) knocker)
"Resolve the hand when KNOCKER knocks; score and end the hand."
"Resolve GAME's hand when KNOCKER knocks; score and end the hand."
(let* ((kpart (card-games-rummy-best-partition (card-games-rummy--hand game knocker)))
(kmelds (plist-get kpart :melds))
(kdw (plist-get kpart :count))
@ -551,7 +552,7 @@ Keyword ARGS: :title :infos :melds :discard :stock :hand :cursor :marks
(aref scores 0) (aref scores 1))))))))
(cl-defmethod card-games-gin--exhaust ((game card-games-gin-game))
"End a hand washed out because the stock ran dry."
"End a GAME hand washed out because the stock ran dry."
(card-games-put game :phase 'hand-over)
(card-games-put game :reveal t)
(card-games-put game :message "Stock exhausted -- the hand is a wash. n: next hand."))
@ -709,7 +710,7 @@ Keyword ARGS: :title :infos :melds :discard :stock :hand :cursor :marks
(card-games-gin--after-discard g)))))
(defun card-games-gin-knock ()
"Knock, discarding the selected card, if your deadwood allows."
"Knock, discarding the selected card, if your deadwood is low enough."
(interactive)
(let* ((g card-games-gin--game) (card (card-games-gin--cursor-card)))
(cond

32
card-games-scopa.el
View file

@ -60,16 +60,16 @@
(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)
"Return non-nil when CARD in GAME captures only equal-rank cards (no sums).")
(cl-defmethod card-games-fish--face-pair-p ((_game card-games-fish-game) _card) "Base fishing games capture rank pairs only, never sums." nil)
(cl-defgeneric card-games-fish--score-round (game)
"Add this round's points to GAME's running scores.")
(defsubst card-games-fish--hand (game s) (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))
(defsubst card-games-fish--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
(defsubst card-games-fish--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
(defsubst card-games-fish--captured (game s) "Return the cards seat S has captured in GAME." (aref (card-games-get game :captured) s))
(defun card-games-fish--who (s) (if (= s 0) "You" "Computer"))
(defun card-games-fish--who (s) "Return the display name of seat S." (if (= s 0) "You" "Computer"))
;;;; Capture search
@ -103,7 +103,7 @@ Only subsets of two or more cards are considered. Return nil if none."
;;;; 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."
"Start a fresh round of GAME: shuffle, deal the table and first hands."
(let* ((n (oref game nplayers)) (deck (card-games-fish--deck game))
(hands (make-vector n nil)) (table '()))
(dotimes (_ 4) (push (pop deck) table))
@ -125,7 +125,7 @@ Only subsets of two or more cards are considered. Return nil if none."
game))
(defun card-games-fish--refill (game)
"Deal fresh hands from the deck when every hand is empty."
"Deal GAME fresh hands from the deck when every hand is empty."
(when (and (cl-every #'null (append (card-games-get game :hands) nil)) (card-games-get game :deck))
(let ((deck (card-games-get game :deck)))
(dotimes (s (card-games-get game :nplayers))
@ -136,11 +136,12 @@ Only subsets of two or more cards are considered. Return nil if none."
(card-games-put game :deck deck))))
(defun card-games-fish--round-over-p (game)
"Return non-nil when GAME's deck and every hand are empty."
(and (null (card-games-get game :deck))
(cl-every #'null (append (card-games-get game :hands) nil))))
(cl-defmethod card-games-fish--play ((game card-games-fish-game) s card)
"Seat S plays CARD: capture if possible, else trail it on the table."
"Have seat S play CARD in GAME: capture if possible, else trail it."
(card-games-fish--set-hand game s (cl-remove card (card-games-fish--hand game s) :test #'equal :count 1))
(let ((cap (card-games-fish--capture game card)))
(if cap
@ -164,7 +165,7 @@ Only subsets of two or more cards are considered. Return nil if none."
(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."
"Award GAME's leftover table cards to the last capturer and score the round."
(when (and (card-games-get game :table) (card-games-get game :last-capturer))
(let ((s (card-games-get game :last-capturer)))
(aset (card-games-get game :captured) s
@ -185,14 +186,14 @@ Only subsets of two or more cards are considered. Return nil if none."
"(n: next round)")))))
(defun card-games-fish--award-most (game suit-pred pts)
"Give PTS to whoever captured more cards satisfying SUIT-PRED."
"Give PTS to whoever captured more of GAME's cards satisfying SUIT-PRED."
(let ((c0 (cl-count-if suit-pred (card-games-fish--captured game 0)))
(c1 (cl-count-if suit-pred (card-games-fish--captured game 1))))
(cond ((> c0 c1) (aset (card-games-get game :scores) 0 (+ (aref (card-games-get game :scores) 0) pts)))
((> c1 c0) (aset (card-games-get game :scores) 1 (+ (aref (card-games-get game :scores) 1) pts))))))
(cl-defmethod card-games-fish--ai-play ((game card-games-fish-game) s)
"Have AI seat S capture the most it can, else trail its lowest card."
"Have GAME AI seat S capture the most it can, else trail its lowest card."
(let ((hand (card-games-fish--hand game s)) (best nil) (bestn -1) (sweep nil))
(dolist (c hand)
(let* ((cap (card-games-fish--capture game c))
@ -208,7 +209,7 @@ Only subsets of two or more cards are considered. Return nil if none."
(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."
"Advance GAME's AI seats until your turn or the round ends."
(let ((guard 0))
(while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0) (< guard 200))
(setq guard (1+ guard))
@ -266,6 +267,7 @@ Only subsets of two or more cards are considered. Return nil if none."
(_ (cl-call-next-method))))
(defun card-games-fish--redisplay ()
"Redraw the current fishing-family game buffer."
(let ((game card-games-fish--game) (inhibit-read-only t))
(setq card-games-current-game game card-games-redisplay-function #'card-games-fish--redisplay)
(setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))
@ -369,7 +371,7 @@ Only subsets of two or more cards are considered. Return nil if none."
(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."
"Score a Scopa round for GAME: cards, coins, sette bello, primiera, sweeps."
(let ((scores (card-games-get game :scores)))
(card-games-fish--award-most game (lambda (_c) t) 1) ; most cards
(card-games-fish--award-most game (lambda (c) (= (car c) 2)) 1) ; most coins (diamonds)
@ -415,7 +417,7 @@ Only subsets of two or more cards are considered. Return nil if none."
(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."
"Score a Casino round for GAME: cards, spades, casinos, aces, sweeps."
(let ((scores (card-games-get game :scores)))
(card-games-fish--award-most game (lambda (_c) t) 3) ; most cards
(card-games-fish--award-most game (lambda (c) (= (car c) 0)) 1) ; most spades

66
card-games-solitaire.el
View file

@ -128,21 +128,21 @@ empty-slot dot."
(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."
"Return non-nil when LOWER may rest on UPPER within a GAME 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."
"Return non-nil when CARD may be placed on a GAME column topped by 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."
"Return non-nil when CARD may be placed on an empty GAME column."
(pcase (oref game empty-rule)
('king (= (cdr card) 12))
(_ t)))
@ -150,15 +150,19 @@ empty-slot dot."
;;;; Layout and dealing
(cl-defgeneric card-games-sol--layout (game)
"Return a list of (DOWN . UP) card counts, one per tableau column.")
"Return GAME's list of (DOWN . UP) card counts, one per tableau column.")
(cl-defmethod card-games-sol--layout ((_ card-games-klondike-game))
"Return the Klondike tableau layout (DOWN . UP per column)."
(cl-loop for i below 7 collect (cons i 1)))
(cl-defmethod card-games-sol--layout ((_ card-games-yukon-game))
"Return the Yukon tableau layout (DOWN . UP per column)."
(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))
"Return the FreeCell tableau layout (DOWN . UP per column)."
(append (make-list 4 (cons 0 7)) (make-list 4 (cons 0 6))))
(cl-defmethod card-games-sol--layout ((_ card-games-spider-game))
"Return the Spider tableau layout (DOWN . UP per column)."
(append (make-list 4 (cons 5 1)) (make-list 6 (cons 4 1))))
(cl-defmethod card-games-sol--deal ((game card-games-solitaire-game))
@ -195,7 +199,7 @@ empty-slot dot."
;;;; 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."
"Return GAME's ordered (TYPE . INDEX) piles the cursor can visit."
(append
(when (oref game has-stock) '((stock . 0)))
(when (oref game has-waste) '((waste . 0)))
@ -205,26 +209,26 @@ empty-slot dot."
(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."
"Return GAME's (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--set-col (game c v) "Set column C in GAME to V." (aset (card-games-get game :tableau) c v))
(defun card-games-sol--down (game c) "Return the face-down count of column C in GAME." (aref (card-games-get game :down) c))
(defun card-games-sol--set-down (game c v) "Set the face-down count of column C in GAME to 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."
"Return the top (accessible) card of GAME 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)."
"Return the face-up cards of GAME 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)."
"Return the longest movable run from GAME column C's top (bottom..top)."
(let ((top->bottom (reverse (card-games-sol--exposed game c))))
(if (null top->bottom)
nil
@ -238,7 +242,7 @@ empty-slot dot."
run))))
(defun card-games-sol--spot-top (game spot)
"Return the top card available at SPOT, or nil."
"Return the top card available at GAME SPOT, or nil."
(pcase (car spot)
('col (card-games-sol--col-top game (cdr spot)))
('waste (car (last (card-games-get game :waste))))
@ -261,7 +265,7 @@ empty-slot dot."
(= (cdr card) need)))))))
(defun card-games-sol--found-for (game card)
"Return the index of a foundation that would accept CARD, or nil."
"Return the index of a GAME 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))
@ -303,14 +307,14 @@ empty-slot dot."
t)))
(defun card-games-sol--flip (game c)
"Flip the top of column C face up if it is face down."
"Flip the top of GAME 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."
"Remove and return the top N cards (bottom..top) from GAME SPOT."
(pcase (car spot)
('col (let* ((c (cdr spot)) (col (card-games-sol--col game c))
(run (last col n)))
@ -331,7 +335,7 @@ empty-slot dot."
(_ nil)))
(defun card-games-sol--can-drop (game spot cards)
"Return non-nil when the run CARDS (bottom..top) may drop on SPOT."
"Return non-nil when run CARDS (bottom..top) may drop on GAME SPOT."
(and cards
(pcase (car spot)
('col (let* ((c (cdr spot)) (top (card-games-sol--col-top game c)))
@ -345,7 +349,7 @@ empty-slot dot."
(_ nil))))
(defun card-games-sol--drop (game spot cards)
"Place the run CARDS (bottom..top) onto SPOT."
"Place run CARDS (bottom..top) onto GAME SPOT."
(pcase (car spot)
('col (let ((c (cdr spot)))
(card-games-sol--set-col game c (append (card-games-sol--col game c) cards))))
@ -357,7 +361,7 @@ empty-slot dot."
;;;; 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.
"Remove a complete K..A same-suit run from a GAME column top; tally it.
Only games without foundations (NFOUND 0: Spider, Scorpion) harvest runs."
(when (= 0 (oref game nfound))
(dotimes (c (oref game ncols))
@ -384,7 +388,7 @@ Only games without foundations (NFOUND 0: Spider, Scorpion) harvest runs."
: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'."
"Deal GAME's `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)
@ -402,6 +406,7 @@ Only games without foundations (NFOUND 0: Spider, Scorpion) harvest runs."
(card-games-put game :message "The stock is empty."))))))
(cl-defmethod card-games-sol--stock-action ((game card-games-klondike-game))
"Deal GAME's Klondike stock to the waste, recycling when empty."
(card-games-sol--snapshot game)
(let ((stock (card-games-get game :stock)) (waste (card-games-get game :waste)))
(if stock
@ -417,6 +422,7 @@ Only games without foundations (NFOUND 0: Spider, Scorpion) harvest runs."
(card-games-put game :message "Stock and waste are both empty.")))))
(cl-defmethod card-games-sol--stock-action ((game card-games-spider-game))
"Deal a Spider row into GAME: one card onto every column."
(let ((stock (card-games-get game :stock)))
(cond
((null stock) (card-games-put game :message "The stock is empty."))
@ -692,14 +698,16 @@ DISPLAY is a propertized one-image string; REGIONS is a click map of
(card-games-sol--render-text game)))
(cl-defmethod card-games-render-text ((game card-games-solitaire-game))
"Return the plain-text rendering of GAME."
(card-games-sol--render-text game))
(cl-defmethod card-games-render-svg ((game card-games-solitaire-game))
"Return the SVG rendering of 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."
"Apply GAME 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))))
@ -790,7 +798,7 @@ DISPLAY is a propertized one-image string; REGIONS is a click map of
;;;; Mode and commands
(defun card-games-sol-mouse (event)
"Handle a mouse click on the solitaire board: select that pile and act."
"Handle mouse EVENT on the solitaire board: select that pile and act."
(interactive "e")
(let* ((game card-games-sol--game)
(r (and game (oref game renderer)))
@ -873,6 +881,7 @@ DISPLAY is a propertized one-image string; REGIONS is a click map of
"Forty Thieves: two decks, ten columns, eight foundations, no redeal.")
(cl-defmethod card-games-sol--layout ((_ card-games-forty-game))
"Return the Forty Thieves tableau layout (DOWN . UP per column)."
(make-list 10 (cons 0 4)))
(defclass card-games-scorpion-game (card-games-solitaire-game)
@ -882,10 +891,11 @@ DISPLAY is a propertized one-image string; REGIONS is a click map of
"Scorpion: build down by suit, move any buried group, clear four runs.")
(cl-defmethod card-games-sol--layout ((_ card-games-scorpion-game))
"Return the Scorpion tableau layout (DOWN . UP per column)."
(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."
"Deal GAME's 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.")
@ -905,7 +915,7 @@ DISPLAY is a propertized one-image string; REGIONS is a click map of
"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."
"Deal GAME's 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))
@ -933,9 +943,9 @@ DISPLAY is a propertized one-image string; REGIONS is a click map of
(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 ((_ card-games-solitaire-game)) "Most solitaires do not autofill empty columns." nil)
(cl-defmethod card-games-sol--autofill ((game card-games-canfield-game))
"Fill empty columns from the reserve, as Canfield requires."
"Fill GAME's 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)))))
@ -961,7 +971,7 @@ DISPLAY is a propertized one-image string; REGIONS is a click map of
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."
"Deal GAME's Russian Bank 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))
@ -985,7 +995,7 @@ foundations up by suit from the Ace, and a thirteen-card reserve.")
game))
(cl-defmethod card-games-sol--autofill ((game card-games-russian-bank-game))
"Fill an empty house from the reserve, as Russian Bank does."
"Fill a GAME 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)))))

46
card-games-spite.el
View file

@ -68,13 +68,13 @@
;;;; 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
(defsubst card-games-spite--goal (game s) "Return seat S's goal pile in GAME." (aref (card-games-get game :goal) s))
(defsubst card-games-spite--set-goal (game s v) "Set seat S's goal pile in GAME to V." (aset (card-games-get game :goal) s v))
(defsubst card-games-spite--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hand) s))
(defsubst card-games-spite--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hand) s v))
(defsubst card-games-spite--disc (game s) "Return seat S's discard piles in GAME." (aref (card-games-get game :disc) s)) ; vector of 4 lists
(defun card-games-spite--who (s) (if (= s 0) "You" "Computer"))
(defun card-games-spite--who (s) "Return the display name of seat S." (if (= s 0) "You" "Computer"))
(cl-defmethod card-games-spite--deal ((game card-games-spite-game))
"Deal a fresh Spite & Malice game into GAME."
@ -99,7 +99,7 @@
;;;; 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."
"Pop one card from GAME's stock, recycling the muck when it is empty."
(when (and (null (card-games-get game :stock)) (card-games-get game :muck))
(card-games-put game :stock (card-games-shuffle (card-games-get game :muck)))
(card-games-put game :muck nil))
@ -107,7 +107,7 @@
(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."
"Draw GAME seat S's hand back up to five cards."
(while (and (< (length (card-games-spite--hand game s)) 5) (or (card-games-get game :stock)
(card-games-get game :muck)))
(let ((c (card-games-spite--draw-stock game)))
@ -115,12 +115,12 @@
(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)."
"Return the rank GAME centre pile I needs next (0 for an empty slot)."
(let ((p (aref (card-games-get game :center) i)))
(if p (1+ (car p)) 0)))
(defun card-games-spite--legal-center (game card)
"Return the index of the first centre pile CARD may be played on, or nil."
"Return the index of the first GAME centre pile CARD may be played on, or nil."
(let ((found nil))
(dotimes (i 4)
(let ((need (card-games-spite--needed game i)))
@ -130,7 +130,7 @@
found))
(defun card-games-spite--put-center (game card i)
"Place CARD on centre pile I; clear the pile if it reaches a Queen."
"Place CARD on GAME centre pile I; clear the pile if it reaches a Queen."
(let* ((need (card-games-spite--needed game i))
(p (aref (card-games-get game :center) i))
(cards (cons card (and p (cdr p)))))
@ -142,13 +142,13 @@
;;;; Plays
(defun card-games-spite--play-hand (game s card i)
"Seat S plays hand CARD onto centre pile I."
"Have GAME seat S play hand CARD onto centre pile I."
(card-games-spite--set-hand game s (cl-remove card (card-games-spite--hand game s) :test #'equal :count 1))
(card-games-spite--put-center game card i)
(when (null (card-games-spite--hand game s)) (card-games-spite--refill game s)))
(defun card-games-spite--play-goal (game s i)
"Seat S plays the top of their goal pile onto centre pile I."
"Have GAME seat S play the top of their goal pile onto centre pile I."
(let ((card (car (card-games-spite--goal game s))))
(card-games-spite--set-goal game s (cdr (card-games-spite--goal game s)))
(card-games-spite--put-center game card i)
@ -156,13 +156,13 @@
(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."
"Have GAME seat S play the top of discard pile D onto centre pile I."
(let* ((pile (aref (card-games-spite--disc game s) d)) (card (car pile)))
(aset (card-games-spite--disc game s) d (cdr pile))
(card-games-spite--put-center game card i)))
(defun card-games-spite--discard (game s card d)
"Seat S discards CARD from hand onto discard pile D, ending the turn."
"Have GAME seat S discard CARD from hand onto pile D, ending the turn."
(card-games-spite--set-hand game s (cl-remove card (card-games-spite--hand game s) :test #'equal :count 1))
(aset (card-games-spite--disc game s) d (cons card (aref (card-games-spite--disc game s) d)))
(card-games-put game :turn (- 1 s)))
@ -170,7 +170,7 @@
;;;; AI
(defun card-games-spite--ai-one (game s)
"Make one beneficial play for seat S; return non-nil if a play was made."
"Make one beneficial play for GAME seat S; return non-nil if one was made."
(let ((goal (car (card-games-spite--goal game s))) (done nil))
(cond
;; 1. advance the goal card (a wild goal card plays anywhere)
@ -214,7 +214,7 @@
done))
(defun card-games-spite--ai-turn (game s)
"Take seat S's whole AI turn: play what helps, then discard."
"Take GAME seat S's whole AI turn: play what helps, then discard."
(card-games-spite--refill game s)
(let ((guard 0))
(while (and (eq (card-games-get game :phase) 'play) (< guard 300)
@ -232,7 +232,7 @@
(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."
"Choose GAME seat S's discard pile for CARD (empty, else topped just above)."
(let ((disc (card-games-spite--disc game s)) (empty nil) (best nil) (bestv 99))
(dotimes (d 4)
(let ((top (car (aref disc d))))
@ -243,7 +243,7 @@
(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 the computer (seat 1) act in GAME until your turn or the game ends."
(let ((guard 0))
(while (and (eq (card-games-get game :phase) 'play) (= (card-games-get game :turn) 1) (< guard 200))
(setq guard (1+ guard))
@ -254,7 +254,7 @@
(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."
"Return a one-line depiction of GAME's centre piles."
(let ((parts '()))
(dotimes (i 4)
(let ((p (aref (card-games-get game :center) i)))
@ -265,7 +265,7 @@
(mapconcat #'identity (nreverse parts) " ")))
(defun card-games-spite--disc-string (game s)
"Return a depiction of seat S's four discard-pile tops."
"Return a depiction of GAME seat S's four discard-pile tops."
(let ((parts '()))
(dotimes (d 4)
(let ((top (car (aref (card-games-spite--disc game s) d))))
@ -368,12 +368,14 @@
(_ (cl-call-next-method))))
(defun card-games-spite--redisplay ()
"Redraw the current Spite & Malice buffer."
(let ((game card-games-spite--game) (inhibit-read-only t))
(setq card-games-current-game game card-games-redisplay-function #'card-games-spite--redisplay)
(setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
(defun card-games-spite--my-turn-p (g)
"Return non-nil when it is your turn to play in G."
(and (eq (card-games-get g :phase) 'play) (= (card-games-get g :turn) 0)))
(defun card-games-spite-left ()
@ -391,7 +393,7 @@
(card-games-spite--redisplay)))
(defun card-games-spite--ensure-hand (g)
"Draw your hand up to five at the start of your turn."
"Draw your hand in G up to five at the start of your turn."
(card-games-spite--refill g 0))
(defun card-games-spite-play ()

21
card-games-svg.el
View file

@ -293,7 +293,7 @@ X, Y and W, H give the card's top-left corner and size."
(card-games-svg--text svg "JOKER" (+ x (/ w 2.0)) (+ y (* h 0.74)) (* h 0.135) color t))
(defun card-games-svg--back-dots (svg x y w h)
"Draw the dotted-medallion back pattern."
"Draw the dotted-medallion back pattern on SVG within X, Y, W, H."
(let ((gy (+ y 10)))
(while (< gy (- (+ y h) 8))
(let ((gx (+ x 10)))
@ -303,7 +303,7 @@ X, Y and W, H give the card's top-left corner and size."
(setq gy (+ gy 9)))))
(defun card-games-svg--back-lattice (svg x y w h)
"Draw a small-cross lattice back pattern."
"Draw a small-cross lattice back pattern on SVG within X, Y, W, H."
(let ((gy (+ y 13)))
(while (< gy (- (+ y h) 10))
(let ((gx (+ x 13)))
@ -316,7 +316,7 @@ X, Y and W, H give the card's top-left corner and size."
(setq gy (+ gy 11)))))
(defun card-games-svg--back-waves (svg x y w h)
"Draw a staggered-dash (brickwork) back pattern."
"Draw a staggered-dash (brickwork) back pattern on SVG within X, Y, W, H."
(let ((gy (+ y 12)) (row 0))
(while (< gy (- (+ y h) 9))
(let ((gx (+ x (if (cl-evenp row) 9 15))))
@ -326,7 +326,7 @@ X, Y and W, H give the card's top-left corner and size."
(setq gy (+ gy 8) row (1+ row)))))
(defun card-games-svg--back-diamond (svg x y w h)
"Draw concentric diamonds as the back pattern."
"Draw concentric diamonds as the back pattern on SVG within X, Y, W, H."
(let ((cx (+ x (/ w 2.0))) (cy (+ y (/ h 2.0))))
(dolist (f '(0.40 0.28 0.16))
(let ((dw (* w f)) (dh (* h f)))
@ -335,7 +335,8 @@ X, Y and W, H give the card's top-left corner and size."
:fill "none" :stroke card-games-svg-back-trim :stroke-width 1)))))
(defun card-games-svg--back-logo (svg x y w h back)
"Stamp the Emacs logo for BACK centred on the card, or dots if unavailable."
"Stamp the Emacs logo named BACK on SVG within X, Y, W, H.
Fall back to dots when the logo image is unavailable."
(let ((file (and (fboundp 'svg-embed)
(card-games-svg--logo-file (card-games-svg--back-logo-name back)))))
(if (null file)
@ -590,7 +591,8 @@ emblem and `none' shows nothing."
when (file-readable-p f) return f))
(defun card-games-svg--draw-logo-emblem (svg cx cy fs)
"Draw the built-in purple GNU Emacs emblem centred at CX, CY, scaled FS."
"Draw the built-in purple GNU Emacs emblem on SVG.
Centre it at CX, CY, scaled by FS."
(svg-gradient svg "card-games-logo" 'linear '((0 . "#8056c8") (100 . "#3f1f9e")))
(svg-circle svg cx cy (round (* 26 fs)) :gradient "card-games-logo"
:stroke "#2a1370" :stroke-width 2)
@ -599,9 +601,10 @@ emblem and `none' shows nothing."
(max 10 (round (* 11 fs))) "#c7bbe6"))
(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."
"Draw the configured Emacs emblem on SVG, centred at CX, CY.
The emblem is chosen by `card-games-svg-emacs-logo'; FS scales it. Embeds a
real Emacs logo image when one is available, and otherwise draws the
built-in emblem."
(let ((fs (or fs 1.0)) (choice card-games-svg-emacs-logo))
(pcase choice
('none nil)

54
card-games-trick-ext.el
View file

@ -83,7 +83,7 @@ TRUMP is the trump suit; POWERFN and LEDFN rank cards for this game."
(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.
"Pick a card for GAME SEAT: win cheaply if leading, else shed the cheapest.
POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(let* ((legal (card-games-trick--legal-moves game seat))
(trick (card-games-get game :trick)) (trump (oref game trump)))
@ -103,7 +103,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(car (sort (or losers legal)
(lambda (a b) (< (funcall valuefn a) (funcall valuefn b))))))))))
(defun card-games-tx--plain-led (card _trump) (car card))
(defun card-games-tx--plain-led (card _trump) "Return CARD's suit (the plain led suit)." (car card))
;;;; Briscola
@ -125,23 +125,26 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(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."
"Return CARD's Briscola power given TRUMP and LED (trump dominates)."
(cond ((= (car card) trump) (+ 200 (card-games-bris--power card trump led)))
((= (car card) led) (+ 100 (card-games-bris--power card trump led)))
(t 0)))
(cl-defmethod card-games-trick--legal-p ((game card-games-briscola-game) seat card)
"Briscola has no obligation to follow suit."
"In GAME Briscola, SEAT may play any CARD (following suit is optional)."
(and (member card (card-games-trick--hand game seat)) t))
(cl-defmethod card-games-trick--winner ((game card-games-briscola-game))
"Return the winning seat of GAME's current Briscola trick."
(card-games-tx--winner (reverse (card-games-get game :trick)) (oref game trump)
#'card-games-bris--win-power #'card-games-tx--plain-led))
(cl-defmethod card-games-trick--ai-play ((game card-games-briscola-game) seat)
"Return a card for AI SEAT in Briscola GAME."
(card-games-tx--ai game seat #'card-games-bris--win-power #'card-games-tx--plain-led #'card-games-bris--points))
(cl-defmethod card-games-trick--begin-hand ((game card-games-briscola-game))
"Begin a Briscola hand in GAME: deal and turn the trump."
(card-games-tx--deal game (card-games-tx--deck card-games-briscola--ranks) 10)
(card-games-put game :dealer (mod (1+ (or (card-games-get game :dealer) 3)) 4))
(oset game trump (car (card-games-get game :last-card)))
@ -155,6 +158,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(card-games-trick--run game))
(cl-defmethod card-games-trick--score-hand ((game card-games-briscola-game))
"Score GAME's completed Briscola hand."
(let ((scores (card-games-get game :scores)) (tp (make-vector 2 0)))
(dotimes (s 4)
(aset tp (card-games-trick--team s)
@ -163,13 +167,16 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(dotimes (s 4) (aset scores s (+ (aref scores s) (aref tp (card-games-trick--team s)))))))
(cl-defmethod card-games-trick--game-over-p ((game card-games-briscola-game))
"Return non-nil when GAME's Briscola game is over."
(or (>= (aref (card-games-get game :scores) 0) (oref game target))
(>= (aref (card-games-get game :scores) 1) (oref game target))))
(cl-defmethod card-games-trick--winner-seat ((game card-games-briscola-game))
"Return the winning seat of GAME's Briscola game."
(if (>= (aref (card-games-get game :scores) 0) (aref (card-games-get game :scores) 1)) 0 1))
(cl-defmethod card-games-trick--result-string ((game card-games-briscola-game))
"Return GAME's Briscola game-over summary."
(let ((w (card-games-trick--winner-seat game)))
(format "%s win (%d points)" (if (= w 0) "You and North" "West and East")
(aref (card-games-get game :scores) w))))
@ -199,7 +206,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(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."
"In GAME Pitch, SEAT follows the led suit if able but may always trump CARD."
(let ((hand (card-games-trick--hand game seat)) (trick (card-games-get game :trick))
(trump (oref game trump)))
(and (member card hand)
@ -211,7 +218,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(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."
"In GAME, set trump from the pitcher's first lead (SEAT plays CARD), then play on."
(when (and (null (oref game trump)) (null (card-games-get game :trick)))
(oset game trump (car card))
(card-games-put game :message
@ -221,6 +228,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(cl-call-next-method))
(cl-defmethod card-games-trick--ai-play ((game card-games-pitch-game) seat)
"Return a card for AI SEAT in Pitch GAME."
(if (and (null (oref game trump)) (= seat (card-games-get game :leader)))
;; pitcher's opening lead: lead high from the strongest suit
(let ((best nil) (bestv -1))
@ -234,7 +242,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(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."
"Estimate GAME SEAT's strength if SUIT were trump."
(let ((v 0))
(dolist (c (card-games-trick--hand game seat))
(when (= (car c) suit)
@ -242,7 +250,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
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."
"Return GAME SEAT's Pitch bid (0 to pass, else 2..4), only what is makeable."
(let ((bid 0))
(dotimes (s 4)
(let* ((cards (cl-remove-if-not (lambda (c) (= (car c) s))
@ -260,7 +268,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
bid))
(defun card-games-pitch--read-bid (game high)
"Prompt you for a Pitch bid that must beat HIGH (or 0 to pass)."
"Prompt you for a GAME Pitch bid that must beat HIGH (or 0 to pass)."
(let ((sug (card-games-trick--ai-bid game 0)))
(max 0 (min 4 (read-number
(format "Your bid (0 pass, else %d-4) [suggest %d]: "
@ -268,6 +276,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
sug)))))
(cl-defmethod card-games-trick--begin-hand ((game card-games-pitch-game))
"Begin a Pitch hand in GAME: deal and run the bidding."
(card-games-tx--deal game (card-games-tx--deck (number-sequence 0 12)) 6)
(oset game trump nil)
(card-games-put game :dealer (mod (1+ (or (card-games-get game :dealer) 3)) 4))
@ -289,6 +298,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(card-games-trick--run game)))
(cl-defmethod card-games-trick--score-hand ((game card-games-pitch-game))
"Score GAME's completed Pitch hand."
(let* ((trump (oref game trump)) (scores (card-games-get game :scores))
(earned (make-vector 4 0)) (game-pts (make-vector 4 0))
(bidder (card-games-get game :bidder)) (bid (card-games-get game :bid))
@ -317,15 +327,18 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(card-games-put game :last-earned earned)))
(cl-defmethod card-games-trick--game-over-p ((game card-games-pitch-game))
"Return non-nil when GAME's Pitch game is over."
(cl-some (lambda (s) (>= s (oref game target))) (append (card-games-get game :scores) nil)))
(cl-defmethod card-games-trick--winner-seat ((game card-games-pitch-game))
"Return the winning seat of GAME's Pitch game."
(let ((best 0)) (dotimes (s 4)
(when (> (aref (card-games-get game :scores) s)
(aref (card-games-get game :scores) best)) (setq best s)))
best))
(cl-defmethod card-games-trick--result-string ((game card-games-pitch-game))
"Return GAME's Pitch game-over summary."
(format "%s wins" (aref card-games-trick-seat-names (card-games-trick--winner-seat game))))
;;;###autoload
@ -343,9 +356,11 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
"Euchre: 24 cards, bowers, order up or call trump, partnership to 10.")
(defun card-games-euchre--right-bower-p (card trump)
"Return non-nil when CARD is the right bower for TRUMP."
(and (= (cdr card) 9) (= (car card) trump)))
(defun card-games-euchre--left-bower-p (card trump)
"Return non-nil when CARD is the left bower for TRUMP."
(and (= (cdr card) 9) (= (car card) (card-games-sister-suit trump))))
(defun card-games-euchre--eff-suit (card trump)
@ -360,10 +375,10 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
((= (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))
(defun card-games-euchre--eff-led (card trump) "Return CARD's effective led suit under TRUMP." (card-games-euchre--eff-suit card trump))
(cl-defmethod card-games-trick--legal-p ((game card-games-euchre-game) seat card)
"Euchre: follow the effective led suit if able (left bower is trump)."
"In GAME Euchre, SEAT must follow the effective led suit with CARD if able."
(let ((hand (card-games-trick--hand game seat)) (trick (card-games-get game :trick))
(trump (oref game trump)))
(and (member card hand)
@ -374,15 +389,17 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
t))))))
(cl-defmethod card-games-trick--winner ((game card-games-euchre-game))
"Return the winning seat of GAME's current Euchre trick."
(card-games-tx--winner (reverse (card-games-get game :trick)) (oref game trump)
#'card-games-euchre--power #'card-games-euchre--eff-led))
(cl-defmethod card-games-trick--ai-play ((game card-games-euchre-game) seat)
"Return a card for AI SEAT in Euchre GAME."
(card-games-tx--ai game seat #'card-games-euchre--power #'card-games-euchre--eff-led
(lambda (c) (card-games-euchre--power c (oref game trump) -1))))
(defun card-games-euchre--strength (game seat suit)
"Estimate SEAT's trump strength if SUIT were trump."
"Estimate GAME SEAT's trump strength if SUIT were trump."
(let ((v 0))
(dolist (c (card-games-trick--hand game seat))
(cond ((card-games-euchre--right-bower-p c suit) (setq v (+ v 4)))
@ -392,11 +409,11 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
v))
(defun card-games-euchre--ai-order (game seat upsuit)
"Return non-nil if SEAT orders up the UPSUIT."
"Return non-nil if GAME SEAT orders up the UPSUIT."
(>= (card-games-euchre--strength game seat upsuit) 6))
(defun card-games-euchre--ai-call (game seat upsuit)
"Return a suit SEAT calls in round two, or nil to pass."
"Return a suit GAME SEAT names in round two after UPSUIT, or nil to pass."
(let ((best nil) (bestv 0))
(dotimes (s 4)
(unless (= s upsuit)
@ -405,7 +422,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(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)."
"Return GAME SEAT's strongest suit other than UPSUIT (for a stuck dealer)."
(let ((best (mod (1+ upsuit) 4)) (bestv -1))
(dotimes (s 4)
(unless (= s upsuit)
@ -414,7 +431,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
best))
(defun card-games-euchre--dealer-pickup (game up)
"Dealer takes the UP card and discards their weakest card."
"In GAME, the dealer takes the UP card and discards their weakest."
(let* ((d (card-games-get game :dealer)) (trump (car up))
(hand (cons up (card-games-trick--hand game d)))
(worst (car (sort (copy-sequence hand)
@ -423,6 +440,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(card-games-trick--set-hand game d (card-games-trick--sort (remove worst hand)))))
(cl-defmethod card-games-trick--begin-hand ((game card-games-euchre-game))
"Begin a Euchre hand in GAME: deal, turn up, run the bidding."
(card-games-tx--deal game (card-games-tx--deck '(7 8 9 10 11 12)) 5)
(oset game trump nil)
(card-games-put game :dealer (mod (1+ (or (card-games-get game :dealer) 3)) 4))
@ -468,6 +486,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(cdr (assoc pick choices))))
(cl-defmethod card-games-trick--score-hand ((game card-games-euchre-game))
"Score GAME's completed Euchre hand."
(let* ((scores (card-games-get game :scores))
(mteam (card-games-trick--team (card-games-get game :maker)))
(mt (+ (aref (card-games-get game :tricks) mteam)
@ -480,13 +499,16 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(t (award oteam 2))))))
(cl-defmethod card-games-trick--game-over-p ((game card-games-euchre-game))
"Return non-nil when GAME's Euchre game is over."
(or (>= (aref (card-games-get game :scores) 0) (oref game target))
(>= (aref (card-games-get game :scores) 1) (oref game target))))
(cl-defmethod card-games-trick--winner-seat ((game card-games-euchre-game))
"Return the winning seat of GAME's Euchre game."
(if (>= (aref (card-games-get game :scores) 0) (aref (card-games-get game :scores) 1)) 0 1))
(cl-defmethod card-games-trick--result-string ((game card-games-euchre-game))
"Return GAME's Euchre game-over summary."
(let ((w (card-games-trick--winner-seat game)))
(format "%s win" (if (= w 0) "You and North" "West and East"))))

88
card-games-trick.el
View file

@ -57,7 +57,7 @@
(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))))
(defsubst card-games-trick-red-p (card) "Return non-nil when CARD is red." (and card (card-games-red-suit-p (car card))))
(defun card-games-trick--full-deck ()
"Return a fresh shuffled 52-card deck."
@ -114,26 +114,26 @@
(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))
(defsubst card-games-trick--hand (game s) "Return seat S's hand in GAME." (aref (card-games-get game :hands) s))
(defsubst card-games-trick--set-hand (game s v) "Set seat S's hand in GAME to V." (aset (card-games-get game :hands) s v))
(defsubst card-games-trick--partner (s) "Return seat S's partner seat." (mod (+ s 2) 4))
(defsubst card-games-trick--team (s) "Return seat S's team index (0 or 1)." (mod s 2))
;;;; Trick mechanics
(defun card-games-trick--led-suit (game)
"Return the suit led to the current trick, or nil if none yet."
"Return the suit led to GAME's current trick, or nil if none yet."
(let ((tr (card-games-get game :trick)))
(and tr (car (cdr (car (last tr))))))) ; first entry played
(defun card-games-trick--first-play (game)
"Return the (SEAT . CARD) led to the current trick, or nil."
"Return the (SEAT . CARD) led to GAME's current trick, or nil."
(car (last (card-games-get game :trick))))
(cl-defmethod card-games-trick--has-points-only-p ((_ card-games-trick-game) _hand) nil)
(cl-defmethod card-games-trick--has-points-only-p ((_ card-games-trick-game) _hand) "By default no trick restricts play to point cards." nil)
(cl-defmethod card-games-trick--legal-p ((game card-games-trick-game) seat card)
"Return non-nil when SEAT may legally play CARD now."
"Return non-nil when SEAT may legally play CARD in GAME now."
(let* ((hand (card-games-trick--hand game seat))
(trick (card-games-get game :trick))
(restricted (oref game restricted))
@ -152,12 +152,12 @@
t)))))
(defun card-games-trick--legal-moves (game seat)
"Return the list of cards SEAT may legally play now."
"Return the cards SEAT may legally play in GAME now."
(cl-remove-if-not (lambda (c) (card-games-trick--legal-p game seat c))
(card-games-trick--hand game seat)))
(cl-defmethod card-games-trick--winner ((game card-games-trick-game))
"Return the seat that wins the now-complete current trick."
"Return the seat that wins GAME's now-complete current trick."
(let* ((trick (reverse (card-games-get game :trick))) ; play order
(led (car (cdr (car trick))))
(trump (oref game trump))
@ -175,7 +175,7 @@
(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."
"Have GAME SEAT play CARD, resolving the trick when it completes."
(card-games-trick--set-hand game seat (remove card (card-games-trick--hand game seat)))
(when (= (car card) (oref game restricted)) (card-games-put game :broken t))
(card-games-put game :trick (cons (cons seat card) (card-games-get game :trick)))
@ -193,7 +193,7 @@
nil))
(defun card-games-trick--hand-over-p (game)
"Return non-nil when all 13 tricks of the hand have been played."
"Return non-nil when all 13 tricks of GAME's hand have been played."
(and (null (card-games-get game :trick))
(cl-every #'null (append (card-games-get game :hands) nil))))
@ -206,7 +206,7 @@
(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."
"In GAME, apply Hearts legality (SEAT/CARD), adding the first-trick rules."
(and (cl-call-next-method)
(let ((trick (card-games-get game :trick))
(hand (card-games-trick--hand game seat))
@ -221,19 +221,19 @@
(t t)))))
(cl-defmethod card-games-trick--leader-init ((game card-games-hearts-game))
"Hearts: the holder of the Two of Clubs leads first."
"In GAME Hearts, the holder of the Two of Clubs leads first."
(let (seat)
(dotimes (s 4)
(when (member '(1 . 0) (card-games-trick--hand game s)) (setq seat s)))
(card-games-put game :leader seat) (card-games-put game :turn seat)))
(cl-defmethod card-games-trick--leader-init ((game card-games-spades-game))
"Spades: the player left of the dealer leads first."
"In GAME Spades, the player left of the dealer leads first."
(let ((s (mod (1+ (or (card-games-get game :dealer) 3)) 4)))
(card-games-put game :leader s) (card-games-put game :turn s)))
(cl-defmethod card-games-trick--score-hand ((game card-games-hearts-game))
"Score a finished Hearts hand into the cumulative scores."
"Score GAME's finished Hearts hand into the cumulative scores."
(let ((pts (make-vector 4 0)) (scores (card-games-get game :scores)))
(dotimes (s 4)
(aset pts s (apply #'+ (mapcar #'card-games-hearts--card-points
@ -247,11 +247,11 @@
(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."
"In GAME, Hearts ends when any score reaches the target."
(cl-some (lambda (s) (>= s (oref game target))) (append (card-games-get game :scores) nil)))
(cl-defmethod card-games-trick--winner-seat ((game card-games-hearts-game))
"Return the winning seat (lowest score) for a finished Hearts game."
"Return GAME's winning seat (lowest score) for a finished Hearts game."
(let ((best 0))
(dotimes (s 4) (when (< (aref (card-games-get game :scores) s)
(aref (card-games-get game :scores) best))
@ -261,7 +261,7 @@
;;;; Spades specifics
(cl-defmethod card-games-trick--score-hand ((game card-games-spades-game))
"Score a finished Spades hand into the cumulative team scores."
"Score GAME's finished Spades hand into the cumulative team scores."
(let ((scores (card-games-get game :scores))
(bags (card-games-get game :bags))
(bids (card-games-get game :bids))
@ -289,17 +289,17 @@
(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)."
"In GAME, Spades ends when a team reaches the target (or falls badly behind)."
(cl-some (lambda (s) (>= s (oref game target))) (append (card-games-get game :scores) nil)))
(cl-defmethod card-games-trick--winner-seat ((game card-games-spades-game))
"Return a member seat of the winning team for a finished Spades game."
"Return a seat of GAME's winning team for a finished Spades game."
(if (>= (aref (card-games-get game :scores) 0) (aref (card-games-get game :scores) 1)) 0 1))
;;;; AI
(cl-defmethod card-games-trick--ai-bid ((game card-games-spades-game) seat)
"Return a simple trick estimate (bid) for SEAT in Spades."
"Return a simple trick estimate (bid) for GAME SEAT in Spades."
(let ((hand (card-games-trick--hand game seat)) (bid 0))
(dolist (c hand)
(cond
@ -312,7 +312,7 @@
(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."
"Choose a legal Hearts card for GAME SEAT, avoiding points."
(let* ((moves (card-games-trick--legal-moves game seat))
(trick (card-games-get game :trick)))
(or
@ -341,7 +341,7 @@
(car moves))))
(cl-defmethod card-games-trick--ai-play ((game card-games-spades-game) seat)
"Choose a legal Spades card for SEAT."
"Choose a legal Spades card for GAME SEAT."
(let* ((moves (card-games-trick--legal-moves game seat))
(trick (card-games-get game :trick))
(trump (oref game trump)))
@ -390,7 +390,7 @@
game)
(defun card-games-trick--simulate-hand (game)
"Play a whole hand with AI for every seat (used by tests)."
"Play a whole GAME hand with AI for every seat (used by the test suite)."
(while (not (card-games-trick--hand-over-p game))
(let ((seat (card-games-get game :turn)))
(card-games-trick--play game seat
@ -415,6 +415,7 @@
"Deal and set up a new hand of GAME, then run AI up to the human's turn.")
(cl-defmethod card-games-trick--begin-hand ((game card-games-hearts-game))
"Begin a Hearts hand in GAME: deal and set the leader."
(card-games-trick--deal game)
(card-games-put game :hand-no (1+ (or (card-games-get game :hand-no) 0)))
(card-games-put game :cursor 0) (card-games-put game :marks nil)
@ -431,6 +432,7 @@
(card-games-trick--dir-name dir))))))
(cl-defmethod card-games-trick--begin-hand ((game card-games-spades-game))
"Begin a Spades hand in GAME: deal and run the bidding."
(card-games-trick--deal game)
(card-games-put game :dealer (mod (1+ (or (card-games-get game :dealer) 3)) 4))
(card-games-put game :cursor 0)
@ -460,7 +462,7 @@
game)
(defun card-games-trick--run (game)
"Advance AI seats until it is the human's turn or the hand ends."
"Advance GAME's AI seats until the human's turn or the hand ends."
(while (and (eq (card-games-get game :phase) 'play)
(not (card-games-trick--hand-over-p game))
(/= (card-games-get game :turn) 0))
@ -480,10 +482,12 @@
(card-games-trick--begin-hand game)))
(cl-defmethod card-games-trick--result-string ((game card-games-hearts-game))
"Return GAME's Hearts game-over summary."
(format "%s wins with the lowest score"
(aref card-games-trick-seat-names (card-games-trick--winner-seat game))))
(cl-defmethod card-games-trick--result-string ((game card-games-spades-game))
"Return GAME's Spades game-over summary."
(let ((w (card-games-trick--winner-seat game)))
(format "%s win" (if (= w 0) "You and North" "West and East"))))
@ -541,7 +545,8 @@
(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)."
"Return an SVG row for CARDS with CURSOR and HINTS, clickable via REGION-TAG.
The MARKS list highlights any selected cards."
(card-games-svg-hand-image (mapcar #'card-games-trick--spec cards)
:cursor cursor :marks marks :hints hints
:overlap (if (> (length cards) 11)
@ -549,7 +554,7 @@
: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."
"Draw up to three overlapped face-down backs on SVG at X, Y for N cards."
(let ((k (min (max n 0) 3)) (xx x))
(dotimes (_ k)
(card-games-svg-card svg xx y :down t)
@ -676,14 +681,14 @@ The South hand carries clickable (hand . INDEX) regions."
(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."
"Return a depiction of GAME.
Use a full SVG table on a graphical display, else a plain-text board."
(if (and card-games-trick-svg-cards (display-graphic-p))
(card-games-trick--svg game)
(card-games-trick--render-text game)))
(cl-defmethod card-games-render-apply ((g card-games-trick-game) action)
"Apply a click ACTION on the hand: select that card and play it."
"Apply click ACTION on G's hand: select that card and play it."
(pcase action
(`(hand . ,i) (card-games-put g :cursor i) (card-games-trick-act))
(_ (cl-call-next-method))))
@ -701,7 +706,7 @@ else a plain-text board."
;;;; Commands
(defun card-games-trick--cursor-card (game)
"Return the South card currently under the cursor."
"Return GAME's South card currently under the cursor."
(nth (card-games-get game :cursor) (card-games-trick--sort (card-games-trick--hand game 0))))
(defun card-games-trick-left ()
@ -821,14 +826,16 @@ else a plain-text board."
"Oh Hell: hand size shrinks each round; bid the exact tricks you will take.")
(cl-defmethod card-games-trick--leader-init ((game card-games-whist-game))
"In GAME Whist, the player left of the dealer leads first."
(let ((s (mod (1+ (or (card-games-get game :dealer) 3)) 4)))
(card-games-put game :leader s) (card-games-put game :turn s)))
(cl-defmethod card-games-trick--leader-init ((game card-games-ohhell-game))
"In GAME Oh Hell, the player left of the dealer leads first."
(let ((s (mod (1+ (or (card-games-get game :dealer) 3)) 4)))
(card-games-put game :leader s) (card-games-put game :turn s)))
(defun card-games-trick--ai-trump-play (game seat)
"A generic legal trump-game play for SEAT: follow and win cheaply, else low."
"A generic legal trump-game play for GAME SEAT: follow and win cheaply, else low."
(let* ((moves (card-games-trick--legal-moves game seat))
(trick (card-games-get game :trick)))
(or
@ -846,12 +853,15 @@ else a plain-text board."
(car moves))))
(cl-defmethod card-games-trick--ai-play ((game card-games-whist-game) seat)
"Choose a legal Whist card for AI SEAT in GAME."
(card-games-trick--ai-trump-play game seat))
(cl-defmethod card-games-trick--ai-play ((game card-games-ohhell-game) seat)
"Choose a legal Oh Hell card for AI SEAT in GAME."
(card-games-trick--ai-trump-play game seat))
;; Whist
(cl-defmethod card-games-trick--begin-hand ((game card-games-whist-game))
"Begin a Whist hand in GAME: deal and turn the trump."
(card-games-trick--deal game)
(card-games-put game :dealer (mod (1+ (or (card-games-get game :dealer) 3)) 4))
(oset game trump (car (card-games-get game :last-card))) ; dealer's last card turns trump
@ -863,6 +873,7 @@ else a plain-text board."
(card-games-trick--run game))
(cl-defmethod card-games-trick--score-hand ((game card-games-whist-game))
"Score GAME's finished Whist hand."
(let ((scores (card-games-get game :scores)) (tricks (card-games-get game :tricks)))
(dotimes (team 2)
(let ((over (max 0 (- (+ (aref tricks team) (aref tricks (+ team 2))) 6))))
@ -871,10 +882,13 @@ else a plain-text board."
(card-games-put game :scores scores)))
(cl-defmethod card-games-trick--game-over-p ((game card-games-whist-game))
"Return non-nil when GAME's Whist game is over."
(cl-some (lambda (s) (>= s (oref game target))) (append (card-games-get game :scores) nil)))
(cl-defmethod card-games-trick--winner-seat ((game card-games-whist-game))
"Return the winning seat of GAME's Whist game."
(if (>= (aref (card-games-get game :scores) 0) (aref (card-games-get game :scores) 1)) 0 1))
(cl-defmethod card-games-trick--result-string ((game card-games-whist-game))
"Return GAME's Whist game-over summary."
(format "%s win" (if (= 0 (card-games-trick--winner-seat game)) "You and North" "West and East")))
;; Oh Hell
@ -882,6 +896,7 @@ else a plain-text board."
"Hand sizes dealt in successive Oh Hell rounds.")
(cl-defmethod card-games-trick--ai-bid ((game card-games-ohhell-game) seat)
"Return an exact-tricks bid for GAME AI SEAT in Oh Hell."
(let ((hand (card-games-trick--hand game seat)) (trump (oref game trump)) (bid 0))
(dolist (c hand)
(cond ((= (cdr c) 12) (cl-incf bid))
@ -889,6 +904,7 @@ else a plain-text board."
(min bid (length hand))))
(cl-defmethod card-games-trick--begin-hand ((game card-games-ohhell-game))
"Begin an Oh Hell hand in GAME: deal the round and run the bidding."
(let* ((round (or (card-games-get game :round) 0))
(hs (aref card-games-ohhell--sizes (min round (1- (length card-games-ohhell--sizes))))))
(oset game hand-size hs)
@ -912,6 +928,7 @@ else a plain-text board."
(card-games-trick--run game)))
(cl-defmethod card-games-trick--score-hand ((game card-games-ohhell-game))
"Score GAME's finished Oh Hell round."
(let ((scores (card-games-get game :scores)) (bids (card-games-get game :bids))
(tricks (card-games-get game :tricks)))
(dotimes (s 4)
@ -921,12 +938,15 @@ else a plain-text board."
(card-games-put game :round (1+ (or (card-games-get game :round) 0)))))
(cl-defmethod card-games-trick--game-over-p ((game card-games-ohhell-game))
"Return non-nil when GAME's Oh Hell game is over."
(>= (or (card-games-get game :round) 0) (length card-games-ohhell--sizes)))
(cl-defmethod card-games-trick--winner-seat ((game card-games-ohhell-game))
"Return the winning seat of GAME's Oh Hell game."
(let ((best 0)) (dotimes (s 4) (when (> (aref (card-games-get game :scores) s)
(aref (card-games-get game :scores) best)) (setq best s)))
best))
(cl-defmethod card-games-trick--result-string ((game card-games-ohhell-game))
"Return GAME's Oh Hell game-over summary."
(format "%s wins" (aref card-games-trick-seat-names (card-games-trick--winner-seat game))))
;;;###autoload

3
card-games.el
View file

@ -148,7 +148,8 @@ Each entry is (NAME COMMAND DESCRIPTION); `card-games' lists them.")
;;;###autoload
(defun card-games-set-treatment (treatment)
"Set how games are drawn: `text' (UNICODE), `svg' (cards), or `full'.
"Set how games are drawn to TREATMENT.
TREATMENT is `text' (UNICODE), `svg' (cards), or `full'.
`full' also uses the full-window SVG table where a game has one (Gaps and
500). Takes effect the next time a game is drawn -- press g to redraw an
open game. Gaps and 500 are always graphical on a window system."