Corwin Brust
5da3144c0a
Full-SVG 500 made mouse-operable for newcomers: kitty Discard button and five-card cap, on-table phase banner, ? Help/Rules overlay with the bid legend, legal-play dimming, card-size slider, and a layout pass that moves the Help and size controls into the log panel so nothing overlaps. Bump all files to 1.0.90, add NEWS, a README testing quick-start, and make the shared engine files checkdoc-clean.
425 lines
18 KiB
EmacsLisp
425 lines
18 KiB
EmacsLisp
;;; cg-president.el --- President (Scum), a climbing card game -*- lexical-binding: t; -*-
|
||
|
||
;; Copyright (C) 2026 Corwin Brust
|
||
|
||
;; Author: Corwin Brust <corwin@bru.st>
|
||
;; Maintainer: Corwin Brust <corwin@bru.st>
|
||
;; Version: 1.0.90
|
||
;; Package-Requires: ((emacs "26.1"))
|
||
;; Keywords: games
|
||
;; URL: https://code.bru.st/corwin/card-game.el
|
||
|
||
;; This program is free software; you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation, either version 3 of the License, or
|
||
;; (at your option) any later version.
|
||
|
||
;; This program is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||
|
||
;;; Commentary:
|
||
|
||
;; President (also Scum, Asshole, Daihinmin): a climbing/shedding game.
|
||
;; The leader plays one to four cards of a single rank; each player in turn
|
||
;; must beat it with the same number of a higher rank or pass. Once all but
|
||
;; one have passed, the pile clears and the last player to play leads again.
|
||
;; The first player out is President, the last is Scum; on the next deal the
|
||
;; Scum hands the President their two best cards and gets two junk cards back.
|
||
;;
|
||
;; You are the South player (seat 0); the rest are simple AI. Card power
|
||
;; runs 3 (low) .. K, A, then the Two (highest). Cards are the package
|
||
;; cons (SUIT . RANK) with RANK 0 (the Two) .. 12 (the Ace).
|
||
|
||
;;; Code:
|
||
|
||
(require 'cl-lib)
|
||
(require 'eieio)
|
||
(require 'cg-core)
|
||
(require 'cg-svg)
|
||
|
||
(defconst cg-pres-ranks
|
||
["2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K" "A"]
|
||
"Rank labels indexed 0 (Two) .. 12 (Ace).")
|
||
|
||
(defconst cg-pres-titles ["President" "Vice-President" "Citizen"
|
||
"Vice-Scum" "Scum"]
|
||
"Finishing titles from first out to last.")
|
||
|
||
(defcustom cg-president-players 4
|
||
"Number of players in President, including you (3-6)."
|
||
:type 'integer :group 'card-games)
|
||
|
||
(defun cg-pres--power (rank)
|
||
"Return the climbing power of RANK; the Two (RANK 0) is highest."
|
||
(if (= rank 0) 13 rank))
|
||
|
||
(defun cg-pres-card-string (card)
|
||
(if (null card) "·"
|
||
(concat (aref cg-pres-ranks (cdr card)) (cg-suit-glyph (car card)))))
|
||
|
||
(defsubst cg-pres-red-p (card) (and card (cg-red-suit-p (car card))))
|
||
|
||
(defun cg-pres--deck ()
|
||
(cg-shuffle (cl-loop for s below 4 append
|
||
(cl-loop for r below 13 collect (cons s r)))))
|
||
|
||
(defun cg-pres--sort (cards)
|
||
"Sort CARDS by climbing power then suit."
|
||
(sort (copy-sequence cards)
|
||
(lambda (a b) (if (= (cg-pres--power (cdr a)) (cg-pres--power (cdr b)))
|
||
(< (car a) (car b))
|
||
(< (cg-pres--power (cdr a)) (cg-pres--power (cdr b)))))))
|
||
|
||
(defclass cg-president-game (cg-game)
|
||
((vname :initform "President"))
|
||
"A game of President (Scum).")
|
||
|
||
(defsubst cg-pres--hand (game s) (aref (cg-get game :hands) s))
|
||
(defsubst cg-pres--set-hand (game s v) (aset (cg-get game :hands) s v))
|
||
(defsubst cg-pres--name (_game s)
|
||
(if (= s 0) "You" (format "Player %d" s)))
|
||
|
||
;;;; Dealing and the inter-game exchange
|
||
|
||
(cl-defmethod cg-pres--deal ((game cg-president-game))
|
||
(let* ((n (max 3 (min 6 cg-president-players)))
|
||
(deck (cg-pres--deck))
|
||
(hands (make-vector n nil))
|
||
(s 0))
|
||
(while deck
|
||
(push (pop deck) (aref hands (mod s n)))
|
||
(cl-incf s))
|
||
(dotimes (i n) (aset hands i (cg-pres--sort (aref hands i))))
|
||
(cg-put game :hands hands)
|
||
(cg-put game :nplayers n)
|
||
(cg-pres--exchange game) ; carry out roles from the last deal
|
||
(cg-put game :count 0)
|
||
(cg-put game :top -1)
|
||
(cg-put game :passed (make-vector n nil))
|
||
(cg-put game :out nil)
|
||
(cg-put game :last-player nil)
|
||
(cg-put game :turn 0)
|
||
(cg-put game :phase 'play)
|
||
(cg-put game :cursor 0)
|
||
(unless (cg-get game :games) (cg-put game :games 0))
|
||
(cg-put game :message
|
||
"Lead any rank; others beat it with a higher one or pass. p passes.")
|
||
game))
|
||
|
||
(defun cg-pres--best (hand k) "The K highest-power cards of HAND." (last (cg-pres--sort hand) k))
|
||
(defun cg-pres--worst (hand k) "The K lowest-power cards of HAND." (cl-subseq (cg-pres--sort hand) 0 k))
|
||
|
||
(cl-defmethod cg-pres--exchange ((game cg-president-game))
|
||
"Trade cards by rank from the previous deal's finishing order, if any."
|
||
(let ((order (cg-get game :order)) (n (cg-get game :nplayers)))
|
||
(when (and order (= (length order) n) (>= n 4))
|
||
(let* ((prez (nth 0 order)) (scum (nth (1- n) order))
|
||
(vp (nth 1 order)) (vice (nth (- n 2) order)))
|
||
(cg-pres--give game scum prez 2) ; scum's 2 best -> president
|
||
(cg-pres--give game prez scum 2 t) ; president's 2 worst -> scum
|
||
(cg-pres--give game vice vp 1)
|
||
(cg-pres--give game vp vice 1 t)))))
|
||
|
||
(defun cg-pres--give (game from to k &optional worst)
|
||
"Move K cards (best, or WORST) from seat FROM to seat TO."
|
||
(let* ((cards (if worst (cg-pres--worst (cg-pres--hand game from) k)
|
||
(cg-pres--best (cg-pres--hand game from) k))))
|
||
(cg-pres--set-hand game from
|
||
(cl-set-difference (cg-pres--hand game from) cards :test #'equal))
|
||
(cg-pres--set-hand game to
|
||
(cg-pres--sort (append (cg-pres--hand game to) cards)))))
|
||
|
||
;;;; Move logic
|
||
|
||
(defun cg-pres--rank-counts (game s)
|
||
"Return an alist (RANK . COUNT) for seat S's hand."
|
||
(let ((tbl nil))
|
||
(dolist (c (cg-pres--hand game s))
|
||
(setf (alist-get (cdr c) tbl 0) (1+ (alist-get (cdr c) tbl 0))))
|
||
tbl))
|
||
|
||
(defun cg-pres--legal-ranks (game s)
|
||
"Return the ranks seat S may legally play now."
|
||
(let ((cnt (cg-get game :count)) (top (cg-get game :top)))
|
||
(cl-loop for (r . c) in (cg-pres--rank-counts game s)
|
||
when (if (= cnt 0) t (and (>= c cnt) (> (cg-pres--power r) top)))
|
||
collect r)))
|
||
|
||
(defun cg-pres--remove-n (hand rank n)
|
||
"Remove N cards of RANK from HAND."
|
||
(let ((out nil) (left n))
|
||
(dolist (c hand) (if (and (> left 0) (= (cdr c) rank))
|
||
(cl-decf left) (push c out)))
|
||
(nreverse out)))
|
||
|
||
(defun cg-pres--in-game (game)
|
||
"Seats that still hold cards."
|
||
(cl-loop for s below (cg-get game :nplayers)
|
||
unless (memq s (cg-get game :out)) collect s))
|
||
|
||
(defun cg-pres--round-active (game)
|
||
"Seats that can still act on the current pile."
|
||
(cl-loop for s below (cg-get game :nplayers)
|
||
unless (or (memq s (cg-get game :out)) (aref (cg-get game :passed) s))
|
||
collect s))
|
||
|
||
(defun cg-pres--next (game from)
|
||
"Next seat after FROM that is still in the round."
|
||
(let ((n (cg-get game :nplayers)) (s from) (res nil))
|
||
(dotimes (_ n)
|
||
(setq s (mod (1+ s) n))
|
||
(when (and (not res)
|
||
(not (memq s (cg-get game :out)))
|
||
(not (aref (cg-get game :passed) s)))
|
||
(setq res s)))
|
||
(or res from)))
|
||
|
||
(defun cg-pres--clear (game)
|
||
"Clear the pile; the last player to play leads (or the next active seat)."
|
||
(cg-put game :count 0) (cg-put game :top -1)
|
||
(cg-put game :passed (make-vector (cg-get game :nplayers) nil))
|
||
(let ((last (cg-get game :last-player)))
|
||
(cg-put game :turn (if (and last (not (memq last (cg-get game :out)))) last
|
||
(cg-pres--next game (or last 0)))))
|
||
(cg-put game :message "Pile cleared."))
|
||
|
||
(defun cg-pres--check-finish (game)
|
||
"End the game when only one player still holds cards (the Scum)."
|
||
(let ((in (cg-pres--in-game game)))
|
||
(when (<= (length in) 1)
|
||
(when in (cg-put game :out (append (cg-get game :out) in)))
|
||
(cg-put game :order (cg-get game :out))
|
||
(cg-put game :games (1+ (or (cg-get game :games) 0)))
|
||
(cg-put game :phase 'game-over)
|
||
(cg-put game :message (cg-pres--result game))
|
||
t)))
|
||
|
||
(defun cg-pres--advance (game)
|
||
"Decide the next turn or clear the pile after a move."
|
||
(unless (cg-pres--check-finish game)
|
||
(let* ((active (cg-pres--round-active game))
|
||
(last (cg-get game :last-player))
|
||
(others (and last (cl-remove last active))))
|
||
(if (and (> (cg-get game :count) 0) (null others))
|
||
(cg-pres--clear game)
|
||
(cg-put game :turn (cg-pres--next game (cg-get game :turn)))))))
|
||
|
||
(defun cg-pres--play (game seat rank n)
|
||
"Seat SEAT plays N cards of RANK."
|
||
(cg-pres--set-hand game seat (cg-pres--remove-n (cg-pres--hand game seat) rank n))
|
||
(cg-put game :count n) (cg-put game :top (cg-pres--power rank))
|
||
(cg-put game :last-player seat)
|
||
(when (null (cg-pres--hand game seat))
|
||
(cg-put game :out (append (cg-get game :out) (list seat))))
|
||
(cg-put game :message (format "%s plays %d × %s" (cg-pres--name game seat)
|
||
n (aref cg-pres-ranks rank)))
|
||
(cg-pres--advance game))
|
||
|
||
(defun cg-pres--pass (game seat)
|
||
"Seat SEAT passes for the current pile."
|
||
(aset (cg-get game :passed) seat t)
|
||
(cg-put game :message (format "%s passes." (cg-pres--name game seat)))
|
||
(cg-pres--advance game))
|
||
|
||
(defun cg-pres--ai-move (game seat)
|
||
"Make seat SEAT's move: lead low, beat low, or pass."
|
||
(let* ((cnt (cg-get game :count)) (top (cg-get game :top))
|
||
(counts (cg-pres--rank-counts game seat)))
|
||
(if (= cnt 0)
|
||
(let ((r (caar (cl-sort counts #'< :key (lambda (x) (cg-pres--power (car x)))))))
|
||
(cg-pres--play game seat r 1))
|
||
(let ((cand (cl-loop for (r . c) in counts
|
||
when (and (>= c cnt) (> (cg-pres--power r) top)) collect r)))
|
||
(if cand
|
||
(cg-pres--play game seat
|
||
(car (cl-sort cand #'< :key #'cg-pres--power)) cnt)
|
||
(cg-pres--pass game seat))))))
|
||
|
||
(defun cg-pres--result (game)
|
||
"Return a finishing summary string."
|
||
(let* ((order (cg-get game :order)) (n (length order)) (parts nil))
|
||
(dotimes (i n)
|
||
(let ((title (cond ((= i 0) "President") ((= i (1- n)) "Scum")
|
||
((= i 1) "Vice-President") ((= i (- n 2)) "Vice-Scum")
|
||
(t "Citizen"))))
|
||
(push (format "%s: %s" title (cg-pres--name game (nth i order))) parts)))
|
||
(concat "Game over -- " (mapconcat #'identity (nreverse parts) ", ")
|
||
". Press n for the next deal.")))
|
||
|
||
;;;; UI
|
||
|
||
(defvar-local cg-pres--game nil "The President game in the current buffer.")
|
||
|
||
(defun cg-pres--run (game)
|
||
"Advance AI seats until it is the human's turn or the game ends."
|
||
(while (and (eq (cg-get game :phase) 'play) (/= (cg-get game :turn) 0))
|
||
(cg-pres--ai-move game (cg-get game :turn))))
|
||
|
||
(defun cg-pres--hand-ranks (game)
|
||
"Distinct ranks in seat 0's hand, ordered by power."
|
||
(let ((rs (delete-dups (mapcar #'cdr (cg-pres--hand game 0)))))
|
||
(cl-sort rs #'< :key #'cg-pres--power)))
|
||
|
||
(defun cg-pres-act (&optional count)
|
||
"Play the selected rank. With prefix COUNT, lead that many of it."
|
||
(interactive "P")
|
||
(let* ((game cg-pres--game)
|
||
(ranks (cg-pres--hand-ranks game)))
|
||
(cond
|
||
((not (eq (cg-get game :phase) 'play)) (cg-put game :message "Press n for a new deal."))
|
||
((/= (cg-get game :turn) 0) (cg-put game :message "Not your turn."))
|
||
((null ranks) (cg-put game :message "You are out."))
|
||
(t (let* ((rank (nth (min (cg-get game :cursor) (1- (length ranks))) ranks))
|
||
(have (cl-count rank (mapcar #'cdr (cg-pres--hand game 0))))
|
||
(need (cg-get game :count)))
|
||
(if (= need 0)
|
||
(let ((n (min have (max 1 (prefix-numeric-value (or count 1))))))
|
||
(cg-pres--play game 0 rank n)
|
||
(cg-put game :cursor 0)
|
||
(cg-pres--run game))
|
||
(if (and (>= have need) (> (cg-pres--power rank) (cg-get game :top)))
|
||
(progn (cg-pres--play game 0 rank need)
|
||
(cg-put game :cursor 0)
|
||
(cg-pres--run game))
|
||
(cg-put game :message
|
||
(format "Need %d of a rank higher than the pile." need)))))))
|
||
(cg-pres--redisplay)))
|
||
|
||
(defun cg-pres-pass ()
|
||
"Pass for the current pile."
|
||
(interactive)
|
||
(let ((game cg-pres--game))
|
||
(cond
|
||
((/= (cg-get game :turn) 0) (cg-put game :message "Not your turn."))
|
||
((= (cg-get game :count) 0) (cg-put game :message "You lead -- you must play."))
|
||
(t (cg-pres--pass game 0) (cg-pres--run game)))
|
||
(cg-pres--redisplay)))
|
||
|
||
(defun cg-pres-left () "Cursor left." (interactive)
|
||
(let* ((g cg-pres--game) (n (length (cg-pres--hand-ranks g))))
|
||
(when (> n 0) (cg-put g :cursor (mod (1- (cg-get g :cursor)) n))) (cg-pres--redisplay)))
|
||
(defun cg-pres-right () "Cursor right." (interactive)
|
||
(let* ((g cg-pres--game) (n (length (cg-pres--hand-ranks g))))
|
||
(when (> n 0) (cg-put g :cursor (mod (1+ (cg-get g :cursor)) n))) (cg-pres--redisplay)))
|
||
(defun cg-pres-new () "New deal." (interactive)
|
||
(cg-pres--deal cg-pres--game) (cg-pres--run cg-pres--game) (cg-pres--redisplay))
|
||
(defun cg-pres-redraw () "Redraw." (interactive) (cg-pres--redisplay))
|
||
(defun cg-pres-help () "Controls." (interactive)
|
||
(message "Arrows or click: choose/play RET: play (C-u N to lead N) p: pass +/-: size n: new"))
|
||
|
||
(defcustom cg-pres-svg-cards t
|
||
"When non-nil, draw the hand as SVG on a graphical display."
|
||
:type 'boolean :group 'card-games)
|
||
|
||
(defun cg-pres--svg (game)
|
||
"Return a propertized, clickable SVG row of the hand: one card per rank.
|
||
Each rank maps to a (hand . INDEX) region and a card-size slider sits below."
|
||
(let* ((w cg-svg-card-width) (h cg-svg-card-height) (pad 10)
|
||
(gap (+ cg-svg-card-gap 8)) (ranks (cg-pres--hand-ranks game))
|
||
(cur (cg-get game :cursor)) (hand (cg-pres--hand game 0))
|
||
(n (length ranks)) (lc (cg-color 'shadow :foreground "gray40"))
|
||
(sh (cg-svg-slider-height)) (slider-y (+ pad h 22))
|
||
(width (+ (* 2 pad) (max (+ w gap) (* n (+ w gap)) (cg-svg-slider-width))))
|
||
(height (+ slider-y sh pad)) (svg (svg-create width height))
|
||
(x pad) (i 0) (regions '()))
|
||
(dolist (r ranks)
|
||
(let* ((cnt (cl-count r (mapcar #'cdr hand)))
|
||
(suit (car (cl-find r hand :key #'cdr))))
|
||
(cg-svg-card svg x pad :rank (aref cg-pres-ranks r) :suit suit
|
||
:highlight (= i cur))
|
||
(svg-text svg (format "x%d" cnt) :x (+ x 3) :y (+ pad h 15)
|
||
:font-size 13 :fill lc :font-family cg-svg-font-family)
|
||
(push (cons (list x pad w h) (cons 'hand i)) regions))
|
||
(setq x (+ x w gap) i (1+ i)))
|
||
(setq regions (append (nreverse regions)
|
||
(cg-svg-slider-draw svg pad slider-y cg-card-scale)))
|
||
(propertize "*" 'display (cg-svg-image svg (cg-scale)) 'cg-regions regions)))
|
||
|
||
(cl-defmethod cg-render ((game cg-president-game))
|
||
"Return a propertized string depicting GAME for a text display."
|
||
(let* ((out (list)) (ranks (cg-pres--hand-ranks game))
|
||
(cur (cg-get game :cursor)))
|
||
(push (format " President\n\n") out)
|
||
(dotimes (s (cg-get game :nplayers))
|
||
(unless (= s 0)
|
||
(push (format " Player %d: %d cards%s\n" s (length (cg-pres--hand game s))
|
||
(if (memq s (cg-get game :out)) " (out)" "")) out)))
|
||
(push (format "\n Pile: %s\n\n"
|
||
(if (> (cg-get game :count) 0)
|
||
(format "%d × power-%d (last: %s)"
|
||
(cg-get game :count) (cg-get game :top)
|
||
(cg-pres--name game (cg-get game :last-player)))
|
||
"empty -- your lead"))
|
||
out)
|
||
(push " Your hand (by rank):\n " out)
|
||
(if (and cg-pres-svg-cards (display-graphic-p))
|
||
(push (cg-pres--svg game) out)
|
||
(let ((i 0))
|
||
(dolist (r ranks)
|
||
(let* ((cnt (cl-count r (mapcar #'cdr (cg-pres--hand game 0))))
|
||
(str (format "%s×%d" (aref cg-pres-ranks r) cnt))
|
||
(faces nil))
|
||
(when (= i cur) (push 'cg-cursor faces))
|
||
(push (propertize (format "%6s" str) 'face (or faces 'default)) out))
|
||
(cl-incf i))))
|
||
(push (format "\n\n %s\n" (cg-get game :message)) out)
|
||
(apply #'concat (nreverse out))))
|
||
|
||
(cl-defmethod cg-render-apply ((g cg-president-game) action)
|
||
"Apply a click ACTION on the rank row to GAME G (a click also plays)."
|
||
(pcase action
|
||
(`(hand . ,i)
|
||
(cg-put g :cursor i)
|
||
(when (and (eq (cg-get g :phase) 'play) (= (cg-get g :turn) 0))
|
||
(cg-pres-act)))
|
||
(_ (cl-call-next-method))))
|
||
|
||
(defun cg-pres--redisplay ()
|
||
(let ((game cg-pres--game) (inhibit-read-only t))
|
||
(setq cg-current-game game cg-redisplay-function #'cg-pres--redisplay)
|
||
(setq-local mode-line-process (format " [%s]" (cg-get game :phase)))
|
||
(erase-buffer) (insert (cg-render game)) (goto-char (point-min))))
|
||
|
||
(defvar cg-pres-mode-map
|
||
(let ((map (make-sparse-keymap)))
|
||
(define-key map [mouse-1] #'cg-card-click)
|
||
(define-key map "+" #'cg-card-zoom-in)
|
||
(define-key map "=" #'cg-card-zoom-in)
|
||
(define-key map "-" #'cg-card-zoom-out)
|
||
(define-key map "0" #'cg-card-zoom-reset)
|
||
(define-key map (kbd "<left>") #'cg-pres-left)
|
||
(define-key map (kbd "<right>") #'cg-pres-right)
|
||
(define-key map (kbd "RET") #'cg-pres-act)
|
||
(define-key map (kbd "SPC") #'cg-pres-act)
|
||
(define-key map "p" #'cg-pres-pass)
|
||
(define-key map "n" #'cg-pres-new)
|
||
(define-key map "g" #'cg-pres-redraw)
|
||
(define-key map "?" #'cg-pres-help)
|
||
map)
|
||
"Keymap for `cg-pres-mode'.")
|
||
|
||
(define-derived-mode cg-pres-mode special-mode "President"
|
||
"Major mode for President."
|
||
(setq-local truncate-lines t)
|
||
(setq-local cursor-type cg-cursor-type))
|
||
|
||
;;;###autoload
|
||
(defun cg-president ()
|
||
"Play President (Scum) against the computer."
|
||
(interactive)
|
||
(let ((buf (get-buffer-create "*President*")))
|
||
(with-current-buffer buf
|
||
(cg-pres-mode)
|
||
(setq cg-pres--game (cg-president-game))
|
||
(cg-pres--deal cg-pres--game)
|
||
(cg-pres--run cg-pres--game)
|
||
(cg-pres--redisplay))
|
||
(switch-to-buffer buf)))
|
||
|
||
(provide 'cg-president)
|
||
;;; cg-president.el ends here
|