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 ;;;; Rendering
(defun card-games-bid--trick-card-for (game seat) (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)))) (let ((tr (or (card-games-get game :trick) (card-games-get game :last-trick))))
(cdr (assq seat tr)))) (cdr (assq seat tr))))
@ -162,14 +162,14 @@ matches your Emacs theme."
:type 'number :group 'card-games-svg) :type 'number :group 'card-games-svg)
(defcustom card-games-bid-svg-ui nil (defcustom card-games-bid-svg-ui nil
"When non-nil (and on a graphical display), render 500 as a single "Whether to render 500 as one full-buffer SVG.
full-buffer SVG: the table in the centre, a status/compass/bid panel on When non-nil (and on a graphical display), the table sits in the centre, a
the left, and a scrollable message log on the right." status/compass/bid panel on the left, and a scrollable message log on the right."
:type 'boolean :group 'card-games-svg) :type 'boolean :group 'card-games-svg)
(defcustom card-games-bid-svg-fill t (defcustom card-games-bid-svg-fill t
"When non-nil, size the full-SVG UI to fill the window and enlarge the "Whether the full-SVG UI fills the window and enlarges the South hand.
South hand, re-fitting on window changes. Only used when `card-games-bid-svg-ui'." Re-fit on window changes. Only used when `card-games-bid-svg-ui' is set."
:type 'boolean :group 'card-games-svg) :type 'boolean :group 'card-games-svg)
(defcustom card-games-bid-card-scale 1.0 (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)))) (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) (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." FS scales the name pill and its fonts."
(let* ((fs (or fs 1.0)) (let* ((fs (or fs 1.0))
(n (length (card-games-bid--hand game seat))) (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)))) (unless sitter (card-games-bid--draw-backs svg cx top n))))
(defun card-games-bid--draw-trick (svg game) (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) (let* ((W card-games-bid--canvas-w) (H card-games-bid--canvas-h)
(w card-games-bid--tw) (h card-games-bid--th) (w card-games-bid--tw) (h card-games-bid--th)
(cx (/ W 2)) (cy (/ H 2)) (cx (/ W 2)) (cy (/ H 2))
@ -269,7 +269,7 @@ FS scales the name pill and its fonts."
:rank (car spec) :suit (cdr spec))))))) :rank (car spec) :suit (cdr spec)))))))
(defun card-games-bid--draw-south (svg game) (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) (let* ((trump (and (card-games-get game :contract)
(card-games-bid-trump (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))) (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)))) (insert (format "\n %s\n" (card-games-get game :message))))
(defun card-games-bid--south-hit (px py n) (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)) (let* ((lay (card-games-bid--south-layout n))
(x0 (nth 0 lay)) (step (nth 1 lay)) (y (nth 2 lay))) (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)) (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)))) (goto-char (point-min))))
(defun card-games-bid--refresh () (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)) (let ((game card-games-bid--game))
(if (or (not card-games-bid-animate) (<= card-games-bid-ai-delay 0)) (if (or (not card-games-bid-animate) (<= card-games-bid-ai-delay 0))
(progn (card-games-bid--run game) (card-games-bid--redisplay)) (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)))) (card-games-bid--refresh))))
(defun card-games-bid-new () (defun card-games-bid-new ()
"Advance to the next hand once a hand is over, or start a fresh game at "Advance to the next hand, or start a fresh game once one is over.
game over. 500 is a multi-hand game with no mid-hand redeal, so a hand in 500 is a multi-hand game with no mid-hand redeal, so a hand in progress
progress must be played out (unlike the solitaire games)." must be played out (unlike the solitaire games)."
(interactive) (interactive)
(let* ((game card-games-bid--game) (phase (card-games-get game :phase))) (let* ((game card-games-bid--game) (phase (card-games-get game :phase)))
(cond (cond
@ -581,7 +581,7 @@ progress must be played out (unlike the solitaire games)."
(card-games-bid--redisplay))))) (card-games-bid--redisplay)))))
(defun card-games-bid-mouse (event) (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") (interactive "e")
(let ((start (event-start event)) (game card-games-bid--game)) (let ((start (event-start event)) (game card-games-bid--game))
(if (and card-games-bid-svg-ui (display-graphic-p) (posn-image start)) (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))) (apply #'svg-text svg str a)))
(defun card-games-bid--ui-label (svg str x y &optional size) (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)) (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 :fill "#8fc79b" :text-anchor "start" :font-family card-games-svg-font-family
:font-weight "bold" :letter-spacing "2")) :font-weight "bold" :letter-spacing "2"))
(defun card-games-bid--ui-divider (svg x1 x2 y) (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)) (svg-line svg x1 y x2 y :stroke "#1b6b35" :stroke-width 1))
(defun card-games-bid--active-seat (game) (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) (pcase (card-games-get game :phase)
('auction (card-games-get game :bidder)) ('auction (card-games-get game :bidder))
('kitty (card-games-get game :contractor)) ('kitty (card-games-get game :contractor))
@ -760,7 +760,7 @@ keep a minimum gutter so each rank index stays visible."
(list x0 step y))) (list x0 step y)))
(defun card-games-bid--draw-trick-at (svg game cx cy &optional fs) (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." FS scales the drop-zone, the played cards, and their spread."
(let* ((fs (or fs 1.0)) (let* ((fs (or fs 1.0))
(r (round (* 80 fs))) (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)))))))) (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) (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))." Return (:hand (X0 STEP Y N SH))."
(let* ((trump (and (card-games-get game :contract) (card-games-bid-trump (card-games-get game :contract)))) (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))) (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))))) (list :hand (list x0 step y n sh)))))
(defun card-games-bid--draw-compass (svg game cx cy r &optional fs) (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." FS scales the N/S/E/W label fonts."
(let ((active (card-games-bid--active-seat game)) (let ((active (card-games-bid--active-seat game))
(lsz (max 12 (round (* 13 (or fs 1.0)))))) (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)))) (list (+ gx (* col (+ cw g))) (+ gy (* row (+ ch g))) cw ch))))
(defun card-games-bid--grid-pass-cell (gx gy cw ch g) (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)) (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) (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 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 Y (also the North reference line). All metrics scale with FS so the
panel content grows with the window." panel content grows with the window."
@ -960,8 +960,9 @@ panel content grows with the window."
regions)) regions))
(defun card-games-bid--draw-log (svg game x w h fs ccy) (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. "Draw GAME's full-height right log panel on SVG; return its regions.
FS scales the emblem and fonts; CCY aligns the divider with the compass." 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)))) (let* ((F (lambda (n) (round (* n fs))))
(y 6) (bottom (- h 6 (funcall F 64))) ; reserve a control strip (y 6) (bottom (- h 6 (funcall F 64))) ; reserve a control strip
(logtop (+ ccy (funcall F 44) (funcall F 12))) ; align with left divider (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)))))) :help (list hx cz hw hh) :sizer (nreverse srs))))))
(defun card-games-bid--draw-banner (svg game tx tw ty fs) (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)) (let* ((txt (card-games-bid--phase-text game))
(by (+ ty (round (* 6 fs)))) (bh (round (* 30 fs))) (by (+ ty (round (* 6 fs)))) (bh (round (* 30 fs)))
(bw (min (- tw (round (* 90 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))) (round (* 14 fs)) "#f4faf4" t)))
(defun card-games-bid--draw-help-overlay (svg _game tx ty tw th fs) (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)))) (let* ((F (lambda (n) (round (* n fs))))
(m (funcall F 26)) (m (funcall F 26))
(ox (+ tx m)) (oy (+ ty m)) (ow (- tw (* 2 m))) (oh (- th (* 2 m))) (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))) (card-games-bid--redisplay)))
(defun card-games-bid-wheel (event) (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." Elsewhere, fall back to normal buffer scrolling."
(interactive "e") (interactive "e")
(let ((start (event-start event)) (rg card-games-bid--regions) (handled nil)) (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))))) (ignore-errors (require 'mwheel) (mwheel-scroll event)))))
(defun card-games-bid--region-bid (px py rg) (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))) (cl-some (lambda (e) (and (card-games-bid--in-rect px py (cdr e)) (car e)))
(plist-get rg :bids))) (plist-get rg :bids)))

82
card-games-bid.el
View file

@ -109,13 +109,13 @@
"Bidding schedule, ascending by value. "Bidding schedule, ascending by value.
Each entry is (LABEL NAME VALUE TRICKS TRUMP [OPEN]).") Each entry is (LABEL NAME VALUE TRICKS TRUMP [OPEN]).")
(defsubst card-games-bid-label (bid) (nth 0 bid)) (defsubst card-games-bid-label (bid) "Return BID's label string." (nth 0 bid))
(defsubst card-games-bid-name (bid) (nth 1 bid)) (defsubst card-games-bid-name (bid) "Return BID's full name." (nth 1 bid))
(defsubst card-games-bid-value (bid) (nth 2 bid)) (defsubst card-games-bid-value (bid) "Return BID's score value." (nth 2 bid))
(defsubst card-games-bid-tricks (bid) (nth 3 bid)) (defsubst card-games-bid-tricks (bid) "Return BID's trick target." (nth 3 bid))
(defsubst card-games-bid-trump (bid) (nth 4 bid)) (defsubst card-games-bid-trump (bid) "Return BID's trump suit." (nth 4 bid))
(defsubst card-games-bid-open-p (bid) (nth 5 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) (eq (card-games-bid-trump bid) 'nullo)) (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 ;;;; Card power and trick logic
@ -170,7 +170,7 @@ must follow the led suit if able."
(or follow hand)))) (or follow hand))))
(defun card-games-bid-sort-hand (hand trump) (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) (sort (copy-sequence hand)
(lambda (a b) (lambda (a b)
(let* (( at (and (numberp trump) (let* (( at (and (numberp trump)
@ -190,7 +190,7 @@ must follow the led suit if able."
(defun card-games-bid--display-key (card trump) (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 Trumps (and the Joker) sort first, strongest first; the remaining
suits are grouped spades, hearts, clubs, diamonds, high rank first." suits are grouped spades, hearts, clubs, diamonds, high rank first."
(cond (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." "Return non-nil when SEAT is played by a human."
(memq seat card-games-bid--human-seats)) (memq seat card-games-bid--human-seats))
(defsubst card-games-bid--partner (seat) (mod (+ seat 2) 4)) (defsubst card-games-bid--partner (seat) "Return SEAT's 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--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) (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." "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)))) (card-games-get game :bidder))))
game)) game))
(defun card-games-bid--hand (game seat) (aref (card-games-get game :hands) seat)) (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) (aset (card-games-get game :hands) seat cards)) (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 ;;;; Auction
(defun card-games-bid--legal-bids (game) (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) (let ((hv (if (card-games-get game :high-bid)
(card-games-bid-value (card-games-get game :high-bid)) 0))) (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))) (cl-remove-if-not (lambda (b) (> (card-games-bid-value b) hv)) card-games-bid-schedule)))
(defun card-games-bid--active-seats (game) (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 (cl-loop for s below 4
unless (aref (card-games-get game :passed) s) collect s)) unless (aref (card-games-get game :passed) s) collect s))
(defun card-games-bid--next-bidder (game from) (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 (cl-loop for i from 1 to 4
for s = (mod (+ from i) 4) for s = (mod (+ from i) 4)
unless (aref (card-games-get game :passed) s) return s)) 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)) (card-games-put game :log-scroll 0))
(cl-defmethod card-games-bid--auction-act ((game card-games-bid-game) seat bid) (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 (if bid
(progn (card-games-put game :high-bid bid) (progn (card-games-put game :high-bid bid)
(card-games-put game :high-bidder seat) (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)))))) (card-games-put game :bidder (card-games-bid--next-bidder game seat))))))
(cl-defmethod card-games-bid--begin-contract ((game card-games-bid-game)) (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)) (let* ((contractor (card-games-get game :high-bidder))
(bid (card-games-get game :high-bid))) (bid (card-games-get game :high-bid)))
(card-games-put game :contractor contractor) (card-games-put game :contractor contractor)
@ -344,7 +344,7 @@ Trumps lead (strongest first), then each side suit runs high to low."
;;;; Kitty discard ;;;; Kitty discard
(cl-defmethod card-games-bid--discard ((game card-games-bid-game) seat cards) (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 (card-games-bid--set-hand game seat
(cl-set-difference (card-games-bid--hand game seat) cards (cl-set-difference (card-games-bid--hand game seat) cards
:test #'equal)) :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) ;;;; Seat order (a partner sits out during a misère)
(defun card-games-bid--misere-p (game) (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)))) (let ((c (card-games-get game :contract))) (and c (card-games-bid-nullo-p c))))
(defun card-games-bid--sitter (game) (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) (and (card-games-bid--misere-p game)
(card-games-bid--partner (card-games-get game :contractor)))) (card-games-bid--partner (card-games-get game :contractor))))
(defun card-games-bid--in-play-p (game seat) (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)))) (not (eql seat (card-games-bid--sitter game))))
(defun card-games-bid--num-players (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)) (if (card-games-bid--misere-p game) 3 4))
(defun card-games-bid--next-seat (game seat) (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))) (let ((n (mod (1+ seat) 4)))
(if (card-games-bid--in-play-p game n) n (mod (1+ n) 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 ;;;; Trick play
(cl-defmethod card-games-bid--play ((game card-games-bid-game) seat card) (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))) (let* ((trump (card-games-bid-trump (card-games-get game :contract)))
(led (card-games-get game :led)) (led (card-games-get game :led))
(lead-p (null (card-games-get game :trick)))) (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))))) (card-games-put game :turn (card-games-bid--next-seat game seat)))))
(defun card-games-bid--nominate-suit (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))) (let ((hand (card-games-bid--hand game seat)))
(if (card-games-bid--human-p seat) (if (card-games-bid--human-p seat)
(let ((ch (read-char-choice (let ((ch (read-char-choice
@ -429,7 +429,7 @@ Trumps lead (strongest first), then each side suit runs high to low."
best))))) best)))))
(cl-defmethod card-games-bid--finish-trick ((game card-games-bid-game)) (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))) (let* ((trump (card-games-bid-trump (card-games-get game :contract)))
(led (card-games-get game :led)) (led (card-games-get game :led))
(plays (card-games-get game :trick)) (plays (card-games-get game :trick))
@ -458,7 +458,7 @@ Trumps lead (strongest first), then each side suit runs high to low."
;;;; Scoring ;;;; Scoring
(cl-defmethod card-games-bid--score-hand ((game card-games-bid-game)) (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)) (let* ((bid (card-games-get game :contract))
(contractor (card-games-get game :contractor)) (contractor (card-games-get game :contractor))
(cteam (card-games-bid--team 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.")))))) (concat result " — press n for the next hand."))))))
(cl-defmethod card-games-bid--check-gameover ((game card-games-bid-game) made cteam) (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 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; just scored: a side wins only by reaching 500 on a made contract;
a side that sinks to -500 loses." 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)))))) (card-games-bid-power b trump led))))))
(defun card-games-bid--trump-cards (hand trump) (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 (cl-remove-if-not
(lambda (c) (or (card-games-bid-joker-p c) (lambda (c) (or (card-games-bid-joker-p c)
(and (numberp trump) (eq (card-games-bid-effective-suit c trump) trump)))) (and (numberp trump) (eq (card-games-bid-effective-suit c trump) trump))))
@ -591,7 +591,7 @@ a side that sinks to -500 loses."
best)) best))
(defun card-games-bid--ai-bid-basic (game seat) (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)) (let* ((hand (card-games-bid--hand game seat))
(best (card-games-bid--ai-best-contract hand)) (best (card-games-bid--ai-best-contract hand))
(trump (car best)) (trump (car best))
@ -608,14 +608,14 @@ a side that sinks to -500 loses."
(card-games-bid--auction-act game seat choice))) (card-games-bid--auction-act game seat choice)))
(defun card-games-bid--ai-discard-basic (game seat) (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))) (let* ((trump (card-games-bid-trump (card-games-get game :contract)))
(sorted (card-games-bid-sort-hand (card-games-bid--hand game seat) trump)) (sorted (card-games-bid-sort-hand (card-games-bid--hand game seat) trump))
(discard (last sorted 5))) (discard (last sorted 5)))
(card-games-bid--discard game seat discard))) (card-games-bid--discard game seat discard)))
(defun card-games-bid--ai-play-positive (game seat) (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))) (let* ((trump (card-games-bid-trump (card-games-get game :contract)))
(led (card-games-get game :led)) (led (card-games-get game :led))
(hand (card-games-bid--hand game seat)) (hand (card-games-bid--hand game seat))
@ -683,7 +683,7 @@ a side that sinks to -500 loses."
best)) best))
(defun card-games-bid--ai-bid-smart (game seat) (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)) (let* ((hand (card-games-bid--hand game seat))
(best (card-games-bid--best-smart hand)) (best (card-games-bid--best-smart hand))
(trump (car best)) (trump (car best))
@ -700,7 +700,7 @@ a side that sinks to -500 loses."
(card-games-bid--auction-act game seat choice))) (card-games-bid--auction-act game seat choice)))
(defun card-games-bid--ai-discard-smart (game seat) (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))) (let* ((trump (card-games-bid-trump (card-games-get game :contract)))
(hand (card-games-bid--hand game seat)) (hand (card-games-bid--hand game seat))
(cand '())) (cand '()))
@ -721,7 +721,7 @@ a side that sinks to -500 loses."
(card-games-bid--discard game seat discard))))) (card-games-bid--discard game seat discard)))))
(defun card-games-bid--lead-low-long (hand trump legal) (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)) (let ((best-suit nil) (best-len -1))
(dotimes (s 4) (dotimes (s 4)
(unless (and (numberp trump) (= s trump)) (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)))) (card-games-bid--lowest (or cs legal) trump nil))))
(defun card-games-bid--ai-play-smart (game seat) (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 declarer draws trumps and cashes aces; everyone wins as cheaply as
possible and never overtakes a partner who is already winning." possible and never overtakes a partner who is already winning."
(let* ((trump (card-games-bid-trump (card-games-get game :contract))) (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 ;;; dispatch
(cl-defmethod card-games-bid--ai-bid ((game card-games-bid-game) seat) (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) (if (eq (card-games-bid--policy seat) 'smart)
(card-games-bid--ai-bid-smart game seat) (card-games-bid--ai-bid-smart game seat)
(card-games-bid--ai-bid-basic game seat))) (card-games-bid--ai-bid-basic game seat)))
(cl-defmethod card-games-bid--ai-discard ((game card-games-bid-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) (if (eq (card-games-bid--policy seat) 'smart)
(card-games-bid--ai-discard-smart game seat) (card-games-bid--ai-discard-smart game seat)
(card-games-bid--ai-discard-basic game seat))) (card-games-bid--ai-discard-basic game seat)))
(cl-defmethod card-games-bid--ai-play ((game card-games-bid-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)) (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)) ((eq (card-games-bid--policy seat) 'smart) (card-games-bid--ai-play-smart game seat))
(t (card-games-bid--ai-play-positive game seat)))) (t (card-games-bid--ai-play-positive game seat))))
(defun card-games-bid--ai-play-misere (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 The contractor sheds its highest card that still loses (or ducks
lowest when leading); defenders simply play low." lowest when leading); defenders simply play low."
(let* ((trump 'nullo) (let* ((trump 'nullo)

51
card-games-bridge.el
View file

@ -96,7 +96,7 @@
(cl-count suit hand :key #'car)) (cl-count suit hand :key #'car))
(defun card-games-bridge--longest (hand) (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)) (let ((best 0) (bestn -1))
;; check in order hearts, diamonds, clubs, spades so spades win ties last ;; check in order hearts, diamonds, clubs, spades so spades win ties last
(dolist (s '(3 2 1 0)) (dolist (s '(3 2 1 0))
@ -115,9 +115,9 @@
;;;; Auction mechanics ;;;; Auction mechanics
(defsubst card-games-bridge--hand (game s) (aref (card-games-get game :hands) s)) (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) (aset (card-games-get game :hands) s v)) (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) (mod s 2)) (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)) (cl-defmethod card-games-bridge--deal ((game card-games-bridge-game))
"Deal a fresh Bridge hand into GAME, leaving it ready for the auction." "Deal a fresh Bridge hand into GAME, leaving it ready for the auction."
@ -147,12 +147,12 @@
game)) game))
(defun card-games-bridge--high-bid (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) (cl-loop for (_s . call) in (card-games-get game :calls)
when (consp call) return call)) when (consp call) return call))
(defun card-games-bridge--high-bidder (game) (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) (cl-loop for (s . call) in (card-games-get game :calls)
when (consp call) return s)) when (consp call) return s))
@ -176,7 +176,7 @@
(card-games-bridge--call> call high)))))) (card-games-bridge--call> call high))))))
(defun card-games-bridge--apply-call (game seat call) (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))) (card-games-put game :calls (cons (cons seat call) (card-games-get game :calls)))
(pcase call (pcase call
('double (card-games-put game :doubled 1)) ('double (card-games-put game :doubled 1))
@ -185,7 +185,7 @@
(card-games-put game :bidder (mod (1+ seat) 4))) (card-games-put game :bidder (mod (1+ seat) 4)))
(defun card-games-bridge--auction-done-p (game) (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." Sets up the contract (or a pass-out) as a side effect."
(let* ((calls (card-games-get game :calls)) (n (length calls))) (let* ((calls (card-games-get game :calls)) (n (length calls)))
(cond (cond
@ -201,7 +201,7 @@ Sets up the contract (or a pass-out) as a side effect."
(t nil)))) (t nil))))
(defun card-games-bridge--establish-contract (game) (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)) (let* ((bid (card-games-bridge--high-bid game))
(side (card-games-bridge--side (card-games-bridge--high-bidder game))) (side (card-games-bridge--side (card-games-bridge--high-bidder game)))
(strain (cdr bid)) (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))))) (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) (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))) (let ((tr (card-games-get game :trick)))
(and tr (car (cdr (car (last tr))))))) (and tr (car (cdr (car (last tr)))))))
(defun card-games-bridge--legal-play-p (game seat card) (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))) (let ((hand (card-games-bridge--hand game seat)) (led (card-games-bridge--led-suit game)))
(and (member card hand) (and (member card hand)
(or (null led) (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)))))) (not (cl-some (lambda (c) (= (car c) led)) hand))))))
(defun card-games-bridge--legal-plays (game seat) (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)) (cl-remove-if-not (lambda (c) (card-games-bridge--legal-play-p game seat c))
(card-games-bridge--hand game seat))) (card-games-bridge--hand game seat)))
(defun card-games-bridge--trick-winner (plays trump) (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))) (let ((best (car plays)))
(dolist (p (cdr plays)) (dolist (p (cdr plays))
(let ((bc (cdr best)) (pc (cdr p))) (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))) (car best)))
(defun card-games-bridge--play-card (game seat card) (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-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))) (card-games-put game :trick (cons (cons seat card) (card-games-get game :trick)))
;; expose the dummy after the opening lead ;; expose the dummy after the opening lead
@ -361,7 +361,7 @@ vulnerability, and TRICKS the declarer side's trick count. Keys:
;;;; AI -- bidding ;;;; AI -- bidding
(cl-defmethod card-games-bridge--ai-call ((game card-games-bridge-game) seat) (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)) (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)) (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))))) (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 ;;;; AI -- play
(cl-defmethod card-games-bridge--ai-play ((game card-games-bridge-game) seat) (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)) (let* ((legal (card-games-bridge--legal-plays game seat))
(trump (card-games-bridge--trump game)) (trick (card-games-get game :trick))) (trump (card-games-bridge--trump game)) (trick (card-games-get game :trick)))
(if (null 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))))))))))) (t (car (sort (copy-sequence legal) (lambda (a b) (< (cdr a) (cdr b)))))))))))
(defun card-games-bridge--controls (game) (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))) (let ((decl (card-games-get game :declarer)))
(cond ((null decl) nil) (cond ((null decl) nil)
((= decl 0) '(0 2)) ; South declares: play hand + dummy ((= 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)))) (not (memq seat (card-games-bridge--controls game))))
(defun card-games-bridge--run-play (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)) (let ((guard 0))
(while (and (eq (card-games-get game :phase) 'play) (while (and (eq (card-games-get game :phase) 'play)
(card-games-bridge--auto-seat-p game (card-games-get game :turn)) (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)))))) (card-games-bridge--ai-play game (card-games-get game :turn))))))
(defun card-games-bridge--run-auction (game) (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)) (let ((guard 0))
(while (and (eq (card-games-get game :phase) 'auction) (/= (card-games-get game :bidder) 0) (while (and (eq (card-games-get game :phase) 'auction) (/= (card-games-get game :bidder) 0)
(< guard 40)) (< guard 40))
@ -471,7 +471,7 @@ vulnerability, and TRICKS the declarer side's trick count. Keys:
(apply #'concat (nreverse out)))) (apply #'concat (nreverse out))))
(defun card-games-bridge--auction-string (game) (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 '())) (let ((calls (reverse (card-games-get game :calls))) (out '()))
(dolist (sc calls) (dolist (sc calls)
(push (format "%s:%s" (aref card-games-bridge-seat-names (car sc)) (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))) (cons (aref card-games-bridge-ranks (cdr card)) (car card)))
(cl-defun card-games-bridge--svg-row (cards &key cursor hints region-tag) (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) (card-games-svg-hand-image (mapcar #'card-games-bridge--spec cards)
:cursor cursor :hints hints :cursor cursor :hints hints
:overlap (if (> (length cards) 11) :overlap (if (> (length cards) 11)
@ -498,7 +498,7 @@ vulnerability, and TRICKS the declarer side's trick count. Keys:
:region-tag region-tag)) :region-tag region-tag))
(defun card-games-bridge--draw-backs (svg x y n) (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)) (let ((k (min (max n 0) 3)) (xx x))
(dotimes (_ k) (card-games-svg-card svg xx y :down t) (setq xx (+ xx 16))))) (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)))) (apply #'concat (nreverse out))))
(cl-defmethod card-games-render-apply ((g card-games-bridge-game) action) (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 (pcase action
(`(hand . ,i) (card-games-put g :cursor i) (card-games-bridge-play)) (`(hand . ,i) (card-games-put g :cursor i) (card-games-bridge-play))
(_ (cl-call-next-method)))) (_ (cl-call-next-method))))
(defun card-games-bridge--redisplay () (defun card-games-bridge--redisplay ()
"Redraw the current Bridge buffer."
(let ((game card-games-bridge--game) (inhibit-read-only t)) (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 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))) (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))) (card-games-bridge--redisplay)))
(defun card-games-bridge--after-call (g) (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) (unless (card-games-bridge--auction-done-p g)
(card-games-bridge--run-auction g)) (card-games-bridge--run-auction g))
(when (eq (card-games-get g :phase) 'play) (card-games-bridge--run-play 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 ;;;; Play commands
(defun card-games-bridge--act-hand (g) (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))) (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)))) (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)))))) (= 1 (abs (- (cdr pile-top) (cdr card))))))
(defun card-games-crap--found-for (game 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)) (cl-loop for i below 8 when (card-games-crap--found-accepts game i card) return i))
;;;; Sequenced house moves ;;;; Sequenced house moves
(defun card-games-crap--house-run (game i) (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 The run is the longest sequence of cards at the top of the house that is
built down in alternating colours." built down in alternating colours."
(let ((rev (reverse (card-games-crap--house game i)))) ; top-first (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))) (cl-count-if #'null (append (card-games-get game :houses) nil)))
(defun card-games-crap--capacity (game dest-i) (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 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)." F onto an empty house (the destination itself cannot serve as a relay)."
(let ((free (card-games-crap--free-houses game))) (let ((free (card-games-crap--free-houses game)))
@ -291,7 +291,7 @@ and nil when nothing fits."
(_ nil))) (_ nil)))
(defun card-games-crap--dest-ok (game from to card p) (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) (pcase (car to)
('found (card-games-crap--found-accepts game (cdr to) card)) ('found (card-games-crap--found-accepts game (cdr to) card))
('house (card-games-crap--house-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))))))) (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) (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." Return non-nil when the move was legal and performed."
(let ((card (card-games-crap--spot-top game from))) (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)) (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) (defun card-games-crap--do-move (game from to p &optional want)
"Perform player P's move from FROM to TO in GAME. "Perform player P's move from FROM to TO in GAME.
A house-to-house move may carry a legal sequence of cards (see 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 `card-games-crap--house-move', to which WANT is passed); every other
a single card. Returns the same values as those functions (non-nil on move carries a single card. Returns the same values as those
success, `space' when a sequence is too long for the empty houses)." 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)) (if (and (eq (car from) 'house) (eq (car to) 'house))
(card-games-crap--house-move game (cdr from) (cdr to) want) (card-games-crap--house-move game (cdr from) (cdr to) want)
(card-games-crap--move game from to p))) (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 ;;;; Turn logic
(defun card-games-crap--forced (game p) (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) (let (out)
(dolist (spot (card-games-crap--sources game p)) (dolist (spot (card-games-crap--sources game p))
(let ((card (card-games-crap--spot-top game spot))) (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))) (nreverse out)))
(defun card-games-crap--card-playable (game p card) (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) (or (card-games-crap--found-for game card)
(cl-loop for i below 8 thereis (card-games-crap--house-accepts game i 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--reserve game (- 1 p))) card)
(card-games-crap--load-accepts (card-games-crap--top (card-games-crap--waste 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) (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)) (and (null (card-games-crap--reserve game p))
(null (card-games-crap--hand game p)) (null (card-games-crap--hand game p))
(null (card-games-crap--waste 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!"))) (card-games-crap--msg game "You emptied your cards -- you win!")))
(defun card-games-crap--end-turn (game) (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) (unless (card-games-get game :winner)
(card-games-put game :sel nil) (card-games-put game :sel nil)
(card-games-put game :turn 1) (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)))) (card-games-put game :history nil))))
(defun card-games-crap--stop (game) (defun card-games-crap--stop (game)
"Enforce foundation priority: call \"stop\" or block, per `card-games-crapette-stops'. "Enforce GAME's foundation priority, per `card-games-crapette-stops'.
Return non-nil when the offending action must be abandoned by its caller." Call \"stop\" or block; return non-nil when the offending action must be
abandoned by its caller."
(when (card-games-crap--forced game 0) (when (card-games-crap--forced game 0)
(if card-games-crapette-stops (if card-games-crapette-stops
(let ((note "North calls STOP -- you must play to a foundation first!")) (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) ;;;; The AI opponent (player 1)
(defun card-games-crap--ai-found-move (game) (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) (cl-loop for spot in (card-games-crap--sources game 1)
for card = (card-games-crap--spot-top game spot) for card = (card-games-crap--spot-top game spot)
for fi = (and card (card-games-crap--found-for game card)) for fi = (and card (card-games-crap--found-for game card))
when fi return (cons spot (cons 'found fi)))) when fi return (cons spot (cons 'found fi))))
(defun card-games-crap--ai-unload-move (game) (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; 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 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." 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)) best))
(defun card-games-crap--ai-enabling-move (game) (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 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 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, 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))) nil)))
(defun card-games-crap--ai-greedy-move (game) (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 Empties the reserve or waste top onto the first legal spot, without the
scoring or the house-rearranging lookahead of the tougher levels." scoring or the house-rearranging lookahead of the tougher levels."
(catch 'm (catch 'm
@ -569,7 +571,7 @@ scoring or the house-rearranging lookahead of the tougher levels."
(card-games-crap--holding-line g))))) (card-games-crap--holding-line g)))))
(defun 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." Empty when nothing (or a single card) is held from a house."
(let ((sel (card-games-get g :sel))) (let ((sel (card-games-get g :sel)))
(if (not (and sel (eq (car sel) 'house))) (if (not (and sel (eq (car sel) 'house)))
@ -675,7 +677,7 @@ REGIONS maps clicked rectangles to (TYPE . INDEX) spots."
rev)))) rev))))
(defun card-games-crap-mouse (event) (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") (interactive "e")
(let* ((g card-games-crap--game) (spot (card-games-mouse-action event))) (let* ((g card-games-crap--game) (spot (card-games-mouse-action event)))
(when spot (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)) (interactive) (card-games-crap--move-cursor card-games-crap--game 1))
(defun card-games-crap--your-turn-p (g) (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) (cond ((card-games-get g :winner)
(card-games-crap--msg g "The game is over -- press n for a new game.") nil) (card-games-crap--msg g "The game is over -- press n for a new game.") nil)
((/= (card-games-get g :turn) 0) ((/= (card-games-get g :turn) 0)

38
card-games-cribbage.el
View file

@ -75,7 +75,7 @@
tot)) tot))
(defun card-games-crib--count-runs (cards) (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)) (let ((cnt (make-vector 13 0)) (total 0) (r 0))
(dolist (c cards) (aset cnt (cdr c) (1+ (aref cnt (cdr c))))) (dolist (c cards) (aset cnt (cdr c) (1+ (aref cnt (cdr c)))))
(while (< r 13) (while (< r 13)
@ -96,7 +96,7 @@ A crib (IS-CRIB) flush must include the starter."
(t 4)))) (t 4))))
(defun card-games-crib--nobs (hand starter) (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) (if (cl-find-if (lambda (c) (and (= (cdr c) 10) (= (car c) (car starter)))) hand)
1 0)) 1 0))
@ -135,12 +135,12 @@ TOTAL is the running count after the play."
;;;; Setup and flow ;;;; Setup and flow
(defsubst card-games-crib--hand (game s) (aref (card-games-get game :hands) s)) (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) (aset (card-games-get game :hands) s v)) (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) (aref (card-games-get game :play) s)) (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) (aset (card-games-get game :play) s v)) (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)) (cl-defmethod card-games-crib--deal ((game card-games-cribbage-game))
"Deal a fresh Cribbage hand into GAME." "Deal a fresh Cribbage hand into GAME."
@ -160,7 +160,7 @@ TOTAL is the running count after the play."
game)) game))
(defun card-games-crib--add (game s pts) (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) (when (> pts 0)
(aset (card-games-get game :scores) s (+ (aref (card-games-get game :scores) s) pts)) (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) (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)))) (card-games-put game :winner s))))
(defun card-games-crib--ai-discard (game 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)) (let* ((hand (card-games-crib--hand game s)) (best nil) (bestv -1))
(dolist (combo (card-games-rummy--combinations hand 4)) (dolist (combo (card-games-rummy--combinations hand 4))
(let ((v (card-games-crib--score-show combo '(0 . 0)))) ; rough: no starter (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-set-difference hand best :test #'equal)))
(cl-defmethod card-games-crib--start-play ((game card-games-cribbage-game)) (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)) (let* ((deck (card-games-get game :deck))
(starter (nth (random (length deck)) deck)) (starter (nth (random (length deck)) deck))
(dealer (card-games-get game :dealer))) (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))))) (card-games-crib--who (- 1 dealer)) (card-games-rummy-card-string starter)))))
(defun card-games-crib--legal (game s) (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)))) (cl-remove-if (lambda (c) (> (card-games-crib--val c) (- 31 (card-games-get game :total))))
(card-games-crib--play game s))) (card-games-crib--play game s)))
(defun card-games-crib--peg-play (game s card) (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-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 :seq (cons card (card-games-get game :seq)))
(card-games-put game :total (+ (card-games-get game :total) (card-games-crib--val card))) (card-games-put game :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)))) (card-games-put game :pturn (- 1 s))))
(defun card-games-crib--peg-reset (game) (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 :seq nil)
(card-games-put game :total 0) (card-games-put game :total 0)
(card-games-put game :go nil) (card-games-put game :go nil)
(card-games-put game :pturn (- 1 (card-games-get game :last-player)))) (card-games-put game :pturn (- 1 (card-games-get game :last-player))))
(defun card-games-crib--peg-over-p (game) (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)))) (and (null (card-games-crib--play game 0)) (null (card-games-crib--play game 1))))
(defun card-games-crib--peg-go (game s) (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))) (let ((other (- 1 s)))
(if (card-games-crib--legal game other) (if (card-games-crib--legal game other)
(card-games-put game :pturn other) ; opponent plays on (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)))) (card-games-crib--peg-reset game))))
(cl-defmethod card-games-crib--ai-play ((game card-games-cribbage-game) s) (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))) (let ((legal (card-games-crib--legal game s)))
(if (null legal) (card-games-crib--peg-go game s) (if (null legal) (card-games-crib--peg-go game s)
(let ((best (car legal)) (bestv -1)) (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))))) (card-games-crib--peg-play game s best)))))
(defun card-games-crib--peg-advance (game) (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)) (let ((guard 0))
(while (and (eq (card-games-get game :phase) 'play) (not (card-games-crib--peg-over-p game)) (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)) (/= (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))) (card-games-crib--show game)))
(cl-defmethod card-games-crib--show ((game card-games-cribbage-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)) (let* ((starter (card-games-get game :starter))
(dealer (card-games-get game :dealer)) (pone (- 1 dealer)) (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)) (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)))) (_ (cl-call-next-method))))
(defun card-games-crib--redisplay () (defun card-games-crib--redisplay ()
"Redraw the current Cribbage buffer."
(let ((game card-games-crib--game) (inhibit-read-only t)) (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 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))) (setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min)))) (erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
(defun card-games-crib--cur-list (g) (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))) (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 () (defun card-games-crib-left ()

31
card-games-eights.el
View file

@ -55,13 +55,13 @@
(if (null card) "·" (if (null card) "·"
(concat (aref card-games-eights-ranks (cdr card)) (card-games-suit-glyph (car 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) (defun card-games-eights--value (card)
"Return the scoring value of CARD held at the end of a hand." "Return the scoring value of CARD held at the end of a hand."
(cond ((= (cdr card) card-games-eights--wild) 50) (cond ((= (cdr card) card-games-eights--wild) 50)
((>= (cdr card) 9) 10) ; J Q K ((>= (cdr card) 9) 10) ; J Q K
((= (cdr card) 12) 1) ; (Ace handled above by >=9? no) ((= (cdr card) 12) 1) ; (Ace handled above by >=9? no)
(t (+ 2 (cdr card))))) (t (+ 2 (cdr card)))))
(defun card-games-eights--deck () (defun card-games-eights--deck ()
@ -74,9 +74,9 @@
((vname :initform "Crazy Eights")) ((vname :initform "Crazy Eights"))
"A game of 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--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) (aset (card-games-get game :hands) s v)) (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) (car (card-games-get game :discard))) (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)) (cl-defmethod card-games-eights--deal ((game card-games-eights-game))
"Deal a fresh Crazy Eights hand into GAME." "Deal a fresh Crazy Eights hand into GAME."
@ -104,18 +104,18 @@
game)) game))
(cl-defmethod card-games-eights--legal-p ((game card-games-eights-game) card) (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) (or (= (cdr card) card-games-eights--wild)
(= (car card) (card-games-get game :suit)) (= (car card) (card-games-get game :suit))
(= (cdr card) (cdr (card-games-eights--top game))))) (= (cdr card) (cdr (card-games-eights--top game)))))
(defun card-games-eights--legal-moves (game s) (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)) (cl-remove-if-not (lambda (c) (card-games-eights--legal-p game c))
(card-games-eights--hand game s))) (card-games-eights--hand game s)))
(defun card-games-eights--best-suit (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))) (let ((counts (make-vector 4 0)))
(dolist (c (card-games-eights--hand game s)) (dolist (c (card-games-eights--hand game s))
(unless (= (cdr c) card-games-eights--wild) (unless (= (cdr c) card-games-eights--wild)
@ -125,7 +125,7 @@
best))) best)))
(cl-defmethod card-games-eights--play ((game card-games-eights-game) s card &optional suit) (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-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 :discard (cons card (card-games-get game :discard)))
(card-games-put game :suit (if (= (cdr card) card-games-eights--wild) (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))))) (card-games-put game :turn (mod (1+ s) (card-games-get game :nplayers)))))
(defun card-games-eights--draw-card (game s) (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." Return the drawn card, or nil when none is available."
(when (and (null (card-games-get game :stock)) (cdr (card-games-get game :discard))) (when (and (null (card-games-get game :stock)) (cdr (card-games-get game :discard)))
(let ((top (car (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)))) card))))
(cl-defmethod card-games-eights--finish ((game card-games-eights-game) winner) (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)) (let ((sum 0))
(dotimes (s (card-games-get game :nplayers)) (dotimes (s (card-games-get game :nplayers))
(unless (= s winner) (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)))) (if (= winner 0) "You" (format "Player %d" winner)) sum))))
(cl-defmethod card-games-eights--ai-turn ((game card-games-eights-game) s) (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))) (let ((moves (card-games-eights--legal-moves game s)))
(unless moves (unless moves
;; draw up to a small limit looking for a play ;; 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)))))) (card-games-put game :turn (mod (1+ s) (card-games-get game :nplayers))))))
(defun card-games-eights--run (game) (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) (while (and (eq (card-games-get game :phase) 'play)
(/= (card-games-get game :turn) 0) (/= (card-games-get game :turn) 0)
(< (card-games-get game :passes) (card-games-get game :nplayers))) (< (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))) (card-games-eights--deadlock game)))
(cl-defmethod card-games-eights--deadlock ((game card-games-eights-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)) (let ((best 0) (bestv most-positive-fixnum))
(dotimes (s (card-games-get game :nplayers)) (dotimes (s (card-games-get game :nplayers))
(let ((v (apply #'+ (mapcar #'card-games-eights--value (card-games-eights--hand game s))))) (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)))) (erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
(defun card-games-eights--cursor-card (game) (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))) (nth (card-games-get game :cursor) (card-games-eights--hand game 0)))
(defun card-games-eights-left () (defun card-games-eights-left ()
@ -340,7 +341,7 @@ Return the drawn card, or nil when none is available."
(card-games-eights--redisplay))) (card-games-eights--redisplay)))
(defun card-games-eights--choose-suit (game) (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) (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))) (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))) (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) :abstract t)
(cl-defgeneric card-games-gaps--head (game) (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) (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) (cl-defgeneric card-games-gaps--vname (game)
"Return the human-readable variant name for GAME.") "Return the human-readable variant name for GAME.")
(defclass card-games-montana-game (card-games-gaps-game) (defclass card-games-montana-game (card-games-gaps-game)
((name :initform "Montana")) ((name :initform "Montana"))
"Gaps / Montana: a Two anchors the head; rows build up 2..K.") "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--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)) 1) (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)) "Gaps (Montana)") (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) (defclass card-games-acre-game (card-games-gaps-game)
((name :initform "Hell's Half-Acre")) ((name :initform "Hell's Half-Acre"))
"Hell's Half-Acre: a King anchors the head; rows build down K..2.") "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--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)) -1) (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)) "Hell's Half-Acre") (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) (defalias 'card-games-gaps--shuffle 'card-games-shuffle)
@ -250,7 +250,7 @@ other fillable gap, or nil if nothing fits."
hints)) hints))
(cl-defmethod card-games-gaps--prefix-len ((game card-games-gaps-game) board r) (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)) (let ((row (aref board r))
(head (card-games-gaps--head game)) (head (card-games-gaps--head game))
(step (card-games-gaps--step 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.") (defconst card-games-gaps--svg-pad 10 "Margin around the SVG board.")
(defcustom card-games-gaps-svg-ui nil (defcustom card-games-gaps-svg-ui nil
"When non-nil (and on a graphical display), render the gaps board as a "Whether to render the gaps board as one full-buffer SVG.
single full-buffer SVG: the board fills the window with a status/controls When non-nil (and on a graphical display), the board fills the window with a
panel down the left side, mirroring the 500 full-SVG UI. Toggle with `v'." status/controls panel down the left side, mirroring the 500 full-SVG UI.
Toggle with `v'."
:type 'boolean :group 'card-games-svg) :type 'boolean :group 'card-games-svg)
(defcustom card-games-gaps-svg-fill t (defcustom card-games-gaps-svg-fill t
"When non-nil, size the full-SVG gaps UI to fill the window and re-fit on "Whether the full-SVG gaps UI fills the window and re-fits on size changes.
window changes. Only used when `card-games-gaps-svg-ui' is enabled." Only used when `card-games-gaps-svg-ui' is enabled."
:type 'boolean :group 'card-games-svg) :type 'boolean :group 'card-games-svg)
(defun card-games-gaps--insert-graphical (game) (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) (defun card-games-gaps--key-button (key word cmd help)
"Insert a control where the KEY hint itself is the button running CMD. "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) (insert-text-button (format "%s %s" key word)
'action (lambda (_) (call-interactively cmd)) 'action (lambda (_) (call-interactively cmd))
'help-echo help 'follow-link t 'face 'link) '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))) (apply #'svg-text svg str a)))
(defun card-games-gaps--ui-label (svg str x y size) (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) (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 :fill "#8fc79b" :text-anchor "start" :font-family card-games-svg-font-family
:font-weight "bold" :letter-spacing "2")) :font-weight "bold" :letter-spacing "2"))
(defun card-games-gaps--ui-divider (svg x1 x2 y) (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)) (svg-line svg x1 y x2 y :stroke "#1b6b35" :stroke-width 1))
(defun card-games-gaps--draw-panel (svg game h lpw fs) (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." Return a plist of clickable control regions."
(let* ((regions nil) (let* ((regions nil)
(F (lambda (n) (round (* n fs)))) (F (lambda (n) (round (* n fs))))

57
card-games-handfoot.el
View file

@ -110,12 +110,12 @@
(<= (length wilds) 3) (<= (length wilds) 3)
(<= (length wilds) (length nats))))) (<= (length wilds) (length nats)))))
(defun card-games-hf--book-complete-p (cards) (>= (length cards) 7)) (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) (not (cl-some #'card-games-hf--wild-p cards))) (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 ;;;; 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)) (cl-defmethod card-games-hf--deal ((game card-games-handfoot-game))
"Deal a fresh round into GAME." "Deal a fresh round into GAME."
@ -145,11 +145,11 @@
(card-games-put game :message "Your turn: s draws two cards.") (card-games-put game :message "Your turn: s draws two cards.")
game)) game))
(defun card-games-hf--books (game team) (aref (card-games-get game :books) team)) (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) (aset (card-games-get game :books) team v)) (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) (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)) (aref (card-games-get game :down) team))
(defun card-games-hf--min-for-round (game) (defun card-games-hf--min-for-round (game)
@ -159,7 +159,7 @@
(min r (1- (length card-games-handfoot--minimums)))))) (min r (1- (length card-games-handfoot--minimums))))))
(defun card-games-hf--collect-red-threes (game s) (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." Return the number collected."
(let ((team (card-games-hf--team game s)) (moved 0) (again t)) (let ((team (card-games-hf--team game s)) (moved 0) (again t))
(while again (while again
@ -179,13 +179,13 @@ Return the number collected."
moved)) moved))
(defun card-games-hf--take-foot (game s) (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) (aset (card-games-get game :stage) s 1)
(card-games-rummy--set-hand game s (aref (card-games-get game :feet) s)) (card-games-rummy--set-hand game s (aref (card-games-get game :feet) s))
(card-games-hf--collect-red-threes game s)) (card-games-hf--collect-red-threes game s))
(defun card-games-hf--pickup-eligible (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." That needs two natural cards in hand matching a meldable top discard."
(let ((top (card-games-rummy--top game))) (let ((top (card-games-rummy--top game)))
(and top (not (card-games-hf--wild-p top)) (not (card-games-hf--three-p top)) (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)))) 2))))
(defun card-games-hf--pickup (game s) (defun card-games-hf--pickup (game s)
"Seat S picks up the discard pile, melding its top card. "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 Take the top card plus up to `card-games-handfoot-pickup-count' - 1 cards
it into hand, melding the top with two matching naturals. Return the top beneath it into hand, melding the top with two matching naturals. Return
card, or nil if ineligible." the top card, or nil if ineligible."
(when (card-games-hf--pickup-eligible game s) (when (card-games-hf--pickup-eligible game s)
(let* ((pile (card-games-get game :discard)) (top (car pile)) (rank (cdr top)) (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)) (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)))))) (if (and ok (cl-every #'card-games-hf--book-valid-p books)) books nil))))))
(defun card-games-hf--initial-meld (game s cards) (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." Return non-nil when the team goes down."
(let* ((books (card-games-hf--partition-books cards)) (let* ((books (card-games-hf--partition-books cards))
(team (card-games-hf--team game s))) (team (card-games-hf--team game s)))
@ -274,7 +274,7 @@ Return non-nil when the team goes down."
t))) t)))
(defun card-games-hf--ai-go-down (game s) (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." Return non-nil when the team goes down."
(let* ((hand (card-games-rummy--hand game s)) (let* ((hand (card-games-rummy--hand game s))
(byrank (make-hash-table :test 'eql)) (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)))) (card-games-hf--initial-meld game s cards))))
(defun card-games-hf--ai-meld (game s) (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))) (let ((team (card-games-hf--team game s)))
(unless (card-games-hf--down-p game team) (card-games-hf--ai-go-down 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)))) (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 ;;;; Engine
(defun card-games-hf--draw2 (game s) (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)) (let ((ok t))
(dotimes (_ 2) (dotimes (_ 2)
(let ((stock (card-games-get game :stock))) (let ((stock (card-games-get game :stock)))
@ -312,7 +312,7 @@ Return non-nil when the team goes down."
ok)) ok))
(defun card-games-hf--meld (game s cards) (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) (when (and (card-games-hf--book-valid-p cards)
(cl-subsetp cards (card-games-rummy--hand game s) :test #'equal)) (cl-subsetp cards (card-games-rummy--hand game s) :test #'equal))
(let ((team (card-games-hf--team game s))) (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))) (cl-remove-if (lambda (c) (and (not seen) (equal c card) (setq seen t))) list)))
(defun card-games-hf--layoff (game s card) (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)) (let* ((team (card-games-hf--team game s)) (books (card-games-hf--books game team)) (done nil))
(catch 'hit (catch 'hit
(dolist (bk books) (dolist (bk books)
@ -343,7 +343,7 @@ Return non-nil when the team goes down."
done)) done))
(defun card-games-hf--advance (game s) (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))) (let ((stage (card-games-get game :stage)))
(when (and (= (aref stage s) 0) (null (card-games-rummy--hand game s))) (when (and (= (aref stage s) 0) (null (card-games-rummy--hand game s)))
;; hand exhausted: pick up the foot ;; hand exhausted: pick up the foot
@ -355,17 +355,17 @@ Return non-nil when the team goes down."
(card-games-put game :step 'draw)))) (card-games-put game :step 'draw))))
(defun card-games-hf--can-go-out-p (game team) (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)) (>= (cl-count-if #'card-games-hf--book-complete-p (card-games-hf--books game team)) 2))
(defun card-games-hf--discard (game s card) (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-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-put game :discard (cons card (card-games-get game :discard)))
(card-games-hf--advance game s)) (card-games-hf--advance game s))
(cl-defmethod card-games-hf--score-round ((game card-games-handfoot-game) outseat) (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))) (let* ((nt (card-games-get game :nteams)) (scores (card-games-get game :scores)))
(dotimes (team nt) (dotimes (team nt)
(let ((pts 0)) (let ((pts 0))
@ -411,7 +411,7 @@ Return non-nil when the team goes down."
;;;; AI ;;;; AI
(defun card-games-hf--ai-extend (game s) (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 ;; lay off naturals onto existing incomplete team books
(let ((again t)) (let ((again t))
(while again (while again
@ -462,7 +462,7 @@ Return non-nil when the team goes down."
(setq again t)))))))) (setq again t))))))))
(defun card-games-hf--ai-discard-card (game s) (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))) (let ((hand (card-games-rummy--hand game s)))
(or (cl-find-if #'card-games-hf--three-p hand) (or (cl-find-if #'card-games-hf--three-p hand)
;; a high singleton, else the first card ;; a high singleton, else the first card
@ -477,7 +477,7 @@ Return non-nil when the team goes down."
best)))) best))))
(cl-defmethod card-games-hf--ai-turn ((game card-games-handfoot-game) s) (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) (let ((got (or (and (> (length (card-games-get game :stock)) 30)
(card-games-hf--pickup-eligible game s) (card-games-hf--pickup-eligible game s)
(card-games-hf--pickup 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))))))) (card-games-hf--advance game s)))))))
(defun card-games-hf--run (game) (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)) (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)))) (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)))) (erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
(defun card-games-hf--clamp (g) (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)))) (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 :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))))) (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) (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))) (and (eq (card-games-get g :phase) 'play) (= (card-games-get g :turn) 0)))
(defun card-games-hf-left () (defun card-games-hf-left ()

52
card-games-match.el
View file

@ -52,17 +52,17 @@
((vname :initform "Go Fish")) ((vname :initform "Go Fish"))
"A game of 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--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) (aset (card-games-get game :hands) s v)) (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) (defun card-games-gf--rank-count (hand rank)
"Return how many cards of RANK are in HAND." "Return how many cards of RANK are in HAND."
(cl-count rank hand :key #'cdr)) (cl-count rank hand :key #'cdr))
(defun card-games-gf--check-books (game s) (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) (dotimes (r 13)
(when (>= (card-games-gf--rank-count (card-games-gf--hand game s) r) 4) (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)) (card-games-gf--set-hand game s (cl-remove r (card-games-gf--hand game s) :key #'cdr))
@ -88,7 +88,7 @@
game)) game))
(defun card-games-gf--draw (game s) (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))) (let ((stock (card-games-get game :stock)))
(when stock (when stock
(card-games-gf--set-hand game s (card-games-rummy-sort-hand (cons (car stock) (card-games-gf--hand game s)))) (card-games-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)))) (car stock))))
(defun card-games-gf--total-books (game) (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)) (let ((sum 0)) (dotimes (s (card-games-get game :nplayers))
(setq sum (+ sum (card-games-gf--books game s)))) (setq sum (+ sum (card-games-gf--books game s))))
sum)) sum))
(defun card-games-gf--maybe-over (game) (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) (when (>= (card-games-gf--total-books game) 13)
(let ((best 0)) (let ((best 0))
(dotimes (s (card-games-get game :nplayers)) (dotimes (s (card-games-get game :nplayers))
@ -112,10 +113,10 @@
(format "Game over. %s wins with %d books! (n: new game)" (format "Game over. %s wins with %d books! (n: new game)"
(card-games-gf--who best) (card-games-gf--books game best)))))) (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) (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))) (let* ((got (cl-remove-if-not (lambda (c) (= (cdr c) rank)) (card-games-gf--hand game target)))
(keep nil)) (keep nil))
(if got (if got
@ -148,14 +149,14 @@
keep)) keep))
(defun card-games-gf--next (game s) (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)) (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))) (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))) (setq i (mod (1+ i) n) tries (1+ tries)))
i)) i))
(defun card-games-gf--start-turn (game s) (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." Return non-nil when S can ask."
(when (and (null (card-games-gf--hand game s)) (card-games-get game :stock)) (when (and (null (card-games-gf--hand game s)) (card-games-get game :stock))
(card-games-gf--draw game s)) (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))) (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) (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) (when (card-games-gf--start-turn game s)
(let ((guard 0)) (let ((guard 0))
(while (and (= (card-games-get game :turn) s) (eq (card-games-get game :phase) 'play) (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))))))))) (card-games-put game :turn (card-games-gf--next game s)))))))))
(defun card-games-gf--run (game) (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)) (let ((guard 0))
(while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0) (< guard 1000)) (while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0) (< guard 1000))
(setq guard (1+ guard)) (setq guard (1+ guard))
@ -218,7 +219,7 @@ Return non-nil when S can ask."
(_ (cl-call-next-method)))) (_ (cl-call-next-method))))
(defun card-games-gf--hand-ranks (game) (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 '())) (let ((seen (make-vector 13 nil)) (out '()))
(dolist (c (card-games-gf--hand game 0)) (aset seen (cdr c) t)) (dolist (c (card-games-gf--hand game 0)) (aset seen (cdr c) t))
(dotimes (r 13) (when (aref seen r) (push r out))) (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))) (card-games-gf--redisplay)))
(defun card-games-gf--insert-rank-picker (game) (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 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." instead of hunting for one overlapped card in a big hand."
(let* ((ranks (card-games-gf--hand-ranks game)) (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")))) (insert "\n"))))
(defun card-games-gf--redisplay () (defun card-games-gf--redisplay ()
"Redraw the current Go Fish buffer."
(let ((game card-games-gf--game) (inhibit-read-only t)) (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 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))) (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")) ((vname :initform "Old Maid"))
"A game of 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--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) (aset (card-games-get game :hands) s v)) (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) (defun card-games-om--discard-pairs (hand)
"Return HAND with every matched pair of ranks removed." "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)) game))
(defun card-games-om--active (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) (cl-loop for s below (card-games-get game :nplayers)
when (card-games-om--hand game s) collect s)) when (card-games-om--hand game s) collect s))
(defun card-games-om--target (game 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)) (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)))) (while (and (< tries n) (or (= i s) (null (card-games-om--hand game i))))
(setq i (mod (1+ i) n) tries (1+ tries))) (setq i (mod (1+ i) n) tries (1+ tries)))
(and (card-games-om--hand game i) i))) (and (card-games-om--hand game i) i)))
(defun card-games-om--skip-empty (game) (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)) (let ((n (card-games-get game :nplayers)) (tries 0))
(while (and (< tries n) (null (card-games-om--hand game (card-games-get game :turn)))) (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)) (card-games-put game :turn (mod (1+ (card-games-get game :turn)) n))
(setq tries (1+ tries))))) (setq tries (1+ tries)))))
(defun card-games-om--total (game) (defun card-games-om--total (game)
"Return the total cards remaining in GAME."
(let ((sum 0)) (dotimes (s (card-games-get game :nplayers)) (let ((sum 0)) (dotimes (s (card-games-get game :nplayers))
(setq sum (+ sum (length (card-games-om--hand game s))))) (setq sum (+ sum (length (card-games-om--hand game s)))))
sum)) sum))
(cl-defmethod card-games-om--draw ((game card-games-old-maid-game) drawer idx) (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))) (let ((target (card-games-om--target game drawer)))
(when target (when target
(let* ((thand (card-games-om--hand game 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)))) (card-games-om--skip-empty game))))
(cl-defmethod card-games-om--finish ((game card-games-old-maid-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)))) (let ((loser (car (card-games-om--active game))))
(card-games-put game :phase 'game-over) (card-games-put game :phase 'game-over)
(card-games-put game :winner loser) (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)")))) "All paired off -- a draw! (n: new game)"))))
(defun card-games-om--ai-turn (game s) (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))) (let ((target (card-games-om--target game s)))
(if (null target) (card-games-om--finish game) (if (null target) (card-games-om--finish game)
(card-games-om--draw game s (random (length (card-games-om--hand game target))))))) (card-games-om--draw game s (random (length (card-games-om--hand game target)))))))
(defun card-games-om--run (game) (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)) (let ((guard 0))
(while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0) (< guard 500)) (while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0) (< guard 500))
(setq guard (1+ guard)) (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)))) (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) (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 (pcase action
(`(pick . ,i) (card-games-put g :pick i) (card-games-om-draw)) (`(pick . ,i) (card-games-put g :pick i) (card-games-om-draw))
(_ (cl-call-next-method)))) (_ (cl-call-next-method))))
@ -531,6 +534,7 @@ instead of hunting for one overlapped card in a big hand."
(apply #'concat (nreverse out)))) (apply #'concat (nreverse out))))
(defun card-games-om--redisplay () (defun card-games-om--redisplay ()
"Redraw the current Old Maid buffer."
(let ((game card-games-om--game) (inhibit-read-only t)) (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 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))) (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)))) (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) (defun card-games-net-host-start (game &optional port)
"Begin hosting GAME on PORT (default `card-games-net-port'). Return the server process. "Begin hosting GAME on PORT (default `card-games-net-port').
The socket binds `card-games-net-host-address' -- by default, this machine only." 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)) (let* ((port (or port card-games-net-port))
(server (make-network-process (server (make-network-process
:name "card-games-host" :server t :service port :name "card-games-host" :server t :service port

34
card-games-patience.el
View file

@ -54,9 +54,9 @@
(if (null card) "·" (if (null card) "·"
(concat (aref card-games-pat-ranks (cdr card)) (card-games-suit-glyph (car 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))))) (cl-loop for r below 13 collect (cons s r)))))
;;;; Classes ;;;; Classes
@ -81,6 +81,7 @@
"Build GAME's board from DECK; return (CARDS COVER ROWS STOCK WASTE).") "Build GAME's board from DECK; return (CARDS COVER ROWS STOCK WASTE).")
(cl-defmethod card-games-pat--layout ((_ card-games-golf-game) deck) (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)) (let ((cards (make-vector 35 nil)) (cover (make-vector 35 nil)) (rows nil))
(dotimes (c 7) (dotimes (r 5) (dotimes (c 7) (dotimes (r 5)
(let ((i (+ (* c 5) r))) (let ((i (+ (* c 5) r)))
@ -91,6 +92,7 @@
(list cards cover (nreverse rows) deck waste)))) (list cards cover (nreverse rows) deck waste))))
(cl-defmethod card-games-pat--layout ((_ card-games-tripeaks-game) deck) (cl-defmethod card-games-pat--layout ((_ card-games-tripeaks-game) deck)
"Lay out DECK as a TriPeaks board."
(let ((cards (make-vector 28 nil)) (let ((cards (make-vector 28 nil))
(cover (vector '(3 4) '(5 6) '(7 8) (cover (vector '(3 4) '(5 6) '(7 8)
'(9 10) '(10 11) '(12 13) '(13 14) '(15 16) '(16 17) '(9 10) '(10 11) '(12 13) '(13 14) '(15 16) '(16 17)
@ -105,6 +107,7 @@
(list cards cover rows deck waste)))) (list cards cover rows deck waste))))
(cl-defmethod card-games-pat--layout ((_ card-games-pyramid-game) deck) (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)) (let ((cards (make-vector 28 nil)) (cover (make-vector 28 nil)) (rows nil))
(dotimes (r 7) (dotimes (r 7)
(let ((start (/ (* r (1+ r)) 2)) (row nil)) (let ((start (/ (* r (1+ r)) 2)) (row nil))
@ -140,33 +143,33 @@
game)) game))
(defun card-games-pat--exposed-p (game i) (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))) (let ((cards (card-games-get game :cards)))
(and (aref cards i) (and (aref cards i)
(cl-every (lambda (j) (null (aref cards j))) (aref (card-games-get game :cover) i))))) (cl-every (lambda (j) (null (aref cards j))) (aref (card-games-get game :cover) i)))))
(defun card-games-pat--exposed (game) (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)) (cl-loop for i below (length (card-games-get game :cards))
when (card-games-pat--exposed-p game i) collect i)) when (card-games-pat--exposed-p game i) collect i))
(defun card-games-pat--spots (game) (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)) (append (mapcar (lambda (i) (cons 'slot i)) (card-games-pat--exposed game))
'((waste . 0) (stock . 0)))) '((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) (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-every #'null (append (card-games-get game :cards) nil)))
(cl-defmethod card-games-won-p ((game card-games-patience-game)) (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)) (card-games-pat--board-empty-p game))
(defun card-games-pat--adjacent (a b wrap) (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))))) (let ((d (abs (- a b)))) (or (= d 1) (and wrap (= d 12)))))
(defun card-games-pat--snapshot (game) (defun card-games-pat--snapshot (game)
@ -190,7 +193,7 @@
t))) t)))
(defun card-games-pat--deal-stock (game) (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))) (let ((stock (card-games-get game :stock)))
(if (null stock) (if (null stock)
(card-games-put game :message "The stock is empty.") (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--value (card) "Sum-of-13 value of CARD." (1+ (cdr card)))
(defun card-games-pat--remove-slot (game i) (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)) (aset (card-games-get game :cards) i nil))
;;;; Interaction ;;;; Interaction
@ -211,6 +214,7 @@
(defvar-local card-games-pat--game nil "The pile-solitaire game in the current buffer.") (defvar-local card-games-pat--game nil "The pile-solitaire game in the current buffer.")
(defun card-games-pat--cur-spot (game) (defun card-games-pat--cur-spot (game)
"Return the spot the cursor is on in GAME."
(let ((spots (card-games-pat--spots game))) (let ((spots (card-games-pat--spots game)))
(nth (min (card-games-get game :cursor) (1- (length spots))) spots))) (nth (min (card-games-get game :cursor) (1- (length spots))) spots)))
@ -242,13 +246,13 @@
(card-games-pat--after game))) (card-games-pat--after game)))
(defun card-games-pat--mark-value (game m) (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) (pcase (car m)
('slot (card-games-pat--value (aref (card-games-get game :cards) (cdr 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)))))) ('waste (let ((w (card-games-pat--waste-top game))) (and w (card-games-pat--value w))))))
(defun card-games-pat--toggle-mark (game m) (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)) (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 (remove m (card-games-get game :marks)))
(card-games-put game :marks (cons m (card-games-get game :marks)))) (card-games-put game :marks (cons m (card-games-get game :marks))))
@ -276,6 +280,7 @@
(message "Solved!"))) (message "Solved!")))
(defun card-games-pat--move (delta) (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)))) (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-put game :cursor (mod (+ (card-games-get game :cursor) delta) n))
(card-games-pat--redisplay))) (card-games-pat--redisplay)))
@ -295,6 +300,7 @@
;;;; Rendering ;;;; Rendering
(defun card-games-pat--render-card (card &optional exposed marked cursor) (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)) (let ((s (card-games-pat-card-string card)) (faces nil))
(when (card-games-pat-red-p card) (push 'card-games-red-suit faces)) (when (card-games-pat-red-p card) (push 'card-games-red-suit faces))
(when (and card (not exposed)) (push 'card-games-gap 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)))) (apply #'concat (nreverse out))))
(defun card-games-pat--redisplay () (defun card-games-pat--redisplay ()
"Redraw the current patience-game buffer."
(let ((game card-games-pat--game) (inhibit-read-only t)) (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 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"))) (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)) (setq-local cursor-type card-games-cursor-type))
(defun card-games-pat--play (class) (defun card-games-pat--play (class)
"Start a patience game of CLASS."
(let* ((game (card-games-pat--deal (make-instance class))) (let* ((game (card-games-pat--deal (make-instance class)))
(buf (get-buffer-create (format "*%s*" (oref game vname))))) (buf (get-buffer-create (format "*%s*" (oref game vname)))))
(with-current-buffer buf (with-current-buffer buf

45
card-games-president.el
View file

@ -58,12 +58,14 @@
(if (= rank 0) 13 rank)) (if (= rank 0) 13 rank))
(defun card-games-pres-card-string (card) (defun card-games-pres-card-string (card)
"Return the display string for CARD (a middot for nil)."
(if (null card) "·" (if (null card) "·"
(concat (aref card-games-pres-ranks (cdr card)) (card-games-suit-glyph (car 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 () (defun card-games-pres--deck ()
"Return a fresh shuffled 52-card deck."
(card-games-shuffle (cl-loop for s below 4 append (card-games-shuffle (cl-loop for s below 4 append
(cl-loop for r below 13 collect (cons s r))))) (cl-loop for r below 13 collect (cons s r)))))
@ -78,14 +80,16 @@
((vname :initform "President")) ((vname :initform "President"))
"A game of President (Scum).") "A game of President (Scum).")
(defsubst card-games-pres--hand (game s) (aref (card-games-get game :hands) s)) (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) (aset (card-games-get game :hands) s v)) (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) (defsubst card-games-pres--name (_game s)
"Return the display name of seat S."
(if (= s 0) "You" (format "Player %d" s))) (if (= s 0) "You" (format "Player %d" s)))
;;;; Dealing and the inter-game exchange ;;;; Dealing and the inter-game exchange
(cl-defmethod card-games-pres--deal ((game card-games-president-game)) (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))) (let* ((n (max 3 (min 6 card-games-president-players)))
(deck (card-games-pres--deck)) (deck (card-games-pres--deck))
(hands (make-vector n nil)) (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)) (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)) (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))) (let ((order (card-games-get game :order)) (n (card-games-get game :nplayers)))
(when (and order (= (length order) n) (>= n 4)) (when (and order (= (length order) n) (>= n 4))
(let* ((prez (nth 0 order)) (scum (nth (1- n) order)) (let* ((prez (nth 0 order)) (scum (nth (1- n) order))
@ -125,7 +129,7 @@
(card-games-pres--give game vp vice 1 t))))) (card-games-pres--give game vp vice 1 t)))))
(defun card-games-pres--give (game from to k &optional worst) (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) (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--best (card-games-pres--hand game from) k))))
(card-games-pres--set-hand game from (card-games-pres--set-hand game from
@ -136,14 +140,14 @@
;;;; Move logic ;;;; Move logic
(defun card-games-pres--rank-counts (game s) (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)) (let ((tbl nil))
(dolist (c (card-games-pres--hand game s)) (dolist (c (card-games-pres--hand game s))
(setf (alist-get (cdr c) tbl 0) (1+ (alist-get (cdr c) tbl 0)))) (setf (alist-get (cdr c) tbl 0) (1+ (alist-get (cdr c) tbl 0))))
tbl)) tbl))
(defun card-games-pres--legal-ranks (game s) (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))) (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) (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))) when (if (= cnt 0) t (and (>= c cnt) (> (card-games-pres--power r) top)))
@ -157,18 +161,18 @@
(nreverse out))) (nreverse out)))
(defun card-games-pres--in-game (game) (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) (cl-loop for s below (card-games-get game :nplayers)
unless (memq s (card-games-get game :out)) collect s)) unless (memq s (card-games-get game :out)) collect s))
(defun card-games-pres--round-active (game) (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) (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)) unless (or (memq s (card-games-get game :out)) (aref (card-games-get game :passed) s))
collect s)) collect s))
(defun card-games-pres--next (game from) (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)) (let ((n (card-games-get game :nplayers)) (s from) (res nil))
(dotimes (_ n) (dotimes (_ n)
(setq s (mod (1+ s) n)) (setq s (mod (1+ s) n))
@ -179,7 +183,7 @@
(or res from))) (or res from)))
(defun card-games-pres--clear (game) (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 :count 0) (card-games-put game :top -1)
(card-games-put game :passed (make-vector (card-games-get game :nplayers) nil)) (card-games-put game :passed (make-vector (card-games-get game :nplayers) nil))
(let ((last (card-games-get game :last-player))) (let ((last (card-games-get game :last-player)))
@ -188,7 +192,7 @@
(card-games-put game :message "Pile cleared.")) (card-games-put game :message "Pile cleared."))
(defun card-games-pres--check-finish (game) (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))) (let ((in (card-games-pres--in-game game)))
(when (<= (length in) 1) (when (<= (length in) 1)
(when in (card-games-put game :out (append (card-games-get game :out) in))) (when in (card-games-put game :out (append (card-games-get game :out) in)))
@ -199,7 +203,7 @@
t))) t)))
(defun card-games-pres--advance (game) (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) (unless (card-games-pres--check-finish game)
(let* ((active (card-games-pres--round-active game)) (let* ((active (card-games-pres--round-active game))
(last (card-games-get game :last-player)) (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))))))) (card-games-put game :turn (card-games-pres--next game (card-games-get game :turn)))))))
(defun card-games-pres--play (game seat rank n) (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-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 :count n) (card-games-put game :top (card-games-pres--power rank))
(card-games-put game :last-player seat) (card-games-put game :last-player seat)
@ -220,13 +224,13 @@
(card-games-pres--advance game)) (card-games-pres--advance game))
(defun card-games-pres--pass (game seat) (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) (aset (card-games-get game :passed) seat t)
(card-games-put game :message (format "%s passes." (card-games-pres--name game seat))) (card-games-put game :message (format "%s passes." (card-games-pres--name game seat)))
(card-games-pres--advance game)) (card-games-pres--advance game))
(defun card-games-pres--ai-move (game seat) (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)) (let* ((cnt (card-games-get game :count)) (top (card-games-get game :top))
(counts (card-games-pres--rank-counts game seat))) (counts (card-games-pres--rank-counts game seat)))
(if (= cnt 0) (if (= cnt 0)
@ -240,7 +244,7 @@
(card-games-pres--pass game seat)))))) (card-games-pres--pass game seat))))))
(defun card-games-pres--result (game) (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)) (let* ((order (card-games-get game :order)) (n (length order)) (parts nil))
(dotimes (i n) (dotimes (i n)
(let ((title (cond ((= i 0) "President") ((= i (1- n)) "Scum") (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.") (defvar-local card-games-pres--game nil "The President game in the current buffer.")
(defun card-games-pres--run (game) (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)) (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)))) (card-games-pres--ai-move game (card-games-get game :turn))))
(defun card-games-pres--hand-ranks (game) (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))))) (let ((rs (delete-dups (mapcar #'cdr (card-games-pres--hand game 0)))))
(cl-sort rs #'< :key #'card-games-pres--power))) (cl-sort rs #'< :key #'card-games-pres--power)))
@ -316,7 +320,7 @@
:type 'boolean :group 'card-games) :type 'boolean :group 'card-games)
(defun card-games-pres--svg (game) (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." 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) (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)) (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)))) (_ (cl-call-next-method))))
(defun card-games-pres--redisplay () (defun card-games-pres--redisplay ()
"Redraw the current President buffer."
(let ((game card-games-pres--game) (inhibit-read-only t)) (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 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))) (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.") (card-games-put game :message "Your turn: s draws from stock, t takes the discard.")
game)) game))
(defun card-games-tm--ace-high (game) (oref game ace-high)) (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) (oref game ace-15)) (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) (oref game deep-pickup)) (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) (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))) (let ((stock (card-games-get game :stock)))
(when stock (when stock
(let ((c (pop stock))) (let ((c (pop stock)))
@ -99,7 +99,7 @@
c)))) c))))
(defun card-games-tm--take-top (game s) (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))) (let ((c (card-games-rummy--top game)))
(when c (when c
(card-games-put game :discard (cdr (card-games-get game :discard))) (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))) (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) (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) (when (card-games-rummy-meld-p cards :min 3 :ace-high (card-games-tm--ace-high game)
:distinct-suits t) :distinct-suits t)
(dolist (c cards) (card-games-rummy--set-hand game s (remove c (card-games-rummy--hand game s)))) (dolist (c cards) (card-games-rummy--set-hand game s (remove c (card-games-rummy--hand game s))))
@ -123,7 +123,7 @@
t)) t))
(cl-defmethod card-games-tm--layoff ((game card-games-tablemeld-game) s card) (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 (let ((rec (cl-find-if
(lambda (r) (card-games-rummy-meld-p (cons card (cdr r)) :min 3 (lambda (r) (card-games-rummy-meld-p (cons card (cdr r)) :min 3
:ace-high (card-games-tm--ace-high game))) :ace-high (card-games-tm--ace-high game)))
@ -136,7 +136,7 @@
t))) t)))
(cl-defmethod card-games-tm--score-hand ((game card-games-tablemeld-game) outseat) (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)) (let* ((n (card-games-get game :nplayers)) (scores (card-games-get game :scores))
(style (oref game score-style))) (style (oref game score-style)))
(cond (cond
@ -173,7 +173,7 @@
(format "Scores: %s. (n: next hand)" (format "Scores: %s. (n: next hand)"
(card-games-tm--scores-string game)))))))) (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) (defun card-games-tm--scores-string (game)
"Return a compact \"You N · P1 N ...\" score line for GAME." "Return a compact \"You N · P1 N ...\" score line for GAME."
@ -184,14 +184,14 @@
(mapconcat #'identity (nreverse parts) " · "))) (mapconcat #'identity (nreverse parts) " · ")))
(cl-defmethod card-games-tm--end-turn ((game card-games-tablemeld-game) s) (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)) (if (null (card-games-rummy--hand game s))
(card-games-tm--score-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 :turn (mod (1+ s) (card-games-get game :nplayers)))
(card-games-put game :step 'draw))) (card-games-put game :step 'draw)))
(cl-defmethod card-games-tm--discard ((game card-games-tablemeld-game) s card) (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-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-put game :discard (cons card (card-games-get game :discard)))
(card-games-tm--end-turn game s)) (card-games-tm--end-turn game s))
@ -199,7 +199,7 @@
;;;; AI ;;;; AI
(defun card-games-tm--ai-melds (game s) (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." Return non-nil if any meld was laid."
(let ((did nil) (again t)) (let ((did nil) (again t))
(while again (while again
@ -218,7 +218,7 @@ Return non-nil if any meld was laid."
did)) did))
(defun card-games-tm--ai-layoffs (game s) (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)) (let ((again t))
(while again (while again
(setq again nil) (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))))))) (when card (card-games-tm--layoff game s card) (setq again t)))))))
(defun card-games-tm--ai-discard-card (game s) (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)) (let* ((hand (card-games-rummy--hand game s))
(p (card-games-rummy-best-partition hand :ace-high (card-games-tm--ace-high game) (p (card-games-rummy-best-partition hand :ace-high (card-games-tm--ace-high game)
:ace-15 (card-games-tm--ace-15 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)))))) (when (> v bestv) (setq best c bestv v))))))
(defun card-games-tm--meld-for-target (game cards target) (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." Return nil when TARGET cannot join a set or run with the other CARDS."
(let* ((ace-high (card-games-tm--ace-high game)) (let* ((ace-high (card-games-tm--ace-high game))
(pool (cons target cards)) (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))))) (mapcar (lambda (i) (aref vec i)) (car withtgt)))))
(defun card-games-tm--take-deep (game s depth) (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 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 rest enter the hand. Return a status string, or nil when the move is not
legal (the chosen card cannot be used immediately)." 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))))))) (card-games-rummy-card-string target)))))))
(defun card-games-tm--ai-deep-pickup (game s) (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." Return non-nil when one was taken."
(when (card-games-tm--deep-pickup game) (when (card-games-tm--deep-pickup game)
(let* ((pile (card-games-get game :discard)) (n (length pile)) (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))))) (when chosen (card-games-tm--take-deep game s chosen)))))
(cl-defmethod card-games-tm--ai-turn ((game card-games-tablemeld-game) s) (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)) (let* ((deep (card-games-tm--ai-deep-pickup game s))
(drew (if deep t (drew (if deep t
(let* ((hand (card-games-rummy--hand game s)) (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))))))) (card-games-tm--discard game s (card-games-tm--ai-discard-card game s)))))))
(defun card-games-tm--run (game) (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)) (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)))) (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)))) (erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
(defun card-games-tm--clamp-cursor (g) (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)))) (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 :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))))) (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) (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))) (and (eq (card-games-get g :phase) 'play) (= (card-games-get g :turn) 0)))
(defun card-games-tm-left () (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 ;;;; Candidate melds and best partition
(defun card-games-rummy--combinations (lst k) (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)) (cond ((= k 0) (list nil))
((null lst) nil) ((null lst) nil)
(t (append (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))))) (card-games-rummy--combinations (cdr lst) k)))))
(defun card-games-rummy--runs-in (pairs) (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." PAIRS is a list of (RANK . INDEX) sorted ascending by RANK."
(let ((res '()) (vec (vconcat pairs))) (let ((res '()) (vec (vconcat pairs)))
(let ((n (length vec))) (let ((n (length vec)))
@ -243,7 +243,7 @@ ACE-HIGH and ACE-15 are passed to `card-games-rummy-best-partition'."
:count)) :count))
(defun card-games-rummy-layoff-p (card melds &optional ace-high) (defun card-games-rummy-layoff-p (card melds &optional ace-high)
"Return the first meld in MELDS that CARD extends, or nil. "Return the first meld in MELDS that CARD can extend, or nil.
ACE-HIGH allows extending a run with a high Ace." ACE-HIGH allows extending a run with a high Ace."
(cl-find-if (lambda (m) (cl-find-if (lambda (m)
(card-games-rummy-meld-p (cons card m) :min 3 :ace-high ace-high)) (card-games-rummy-meld-p (cons card m) :min 3 :ace-high ace-high))
@ -266,9 +266,9 @@ NDECKS defaults to 1 and JOKERS to 0."
"Abstract base for rummy-style draw-and-discard games." "Abstract base for rummy-style draw-and-discard games."
:abstract t) :abstract t)
(defsubst card-games-rummy--hand (game s) (aref (card-games-get game :hands) s)) (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) (aset (card-games-get game :hands) s v)) (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) (car (card-games-get game :discard))) (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) (defun card-games-rummy-sort-hand (cards)
"Return CARDS sorted by suit then rank for display, jokers last." "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) (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). "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 ((hints (when hint-fn
(let ((hs '()) (i 0)) (let ((hs '()) (i 0))
(dolist (c cards) (when (funcall hint-fn c) (push i hs)) (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.") "Your turn: s draws from stock, t takes the discard.")
game)) 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) (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))) (let ((stock (card-games-get game :stock)))
(when stock (when stock
(let ((c (pop stock))) (let ((c (pop stock)))
@ -465,20 +466,20 @@ Keyword ARGS: :title :infos :melds :discard :stock :hand :cursor :marks
c)))) c))))
(defun card-games-gin--take (game s) (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))) (let ((c (card-games-rummy--top game)))
(card-games-put game :discard (cdr (card-games-get game :discard))) (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))) (card-games-rummy--set-hand game s (cons c (card-games-rummy--hand game s)))
c)) c))
(defun card-games-gin--discard (game s card) (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 (card-games-rummy--set-hand game s (card-games-rummy-sort-hand
(remove card (card-games-rummy--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-put game :discard (cons card (card-games-get game :discard))))
(defun card-games-gin--ai-best-discard (game s) (defun card-games-gin--ai-best-discard (game s)
"Return the card seat S should discard to minimise its deadwood." "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)) (let ((hand (card-games-rummy--hand game s)) (best nil) (bestv most-positive-fixnum))
(dolist (c hand best) (dolist (c hand best)
(let ((d (card-games-gin--deadwood (remove c hand)))) (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)))))) (setq best c bestv d))))))
(cl-defmethod card-games-gin--ai-turn ((game card-games-gin-game) s) (cl-defmethod card-games-gin--ai-turn ((game card-games-gin-game) s)
"Play seat S's whole turn, then hand control back." "Play GAME seat S's whole turn, then hand control back."
(let* ((hand (card-games-rummy--hand game s)) (let* ((hand (card-games-rummy--hand game s))
(cur (card-games-gin--deadwood hand)) (cur (card-games-gin--deadwood hand))
(up (card-games-rummy--top game)) (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))))))))) (card-games-rummy-card-string card)))))))))
(cl-defmethod card-games-gin--knock ((game card-games-gin-game) knocker) (cl-defmethod card-games-gin--knock ((game card-games-gin-game) knocker)
"Resolve the hand when KNOCKER knocks; score and end the hand." "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))) (let* ((kpart (card-games-rummy-best-partition (card-games-rummy--hand game knocker)))
(kmelds (plist-get kpart :melds)) (kmelds (plist-get kpart :melds))
(kdw (plist-get kpart :count)) (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)))))))) (aref scores 0) (aref scores 1))))))))
(cl-defmethod card-games-gin--exhaust ((game card-games-gin-game)) (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 :phase 'hand-over)
(card-games-put game :reveal t) (card-games-put game :reveal t)
(card-games-put game :message "Stock exhausted -- the hand is a wash. n: next hand.")) (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))))) (card-games-gin--after-discard g)))))
(defun card-games-gin-knock () (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) (interactive)
(let* ((g card-games-gin--game) (card (card-games-gin--cursor-card))) (let* ((g card-games-gin--game) (card (card-games-gin--cursor-card)))
(cond (cond

32
card-games-scopa.el
View file

@ -60,16 +60,16 @@
(cl-defgeneric card-games-fish--deck (game) (cl-defgeneric card-games-fish--deck (game)
"Return a fresh shuffled deck for GAME.") "Return a fresh shuffled deck for GAME.")
(cl-defgeneric card-games-fish--face-pair-p (game card) (cl-defgeneric card-games-fish--face-pair-p (game card)
"Return non-nil when CARD captures only equal-rank cards (no sums).") "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) nil) (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) (cl-defgeneric card-games-fish--score-round (game)
"Add this round's points to GAME's running scores.") "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--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) (aset (card-games-get game :hands) s v)) (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) (aref (card-games-get game :captured) s)) (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 ;;;; Capture search
@ -103,7 +103,7 @@ Only subsets of two or more cards are considered. Return nil if none."
;;;; Flow ;;;; Flow
(cl-defmethod card-games-fish--deal-round ((game card-games-fish-game)) (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)) (let* ((n (oref game nplayers)) (deck (card-games-fish--deck game))
(hands (make-vector n nil)) (table '())) (hands (make-vector n nil)) (table '()))
(dotimes (_ 4) (push (pop deck) 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)) game))
(defun card-games-fish--refill (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)) (when (and (cl-every #'null (append (card-games-get game :hands) nil)) (card-games-get game :deck))
(let ((deck (card-games-get game :deck))) (let ((deck (card-games-get game :deck)))
(dotimes (s (card-games-get game :nplayers)) (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)))) (card-games-put game :deck deck))))
(defun card-games-fish--round-over-p (game) (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)) (and (null (card-games-get game :deck))
(cl-every #'null (append (card-games-get game :hands) nil)))) (cl-every #'null (append (card-games-get game :hands) nil))))
(cl-defmethod card-games-fish--play ((game card-games-fish-game) s card) (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)) (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))) (let ((cap (card-games-fish--capture game card)))
(if cap (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)))) (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)) (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)) (when (and (card-games-get game :table) (card-games-get game :last-capturer))
(let ((s (card-games-get game :last-capturer))) (let ((s (card-games-get game :last-capturer)))
(aset (card-games-get game :captured) s (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)"))))) "(n: next round)")))))
(defun card-games-fish--award-most (game suit-pred pts) (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))) (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)))) (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))) (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)))))) ((> 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) (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)) (let ((hand (card-games-fish--hand game s)) (best nil) (bestn -1) (sweep nil))
(dolist (c hand) (dolist (c hand)
(let* ((cap (card-games-fish--capture game c)) (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))) (card-games-fish--play game s best)))
(defun card-games-fish--run (game) (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)) (let ((guard 0))
(while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0) (< guard 200)) (while (and (eq (card-games-get game :phase) 'play) (/= (card-games-get game :turn) 0) (< guard 200))
(setq guard (1+ guard)) (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)))) (_ (cl-call-next-method))))
(defun card-games-fish--redisplay () (defun card-games-fish--redisplay ()
"Redraw the current fishing-family game buffer."
(let ((game card-games-fish--game) (inhibit-read-only t)) (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 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))) (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))) (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)) (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))) (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) t) 1) ; most cards
(card-games-fish--award-most game (lambda (c) (= (car c) 2)) 1) ; most coins (diamonds) (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)) (card-games-rummy-deck))
(cl-defmethod card-games-fish--score-round ((game card-games-casino-game)) (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))) (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) t) 3) ; most cards
(card-games-fish--award-most game (lambda (c) (= (car c) 0)) 1) ; most spades (card-games-fish--award-most game (lambda (c) (= (car c) 0)) 1) ; most spades

68
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))))) (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) (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) (pcase (oref game run-rule)
('any t) ('any t)
('suit (and (= (cdr lower) (1- (cdr upper))) (= (car lower) (car upper)))) ('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))))) (_ (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) (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) (pcase (oref game build)
('any (= (cdr card) (1- (cdr top)))) ('any (= (cdr card) (1- (cdr top))))
('suit (and (= (cdr card) (1- (cdr top))) (= (car card) (car 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))))) (_ (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) (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) (pcase (oref game empty-rule)
('king (= (cdr card) 12)) ('king (= (cdr card) 12))
(_ t))) (_ t)))
@ -150,15 +150,19 @@ empty-slot dot."
;;;; Layout and dealing ;;;; Layout and dealing
(cl-defgeneric card-games-sol--layout (game) (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)) (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-loop for i below 7 collect (cons i 1)))
(cl-defmethod card-games-sol--layout ((_ card-games-yukon-game)) (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)))) (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)) (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)))) (append (make-list 4 (cons 0 7)) (make-list 4 (cons 0 6))))
(cl-defmethod card-games-sol--layout ((_ card-games-spider-game)) (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)))) (append (make-list 4 (cons 5 1)) (make-list 6 (cons 4 1))))
(cl-defmethod card-games-sol--deal ((game card-games-solitaire-game)) (cl-defmethod card-games-sol--deal ((game card-games-solitaire-game))
@ -195,7 +199,7 @@ empty-slot dot."
;;;; Spots (the cursor visits piles) ;;;; Spots (the cursor visits piles)
(cl-defmethod card-games-sol--spots ((game card-games-solitaire-game)) (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 (append
(when (oref game has-stock) '((stock . 0))) (when (oref game has-stock) '((stock . 0)))
(when (oref game has-waste) '((waste . 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)))) (cl-loop for i below (oref game ncols) collect (cons 'col i))))
(defun card-games-sol--cur-spot (game) (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))) (nth (card-games-get game :cursor) (card-games-sol--spots game)))
;;;; Pile access helpers ;;;; 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--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--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) "Face-down count of column C." (aref (card-games-get game :down) c)) (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) (aset (card-games-get game :down) c v)) (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) (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)))) (car (last (card-games-sol--col game c))))
(defun card-games-sol--exposed (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))) (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) (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)))) (let ((top->bottom (reverse (card-games-sol--exposed game c))))
(if (null top->bottom) (if (null top->bottom)
nil nil
@ -238,7 +242,7 @@ empty-slot dot."
run)))) run))))
(defun card-games-sol--spot-top (game spot) (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) (pcase (car spot)
('col (card-games-sol--col-top game (cdr spot))) ('col (card-games-sol--col-top game (cdr spot)))
('waste (car (last (card-games-get game :waste)))) ('waste (car (last (card-games-get game :waste))))
@ -261,7 +265,7 @@ empty-slot dot."
(= (cdr card) need))))))) (= (cdr card) need)))))))
(defun card-games-sol--found-for (game card) (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) (cl-loop for i below (oref game nfound)
when (card-games-sol--found-accepts game i card) return i)) when (card-games-sol--found-accepts game i card) return i))
@ -303,14 +307,14 @@ empty-slot dot."
t))) t)))
(defun card-games-sol--flip (game c) (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))) (let ((len (length (card-games-sol--col game c)))
(d (card-games-sol--down game c))) (d (card-games-sol--down game c)))
(when (and (> len 0) (>= d len)) (when (and (> len 0) (>= d len))
(card-games-sol--set-down game c (1- len))))) (card-games-sol--set-down game c (1- len)))))
(defun card-games-sol--take (game spot n) (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) (pcase (car spot)
('col (let* ((c (cdr spot)) (col (card-games-sol--col game c)) ('col (let* ((c (cdr spot)) (col (card-games-sol--col game c))
(run (last col n))) (run (last col n)))
@ -331,7 +335,7 @@ empty-slot dot."
(_ nil))) (_ nil)))
(defun card-games-sol--can-drop (game spot cards) (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 (and cards
(pcase (car spot) (pcase (car spot)
('col (let* ((c (cdr spot)) (top (card-games-sol--col-top game c))) ('col (let* ((c (cdr spot)) (top (card-games-sol--col-top game c)))
@ -345,7 +349,7 @@ empty-slot dot."
(_ nil)))) (_ nil))))
(defun card-games-sol--drop (game spot cards) (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) (pcase (car spot)
('col (let ((c (cdr spot))) ('col (let ((c (cdr spot)))
(card-games-sol--set-col game c (append (card-games-sol--col game c) cards)))) (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 ;;;; Spider: complete-run removal
(cl-defmethod card-games-sol--harvest ((game card-games-solitaire-game)) (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." Only games without foundations (NFOUND 0: Spider, Scorpion) harvest runs."
(when (= 0 (oref game nfound)) (when (= 0 (oref game nfound))
(dotimes (c (oref game ncols)) (dotimes (c (oref game ncols))
@ -384,7 +388,7 @@ Only games without foundations (NFOUND 0: Spider, Scorpion) harvest runs."
:group 'card-games) :group 'card-games)
(cl-defmethod card-games-sol--stock-action ((game card-games-solitaire-game)) (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)) (if (not (oref game has-waste))
(card-games-put game :message "No stock to deal.") (card-games-put game :message "No stock to deal.")
(card-games-sol--snapshot game) (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.")))))) (card-games-put game :message "The stock is empty."))))))
(cl-defmethod card-games-sol--stock-action ((game card-games-klondike-game)) (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) (card-games-sol--snapshot game)
(let ((stock (card-games-get game :stock)) (waste (card-games-get game :waste))) (let ((stock (card-games-get game :stock)) (waste (card-games-get game :waste)))
(if stock (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."))))) (card-games-put game :message "Stock and waste are both empty.")))))
(cl-defmethod card-games-sol--stock-action ((game card-games-spider-game)) (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))) (let ((stock (card-games-get game :stock)))
(cond (cond
((null stock) (card-games-put game :message "The stock is empty.")) ((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))) (card-games-sol--render-text game)))
(cl-defmethod card-games-render-text ((game card-games-solitaire-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)) (card-games-sol--render-text game))
(cl-defmethod card-games-render-svg ((game card-games-solitaire-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) (if card-games-sol-svg-cards (card-games-sol--svg game)
(cons (card-games-sol--render-text game) nil))) (cons (card-games-sol--render-text game) nil)))
(cl-defmethod card-games-render-apply ((game card-games-solitaire-game) action) (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))) (let ((idx (cl-position action (card-games-sol--spots game) :test #'equal)))
(when idx (card-games-put game :cursor idx) (card-games-sol-act)))) (when idx (card-games-put game :cursor idx) (card-games-sol-act))))
@ -713,7 +721,7 @@ DISPLAY is a propertized one-image string; REGIONS is a click map of
(out (list))) (out (list)))
(push (format " %s Moves: %d%s\n\n" (push (format " %s Moves: %d%s\n\n"
(oref game vname) (card-games-get game :moves) (oref game vname) (card-games-get game :moves)
(if (> (oref game nfound) 0) "" (if (> (oref game nfound) 0) ""
(format " Sets: %d/%d" (card-games-get game :sets) (oref game target-sets)))) (format " Sets: %d/%d" (card-games-get game :sets) (oref game target-sets))))
out) out)
;; Top line: stock / waste / free cells / foundations. ;; Top line: stock / waste / free cells / foundations.
@ -790,7 +798,7 @@ DISPLAY is a propertized one-image string; REGIONS is a click map of
;;;; Mode and commands ;;;; Mode and commands
(defun card-games-sol-mouse (event) (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") (interactive "e")
(let* ((game card-games-sol--game) (let* ((game card-games-sol--game)
(r (and game (oref game renderer))) (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.") "Forty Thieves: two decks, ten columns, eight foundations, no redeal.")
(cl-defmethod card-games-sol--layout ((_ card-games-forty-game)) (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))) (make-list 10 (cons 0 4)))
(defclass card-games-scorpion-game (card-games-solitaire-game) (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.") "Scorpion: build down by suit, move any buried group, clear four runs.")
(cl-defmethod card-games-sol--layout ((_ card-games-scorpion-game)) (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)))) (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)) (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))) (let ((stock (card-games-get game :stock)))
(if (null stock) (if (null stock)
(card-games-put game :message "The stock is empty.") (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.") "Canfield: a 13-card reserve and a variable foundation base rank.")
(cl-defmethod card-games-sol--deal ((game card-games-canfield-game)) (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)) (let* ((deck (card-games-sol--make-deck 1))
(reserve (cl-loop repeat 13 collect (pop deck))) (reserve (cl-loop repeat 13 collect (pop deck)))
(first (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)))) (aref card-games-sol-ranks (cdr first))))
game)) 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)) (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)) (dotimes (c (oref game ncols))
(when (and (null (card-games-sol--col game c)) (card-games-get game :reserve)) (when (and (null (card-games-sol--col game c)) (card-games-get game :reserve))
(let ((card (car (last (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.") foundations up by suit from the Ace, and a thirteen-card reserve.")
(cl-defmethod card-games-sol--deal ((game card-games-russian-bank-game)) (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)) (let* ((deck (card-games-sol--make-deck 1))
(reserve (cl-loop repeat 13 collect (pop deck))) (reserve (cl-loop repeat 13 collect (pop deck)))
(tableau (make-vector 8 nil)) (tableau (make-vector 8 nil))
@ -985,7 +995,7 @@ foundations up by suit from the Ace, and a thirteen-card reserve.")
game)) game))
(cl-defmethod card-games-sol--autofill ((game card-games-russian-bank-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)) (dotimes (c (oref game ncols))
(when (and (null (card-games-sol--col game c)) (card-games-get game :reserve)) (when (and (null (card-games-sol--col game c)) (card-games-get game :reserve))
(let ((card (car (last (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 ;;;; Accessors
(defsubst card-games-spite--goal (game s) (aref (card-games-get game :goal) s)) (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) (aset (card-games-get game :goal) s v)) (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) (aref (card-games-get game :hand) s)) (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) (aset (card-games-get game :hand) s v)) (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) (aref (card-games-get game :disc) s)) ; vector of 4 lists (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)) (cl-defmethod card-games-spite--deal ((game card-games-spite-game))
"Deal a fresh Spite & Malice game into GAME." "Deal a fresh Spite & Malice game into GAME."
@ -99,7 +99,7 @@
;;;; Stock and centre piles ;;;; Stock and centre piles
(defun card-games-spite--draw-stock (game) (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)) (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 :stock (card-games-shuffle (card-games-get game :muck)))
(card-games-put game :muck nil)) (card-games-put game :muck nil))
@ -107,7 +107,7 @@
(when stock (card-games-put game :stock (cdr stock)) (car stock)))) (when stock (card-games-put game :stock (cdr stock)) (car stock))))
(defun card-games-spite--refill (game s) (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) (while (and (< (length (card-games-spite--hand game s)) 5) (or (card-games-get game :stock)
(card-games-get game :muck))) (card-games-get game :muck)))
(let ((c (card-games-spite--draw-stock game))) (let ((c (card-games-spite--draw-stock game)))
@ -115,12 +115,12 @@
(cons c (card-games-spite--hand game s)))))))) (cons c (card-games-spite--hand game s))))))))
(defun card-games-spite--needed (game i) (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))) (let ((p (aref (card-games-get game :center) i)))
(if p (1+ (car p)) 0))) (if p (1+ (car p)) 0)))
(defun card-games-spite--legal-center (game card) (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)) (let ((found nil))
(dotimes (i 4) (dotimes (i 4)
(let ((need (card-games-spite--needed game i))) (let ((need (card-games-spite--needed game i)))
@ -130,7 +130,7 @@
found)) found))
(defun card-games-spite--put-center (game card i) (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)) (let* ((need (card-games-spite--needed game i))
(p (aref (card-games-get game :center) i)) (p (aref (card-games-get game :center) i))
(cards (cons card (and p (cdr p))))) (cards (cons card (and p (cdr p)))))
@ -142,13 +142,13 @@
;;;; Plays ;;;; Plays
(defun card-games-spite--play-hand (game s card i) (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--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) (card-games-spite--put-center game card i)
(when (null (card-games-spite--hand game s)) (card-games-spite--refill game s))) (when (null (card-games-spite--hand game s)) (card-games-spite--refill game s)))
(defun card-games-spite--play-goal (game s i) (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)))) (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--set-goal game s (cdr (card-games-spite--goal game s)))
(card-games-spite--put-center game card i) (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)))) (card-games-put game :phase 'game-over) (card-games-put game :winner s))))
(defun card-games-spite--play-disc (game s d i) (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))) (let* ((pile (aref (card-games-spite--disc game s) d)) (card (car pile)))
(aset (card-games-spite--disc game s) d (cdr pile)) (aset (card-games-spite--disc game s) d (cdr pile))
(card-games-spite--put-center game card i))) (card-games-spite--put-center game card i)))
(defun card-games-spite--discard (game s card d) (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)) (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))) (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))) (card-games-put game :turn (- 1 s)))
@ -170,7 +170,7 @@
;;;; AI ;;;; AI
(defun card-games-spite--ai-one (game s) (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)) (let ((goal (car (card-games-spite--goal game s))) (done nil))
(cond (cond
;; 1. advance the goal card (a wild goal card plays anywhere) ;; 1. advance the goal card (a wild goal card plays anywhere)
@ -214,7 +214,7 @@
done)) done))
(defun card-games-spite--ai-turn (game s) (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) (card-games-spite--refill game s)
(let ((guard 0)) (let ((guard 0))
(while (and (eq (card-games-get game :phase) 'play) (< guard 300) (while (and (eq (card-games-get game :phase) 'play) (< guard 300)
@ -232,7 +232,7 @@
(card-games-spite--discard game s card d)))))) (card-games-spite--discard game s card d))))))
(defun card-games-spite--ai-disc-pile (game s card) (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)) (let ((disc (card-games-spite--disc game s)) (empty nil) (best nil) (bestv 99))
(dotimes (d 4) (dotimes (d 4)
(let ((top (car (aref disc d)))) (let ((top (car (aref disc d))))
@ -243,7 +243,7 @@
(or best empty 0))) (or best empty 0)))
(defun card-games-spite--run (game) (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)) (let ((guard 0))
(while (and (eq (card-games-get game :phase) 'play) (= (card-games-get game :turn) 1) (< guard 200)) (while (and (eq (card-games-get game :phase) 'play) (= (card-games-get game :turn) 1) (< guard 200))
(setq guard (1+ guard)) (setq guard (1+ guard))
@ -254,7 +254,7 @@
(defvar-local card-games-spite--game nil "The Spite & Malice game in the current buffer.") (defvar-local card-games-spite--game nil "The Spite & Malice game in the current buffer.")
(defun card-games-spite--center-string (game) (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 '())) (let ((parts '()))
(dotimes (i 4) (dotimes (i 4)
(let ((p (aref (card-games-get game :center) i))) (let ((p (aref (card-games-get game :center) i)))
@ -265,7 +265,7 @@
(mapconcat #'identity (nreverse parts) " "))) (mapconcat #'identity (nreverse parts) " ")))
(defun card-games-spite--disc-string (game s) (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 '())) (let ((parts '()))
(dotimes (d 4) (dotimes (d 4)
(let ((top (car (aref (card-games-spite--disc game s) d)))) (let ((top (car (aref (card-games-spite--disc game s) d))))
@ -368,12 +368,14 @@
(_ (cl-call-next-method)))) (_ (cl-call-next-method))))
(defun card-games-spite--redisplay () (defun card-games-spite--redisplay ()
"Redraw the current Spite & Malice buffer."
(let ((game card-games-spite--game) (inhibit-read-only t)) (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 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))) (setq-local mode-line-process (format " [%s]" (card-games-get game :phase)))
(erase-buffer) (insert (card-games-render game)) (goto-char (point-min)))) (erase-buffer) (insert (card-games-render game)) (goto-char (point-min))))
(defun card-games-spite--my-turn-p (g) (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))) (and (eq (card-games-get g :phase) 'play) (= (card-games-get g :turn) 0)))
(defun card-games-spite-left () (defun card-games-spite-left ()
@ -391,7 +393,7 @@
(card-games-spite--redisplay))) (card-games-spite--redisplay)))
(defun card-games-spite--ensure-hand (g) (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)) (card-games-spite--refill g 0))
(defun card-games-spite-play () (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)) (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) (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))) (let ((gy (+ y 10)))
(while (< gy (- (+ y h) 8)) (while (< gy (- (+ y h) 8))
(let ((gx (+ x 10))) (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))))) (setq gy (+ gy 9)))))
(defun card-games-svg--back-lattice (svg x y w h) (defun card-games-svg--back-lattice (svg x y w h)
"Draw a small-cross lattice back pattern." "Draw a small-cross lattice back pattern on SVG within X, Y, W, H."
(let ((gy (+ y 13))) (let ((gy (+ y 13)))
(while (< gy (- (+ y h) 10)) (while (< gy (- (+ y h) 10))
(let ((gx (+ x 13))) (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))))) (setq gy (+ gy 11)))))
(defun card-games-svg--back-waves (svg x y w h) (defun card-games-svg--back-waves (svg x y w h)
"Draw a staggered-dash (brickwork) back pattern." "Draw a staggered-dash (brickwork) back pattern on SVG within X, Y, W, H."
(let ((gy (+ y 12)) (row 0)) (let ((gy (+ y 12)) (row 0))
(while (< gy (- (+ y h) 9)) (while (< gy (- (+ y h) 9))
(let ((gx (+ x (if (cl-evenp row) 9 15)))) (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))))) (setq gy (+ gy 8) row (1+ row)))))
(defun card-games-svg--back-diamond (svg x y w h) (defun card-games-svg--back-diamond (svg x y w h)
"Draw concentric diamonds as the back pattern." "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)))) (let ((cx (+ x (/ w 2.0))) (cy (+ y (/ h 2.0))))
(dolist (f '(0.40 0.28 0.16)) (dolist (f '(0.40 0.28 0.16))
(let ((dw (* w f)) (dh (* h f))) (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))))) :fill "none" :stroke card-games-svg-back-trim :stroke-width 1)))))
(defun card-games-svg--back-logo (svg x y w h back) (defun card-games-svg--back-logo (svg x y w h back)
"Stamp the Emacs logo for BACK centred on the card, or dots if unavailable." "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) (let ((file (and (fboundp 'svg-embed)
(card-games-svg--logo-file (card-games-svg--back-logo-name back))))) (card-games-svg--logo-file (card-games-svg--back-logo-name back)))))
(if (null file) (if (null file)
@ -590,7 +591,8 @@ emblem and `none' shows nothing."
when (file-readable-p f) return f)) when (file-readable-p f) return f))
(defun card-games-svg--draw-logo-emblem (svg cx cy fs) (defun card-games-svg--draw-logo-emblem (svg cx cy fs)
"Draw the built-in purple GNU Emacs emblem centred at CX, CY, scaled FS." "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-gradient svg "card-games-logo" 'linear '((0 . "#8056c8") (100 . "#3f1f9e")))
(svg-circle svg cx cy (round (* 26 fs)) :gradient "card-games-logo" (svg-circle svg cx cy (round (* 26 fs)) :gradient "card-games-logo"
:stroke "#2a1370" :stroke-width 2) :stroke "#2a1370" :stroke-width 2)
@ -599,9 +601,10 @@ emblem and `none' shows nothing."
(max 10 (round (* 11 fs))) "#c7bbe6")) (max 10 (round (* 11 fs))) "#c7bbe6"))
(defun card-games-svg-draw-logo (svg cx cy &optional fs) (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. "Draw the configured Emacs emblem on SVG, centred at CX, CY.
FS scales it. Embeds a real Emacs logo image when one is available, and The emblem is chosen by `card-games-svg-emacs-logo'; FS scales it. Embeds a
otherwise draws the built-in emblem." 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)) (let ((fs (or fs 1.0)) (choice card-games-svg-emacs-logo))
(pcase choice (pcase choice
('none nil) ('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))) (car best)))
(defun card-games-tx--ai (game seat powerfn ledfn valuefn) (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." POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(let* ((legal (card-games-trick--legal-moves game seat)) (let* ((legal (card-games-trick--legal-moves game seat))
(trick (card-games-get game :trick)) (trump (oref game trump))) (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) (car (sort (or losers legal)
(lambda (a b) (< (funcall valuefn a) (funcall valuefn b)))))))))) (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 ;;;; 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))) (pcase (cdr card) (12 11) (1 10) (11 4) (10 3) (9 2) (_ 0)))
(defun card-games-bris--win-power (card trump led) (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))) (cond ((= (car card) trump) (+ 200 (card-games-bris--power card trump led)))
((= (car card) led) (+ 100 (card-games-bris--power card trump led))) ((= (car card) led) (+ 100 (card-games-bris--power card trump led)))
(t 0))) (t 0)))
(cl-defmethod card-games-trick--legal-p ((game card-games-briscola-game) seat card) (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)) (and (member card (card-games-trick--hand game seat)) t))
(cl-defmethod card-games-trick--winner ((game card-games-briscola-game)) (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-tx--winner (reverse (card-games-get game :trick)) (oref game trump)
#'card-games-bris--win-power #'card-games-tx--plain-led)) #'card-games-bris--win-power #'card-games-tx--plain-led))
(cl-defmethod card-games-trick--ai-play ((game card-games-briscola-game) seat) (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)) (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)) (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-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)) (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))) (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)) (card-games-trick--run game))
(cl-defmethod card-games-trick--score-hand ((game card-games-briscola-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))) (let ((scores (card-games-get game :scores)) (tp (make-vector 2 0)))
(dotimes (s 4) (dotimes (s 4)
(aset tp (card-games-trick--team s) (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))))))) (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)) (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)) (or (>= (aref (card-games-get game :scores) 0) (oref game target))
(>= (aref (card-games-get game :scores) 1) (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)) (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)) (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)) (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))) (let ((w (card-games-trick--winner-seat game)))
(format "%s win (%d points)" (if (= w 0) "You and North" "West and East") (format "%s win (%d points)" (if (= w 0) "You and North" "West and East")
(aref (card-games-get game :scores) w)))) (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)))) (t (cdr card))))
(cl-defmethod card-games-trick--legal-p ((game card-games-pitch-game) seat 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)) (let ((hand (card-games-trick--hand game seat)) (trick (card-games-get game :trick))
(trump (oref game trump))) (trump (oref game trump)))
(and (member card hand) (and (member card hand)
@ -211,7 +218,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(t t))))))) (t t)))))))
(cl-defmethod card-games-trick--play ((game card-games-pitch-game) seat card) (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))) (when (and (null (oref game trump)) (null (card-games-get game :trick)))
(oset game trump (car card)) (oset game trump (car card))
(card-games-put game :message (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-call-next-method))
(cl-defmethod card-games-trick--ai-play ((game card-games-pitch-game) seat) (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))) (if (and (null (oref game trump)) (= seat (card-games-get game :leader)))
;; pitcher's opening lead: lead high from the strongest suit ;; pitcher's opening lead: lead high from the strongest suit
(let ((best nil) (bestv -1)) (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)))))) (lambda (c) (card-games-pitch--pip (cdr c))))))
(defun card-games-pitch--suit-strength (game seat suit) (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)) (let ((v 0))
(dolist (c (card-games-trick--hand game seat)) (dolist (c (card-games-trick--hand game seat))
(when (= (car c) suit) (when (= (car c) suit)
@ -242,7 +250,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
v)) v))
(cl-defmethod card-games-trick--ai-bid ((game card-games-pitch-game) seat) (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)) (let ((bid 0))
(dotimes (s 4) (dotimes (s 4)
(let* ((cards (cl-remove-if-not (lambda (c) (= (car c) s)) (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)) bid))
(defun card-games-pitch--read-bid (game high) (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))) (let ((sug (card-games-trick--ai-bid game 0)))
(max 0 (min 4 (read-number (max 0 (min 4 (read-number
(format "Your bid (0 pass, else %d-4) [suggest %d]: " (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))))) sug)))))
(cl-defmethod card-games-trick--begin-hand ((game card-games-pitch-game)) (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) (card-games-tx--deal game (card-games-tx--deck (number-sequence 0 12)) 6)
(oset game trump nil) (oset game trump nil)
(card-games-put game :dealer (mod (1+ (or (card-games-get game :dealer) 3)) 4)) (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))) (card-games-trick--run game)))
(cl-defmethod card-games-trick--score-hand ((game card-games-pitch-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)) (let* ((trump (oref game trump)) (scores (card-games-get game :scores))
(earned (make-vector 4 0)) (game-pts (make-vector 4 0)) (earned (make-vector 4 0)) (game-pts (make-vector 4 0))
(bidder (card-games-get game :bidder)) (bid (card-games-get game :bid)) (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))) (card-games-put game :last-earned earned)))
(cl-defmethod card-games-trick--game-over-p ((game card-games-pitch-game)) (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-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)) (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) (let ((best 0)) (dotimes (s 4)
(when (> (aref (card-games-get game :scores) s) (when (> (aref (card-games-get game :scores) s)
(aref (card-games-get game :scores) best)) (setq best s))) (aref (card-games-get game :scores) best)) (setq best s)))
best)) best))
(cl-defmethod card-games-trick--result-string ((game card-games-pitch-game)) (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)))) (format "%s wins" (aref card-games-trick-seat-names (card-games-trick--winner-seat game))))
;;;###autoload ;;;###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.") "Euchre: 24 cards, bowers, order up or call trump, partnership to 10.")
(defun card-games-euchre--right-bower-p (card trump) (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))) (and (= (cdr card) 9) (= (car card) trump)))
(defun card-games-euchre--left-bower-p (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)))) (and (= (cdr card) 9) (= (car card) (card-games-sister-suit trump))))
(defun card-games-euchre--eff-suit (card 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))) ((= (card-games-euchre--eff-suit card trump) led) (+ 100 (cdr card)))
(t (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) (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)) (let ((hand (card-games-trick--hand game seat)) (trick (card-games-get game :trick))
(trump (oref game trump))) (trump (oref game trump)))
(and (member card hand) (and (member card hand)
@ -374,15 +389,17 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
t)))))) t))))))
(cl-defmethod card-games-trick--winner ((game card-games-euchre-game)) (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-tx--winner (reverse (card-games-get game :trick)) (oref game trump)
#'card-games-euchre--power #'card-games-euchre--eff-led)) #'card-games-euchre--power #'card-games-euchre--eff-led))
(cl-defmethod card-games-trick--ai-play ((game card-games-euchre-game) seat) (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 (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)))) (lambda (c) (card-games-euchre--power c (oref game trump) -1))))
(defun card-games-euchre--strength (game seat suit) (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)) (let ((v 0))
(dolist (c (card-games-trick--hand game seat)) (dolist (c (card-games-trick--hand game seat))
(cond ((card-games-euchre--right-bower-p c suit) (setq v (+ v 4))) (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)) v))
(defun card-games-euchre--ai-order (game seat upsuit) (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)) (>= (card-games-euchre--strength game seat upsuit) 6))
(defun card-games-euchre--ai-call (game seat upsuit) (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)) (let ((best nil) (bestv 0))
(dotimes (s 4) (dotimes (s 4)
(unless (= s upsuit) (unless (= s upsuit)
@ -405,7 +422,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
(and (>= bestv 6) best))) (and (>= bestv 6) best)))
(defun card-games-euchre--best-suit (game seat upsuit) (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)) (let ((best (mod (1+ upsuit) 4)) (bestv -1))
(dotimes (s 4) (dotimes (s 4)
(unless (= s upsuit) (unless (= s upsuit)
@ -414,7 +431,7 @@ POWERFN, LEDFN rank cards; VALUEFN gives a card's point worth."
best)) best))
(defun card-games-euchre--dealer-pickup (game up) (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)) (let* ((d (card-games-get game :dealer)) (trump (car up))
(hand (cons up (card-games-trick--hand game d))) (hand (cons up (card-games-trick--hand game d)))
(worst (car (sort (copy-sequence hand) (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))))) (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)) (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) (card-games-tx--deal game (card-games-tx--deck '(7 8 9 10 11 12)) 5)
(oset game trump nil) (oset game trump nil)
(card-games-put game :dealer (mod (1+ (or (card-games-get game :dealer) 3)) 4)) (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)))) (cdr (assoc pick choices))))
(cl-defmethod card-games-trick--score-hand ((game card-games-euchre-game)) (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)) (let* ((scores (card-games-get game :scores))
(mteam (card-games-trick--team (card-games-get game :maker))) (mteam (card-games-trick--team (card-games-get game :maker)))
(mt (+ (aref (card-games-get game :tricks) mteam) (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)))))) (t (award oteam 2))))))
(cl-defmethod card-games-trick--game-over-p ((game card-games-euchre-game)) (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)) (or (>= (aref (card-games-get game :scores) 0) (oref game target))
(>= (aref (card-games-get game :scores) 1) (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)) (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)) (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)) (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))) (let ((w (card-games-trick--winner-seat game)))
(format "%s win" (if (= w 0) "You and North" "West and East")))) (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) "·" (if (null card) "·"
(concat (aref card-games-trick-ranks (cdr card)) (card-games-suit-glyph (car 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 () (defun card-games-trick--full-deck ()
"Return a fresh shuffled 52-card deck." "Return a fresh shuffled 52-card deck."
@ -114,26 +114,26 @@
(card-games-put game :trick-no 0) (card-games-put game :trick-no 0)
game)) game))
(defsubst card-games-trick--hand (game s) (aref (card-games-get game :hands) s)) (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) (aset (card-games-get game :hands) s v)) (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) (mod (+ s 2) 4)) (defsubst card-games-trick--partner (s) "Return seat S's partner seat." (mod (+ s 2) 4))
(defsubst card-games-trick--team (s) (mod s 2)) (defsubst card-games-trick--team (s) "Return seat S's team index (0 or 1)." (mod s 2))
;;;; Trick mechanics ;;;; Trick mechanics
(defun card-games-trick--led-suit (game) (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))) (let ((tr (card-games-get game :trick)))
(and tr (car (cdr (car (last tr))))))) ; first entry played (and tr (car (cdr (car (last tr))))))) ; first entry played
(defun card-games-trick--first-play (game) (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)))) (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) (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)) (let* ((hand (card-games-trick--hand game seat))
(trick (card-games-get game :trick)) (trick (card-games-get game :trick))
(restricted (oref game restricted)) (restricted (oref game restricted))
@ -152,12 +152,12 @@
t))))) t)))))
(defun card-games-trick--legal-moves (game seat) (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)) (cl-remove-if-not (lambda (c) (card-games-trick--legal-p game seat c))
(card-games-trick--hand game seat))) (card-games-trick--hand game seat)))
(cl-defmethod card-games-trick--winner ((game card-games-trick-game)) (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 (let* ((trick (reverse (card-games-get game :trick))) ; play order
(led (car (cdr (car trick)))) (led (car (cdr (car trick))))
(trump (oref game trump)) (trump (oref game trump))
@ -175,7 +175,7 @@
(car best))) (car best)))
(cl-defmethod card-games-trick--play ((game card-games-trick-game) seat card) (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))) (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)) (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))) (card-games-put game :trick (cons (cons seat card) (card-games-get game :trick)))
@ -193,7 +193,7 @@
nil)) nil))
(defun card-games-trick--hand-over-p (game) (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)) (and (null (card-games-get game :trick))
(cl-every #'null (append (card-games-get game :hands) nil)))) (cl-every #'null (append (card-games-get game :hands) nil))))
@ -206,7 +206,7 @@
(t 0))) (t 0)))
(cl-defmethod card-games-trick--legal-p ((game card-games-hearts-game) seat card) (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) (and (cl-call-next-method)
(let ((trick (card-games-get game :trick)) (let ((trick (card-games-get game :trick))
(hand (card-games-trick--hand game seat)) (hand (card-games-trick--hand game seat))
@ -221,19 +221,19 @@
(t t))))) (t t)))))
(cl-defmethod card-games-trick--leader-init ((game card-games-hearts-game)) (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) (let (seat)
(dotimes (s 4) (dotimes (s 4)
(when (member '(1 . 0) (card-games-trick--hand game s)) (setq seat s))) (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))) (card-games-put game :leader seat) (card-games-put game :turn seat)))
(cl-defmethod card-games-trick--leader-init ((game card-games-spades-game)) (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))) (let ((s (mod (1+ (or (card-games-get game :dealer) 3)) 4)))
(card-games-put game :leader s) (card-games-put game :turn s))) (card-games-put game :leader s) (card-games-put game :turn s)))
(cl-defmethod card-games-trick--score-hand ((game card-games-hearts-game)) (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))) (let ((pts (make-vector 4 0)) (scores (card-games-get game :scores)))
(dotimes (s 4) (dotimes (s 4)
(aset pts s (apply #'+ (mapcar #'card-games-hearts--card-points (aset pts s (apply #'+ (mapcar #'card-games-hearts--card-points
@ -247,11 +247,11 @@
(card-games-put game :last-points pts))) (card-games-put game :last-points pts)))
(cl-defmethod card-games-trick--game-over-p ((game card-games-hearts-game)) (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-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)) (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)) (let ((best 0))
(dotimes (s 4) (when (< (aref (card-games-get game :scores) s) (dotimes (s 4) (when (< (aref (card-games-get game :scores) s)
(aref (card-games-get game :scores) best)) (aref (card-games-get game :scores) best))
@ -261,7 +261,7 @@
;;;; Spades specifics ;;;; Spades specifics
(cl-defmethod card-games-trick--score-hand ((game card-games-spades-game)) (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)) (let ((scores (card-games-get game :scores))
(bags (card-games-get game :bags)) (bags (card-games-get game :bags))
(bids (card-games-get game :bids)) (bids (card-games-get game :bids))
@ -289,17 +289,17 @@
(card-games-put game :scores scores))) (card-games-put game :scores scores)))
(cl-defmethod card-games-trick--game-over-p ((game card-games-spades-game)) (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-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)) (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)) (if (>= (aref (card-games-get game :scores) 0) (aref (card-games-get game :scores) 1)) 0 1))
;;;; AI ;;;; AI
(cl-defmethod card-games-trick--ai-bid ((game card-games-spades-game) seat) (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)) (let ((hand (card-games-trick--hand game seat)) (bid 0))
(dolist (c hand) (dolist (c hand)
(cond (cond
@ -312,7 +312,7 @@
(max 1 (min 13 bid)))) (max 1 (min 13 bid))))
(cl-defmethod card-games-trick--ai-play ((game card-games-hearts-game) seat) (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)) (let* ((moves (card-games-trick--legal-moves game seat))
(trick (card-games-get game :trick))) (trick (card-games-get game :trick)))
(or (or
@ -341,7 +341,7 @@
(car moves)))) (car moves))))
(cl-defmethod card-games-trick--ai-play ((game card-games-spades-game) seat) (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)) (let* ((moves (card-games-trick--legal-moves game seat))
(trick (card-games-get game :trick)) (trick (card-games-get game :trick))
(trump (oref game trump))) (trump (oref game trump)))
@ -390,7 +390,7 @@
game) game)
(defun card-games-trick--simulate-hand (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)) (while (not (card-games-trick--hand-over-p game))
(let ((seat (card-games-get game :turn))) (let ((seat (card-games-get game :turn)))
(card-games-trick--play game seat (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.") "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)) (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-trick--deal game)
(card-games-put game :hand-no (1+ (or (card-games-get game :hand-no) 0))) (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) (card-games-put game :cursor 0) (card-games-put game :marks nil)
@ -431,6 +432,7 @@
(card-games-trick--dir-name dir)))))) (card-games-trick--dir-name dir))))))
(cl-defmethod card-games-trick--begin-hand ((game card-games-spades-game)) (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-trick--deal game)
(card-games-put game :dealer (mod (1+ (or (card-games-get game :dealer) 3)) 4)) (card-games-put game :dealer (mod (1+ (or (card-games-get game :dealer) 3)) 4))
(card-games-put game :cursor 0) (card-games-put game :cursor 0)
@ -460,7 +462,7 @@
game) game)
(defun card-games-trick--run (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) (while (and (eq (card-games-get game :phase) 'play)
(not (card-games-trick--hand-over-p game)) (not (card-games-trick--hand-over-p game))
(/= (card-games-get game :turn) 0)) (/= (card-games-get game :turn) 0))
@ -480,10 +482,12 @@
(card-games-trick--begin-hand game))) (card-games-trick--begin-hand game)))
(cl-defmethod card-games-trick--result-string ((game card-games-hearts-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" (format "%s wins with the lowest score"
(aref card-games-trick-seat-names (card-games-trick--winner-seat game)))) (aref card-games-trick-seat-names (card-games-trick--winner-seat game))))
(cl-defmethod card-games-trick--result-string ((game card-games-spades-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))) (let ((w (card-games-trick--winner-seat game)))
(format "%s win" (if (= w 0) "You and North" "West and East")))) (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))) (cons (aref card-games-trick-ranks (cdr card)) (car card)))
(cl-defun card-games-trick--svg-row (cards &key cursor marks hints region-tag) (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) (card-games-svg-hand-image (mapcar #'card-games-trick--spec cards)
:cursor cursor :marks marks :hints hints :cursor cursor :marks marks :hints hints
:overlap (if (> (length cards) 11) :overlap (if (> (length cards) 11)
@ -549,7 +554,7 @@
:region-tag region-tag)) :region-tag region-tag))
(defun card-games-trick--draw-backs (svg x y n) (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)) (let ((k (min (max n 0) 3)) (xx x))
(dotimes (_ k) (dotimes (_ k)
(card-games-svg-card svg xx y :down t) (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)))) (apply #'concat (nreverse out))))
(cl-defmethod card-games-render ((game card-games-trick-game)) (cl-defmethod card-games-render ((game card-games-trick-game))
"Return a depiction of GAME: a full SVG table on a graphical display, "Return a depiction of GAME.
else a plain-text board." Use a full SVG table on a graphical display, else a plain-text board."
(if (and card-games-trick-svg-cards (display-graphic-p)) (if (and card-games-trick-svg-cards (display-graphic-p))
(card-games-trick--svg game) (card-games-trick--svg game)
(card-games-trick--render-text game))) (card-games-trick--render-text game)))
(cl-defmethod card-games-render-apply ((g card-games-trick-game) action) (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 (pcase action
(`(hand . ,i) (card-games-put g :cursor i) (card-games-trick-act)) (`(hand . ,i) (card-games-put g :cursor i) (card-games-trick-act))
(_ (cl-call-next-method)))) (_ (cl-call-next-method))))
@ -701,7 +706,7 @@ else a plain-text board."
;;;; Commands ;;;; Commands
(defun card-games-trick--cursor-card (game) (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)))) (nth (card-games-get game :cursor) (card-games-trick--sort (card-games-trick--hand game 0))))
(defun card-games-trick-left () (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.") "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)) (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))) (let ((s (mod (1+ (or (card-games-get game :dealer) 3)) 4)))
(card-games-put game :leader s) (card-games-put game :turn s))) (card-games-put game :leader s) (card-games-put game :turn s)))
(cl-defmethod card-games-trick--leader-init ((game card-games-ohhell-game)) (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))) (let ((s (mod (1+ (or (card-games-get game :dealer) 3)) 4)))
(card-games-put game :leader s) (card-games-put game :turn s))) (card-games-put game :leader s) (card-games-put game :turn s)))
(defun card-games-trick--ai-trump-play (game seat) (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)) (let* ((moves (card-games-trick--legal-moves game seat))
(trick (card-games-get game :trick))) (trick (card-games-get game :trick)))
(or (or
@ -846,12 +853,15 @@ else a plain-text board."
(car moves)))) (car moves))))
(cl-defmethod card-games-trick--ai-play ((game card-games-whist-game) seat) (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)) (card-games-trick--ai-trump-play game seat))
(cl-defmethod card-games-trick--ai-play ((game card-games-ohhell-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)) (card-games-trick--ai-trump-play game seat))
;; Whist ;; Whist
(cl-defmethod card-games-trick--begin-hand ((game card-games-whist-game)) (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-trick--deal game)
(card-games-put game :dealer (mod (1+ (or (card-games-get game :dealer) 3)) 4)) (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 (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)) (card-games-trick--run game))
(cl-defmethod card-games-trick--score-hand ((game card-games-whist-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))) (let ((scores (card-games-get game :scores)) (tricks (card-games-get game :tricks)))
(dotimes (team 2) (dotimes (team 2)
(let ((over (max 0 (- (+ (aref tricks team) (aref tricks (+ team 2))) 6)))) (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))) (card-games-put game :scores scores)))
(cl-defmethod card-games-trick--game-over-p ((game card-games-whist-game)) (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-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)) (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)) (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)) (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"))) (format "%s win" (if (= 0 (card-games-trick--winner-seat game)) "You and North" "West and East")))
;; Oh Hell ;; Oh Hell
@ -882,6 +896,7 @@ else a plain-text board."
"Hand sizes dealt in successive Oh Hell rounds.") "Hand sizes dealt in successive Oh Hell rounds.")
(cl-defmethod card-games-trick--ai-bid ((game card-games-ohhell-game) seat) (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)) (let ((hand (card-games-trick--hand game seat)) (trump (oref game trump)) (bid 0))
(dolist (c hand) (dolist (c hand)
(cond ((= (cdr c) 12) (cl-incf bid)) (cond ((= (cdr c) 12) (cl-incf bid))
@ -889,6 +904,7 @@ else a plain-text board."
(min bid (length hand)))) (min bid (length hand))))
(cl-defmethod card-games-trick--begin-hand ((game card-games-ohhell-game)) (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)) (let* ((round (or (card-games-get game :round) 0))
(hs (aref card-games-ohhell--sizes (min round (1- (length card-games-ohhell--sizes)))))) (hs (aref card-games-ohhell--sizes (min round (1- (length card-games-ohhell--sizes))))))
(oset game hand-size hs) (oset game hand-size hs)
@ -912,6 +928,7 @@ else a plain-text board."
(card-games-trick--run game))) (card-games-trick--run game)))
(cl-defmethod card-games-trick--score-hand ((game card-games-ohhell-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)) (let ((scores (card-games-get game :scores)) (bids (card-games-get game :bids))
(tricks (card-games-get game :tricks))) (tricks (card-games-get game :tricks)))
(dotimes (s 4) (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))))) (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)) (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))) (>= (or (card-games-get game :round) 0) (length card-games-ohhell--sizes)))
(cl-defmethod card-games-trick--winner-seat ((game card-games-ohhell-game)) (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) (let ((best 0)) (dotimes (s 4) (when (> (aref (card-games-get game :scores) s)
(aref (card-games-get game :scores) best)) (setq best s))) (aref (card-games-get game :scores) best)) (setq best s)))
best)) best))
(cl-defmethod card-games-trick--result-string ((game card-games-ohhell-game)) (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)))) (format "%s wins" (aref card-games-trick-seat-names (card-games-trick--winner-seat game))))
;;;###autoload ;;;###autoload

3
card-games.el
View file

@ -148,7 +148,8 @@ Each entry is (NAME COMMAND DESCRIPTION); `card-games' lists them.")
;;;###autoload ;;;###autoload
(defun card-games-set-treatment (treatment) (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 `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 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." open game. Gaps and 500 are always graphical on a window system."